summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.clang-format27
-rw-r--r--.gitignore1
-rw-r--r--ChangeLog.26
-rw-r--r--Makefile.in21
-rw-r--r--README2
-rw-r--r--admin/CPP-DEFINES1
-rw-r--r--admin/MAINTAINERS10
-rwxr-xr-xadmin/automerge253
-rw-r--r--admin/find-gc.el2
-rw-r--r--admin/gitmerge.el149
-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-gnulib13
-rw-r--r--admin/notes/bugtracker26
-rw-r--r--admin/notes/git-workflow24
-rw-r--r--admin/notes/spelling11
-rw-r--r--admin/notes/unicode4
-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/unidata-gen.el10
-rw-r--r--admin/unidata/uvs.el2
-rwxr-xr-xadmin/update_autogen2
-rwxr-xr-xautogen.sh11
-rwxr-xr-xbuild-aux/config.guess564
-rwxr-xr-xbuild-aux/config.sub2504
-rwxr-xr-xbuild-aux/gitlog-to-changelog4
-rwxr-xr-xbuild-aux/install-sh27
-rwxr-xr-xbuild-aux/move-if-change4
-rwxr-xr-xbuild-aux/update-copyright4
-rw-r--r--configure.ac371
-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/custom.texi31
-rw-r--r--doc/emacs/dired.texi16
-rw-r--r--doc/emacs/display.texi6
-rw-r--r--doc/emacs/emacs.texi1
-rw-r--r--doc/emacs/files.texi34
-rw-r--r--doc/emacs/fixit.texi23
-rw-r--r--doc/emacs/help.texi10
-rw-r--r--doc/emacs/maintaining.texi53
-rw-r--r--doc/emacs/mini.texi20
-rw-r--r--doc/emacs/misc.texi97
-rw-r--r--doc/emacs/msdos.texi7
-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.texi29
-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.texi23
-rw-r--r--doc/lispref/Makefile.in4
-rw-r--r--doc/lispref/abbrevs.texi4
-rw-r--r--doc/lispref/buffers.texi2
-rw-r--r--doc/lispref/control.texi14
-rw-r--r--doc/lispref/debugging.texi119
-rw-r--r--doc/lispref/display.texi51
-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.texi78
-rw-r--r--doc/lispref/frames.texi117
-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.texi58
-rw-r--r--doc/lispref/intro.texi2
-rw-r--r--doc/lispref/keymaps.texi4
-rw-r--r--doc/lispref/lists.texi31
-rw-r--r--doc/lispref/loading.texi2
-rw-r--r--doc/lispref/minibuf.texi10
-rw-r--r--doc/lispref/modes.texi22
-rw-r--r--doc/lispref/nonascii.texi12
-rw-r--r--doc/lispref/numbers.texi491
-rw-r--r--doc/lispref/objects.texi37
-rw-r--r--doc/lispref/os.texi65
-rw-r--r--doc/lispref/package.texi36
-rw-r--r--doc/lispref/processes.texi147
-rw-r--r--doc/lispref/searching.texi4
-rw-r--r--doc/lispref/sequences.texi8
-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.texi479
-rw-r--r--doc/lispref/threads.texi68
-rw-r--r--doc/lispref/windows.texi30
-rw-r--r--doc/man/etags.12
-rw-r--r--doc/misc/Makefile.in8
-rw-r--r--doc/misc/auth.texi54
-rw-r--r--doc/misc/calc.texi6
-rw-r--r--doc/misc/cl.texi6
-rw-r--r--doc/misc/dired-x.texi72
-rw-r--r--doc/misc/ede.texi6
-rw-r--r--doc/misc/efaq.texi76
-rw-r--r--doc/misc/emacs-mime.texi35
-rw-r--r--doc/misc/ert.texi22
-rw-r--r--doc/misc/eshell.texi2
-rw-r--r--doc/misc/eww.texi10
-rw-r--r--doc/misc/flymake.texi202
-rw-r--r--doc/misc/gnus-faq.texi18
-rw-r--r--doc/misc/gnus.texi61
-rw-r--r--doc/misc/message.texi100
-rw-r--r--doc/misc/mh-e.texi11
-rw-r--r--doc/misc/org.texi10
-rw-r--r--doc/misc/texinfo.tex51
-rw-r--r--doc/misc/tramp.texi618
-rw-r--r--doc/misc/trampver.texi12
-rw-r--r--doc/misc/url.texi21
-rw-r--r--etc/DEBUG9
-rw-r--r--etc/HELLO166
-rw-r--r--etc/NEWS2568
-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.261880
-rw-r--r--etc/PROBLEMS41
-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--lib-src/Makefile.in12
-rw-r--r--lib-src/ebrowse.c2
-rw-r--r--lib-src/emacsclient.c23
-rw-r--r--lib-src/etags.c8
-rw-r--r--lib-src/make-docfile.c97
-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/acl-internal.c2
-rw-r--r--lib/acl-internal.h6
-rw-r--r--lib/binary-io.h6
-rw-r--r--lib/dosname.h5
-rw-r--r--lib/dtotimespec.c10
-rw-r--r--lib/dup2.c2
-rw-r--r--lib/errno.in.h4
-rw-r--r--lib/euidaccess.c11
-rw-r--r--lib/fcntl.c194
-rw-r--r--lib/fcntl.in.h2
-rw-r--r--lib/fpending.c6
-rw-r--r--lib/fsusage.c287
-rw-r--r--lib/fsusage.h40
-rw-r--r--lib/fsync.c2
-rw-r--r--lib/get-permissions.c88
-rw-r--r--lib/getdtablesize.c2
-rw-r--r--lib/getloadavg.c10
-rw-r--r--lib/getopt.c2
-rw-r--r--lib/gettime.c29
-rw-r--r--lib/gettimeofday.c8
-rw-r--r--lib/gnulib.mk.in234
-rw-r--r--lib/ieee754.in.h222
-rw-r--r--lib/intprops.h16
-rw-r--r--lib/inttypes.in.h6
-rw-r--r--lib/limits.in.h44
-rw-r--r--lib/md5.c33
-rw-r--r--lib/md5.h7
-rw-r--r--lib/mktime-internal.h16
-rw-r--r--lib/mktime.c122
-rw-r--r--lib/nstrftime.c24
-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.c3935
-rw-r--r--lib/regex.c81
-rw-r--r--lib/regex.h658
-rw-r--r--lib/regex_internal.c1740
-rw-r--r--lib/regex_internal.h914
-rw-r--r--lib/regexec.c4324
-rw-r--r--lib/set-permissions.c254
-rw-r--r--lib/sha1.c35
-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/stat-time.h10
-rw-r--r--lib/stdio-impl.h68
-rw-r--r--lib/stdio.in.h4
-rw-r--r--lib/stdlib.in.h7
-rw-r--r--lib/strtol.c29
-rw-r--r--lib/sys_stat.in.h6
-rw-r--r--lib/sys_types.in.h15
-rw-r--r--lib/time.in.h2
-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.h49
-rw-r--r--lib/utimens.c7
-rw-r--r--lib/verify.h3
-rw-r--r--lib/warn-on-use.h64
-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.in8
-rw-r--r--lisp/abbrev.el86
-rw-r--r--lisp/allout-widgets.el6
-rw-r--r--lisp/allout.el40
-rw-r--r--lisp/ansi-color.el3
-rw-r--r--lisp/arc-mode.el103
-rw-r--r--lisp/auth-source-pass.el91
-rw-r--r--lisp/auth-source.el334
-rw-r--r--lisp/autoarg.el6
-rw-r--r--lisp/autoinsert.el13
-rw-r--r--lisp/autorevert.el96
-rw-r--r--lisp/battery.el3
-rw-r--r--lisp/bindings.el62
-rw-r--r--lisp/bookmark.el2
-rw-r--r--lisp/calc/calc-bin.el6
-rw-r--r--lisp/calc/calc-comb.el6
-rw-r--r--lisp/calc/calc-ext.el8
-rw-r--r--lisp/calc/calc-math.el2
-rw-r--r--lisp/calc/calc.el7
-rw-r--r--lisp/calendar/appt.el44
-rw-r--r--lisp/calendar/cal-dst.el102
-rw-r--r--lisp/calendar/cal-tex.el2
-rw-r--r--lisp/calendar/calendar.el147
-rw-r--r--lisp/calendar/diary-lib.el534
-rw-r--r--lisp/calendar/holidays.el1
-rw-r--r--lisp/calendar/icalendar.el94
-rw-r--r--lisp/calendar/parse-time.el16
-rw-r--r--lisp/calendar/solar.el21
-rw-r--r--lisp/calendar/time-date.el8
-rw-r--r--lisp/calendar/timeclock.el5
-rw-r--r--lisp/calendar/todo-mode.el681
-rw-r--r--lisp/cedet/cedet.el3
-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/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.el1
-rw-r--r--lisp/cedet/mode-local.el2
-rw-r--r--lisp/cedet/pulse.el4
-rw-r--r--lisp/cedet/semantic.el8
-rw-r--r--lisp/cedet/semantic/analyze.el18
-rw-r--r--lisp/cedet/semantic/analyze/refs.el3
-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/ede-grammar.el10
-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.el6
-rw-r--r--lisp/cedet/semantic/scope.el6
-rw-r--r--lisp/cedet/semantic/symref/filter.el2
-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.el21
-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.el11
-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.el2
-rw-r--r--lisp/chistory.el13
-rw-r--r--lisp/comint.el115
-rw-r--r--lisp/completion.el14
-rw-r--r--lisp/composite.el12
-rw-r--r--lisp/cus-edit.el81
-rw-r--r--lisp/cus-face.el2
-rw-r--r--lisp/cus-start.el32
-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.el91
-rw-r--r--lisp/dired-aux.el195
-rw-r--r--lisp/dired-x.el142
-rw-r--r--lisp/dired.el59
-rw-r--r--lisp/dirtrack.el8
-rw-r--r--lisp/disp-table.el4
-rw-r--r--lisp/doc-view.el22
-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.el101
-rw-r--r--lisp/edmacro.el2
-rw-r--r--lisp/elec-pair.el14
-rw-r--r--lisp/electric.el100
-rw-r--r--lisp/emacs-lisp/advice.el120
-rw-r--r--lisp/emacs-lisp/autoload.el59
-rw-r--r--lisp/emacs-lisp/backtrace.el918
-rw-r--r--lisp/emacs-lisp/benchmark.el18
-rw-r--r--lisp/emacs-lisp/bindat.el28
-rw-r--r--lisp/emacs-lisp/byte-opt.el377
-rw-r--r--lisp/emacs-lisp/byte-run.el9
-rw-r--r--lisp/emacs-lisp/bytecomp.el92
-rw-r--r--lisp/emacs-lisp/cconv.el62
-rw-r--r--lisp/emacs-lisp/checkdoc.el135
-rw-r--r--lisp/emacs-lisp/cl-extra.el2
-rw-r--r--lisp/emacs-lisp/cl-generic.el49
-rw-r--r--lisp/emacs-lisp/cl-lib.el5
-rw-r--r--lisp/emacs-lisp/cl-macs.el280
-rw-r--r--lisp/emacs-lisp/cl-preloaded.el38
-rw-r--r--lisp/emacs-lisp/cl-print.el314
-rw-r--r--lisp/emacs-lisp/copyright.el5
-rw-r--r--lisp/emacs-lisp/crm.el3
-rw-r--r--lisp/emacs-lisp/debug.el502
-rw-r--r--lisp/emacs-lisp/derived.el23
-rw-r--r--lisp/emacs-lisp/easy-mmode.el33
-rw-r--r--lisp/emacs-lisp/edebug.el440
-rw-r--r--lisp/emacs-lisp/eieio-base.el34
-rw-r--r--lisp/emacs-lisp/eieio.el67
-rw-r--r--lisp/emacs-lisp/eldoc.el3
-rw-r--r--lisp/emacs-lisp/elint.el18
-rw-r--r--lisp/emacs-lisp/elp.el7
-rw-r--r--lisp/emacs-lisp/ert.el163
-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.el15
-rw-r--r--lisp/emacs-lisp/generic.el2
-rw-r--r--lisp/emacs-lisp/gv.el7
-rw-r--r--lisp/emacs-lisp/lisp-mode.el36
-rw-r--r--lisp/emacs-lisp/lisp.el18
-rw-r--r--lisp/emacs-lisp/map-ynp.el38
-rw-r--r--lisp/emacs-lisp/nadvice.el6
-rw-r--r--lisp/emacs-lisp/package.el405
-rw-r--r--lisp/emacs-lisp/pcase.el7
-rw-r--r--lisp/emacs-lisp/radix-tree.el2
-rw-r--r--lisp/emacs-lisp/rx.el2
-rw-r--r--lisp/emacs-lisp/shadow.el6
-rw-r--r--lisp/emacs-lisp/subr-x.el16
-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.el24
-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.el11
-rw-r--r--lisp/emulation/viper-cmd.el9
-rw-r--r--lisp/emulation/viper-ex.el10
-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.el16
-rw-r--r--lisp/epa.el59
-rw-r--r--lisp/epg-config.el56
-rw-r--r--lisp/epg.el138
-rw-r--r--lisp/erc/erc-autoaway.el3
-rw-r--r--lisp/erc/erc-backend.el40
-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.el39
-rw-r--r--lisp/erc/erc-desktop-notifications.el4
-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.el3
-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.el1
-rw-r--r--lisp/erc/erc-spelling.el6
-rw-r--r--lisp/erc/erc-stamp.el3
-rw-r--r--lisp/erc/erc-track.el6
-rw-r--r--lisp/erc/erc-truncate.el3
-rw-r--r--lisp/erc/erc-xdcc.el3
-rw-r--r--lisp/erc/erc.el126
-rw-r--r--lisp/eshell/em-cmpl.el7
-rw-r--r--lisp/eshell/em-dirs.el18
-rw-r--r--lisp/eshell/em-hist.el63
-rw-r--r--lisp/eshell/em-ls.el38
-rw-r--r--lisp/eshell/em-pred.el19
-rw-r--r--lisp/eshell/em-prompt.el1
-rw-r--r--lisp/eshell/em-script.el2
-rw-r--r--lisp/eshell/em-tramp.el2
-rw-r--r--lisp/eshell/em-unix.el51
-rw-r--r--lisp/eshell/em-xtra.el6
-rw-r--r--lisp/eshell/esh-ext.el2
-rw-r--r--lisp/eshell/esh-mode.el6
-rw-r--r--lisp/eshell/esh-opt.el34
-rw-r--r--lisp/eshell/esh-proc.el18
-rw-r--r--lisp/eshell/esh-util.el9
-rw-r--r--lisp/eshell/esh-var.el2
-rw-r--r--lisp/face-remap.el10
-rw-r--r--lisp/facemenu.el28
-rw-r--r--lisp/ffap.el1
-rw-r--r--lisp/filecache.el218
-rw-r--r--lisp/filenotify.el16
-rw-r--r--lisp/files-x.el35
-rw-r--r--lisp/files.el467
-rw-r--r--lisp/filesets.el3
-rw-r--r--lisp/find-dired.el4
-rw-r--r--lisp/find-lisp.el24
-rw-r--r--lisp/foldout.el4
-rw-r--r--lisp/follow.el46
-rw-r--r--lisp/font-core.el3
-rw-r--r--lisp/font-lock.el11
-rw-r--r--lisp/format-spec.el2
-rw-r--r--lisp/format.el18
-rw-r--r--lisp/frame.el205
-rw-r--r--lisp/frameset.el25
-rw-r--r--lisp/generic-x.el27
-rw-r--r--lisp/gnus/canlock.el3
-rw-r--r--lisp/gnus/deuglify.el8
-rw-r--r--lisp/gnus/gnus-agent.el103
-rw-r--r--lisp/gnus/gnus-art.el79
-rw-r--r--lisp/gnus/gnus-async.el6
-rw-r--r--lisp/gnus/gnus-bcklg.el2
-rw-r--r--lisp/gnus/gnus-cache.el17
-rw-r--r--lisp/gnus/gnus-cite.el49
-rw-r--r--lisp/gnus/gnus-cloud.el12
-rw-r--r--lisp/gnus/gnus-cus.el2
-rw-r--r--lisp/gnus/gnus-demon.el6
-rw-r--r--lisp/gnus/gnus-draft.el1
-rw-r--r--lisp/gnus/gnus-dup.el2
-rw-r--r--lisp/gnus/gnus-fun.el3
-rw-r--r--lisp/gnus/gnus-group.el163
-rw-r--r--lisp/gnus/gnus-html.el8
-rw-r--r--lisp/gnus/gnus-icalendar.el10
-rw-r--r--lisp/gnus/gnus-int.el2
-rw-r--r--lisp/gnus/gnus-kill.el2
-rw-r--r--lisp/gnus/gnus-logic.el2
-rw-r--r--lisp/gnus/gnus-ml.el1
-rw-r--r--lisp/gnus/gnus-mlspl.el26
-rw-r--r--lisp/gnus/gnus-msg.el43
-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.el10
-rw-r--r--lisp/gnus/gnus-score.el41
-rw-r--r--lisp/gnus/gnus-spec.el10
-rw-r--r--lisp/gnus/gnus-srvr.el73
-rw-r--r--lisp/gnus/gnus-start.el178
-rw-r--r--lisp/gnus/gnus-sum.el190
-rw-r--r--lisp/gnus/gnus-topic.el22
-rw-r--r--lisp/gnus/gnus-undo.el2
-rw-r--r--lisp/gnus/gnus-util.el55
-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.el484
-rw-r--r--lisp/gnus/mail-source.el18
-rw-r--r--lisp/gnus/message.el350
-rw-r--r--lisp/gnus/mm-bodies.el4
-rw-r--r--lisp/gnus/mm-decode.el157
-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.el99
-rw-r--r--lisp/gnus/mm-uu.el1
-rw-r--r--lisp/gnus/mm-view.el18
-rw-r--r--lisp/gnus/mml-sec.el11
-rw-r--r--lisp/gnus/mml-smime.el4
-rw-r--r--lisp/gnus/mml.el15
-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.el4
-rw-r--r--lisp/gnus/nndiary.el5
-rw-r--r--lisp/gnus/nndir.el3
-rw-r--r--lisp/gnus/nndoc.el22
-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.el27
-rw-r--r--lisp/gnus/nnimap.el149
-rw-r--r--lisp/gnus/nnir.el132
-rw-r--r--lisp/gnus/nnmail.el42
-rw-r--r--lisp/gnus/nnmaildir.el78
-rw-r--r--lisp/gnus/nnmairix.el2
-rw-r--r--lisp/gnus/nnmbox.el1
-rw-r--r--lisp/gnus/nnmh.el30
-rw-r--r--lisp/gnus/nnml.el4
-rw-r--r--lisp/gnus/nnoo.el4
-rw-r--r--lisp/gnus/nnrss.el18
-rw-r--r--lisp/gnus/nnspool.el10
-rw-r--r--lisp/gnus/nntp.el90
-rw-r--r--lisp/gnus/nnvirtual.el6
-rw-r--r--lisp/gnus/nnweb.el18
-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.el116
-rw-r--r--lisp/help-fns.el16
-rw-r--r--lisp/help-mode.el55
-rw-r--r--lisp/help.el425
-rw-r--r--lisp/hexl.el163
-rw-r--r--lisp/hfy-cmap.el37
-rw-r--r--lisp/hi-lock.el26
-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.el63
-rw-r--r--lisp/ibuf-macs.el61
-rw-r--r--lisp/ibuffer.el23
-rw-r--r--lisp/icomplete.el3
-rw-r--r--lisp/ido.el34
-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.el39
-rw-r--r--lisp/image.el19
-rw-r--r--lisp/image/gravatar.el6
-rw-r--r--lisp/imenu.el24
-rw-r--r--lisp/indent.el12
-rw-r--r--lisp/info-look.el3
-rw-r--r--lisp/info.el24
-rw-r--r--lisp/international/ccl.el22
-rw-r--r--lisp/international/fontset.el11
-rw-r--r--lisp/international/iso-ascii.el5
-rw-r--r--lisp/international/latin1-disp.el4
-rw-r--r--lisp/international/mule-cmds.el104
-rw-r--r--lisp/international/mule-conf.el62
-rw-r--r--lisp/international/mule-diag.el2
-rw-r--r--lisp/international/mule-util.el6
-rw-r--r--lisp/international/mule.el3
-rw-r--r--lisp/international/quail.el20
-rw-r--r--lisp/isearch.el302
-rw-r--r--lisp/jit-lock.el1
-rw-r--r--lisp/jka-cmpr-hook.el3
-rw-r--r--lisp/json.el9
-rw-r--r--lisp/jsonrpc.el700
-rw-r--r--lisp/kmacro.el75
-rw-r--r--lisp/language/thai-util.el9
-rw-r--r--lisp/ldefs-boot.el2254
-rw-r--r--lisp/leim/quail/latin-post.el51
-rw-r--r--lisp/leim/quail/latin-pre.el52
-rw-r--r--lisp/linum.el4
-rw-r--r--lisp/loadhist.el4
-rw-r--r--lisp/ls-lisp.el55
-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.el97
-rw-r--r--lisp/mail/feedmail.el98
-rw-r--r--lisp/mail/flow-fill.el3
-rw-r--r--lisp/mail/footnote.el466
-rw-r--r--lisp/mail/hashcash.el12
-rw-r--r--lisp/mail/ietf-drums.el24
-rw-r--r--lisp/mail/mail-extr.el8
-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.el48
-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.el140
-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.el10
-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.el29
-rw-r--r--lisp/mh-e/mh-acros.el7
-rw-r--r--lisp/mh-e/mh-alias.el3
-rw-r--r--lisp/mh-e/mh-comp.el127
-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-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-show.el2
-rw-r--r--lisp/mh-e/mh-thread.el25
-rw-r--r--lisp/mh-e/mh-utils.el1
-rw-r--r--lisp/minibuf-eldef.el3
-rw-r--r--lisp/minibuffer.el56
-rw-r--r--lisp/mouse.el143
-rw-r--r--lisp/mpc.el30
-rw-r--r--lisp/msb.el3
-rw-r--r--lisp/multifile.el217
-rw-r--r--lisp/mwheel.el24
-rw-r--r--lisp/net/ange-ftp.el71
-rw-r--r--lisp/net/browse-url.el15
-rw-r--r--lisp/net/dbus.el9
-rw-r--r--lisp/net/dns.el24
-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.el3
-rw-r--r--lisp/net/eww.el80
-rw-r--r--lisp/net/gnutls.el21
-rw-r--r--lisp/net/goto-addr.el9
-rw-r--r--lisp/net/imap.el182
-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.el25
-rw-r--r--lisp/net/newst-backend.el309
-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.el44
-rw-r--r--lisp/net/pop3.el26
-rw-r--r--lisp/net/puny.el1
-rw-r--r--lisp/net/quickurl.el2
-rw-r--r--lisp/net/rcirc.el21
-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.el227
-rw-r--r--lisp/net/sieve-manage.el39
-rw-r--r--lisp/net/soap-client.el21
-rw-r--r--lisp/net/socks.el524
-rw-r--r--lisp/net/tramp-adb.el161
-rw-r--r--lisp/net/tramp-archive.el646
-rw-r--r--lisp/net/tramp-cache.el59
-rw-r--r--lisp/net/tramp-cmds.el25
-rw-r--r--lisp/net/tramp-compat.el49
-rw-r--r--lisp/net/tramp-gvfs.el900
-rw-r--r--lisp/net/tramp-sh.el510
-rw-r--r--lisp/net/tramp-smb.el271
-rw-r--r--lisp/net/tramp.el603
-rw-r--r--lisp/net/trampver.el14
-rw-r--r--lisp/net/zeroconf.el2
-rw-r--r--lisp/newcomment.el28
-rw-r--r--lisp/novice.el3
-rw-r--r--lisp/nxml/nxml-mode.el37
-rw-r--r--lisp/nxml/rng-loc.el2
-rw-r--r--lisp/nxml/rng-maint.el5
-rw-r--r--lisp/obsolete/assoc.el1
-rw-r--r--lisp/obsolete/complete.el1
-rw-r--r--lisp/obsolete/crisp.el5
-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.el35
-rw-r--r--lisp/obsolete/pgg-pgp.el3
-rw-r--r--lisp/obsolete/pgg-pgp5.el3
-rw-r--r--lisp/obsolete/pgg.el8
-rw-r--r--lisp/obsolete/sregex.el4
-rw-r--r--lisp/obsolete/starttls.el (renamed from lisp/net/starttls.el)1
-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.el7
-rw-r--r--lisp/obsolete/vi.el2
-rw-r--r--lisp/obsolete/vip.el2
-rw-r--r--lisp/obsolete/xesam.el3
-rw-r--r--lisp/org/ob-core.el5
-rw-r--r--lisp/org/ob-eval.el2
-rw-r--r--lisp/org/org-agenda.el34
-rw-r--r--lisp/org/org-attach.el2
-rw-r--r--lisp/org/org-clock.el14
-rw-r--r--lisp/org/org-ctags.el5
-rw-r--r--lisp/org/org-element.el4
-rw-r--r--lisp/org/org-footnote.el2
-rw-r--r--lisp/org/org-indent.el25
-rw-r--r--lisp/org/org-macro.el3
-rw-r--r--lisp/org/org-macs.el2
-rw-r--r--lisp/org/org-pcomplete.el20
-rw-r--r--lisp/org/org.el38
-rw-r--r--lisp/org/ox-html.el3
-rw-r--r--lisp/org/ox-odt.el4
-rw-r--r--lisp/org/ox-publish.el13
-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.el73
-rw-r--r--lisp/pixel-scroll.el5
-rw-r--r--lisp/play/bubbles.el32
-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.el178
-rw-r--r--lisp/play/gametree.el3
-rw-r--r--lisp/printing.el6
-rw-r--r--lisp/profiler.el6
-rw-r--r--lisp/progmodes/ada-mode.el22
-rw-r--r--lisp/progmodes/antlr-mode.el39
-rw-r--r--lisp/progmodes/bat-mode.el2
-rw-r--r--lisp/progmodes/bug-reference.el5
-rw-r--r--lisp/progmodes/cc-align.el11
-rw-r--r--lisp/progmodes/cc-cmds.el537
-rw-r--r--lisp/progmodes/cc-defs.el28
-rw-r--r--lisp/progmodes/cc-engine.el705
-rw-r--r--lisp/progmodes/cc-fonts.el42
-rw-r--r--lisp/progmodes/cc-langs.el144
-rw-r--r--lisp/progmodes/cc-mode.el318
-rw-r--r--lisp/progmodes/cc-vars.el9
-rw-r--r--lisp/progmodes/cmacexp.el3
-rw-r--r--lisp/progmodes/compile.el20
-rw-r--r--lisp/progmodes/cperl-mode.el1403
-rw-r--r--lisp/progmodes/cpp.el19
-rw-r--r--lisp/progmodes/cwarn.el6
-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.el4
-rw-r--r--lisp/progmodes/ebnf2ps.el102
-rw-r--r--lisp/progmodes/ebrowse.el4
-rw-r--r--lisp/progmodes/elisp-mode.el22
-rw-r--r--lisp/progmodes/etags.el348
-rw-r--r--lisp/progmodes/f90.el15
-rw-r--r--lisp/progmodes/flymake-cc.el140
-rw-r--r--lisp/progmodes/flymake-proc.el60
-rw-r--r--lisp/progmodes/flymake.el435
-rw-r--r--lisp/progmodes/fortran.el8
-rw-r--r--lisp/progmodes/gdb-mi.el12
-rw-r--r--lisp/progmodes/glasses.el11
-rw-r--r--lisp/progmodes/grep.el79
-rw-r--r--lisp/progmodes/gud.el25
-rw-r--r--lisp/progmodes/hideif.el13
-rw-r--r--lisp/progmodes/hideshow.el3
-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.el46
-rw-r--r--lisp/progmodes/js.el36
-rw-r--r--lisp/progmodes/make-mode.el6
-rw-r--r--lisp/progmodes/octave.el8
-rw-r--r--lisp/progmodes/pascal.el4
-rw-r--r--lisp/progmodes/perl-mode.el13
-rw-r--r--lisp/progmodes/prog-mode.el3
-rw-r--r--lisp/progmodes/project.el46
-rw-r--r--lisp/progmodes/python.el177
-rw-r--r--lisp/progmodes/ruby-mode.el13
-rw-r--r--lisp/progmodes/sh-script.el1
-rw-r--r--lisp/progmodes/sql.el584
-rw-r--r--lisp/progmodes/subword.el6
-rw-r--r--lisp/progmodes/tcl.el51
-rw-r--r--lisp/progmodes/verilog-mode.el4
-rw-r--r--lisp/progmodes/vhdl-mode.el14
-rw-r--r--lisp/progmodes/which-func.el3
-rw-r--r--lisp/progmodes/xref.el24
-rw-r--r--lisp/ps-bdf.el14
-rw-r--r--lisp/ps-def.el7
-rw-r--r--lisp/ps-mule.el4
-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.el1
-rw-r--r--lisp/register.el281
-rw-r--r--lisp/registry.el5
-rw-r--r--lisp/replace.el361
-rw-r--r--lisp/reveal.el9
-rw-r--r--lisp/rfn-eshadow.el3
-rw-r--r--lisp/rtree.el7
-rw-r--r--lisp/ruler-mode.el31
-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.el179
-rw-r--r--lisp/ses.el4
-rw-r--r--lisp/shadowfile.el9
-rw-r--r--lisp/shell.el27
-rw-r--r--lisp/simple.el562
-rw-r--r--lisp/skeleton.el4
-rw-r--r--lisp/speedbar.el51
-rw-r--r--lisp/startup.el455
-rw-r--r--lisp/strokes.el3
-rw-r--r--lisp/subr.el446
-rw-r--r--lisp/svg.el22
-rw-r--r--lisp/t-mouse.el3
-rw-r--r--lisp/tar-mode.el28
-rw-r--r--lisp/term.el682
-rw-r--r--lisp/term/common-win.el32
-rw-r--r--lisp/term/internal.el3
-rw-r--r--lisp/term/ns-win.el42
-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.el123
-rw-r--r--lisp/textmodes/artist.el10
-rw-r--r--lisp/textmodes/bibtex.el112
-rw-r--r--lisp/textmodes/css-mode.el225
-rw-r--r--lisp/textmodes/dns-mode.el2
-rw-r--r--lisp/textmodes/enriched.el23
-rw-r--r--lisp/textmodes/fill.el21
-rw-r--r--lisp/textmodes/flyspell.el23
-rw-r--r--lisp/textmodes/ispell.el184
-rw-r--r--lisp/textmodes/mhtml-mode.el2
-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/refill.el3
-rw-r--r--lisp/textmodes/reftex-ref.el2
-rw-r--r--lisp/textmodes/reftex-vars.el6
-rw-r--r--lisp/textmodes/remember.el10
-rw-r--r--lisp/textmodes/rst.el55
-rw-r--r--lisp/textmodes/sgml-mode.el40
-rw-r--r--lisp/textmodes/tex-mode.el3
-rw-r--r--lisp/textmodes/texinfmt.el2
-rw-r--r--lisp/textmodes/texinfo.el5
-rw-r--r--lisp/thingatpt.el54
-rw-r--r--lisp/thread.el200
-rw-r--r--lisp/thumbs.el4
-rw-r--r--lisp/time.el43
-rw-r--r--lisp/tool-bar.el3
-rw-r--r--lisp/tooltip.el18
-rw-r--r--lisp/type-break.el17
-rw-r--r--lisp/url/url-auth.el6
-rw-r--r--lisp/url/url-cache.el12
-rw-r--r--lisp/url/url-cookie.el106
-rw-r--r--lisp/url/url-dired.el5
-rw-r--r--lisp/url/url-file.el26
-rw-r--r--lisp/url/url-handlers.el18
-rw-r--r--lisp/url/url-http.el72
-rw-r--r--lisp/url/url-queue.el18
-rw-r--r--lisp/url/url-util.el28
-rw-r--r--lisp/url/url-vars.el28
-rw-r--r--lisp/url/url.el3
-rw-r--r--lisp/userlock.el2
-rw-r--r--lisp/vc/add-log.el108
-rw-r--r--lisp/vc/diff-mode.el327
-rw-r--r--lisp/vc/diff.el5
-rw-r--r--lisp/vc/ediff-merg.el2
-rw-r--r--lisp/vc/ediff-util.el39
-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.el18
-rw-r--r--lisp/vc/pcvs-info.el8
-rw-r--r--lisp/vc/pcvs-parse.el1
-rw-r--r--lisp/vc/pcvs.el2
-rw-r--r--lisp/vc/smerge-mode.el13
-rw-r--r--lisp/vc/vc-bzr.el12
-rw-r--r--lisp/vc/vc-cvs.el15
-rw-r--r--lisp/vc/vc-dir.el8
-rw-r--r--lisp/vc/vc-dispatcher.el30
-rw-r--r--lisp/vc/vc-git.el81
-rw-r--r--lisp/vc/vc-hg.el40
-rw-r--r--lisp/vc/vc-hooks.el32
-rw-r--r--lisp/vc/vc-rcs.el9
-rw-r--r--lisp/vc/vc-svn.el6
-rw-r--r--lisp/vc/vc.el38
-rw-r--r--lisp/vcursor.el3
-rw-r--r--lisp/version.el6
-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.el24
-rw-r--r--lisp/wid-browse.el5
-rw-r--r--lisp/windmove.el18
-rw-r--r--lisp/window.el105
-rw-r--r--lisp/winner.el3
-rw-r--r--lisp/woman.el88
-rw-r--r--lisp/x-dnd.el17
-rw-r--r--lisp/xdg.el105
-rw-r--r--lisp/xml.el13
-rw-r--r--lisp/xt-mouse.el3
-rw-r--r--lwlib/Makefile.in2
-rw-r--r--lwlib/lwlib-Xaw.h6
-rw-r--r--lwlib/lwlib-Xlw.h6
-rw-r--r--lwlib/lwlib.h6
-rw-r--r--m4/builtin-expect.m449
-rw-r--r--m4/c-strtod.m431
-rw-r--r--m4/eealloc.m431
-rw-r--r--m4/extensions.m48
-rw-r--r--m4/extern-inline.m416
-rw-r--r--m4/fsusage.m4336
-rw-r--r--m4/getloadavg.m49
-rw-r--r--m4/glibc21.m434
-rw-r--r--m4/gnulib-common.m429
-rw-r--r--m4/gnulib-comp.m451
-rw-r--r--m4/ieee754-h.m421
-rw-r--r--m4/inttypes.m43
-rw-r--r--m4/limits-h.m424
-rw-r--r--m4/lstat.m45
-rw-r--r--m4/manywarnings.m424
-rw-r--r--m4/mbstate_t.m441
-rw-r--r--m4/nocrash.m44
-rw-r--r--m4/pkg.m416
-rw-r--r--m4/pselect.m412
-rw-r--r--m4/pthread_sigmask.m470
-rw-r--r--m4/readlink.m412
-rw-r--r--m4/regex.m4300
-rw-r--r--m4/stddef_h.m429
-rw-r--r--m4/stdint.m45
-rw-r--r--m4/stdio_h.m44
-rw-r--r--m4/stdlib_h.m45
-rw-r--r--m4/symlink.m412
-rw-r--r--m4/time_rz.m433
-rw-r--r--m4/unistd_h.m411
-rw-r--r--m4/utimens.m412
-rw-r--r--m4/vararrays.m466
-rw-r--r--m4/warnings.m411
-rwxr-xr-xmake-dist281
-rw-r--r--msdos/sed2v2.inp2
-rw-r--r--nextstep/Makefile.in2
-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/ms-w32.h5
-rw-r--r--oldXMenu/Makefile.in2
-rw-r--r--src/.gdbinit90
-rw-r--r--src/Makefile.in54
-rw-r--r--src/alloc.c968
-rw-r--r--src/atimer.c15
-rw-r--r--src/bidi.c22
-rw-r--r--src/bignum.c332
-rw-r--r--src/bignum.h88
-rw-r--r--src/buffer.c470
-rw-r--r--src/buffer.h30
-rw-r--r--src/bytecode.c123
-rw-r--r--src/callint.c344
-rw-r--r--src/callproc.c29
-rw-r--r--src/casefiddle.c20
-rw-r--r--src/casetab.c35
-rw-r--r--src/category.c52
-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.c308
-rw-r--r--src/charset.h6
-rw-r--r--src/chartab.c100
-rw-r--r--src/cmds.c63
-rw-r--r--src/coding.c444
-rw-r--r--src/coding.h27
-rw-r--r--src/composite.c154
-rw-r--r--src/composite.h58
-rw-r--r--src/conf_post.h46
-rw-r--r--src/data.c1000
-rw-r--r--src/dbusbind.c118
-rw-r--r--src/decompress.c34
-rw-r--r--src/deps.mk9
-rw-r--r--src/dired.c97
-rw-r--r--src/dispextern.h40
-rw-r--r--src/dispnew.c50
-rw-r--r--src/disptab.h4
-rw-r--r--src/doc.c79
-rw-r--r--src/doprnt.c2
-rw-r--r--src/dosfns.c82
-rw-r--r--src/dynlib.c5
-rw-r--r--src/editfns.c1165
-rw-r--r--src/emacs-module.c131
-rw-r--r--src/emacs.c71
-rw-r--r--src/eval.c314
-rw-r--r--src/fileio.c336
-rw-r--r--src/floatfns.c230
-rw-r--r--src/fns.c559
-rw-r--r--src/font.c470
-rw-r--r--src/font.h44
-rw-r--r--src/fontset.c120
-rw-r--r--src/frame.c504
-rw-r--r--src/frame.h23
-rw-r--r--src/fringe.c67
-rw-r--r--src/ftcrfont.c5
-rw-r--r--src/ftfont.c116
-rw-r--r--src/gfilenotify.c15
-rw-r--r--src/gmalloc.c16
-rw-r--r--src/gnutls.c206
-rw-r--r--src/gtkutil.c71
-rw-r--r--src/image.c185
-rw-r--r--src/indent.c152
-rw-r--r--src/inotify.c26
-rw-r--r--src/insdel.c34
-rw-r--r--src/intervals.c52
-rw-r--r--src/intervals.h2
-rw-r--r--src/json.c1031
-rw-r--r--src/keyboard.c961
-rw-r--r--src/keyboard.h9
-rw-r--r--src/keymap.c333
-rw-r--r--src/kqueue.c42
-rw-r--r--src/lastfile.c3
-rw-r--r--src/lcms.c7
-rw-r--r--src/lisp.h1208
-rw-r--r--src/lread.c710
-rw-r--r--src/macfont.m86
-rw-r--r--src/macros.c22
-rw-r--r--src/marker.c62
-rw-r--r--src/menu.c140
-rw-r--r--src/menu.h1
-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.c178
-rw-r--r--src/msdos.c52
-rw-r--r--src/nsfns.m596
-rw-r--r--src/nsfont.m148
-rw-r--r--src/nsgui.h10
-rw-r--r--src/nsimage.m150
-rw-r--r--src/nsmenu.m148
-rw-r--r--src/nsselect.m28
-rw-r--r--src/nsterm.h121
-rw-r--r--src/nsterm.m946
-rw-r--r--src/print.c428
-rw-r--r--src/process.c354
-rw-r--r--src/process.h7
-rw-r--r--src/profiler.c24
-rw-r--r--src/ptr-bounds.h79
-rw-r--r--src/puresize.h2
-rw-r--r--src/regex-emacs.c (renamed from src/regex.c)2766
-rw-r--r--src/regex-emacs.h197
-rw-r--r--src/regex.h644
-rw-r--r--src/scroll.c30
-rw-r--r--src/search.c924
-rw-r--r--src/sound.c17
-rw-r--r--src/syntax.c219
-rw-r--r--src/syntax.h16
-rw-r--r--src/sysdep.c208
-rw-r--r--src/syssignal.h1
-rw-r--r--src/systhread.c98
-rw-r--r--src/systhread.h23
-rw-r--r--src/systime.h26
-rw-r--r--src/term.c78
-rw-r--r--src/termhooks.h10
-rw-r--r--src/terminal.c6
-rw-r--r--src/textprop.c254
-rw-r--r--src/thread.c84
-rw-r--r--src/thread.h32
-rw-r--r--src/tparam.h5
-rw-r--r--src/undo.c34
-rw-r--r--src/unexcw.c6
-rw-r--r--src/w16select.c41
-rw-r--r--src/w32.c577
-rw-r--r--src/w32.h15
-rw-r--r--src/w32common.h31
-rw-r--r--src/w32console.c12
-rw-r--r--src/w32cygwinx.c135
-rw-r--r--src/w32fns.c954
-rw-r--r--src/w32font.c51
-rw-r--r--src/w32heap.c6
-rw-r--r--src/w32inevt.c8
-rw-r--r--src/w32menu.c17
-rw-r--r--src/w32notify.c17
-rw-r--r--src/w32proc.c118
-rw-r--r--src/w32reg.c8
-rw-r--r--src/w32select.c56
-rw-r--r--src/w32term.c133
-rw-r--r--src/w32term.h6
-rw-r--r--src/w32uniscribe.c19
-rw-r--r--src/widget.c10
-rw-r--r--src/window.c568
-rw-r--r--src/window.h13
-rw-r--r--src/xdisp.c930
-rw-r--r--src/xfaces.c480
-rw-r--r--src/xfns.c593
-rw-r--r--src/xfont.c26
-rw-r--r--src/xftfont.c28
-rw-r--r--src/xmenu.c56
-rw-r--r--src/xml.c50
-rw-r--r--src/xrdb.c6
-rw-r--r--src/xselect.c87
-rw-r--r--src/xsettings.c2
-rw-r--r--src/xterm.c197
-rw-r--r--src/xterm.h4
-rw-r--r--src/xwidget.c128
-rw-r--r--src/xwidget.h11
-rw-r--r--test/Makefile.in39
-rw-r--r--test/README32
-rw-r--r--test/data/emacs-module/mod-test.c4
-rw-r--r--test/data/xdg/mimeapps.list9
-rw-r--r--test/data/xdg/mimeinfo.cache4
-rw-r--r--test/lisp/abbrev-tests.el17
-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.el16
-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-tests.el87
-rw-r--r--test/lisp/dired-aux-tests.el77
-rw-r--r--test/lisp/dired-tests.el23
-rw-r--r--test/lisp/electric-tests.el104
-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.el15
-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.el178
-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.el44
-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/package-tests.el45
-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.el5
-rw-r--r--test/lisp/epg-tests.el43
-rw-r--r--test/lisp/eshell/em-ls-tests.el1
-rw-r--r--test/lisp/eshell/esh-opt-tests.el124
-rw-r--r--test/lisp/filenotify-tests.el433
-rw-r--r--test/lisp/files-tests.el801
-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/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/mouse-tests.el14
-rw-r--r--test/lisp/net/gnutls-tests.el30
-rw-r--r--test/lisp/net/secrets-tests.el275
-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.el948
-rw-r--r--test/lisp/net/tramp-tests.el892
-rw-r--r--test/lisp/progmodes/bat-mode-tests.el5
-rw-r--r--test/lisp/progmodes/flymake-tests.el14
-rw-r--r--test/lisp/progmodes/python-tests.el15
-rw-r--r--test/lisp/progmodes/ruby-mode-tests.el6
-rw-r--r--test/lisp/progmodes/tcl-tests.el77
-rw-r--r--test/lisp/ses-tests.el80
-rw-r--r--test/lisp/simple-tests.el72
-rw-r--r--test/lisp/subr-tests.el50
-rw-r--r--test/lisp/term-tests.el20
-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.el2
-rw-r--r--test/lisp/vc/vc-tests.el2
-rw-r--r--test/lisp/xdg-tests.el12
-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/src/buffer-tests.el10
-rw-r--r--test/src/callint-tests.el54
-rw-r--r--test/src/data-tests.el169
-rw-r--r--test/src/editfns-tests.el87
-rw-r--r--test/src/emacs-module-tests.el53
-rw-r--r--test/src/eval-tests.el46
-rw-r--r--test/src/fileio-tests.el6
-rw-r--r--test/src/floatfns-tests.el93
-rw-r--r--test/src/fns-tests.el70
-rw-r--r--test/src/json-tests.el290
-rw-r--r--test/src/keyboard-tests.el36
-rw-r--r--test/src/lread-tests.el50
-rw-r--r--test/src/print-tests.el46
-rw-r--r--test/src/process-tests.el34
-rw-r--r--test/src/regex-emacs-tests.el (renamed from test/src/regex-tests.el)12
-rw-r--r--test/src/thread-tests.el55
1258 files changed, 77676 insertions, 40265 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/.gitignore b/.gitignore
index d3712b0d6cf..26fe4bb34e8 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
diff --git a/ChangeLog.2 b/ChangeLog.2
index b01ab19ebec..71c792e40bc 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/Makefile.in b/Makefile.in
index 19bf7c423ff..c6b2cfa78af 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -516,9 +516,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
@@ -837,7 +839,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'
@@ -924,7 +926,7 @@ $(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.
@@ -1158,3 +1160,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 8fcbb2f43d6..25adcfdbdc9 100644
--- a/README
+++ b/README
@@ -2,7 +2,7 @@ Copyright (C) 2001-2018 Free Software Foundation, Inc.
See the end of the file for license conditions.
-This directory tree holds version 26.1.50 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..04d1ff76f36 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
diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS
index 1a4157ac53e..6db1d8801cb 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/automerge b/admin/automerge
new file mode 100755
index 00000000000..e88711f8d6d
--- /dev/null
+++ b/admin/automerge
@@ -0,0 +1,253 @@
+#!/bin/bash
+### automerge - automatically merge the Emacs release branch to master
+
+## Copyright (C) 2018 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
+
+
+[ "$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/find-gc.el b/admin/find-gc.el
index fb564039c7b..e8cc1136501 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 1058088cce9..a123e0352d7 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\\|\
+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)
@@ -291,23 +321,47 @@ 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
+ ((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))
+ (tempfile (make-temp-file "gitmerge")))
+ (unwind-protect
+ (progn
+ (call-process "git" nil `(:file ,tempfile) nil "diff"
+ (format ":1:%s" file)
+ (format ":3:%s" file))
+ (call-process "git" nil t nil "reset" "--" relfile)
+ (call-process "git" nil t nil "checkout" "--" relfile)
+ (revert-buffer nil 'noconfirm)
+ (call-process "patch" tempfile nil nil temp)
+ (call-process "git" nil t nil "add" "--" temp))
+ (delete-file tempfile))))
+ ;; 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 +441,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 +474,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 +496,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 +505,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 +562,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 +579,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 +595,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 3f550dfb201..da1320dbf0b 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 ce9fff0286a..5ea25508fd4 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 b23adc26fb2..abb192911d9 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
+ crypto/md5-buffer crypto/sha1-buffer crypto/sha256-buffer crypto/sha512-buffer
d-type diffseq dtoastr dtotimespec dup2
environ execinfo explicit_bzero faccessat
fcntl fcntl-h fdatasync fdopendir
- filemode filevercmp flexmember fpieee fstatat fsync
+ 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 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 c39458184f6..f3bc3045542 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.
Some useful control commands:
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/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 4240ac1e76d..40f93fc216f 100644
--- a/admin/notes/unicode
+++ b/admin/notes/unicode
@@ -232,10 +232,6 @@ nontrivial changes to the build process.
* iso-2022-7bit
- This file switches between CJK charsets, which is not encoded in UTF-8.
-
- 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
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 fe98ebdcc7c..e6c1ce8ff38 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 d008626bb3b..7ffa8624765 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/unidata-gen.el b/admin/unidata/unidata-gen.el
index 8cc1893adbb..e520d189090 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))
diff --git a/admin/unidata/uvs.el b/admin/unidata/uvs.el
index 6bb6a2ab763..31840fb1822 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)
diff --git a/admin/update_autogen b/admin/update_autogen
index d2118674792..f4c2c39825c 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 acebc2381a3..2d52f9ea551 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 588fe82a42a..b33c9e890e0 100755
--- a/build-aux/config.guess
+++ b/build-aux/config.guess
@@ -2,7 +2,7 @@
# Attempt to guess a canonical system name.
# Copyright 1992-2018 Free Software Foundation, Inc.
-timestamp='2018-01-01'
+timestamp='2018-08-29'
# 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,39 @@ 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"' 1 2 13 15
+trap 'exitcode=$?; test -z "$tmp" || rm -fr "$tmp"; exit $exitcode' 0
+
+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 +135,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 +152,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 +179,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 +218,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 +229,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 +329,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 +338,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 +353,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,38 +380,33 @@ 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
- 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.
- # This test works for both compilers.
- if [ "$CC_FOR_BUILD" != no_compiler_found ]; then
- if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \
- (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \
- grep IS_64BIT_ARCH >/dev/null
- then
- SUN_ARCH=x86_64
- fi
- fi
- echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+ UNAME_REL="`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'`"
+ case `isainfo -b` in
+ 32)
+ echo i386-pc-solaris2"$UNAME_REL"
+ ;;
+ 64)
+ echo x86_64-pc-solaris2"$UNAME_REL"
+ ;;
+ esac
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 +415,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 +444,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 +502,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 +532,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 +559,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 +571,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 +589,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 +603,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 +612,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 +623,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 +638,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 +692,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 +717,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 +750,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 +771,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 +798,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
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,63 +925,63 @@ 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
+ sed 's/^ //' << EOF > "$dummy.c"
#undef CPU
#undef ${UNAME_MACHINE}
#undef ${UNAME_MACHINE}el
@@ -979,70 +995,70 @@ EOF
#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'`"
+ test "x$CPU" != x && { echo "$CPU-unknown-linux-$LIBC"; 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 +1072,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 +1109,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 +1124,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 +1146,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 +1168,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 +1179,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 +1211,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 +1231,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 +1266,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 +1326,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 +1334,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 +1361,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 +1394,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,16 +1410,16 @@ 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
@@ -1408,7 +1428,7 @@ esac
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 +1470,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 f2632cd8a2b..b51fb8cdb69 100755
--- a/build-aux/config.sub
+++ b/build-aux/config.sub
@@ -2,7 +2,7 @@
# Configuration validation subroutine script.
# Copyright 1992-2018 Free Software Foundation, Inc.
-timestamp='2018-01-01'
+timestamp='2018-08-29'
# 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
@@ -94,7 +94,7 @@ while test $# -gt 0 ; do
*local*)
# First pass through any local machine types.
- echo $1
+ echo "$1"
exit ;;
* )
@@ -110,1251 +110,1159 @@ 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
+IFS="-" read -r 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 patern
+ 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
+
+ *-*)
+ IFS="-" read -r 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 cannonical 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 cannonical 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 cannonical 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 \
+ | 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 | v70 | w65 \
+ | m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | nvptx | picochip \
+ | m88110 | m88k | maxq | mb | mcore | mep | 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 \
+ | mn10200 | mn10300 \
+ | moxie \
+ | mt \
+ | msp430 \
+ | nds32 | nds32le | nds32be \
+ | nfp \
+ | nios | nios2 | nios2eb | nios2el \
+ | none | np1 | ns16k | ns32k \
+ | open8 \
+ | or1k* \
+ | or32 \
+ | orion \
+ | pdp10 | pdp11 | pj | pjl | pn | power \
+ | powerpc | powerpc64 | powerpc64le | powerpcle | powerpcspe \
+ | pru \
+ | pyramid \
+ | riscv | riscv32 | riscv64 \
+ | rl78 | romp | rs6000 | rx \
+ | score \
+ | sh | 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 \
+ | v850 | v850e | v850e1 | v850es | v850e2 | v850e2v3 \
+ | vax \
+ | visium \
+ | 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 +1270,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*)
# 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 +1525,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 d8074aadabf..1e73f4214f7 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 f15923613c8..5da3eae80ae 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
@@ -75,7 +75,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 3bb26abea1b..f2fc97e368f 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-2018 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 029f451cd4a..6f3d7338c35 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.50, 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.
@@ -355,6 +355,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 +372,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])
@@ -899,10 +905,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 +952,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
@@ -1221,53 +1226,63 @@ AC_SUBST([FIND_DELETE])
PAXCTL_dumped=
PAXCTL_notdumped=
-if test $opsys = gnu-linux; then
- if test "${SETFATTR+set}" != set; then
- AC_CACHE_CHECK([for setfattr],
- [emacs_cv_prog_setfattr],
- [touch conftest.tmp
- if (setfattr -n user.pax.flags conftest.tmp) >/dev/null 2>&1; then
- emacs_cv_prog_setfattr=yes
- else
- emacs_cv_prog_setfattr=no
- fi])
- if test "$emacs_cv_prog_setfattr" = yes; then
- PAXCTL_notdumped='$(SETFATTR) -n user.pax.flags -v er'
- SETFATTR=setfattr
- else
- SETFATTR=
+if test "$CANNOT_DUMP" != yes; then
+ if test $opsys = gnu-linux; then
+ if test "${SETFATTR+set}" != set; then
+ AC_CACHE_CHECK([for setfattr],
+ [emacs_cv_prog_setfattr],
+ [touch conftest.tmp
+ if (setfattr -n user.pax.flags conftest.tmp) >/dev/null 2>&1; then
+ emacs_cv_prog_setfattr=yes
+ else
+ emacs_cv_prog_setfattr=no
+ fi])
+ if test "$emacs_cv_prog_setfattr" = yes; then
+ PAXCTL_notdumped='$(SETFATTR) -n user.pax.flags -v er'
+ SETFATTR=setfattr
+ else
+ SETFATTR=
+ fi
+ rm -f conftest.tmp
+ AC_SUBST([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])
+# 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
case `($MAKEINFO --version) 2>/dev/null` in
@@ -1320,39 +1335,6 @@ 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 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
- 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 x$emacs_cv_znocombreloc = xno; then
- LDFLAGS_NOCOMBRELOC=
-fi
-
-
AC_CACHE_CHECK([whether addresses are sanitized],
[emacs_cv_sanitize_address],
[AC_COMPILE_IFELSE(
@@ -2076,7 +2058,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 +2093,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)
@@ -2521,11 +2509,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
@@ -2870,6 +2867,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
@@ -3272,6 +3290,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?
@@ -3428,7 +3450,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 +3495,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=
@@ -3563,45 +3584,54 @@ 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
@@ -3862,13 +3892,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
@@ -4276,6 +4306,32 @@ 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>]])
@@ -5217,7 +5273,7 @@ case "$opsys" in
if test "$HAVE_NS" = "yes"; then
libs_nsgui="-framework AppKit"
if test "$NS_IMPL_COCOA" = "yes"; then
- libs_nsgui="$libs_nsgui -framework IOKit"
+ libs_nsgui="$libs_nsgui -framework IOKit -framework Carbon"
fi
else
libs_nsgui=
@@ -5262,19 +5318,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 "$CANNOT_DUMP" = yes; 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
@@ -5283,8 +5345,6 @@ if test x$ac_enable_profiling != x ; then
esac
fi
-LD_SWITCH_SYSTEM_TEMACS="$LDFLAGS_NOCOMBRELOC $LD_SWITCH_SYSTEM_TEMACS"
-
AC_SUBST(LD_SWITCH_SYSTEM_TEMACS)
## Common for all window systems
@@ -5368,7 +5428,7 @@ 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 CANNOT_DUMP LCMS2 GMP; do
case $opt in
CANNOT_DUMP) eval val=\${$opt} ;;
@@ -5404,7 +5464,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}
@@ -5420,6 +5480,8 @@ 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}
@@ -5438,9 +5500,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 ab9da47513f..26a0d3e9f9d 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 1da2f1550f9..54e173f8d67 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 7e250bf4250..496c4275bc2 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/custom.texi b/doc/emacs/custom.texi
index b93009ad216..ddde5b22e6b 100644
--- a/doc/emacs/custom.texi
+++ b/doc/emacs/custom.texi
@@ -2209,6 +2209,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
@@ -2609,3 +2610,33 @@ 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}.
diff --git a/doc/emacs/dired.texi b/doc/emacs/dired.texi
index fba9d31406e..1b03a3967aa 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.
@@ -1457,6 +1468,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 2f5ce80d607..d9a08b974f6 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 f97a758f324..b64a59df707 100644
--- a/doc/emacs/emacs.texi
+++ b/doc/emacs/emacs.texi
@@ -1163,6 +1163,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
diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi
index e950767c384..c7d3b40f9d1 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.
@@ -1015,13 +1021,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
@@ -1308,17 +1317,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
@@ -1441,7 +1441,7 @@ remains correct. To disable automatic line number correction,
change the variable @code{diff-update-on-the-fly} to @code{nil}.
Diff mode treats each hunk as an error message, similar to
-Compilation mode. Thus, you can use commands such as @kbd{C-x `} to
+Compilation mode. Thus, you can use commands such as @kbd{M-g M-n} to
visit the corresponding source locations. @xref{Compilation Mode}.
In addition, Diff mode provides the following commands to navigate,
diff --git a/doc/emacs/fixit.texi b/doc/emacs/fixit.texi
index 7bbaa0016ba..8277278f521 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/help.texi b/doc/emacs/help.texi
index 94d27a276dc..66673eb2337 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/maintaining.texi b/doc/emacs/maintaining.texi
index d7d7eddf621..4527c23d9e7 100644
--- a/doc/emacs/maintaining.texi
+++ b/doc/emacs/maintaining.texi
@@ -1640,21 +1640,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 +1823,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 +1865,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 +1981,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 multifile-continue
Restart one of the last 2 commands above, from the current location of point.
@end table
@@ -1996,9 +2017,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 multifile-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 multifile-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 +2042,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 multifile-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 multifile-continue}}.
Note that the commands described above carry out much broader
searches than the @code{xref-find-definitions} family. The
@@ -2056,7 +2077,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 +2116,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 e180d1d185d..6fc28903fc7 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 27cd317fe3b..236cb07785c 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
@@ -985,8 +1026,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 +1174,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 +1221,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
@@ -2565,7 +2612,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 679bdd3e83b..c69c7d37f9b 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/package.texi b/doc/emacs/package.texi
index bc6afb7966a..43f5a8497d9 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 46711aaf305..cfeb61e44d4 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 7d16d539128..98eed064536 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 c0ea12f6226..a17ef4938e6 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 053603e54fc..263c4c5dcca 100644
--- a/doc/emacs/search.texi
+++ b/doc/emacs/search.texi
@@ -229,6 +229,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
@@ -250,11 +257,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
@@ -430,7 +437,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.
@@ -439,7 +446,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
@@ -500,6 +507,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{search-exit-option} is customized to @code{shift-move},
+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{search-exit-option} is @code{move}, 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
@@ -1777,7 +1796,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
diff --git a/doc/emacs/sending.texi b/doc/emacs/sending.texi
index 0c5caf0ff98..00b3c4d7531 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 96262a5eef3..1e96163105b 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 7dbd680b9b2..17ce4ad04d3 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,
@@ -354,7 +361,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 71739fdb35f..e2a1229d5ca 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 be3e938b245..0b0c0a167d9 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
@@ -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 98ca90a96d4..221f4f97f51 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 087e6945203..4c9e653cb19 100644
--- a/doc/lispref/abbrevs.texi
+++ b/doc/lispref/abbrevs.texi
@@ -122,7 +122,9 @@ System abbrevs are listed and identified as such. Otherwise the
description is a Lisp expression---a call to @code{define-abbrev-table}
that would define @var{name} as it is currently defined, but without
the system abbrevs. (The mode or package using @var{name} is supposed
-to add these to @var{name} separately.)
+to add these to @var{name} separately.) If the Lisp expression would
+not define any abbrevs (i.e.@: it defines an empty abbrev table), this
+function inserts nothing.
@end defun
@node Defining Abbrevs
diff --git a/doc/lispref/buffers.texi b/doc/lispref/buffers.texi
index b030d2e63a8..1acf4baedba 100644
--- a/doc/lispref/buffers.texi
+++ b/doc/lispref/buffers.texi
@@ -830,7 +830,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/control.texi b/doc/lispref/control.texi
index 5be4b298b46..0f7502f1c20 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -1090,12 +1090,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}
@@ -1250,7 +1248,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)
@@ -1879,9 +1878,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 cbf8778ca8b..89927db21ec 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 deabd31d776..9a6fb422f01 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
@@ -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
diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi
index 5af48fe0963..b1a65117167 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.
@@ -1712,3 +1722,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 6c3182b0c70..a615fcb4b7c 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.
@@ -1344,6 +1346,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
@@ -1388,7 +1391,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 a0e32c5631c..e61ea98e210 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 373b12e79d5..c9401be2535 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
@@ -576,15 +577,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
@@ -874,3 +875,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 c434336d5a6..5682919b645 100644
--- a/doc/lispref/files.texi
+++ b/doc/lispref/files.texi
@@ -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-status-change-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
@@ -2927,7 +2918,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
@@ -3004,10 +2995,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,
@@ -3139,8 +3136,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},
@@ -3161,7 +3158,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},
@@ -3196,7 +3194,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},
@@ -3217,7 +3215,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},
@@ -3411,8 +3410,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 1e008da2476..ba4b9313731 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
@@ -2524,6 +2530,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 +2542,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 +2705,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 +2731,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 +2783,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 +2845,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
diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi
index 93059e8e3a6..05bc8c73d58 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
@@ -1239,7 +1239,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
@@ -1266,15 +1266,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 f7d33eafa34..9c4b56d8dcb 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 db4e413921f..0d50a293f26 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 45c3b87c0ac..d42e2444e68 100644
--- a/doc/lispref/internals.texi
+++ b/doc/lispref/internals.texi
@@ -246,8 +246,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
@@ -318,7 +318,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})
@@ -334,7 +333,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)
@@ -366,19 +365,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)}.
@@ -396,7 +382,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.
@@ -406,6 +392,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.
@@ -507,10 +495,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
@@ -595,6 +581,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
@@ -607,12 +595,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.
@@ -759,6 +741,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.
@@ -996,7 +985,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
@@ -1028,18 +1017,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 f421f3b3efb..197f54ecc52 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.
diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi
index cc2e11e0b6d..d9d213df15a 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 ce62793550d..1548dd49b2f 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
@@ -1144,7 +1160,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 +1178,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 +1752,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 80b75729c13..82c133de753 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 2951ef5aaec..55fde747592 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.
@@ -2239,7 +2245,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.
@@ -2502,7 +2508,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 d7e217c5287..49b7e1ea3fb 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
diff --git a/doc/lispref/nonascii.texi b/doc/lispref/nonascii.texi
index 4d75d6a1f14..9fb5587521d 100644
--- a/doc/lispref/nonascii.texi
+++ b/doc/lispref/nonascii.texi
@@ -829,18 +829,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
diff --git a/doc/lispref/numbers.texi b/doc/lispref/numbers.texi
index c12ffe2cde7..d03113674f5 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:
@@ -305,6 +335,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 +386,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 +425,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 +434,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 +595,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 +848,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 +994,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 +1024,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 +1049,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 +1073,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 +1179,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 +1231,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 b8cae49027c..a0940032eee 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 fd1cf638e78..8ce5a5ed6d8 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}
@vindex window-system-initialization-alist
@item
@@ -154,15 +170,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
@@ -361,6 +368,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}
@@ -384,6 +392,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
@@ -1176,24 +1197,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
@@ -1407,7 +1423,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.
@@ -1660,10 +1677,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
@@ -1723,17 +1736,26 @@ integer 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.
Here is how to add a number of seconds to a time value:
@@ -1978,8 +2000,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 c1c61a1b5c6..37c1ee6697d 100644
--- a/doc/lispref/package.texi
+++ b/doc/lispref/package.texi
@@ -105,24 +105,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
diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi
index 34426f339c6..89ad1cf8381 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
@@ -681,7 +689,9 @@ 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}.
@end table
The original argument list, modified with the actual connection
@@ -2065,8 +2075,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
@@ -2715,8 +2723,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}.
@@ -3119,7 +3126,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
@@ -3362,132 +3368,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 6c1ebb22b53..1b6b80d31b2 100644
--- a/doc/lispref/searching.texi
+++ b/doc/lispref/searching.texi
@@ -642,10 +642,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
.
diff --git a/doc/lispref/sequences.texi b/doc/lispref/sequences.texi
index 51d724cb1d8..6a6f4d5c82e 100644
--- a/doc/lispref/sequences.texi
+++ b/doc/lispref/sequences.texi
@@ -1302,9 +1302,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
@@ -1394,9 +1394,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
diff --git a/doc/lispref/streams.texi b/doc/lispref/streams.texi
index ebd806601ef..032669cb102 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 f3911998799..3558f17301d 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 71c97fdae8c..dcfade3f67d 100644
--- a/doc/lispref/syntax.texi
+++ b/doc/lispref/syntax.texi
@@ -1014,13 +1014,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 477b8fce719..825827095b4 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
@@ -3184,6 +3186,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 +3326,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
@@ -3609,6 +3711,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
@@ -4521,9 +4629,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.
@@ -4541,7 +4649,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
@@ -4708,8 +4816,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
@@ -4721,7 +4836,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
@@ -4776,9 +4894,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.
@@ -4896,6 +5014,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 instantiates
+@code{jsonrpc-connection} objects of one of its concrete subclasses
+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
@@ -5041,8 +5472,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
@@ -5066,6 +5497,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 ddeb2e923fc..c9d5f790485 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/windows.texi b/doc/lispref/windows.texi
index 265067146da..7cfa5ead5f1 100644
--- a/doc/lispref/windows.texi
+++ b/doc/lispref/windows.texi
@@ -4030,6 +4030,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.
@@ -4131,7 +4138,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
@@ -4145,8 +4152,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
@@ -4174,8 +4185,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
@@ -5193,6 +5205,14 @@ whether a specific window has changed size, compare the return values of
@code{window-pixel-height-before-size-change} and
@code{window-pixel-height} for that window (@pxref{Window Sizes}).
+The buffer-local value of this hook is run once for the buffer and the
+frame in question, provided at least one window showing the buffer on
+that frame has changed its size. As it still receives the frame as
+its sole argument, any function called on a buffer-local basis will be
+oblivious to which window(s) showing the buffer changed its (their)
+size and has to check out these windows by using the method described
+in the previous paragraph.
+
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
diff --git a/doc/man/etags.1 b/doc/man/etags.1
index 45d2541ec13..558b249f31b 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 11086b33037..fd07ea4ca13 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 f1667c49f1a..fcbc83ead5b 100644
--- a/doc/misc/auth.texi
+++ b/doc/misc/auth.texi
@@ -86,7 +86,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.
@@ -169,6 +169,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 +238,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 +348,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 +387,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 fdec65a9a7f..83807c6fd28 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/cl.texi b/doc/misc/cl.texi
index 553b935b1ef..6985f194213 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{}
diff --git a/doc/misc/dired-x.texi b/doc/misc/dired-x.texi
index 60915e29962..36a9cb0291a 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 7feb5166fc8..42bedb10f68 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/efaq.texi b/doc/misc/efaq.texi
index 8bdd40c71cf..26d9c82b219 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?
@@ -2958,7 +2988,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 +3041,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 +3763,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 +3774,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 +4568,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-mime.texi b/doc/misc/emacs-mime.texi
index 2c607cc97c5..9280311b5c9 100644
--- a/doc/misc/emacs-mime.texi
+++ b/doc/misc/emacs-mime.texi
@@ -404,12 +404,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
@@ -708,7 +708,7 @@ RFC822 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
@@ -1535,7 +1535,7 @@ 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)
@@ -1561,6 +1561,9 @@ Here's a bunch of time/date/second/day examples:
(time-less-p '(13818 19266) '(13818 19145))
@result{} nil
+(time-equal-p '(13818 19266) '(13818 19145))
+@result{} nil
+
(time-subtract '(13818 19266) '(13818 19145))
@result{} (0 121)
@@ -1641,6 +1644,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 must 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.
@@ -1845,11 +1852,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 6942e853293..6a34f5c5722 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 ea1d070c2aa..c19d5e1a437 100644
--- a/doc/misc/eshell.texi
+++ b/doc/misc/eshell.texi
@@ -330,7 +330,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
diff --git a/doc/misc/eww.texi b/doc/misc/eww.texi
index 43adc2eda0f..aa17eee9d94 100644
--- a/doc/misc/eww.texi
+++ b/doc/misc/eww.texi
@@ -262,6 +262,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 eb82ef04ad1..bda7e1428b5 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-faq.texi b/doc/misc/gnus-faq.texi
index efef01f6978..2ae5a0a0420 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.texi b/doc/misc/gnus.texi
index db0534e8a68..2f7d8407fc4 100644
--- a/doc/misc/gnus.texi
+++ b/doc/misc/gnus.texi
@@ -3102,6 +3102,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 +5592,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 +5616,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 +5658,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 +5850,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 +6680,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 +9815,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 +13230,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 +14320,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 +15501,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
@@ -18478,7 +18513,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:
@@ -19466,8 +19501,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)}
@@ -25854,13 +25889,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")
diff --git a/doc/misc/message.texi b/doc/misc/message.texi
index be1c806c824..61eca759f46 100644
--- a/doc/misc/message.texi
+++ b/doc/misc/message.texi
@@ -162,7 +162,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 +174,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 +185,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 +199,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 +316,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 +345,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 +487,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 +516,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 +593,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 +662,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 +696,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 +746,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 +902,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 +1011,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 +1300,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 +1318,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 +1468,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 +1681,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 +1701,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 +1713,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 +1722,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 +1742,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 +2056,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 +2069,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 +2080,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 +2091,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 +2471,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 +2626,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 +2656,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 b44e503996b..85455257475 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 873ce4d2cdb..9ea78f5ace9 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/texinfo.tex b/doc/misc/texinfo.tex
index 1987c50ba26..d7f7f53a348 100644
--- a/doc/misc/texinfo.tex
+++ b/doc/misc/texinfo.tex
@@ -3,11 +3,11 @@
% 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{2018-06-02.09}
%
% Copyright 1985, 1986, 1988, 1990, 1991, 1992, 1993, 1994, 1995,
% 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-% 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017
+% 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018
% Free Software Foundation, Inc.
%
% This texinfo.tex file is free software: you can redistribute it and/or
@@ -1528,6 +1528,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}
@@ -2235,6 +2238,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}
@@ -2369,6 +2386,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}
@@ -2503,13 +2534,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
}
%
@@ -2519,6 +2557,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.
@@ -11677,7 +11718,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 6e026837079..7bc365ffdfe 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--2018 Free Software Foundation, Inc.
@@ -122,8 +112,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 +155,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
@@ -405,7 +399,8 @@ 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}.
+Hoetzel's @file{tramp-adb.el}. Archive file names are supported since
+December 2017.
XEmacs support was stopped in January 2016. Since March 2017,
@value{tramp} syntax mandates a method.
@@ -463,10 +458,10 @@ 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
@@ -482,12 +477,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}
@@ -502,10 +497,10 @@ must be used here as user name. The default host name is the same.
@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 +513,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
@@ -654,8 +658,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 +680,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 +699,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 +715,21 @@ 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.
@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.
@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 +738,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 +759,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 +787,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 +818,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 +830,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 +846,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 +860,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 +876,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 +896,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 +910,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
@@ -933,18 +929,18 @@ such as the @command{busybox} and do not host any other encode or
decode programs.
@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 +1011,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}
@@ -1061,7 +1057,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 +1068,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 +1078,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 +1089,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 +1107,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
@@ -1395,8 +1391,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}.
@@ -1641,7 +1639,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,6 +1658,13 @@ 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.
@@ -1808,9 +1813,9 @@ shell supports the login argument @samp{-l}.
@end defopt
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 +2024,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 +2053,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 +2272,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 +2295,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 +2352,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
@@ -2553,7 +2559,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
@@ -2875,7 +2881,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}
@@ -2990,6 +2996,242 @@ 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
@@ -3041,7 +3283,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
@@ -3074,7 +3318,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
@@ -3097,6 +3342,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
@@ -3249,6 +3495,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
@@ -3408,7 +3664,7 @@ Due to the remote shell saving tilde expansions triggered by
@value{tramp} can suppress this behavior with the user option
@code{tramp-histfile-override}. When set to @code{t}, environment
variable @env{HISTFILE} is unset, and environment variables
-@env{HISTFILESIZE} @env{HISTSIZE} are set to 0.
+@env{HISTFILESIZE} and @env{HISTSIZE} are set to 0.
Alternatively, @code{tramp-histfile-override} could be a string.
Environment variable @env{HISTFILE} is set to this file name then. Be
@@ -3761,6 +4017,15 @@ export EDITOR=/path/to/emacsclient.sh
@item
+How to determine wheter 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
@@ -3802,6 +4067,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}.
@@ -3811,6 +4077,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
@@ -3819,7 +4100,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.
@@ -3845,6 +4126,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 c6473f5b734..3a3ada9e846 100644
--- a/doc/misc/trampver.texi
+++ b/doc/misc/trampver.texi
@@ -8,7 +8,7 @@
@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
+@set trampver 2.4.1-pre
@c Other flags from configuration
@set instprefix /usr/local
@@ -44,3 +44,13 @@
@set ipv6prefix
@set ipv6postfix
@end ifset
+
+@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
diff --git a/doc/misc/url.texi b/doc/misc/url.texi
index 04bbc48dd2a..eaeae603526 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/DEBUG b/etc/DEBUG
index 50417af5766..1a9068b9c4e 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
diff --git a/etc/HELLO b/etc/HELLO
index 2c95e211369..db7fd23f1a8 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>
+
+Japanese (日本語) こんにちは <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>Korean (한글) 안녕하세요 / 안녕하십니까
+
+<x-charset><param>korean-ksc5601</param>
+
+</x-charset><x-charset><param>unicode</param>
+
Copyright (C) 2001-2018 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/NEWS b/etc/NEWS
index bfd7db016f2..daacf49e62d 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1,1427 +1,943 @@
GNU Emacs NEWS -- history of user-visible changes.
-Copyright (C) 2016-2018 Free Software Foundation, Inc.
+Copyright (C) 2017-2018 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.)
+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,
-* Startup Changes in Emacs 26.2
+* 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.
+
+** 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 support -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.
-
-* Changes in Emacs 26.2
+** Ibuffer
---
-** 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
-
-** Ibuffer
+*** 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.
---
*** New toggle 'ibuffer-do-toggle-lock', bound to 'L'.
-** Imenu
+** Gnus
----
-*** The value for 'imenu-auto-rescan-maxout' has been increased to 600000.
++++
+*** 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.
-** Gnus
+
+* Startup Changes in Emacs 27.1
----
-*** 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.
++++
+** 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.
-** Shell mode
++++
+** 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.
---
-*** 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.)
+** 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.)
-** VC
+
+* Changes in Emacs 27.1
----
-*** 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.)
++++
+** The function 'read-passwd' uses '*' as default character to hide passwords.
---
-**** 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.
+** 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.
---
-**** 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}")'.
+** 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.
---
-** shadowfile.el has been rewritten to support Tramp file names.
-
-
-* New Modes and Packages in Emacs 26.2
-
-
-* Incompatible Lisp Changes in Emacs 26.2
+** Show modeline 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.
----
-** 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.
++++
+** 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.
+++
-** '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.
+** New function 'logcount' calculates an integer's Hamming weight.
----
-** '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'.
++++
+** 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.
-
-* Lisp Changes in Emacs 26.2
++++
+** '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 new function 'read-answer' accepts either long or short answers
-depending on the new customizable variable 'read-answer-short'.
+** The Network Security Manager now allows more fine-grained control
+of what checks to run via the `network-security-protocol-checks'
+variable.
+++
-** New function 'assoc-delete-all'.
-Like 'assq-delete-all', but uses 'equal' for comparison.
+** 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).
----
-** 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.
++++
+** 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.
-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.
++++
+** 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:
-
-* Changes in Emacs 26.2 on Non-Free Operating Systems
+ x\{32768\}
-
-* 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.
+---
+** The German prefix and postfix input methods now support Capital sharp S.
-
-* Startup Changes in Emacs 26.1
+---
+** New input methods hawaiian-postfix and hawaiian-prefix.
-** 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 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.
-** 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.
++++
+** The function 'executable-find' supports an optional argument REMOTE.
+This triggers to search the program on the remote host as indicated by
+'default-directory'.
-** 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.
++++
+** New variable 'auto-save-no-message'.
+When set to t, no message will be shown when auto-saving (default
+value: nil).
-** Emacs now obeys the X resource "scrollBar" at startup.
-The effect is similar to that of "toolBar" resource on the tool bar.
+---
+** 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.
-* 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'.
+* Editing Changes in Emacs 27.1
-'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).
-
-* 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
++++
+** 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.
-*** You can answer 'all' in 'dired-do-delete' to delete recursively all
-remaining directories without more prompts.
+---
+** 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.
-*** Dired supports wildcards in the directory part of the file names.
+---
+** 'write-abbrev-file' now includes special properties.
+'write-abbrev-file' now writes special properties like ':case-fixed'
+for abbrevs that have them.
-*** You can now use '`?`' in 'dired-do-shell-command'.
-It gets replaced by the current file name, like ' ? '.
++++
+** 'insert-abbrev-table-description' skips empty tables.
+'insert-abbrev-table-description' skips inserting empty tables when
+inserting non-readable tables. By extension, this makes
+'write-abbrev-file' skip writing empty tables.
-*** 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.
++++
+** 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 @code{search-forward}.
-*** 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.
+---
+** More commands support noncontiguous rectangular regions, namely
+'upcase-dwim', 'downcase-dwim', 'replace-string', 'replace-regexp'.
-*** 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.
++++
+** 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.
-*** 'W' is now bound to 'browse-url-of-dired-file', and is useful for
-viewing HTML files and the like.
+---
+** 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 (info "(emacs) Directory Variables")
-*** 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.
+
+* Changes in Specialized Modes and Packages in Emacs 27.1
-** html2text is now marked obsolete.
+** project.el
+*** New commands project-search and project-query-replace
-** smerge-refine-regions can refine regions in separate buffers.
+** Etags
++++
+*** 'next-file' is now an obsolete alias of tags-next-file
+*** tags-loop-revert-buffers is an obsolete alias of multifile-revert-buffers
+*** The tags-loop-continue function along with the tags-loop-operate and
+tags-loop-scan variables are now obsolete; use the new multifile-initialize and
+multifile-continue functions instead.
-** Info menu and index completion uses substring completion by default.
-This can be customized via the 'info-menu' category in
-'completion-category-overrides'.
+---
+** bibtex
+*** New commands 'bibtex-next-entry' and 'bibtex-previous-entry'.
+In bibtex-mode-map, forward-paragraph and backward-paragraph are
+remapped to these, respectively.
-** 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'.
++++
+** Dired
-** TeX: Add luatex and xetex as alternatives to pdftex.
+*** New command 'dired-create-empty-file'.
-** Electric-Buffer-menu
+** Change Logs and VC
-*** Key 'U' is bound to 'Buffer-menu-unmark-all' and key 'M-DEL' is
-bound to 'Buffer-menu-unmark-all-buffers'.
+*** 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.
-** 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 customizable variable 'vc-git-grep-template'.
+This new variable allows customizing the default arguments passed to
+git-grep when 'vc-git-grep' is used.
-** bs
+*** 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.
-*** Two new commands 'bs-unmark-all', bound to 'U', and
-'bs-unmark-previous', bound to <backspace>.
+** diff-mode
+*** Hunks are now automatically refined by default.
+To disable it, set the new defcustom 'diff-font-lock-refine' to nil.
-** Buffer-menu
+*** File headers can be shortened, mimicking Magit's diff format.
+To enable it, set the new defcustom 'diff-font-lock-prettify to t.
-*** Two new commands 'Buffer-menu-unmark-all', bound to 'U' and
-'Buffer-menu-unmark-all-buffers', bound to 'M-DEL'.
+** Browse-url
-** Checkdoc
+*** 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.
-*** 'checkdoc-arguments-in-order-flag' now defaults to nil.
+** Comint
-** Gnus
++++
+*** 'send-invisible' is now an obsolete alias for `comint-send-invisible'.
+Also, 'shell-strip-ctrl-m' is declared obsolete.
-*** The ~/.newsrc file will now only be saved if the native select
-method is an NNTP select method.
++++
+*** '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.
-*** A new command for sorting articles by readedness marks has been
-added: 'C-c C-s C-m C-m'.
++++
+*** '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
+
+*** Installation of 'sql-indent' from ELPA is strongly encouraged.
+This package support sophisticated rules for properly indenting SQL
+statements. 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 youhave existing customizations to these variables,
+you should make sure that the new default entry is included.
-*** 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'.
+** Term
-** Ibuffer
+---
+*** 'term-read-noecho' is now obsolete, use 'read-passwd' instead.
-*** New command 'ibuffer-jump'.
+** Flymake
-*** 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'.
++++
+*** 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.
-*** Two new commands 'ibuffer-filter-chosen-by-completion'
-and 'ibuffer-and-filter', the second bound to '/&'.
+*** New customizable variable 'flymake-start-on-save-buffer'.
+Control whether Flymake starts checking the buffer on save.
-*** 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.
+*** 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.
-*** 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.
+** Package
-*** A new command 'ibuffer-copy-buffername-as-kill'; bound
-to 'B'.
+*** 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.
-*** New command 'ibuffer-change-marks'; bound to '* c'.
+*** New function 'package-activate-all'.
-*** A new command 'ibuffer-mark-by-locked' to mark
-all locked buffers; bound to '% L'.
+** Info
-*** A new option 'ibuffer-locked-char' to indicate
-locked buffers; Ibuffer shows a new column displaying
-'ibuffer-locked-char' for locked buffers.
+---
+*** 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.
-*** A new command 'ibuffer-unmark-all-marks' to unmark
-all buffers without asking confirmation; bound to
-'U'; 'ibuffer-do-replace-regexp' bound to 'r'.
+** Xref
-*** A new command 'ibuffer-mark-by-content-regexp' to mark buffers
-whose content matches a regexp; bound to '% g'.
++++
+*** 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.
-*** Two new options 'ibuffer-never-search-content-name' and
-'ibuffer-never-search-content-mode' used by
-'ibuffer-mark-by-content-regexp'.
+** Ecomplete
-** Browse-URL
+*** The ecomplete sorting has changed to a decay-based algorithm.
+This can be controlled by the new 'ecomplete-sort-predicate' variable.
-*** Support for opening links to man pages in Man or WoMan mode.
+*** 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
-** Comint
+** Gnus
-*** 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'.
++++
+*** A prefix argument to 'gnus-summary-limit-to-score' will limit reverse.
+Limit to articles with score at below.
-*** 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.
+*** The function 'gnus-score-find-favorite-words' has been renamed
+from 'gnus-score-find-favourite-words'.
-** Compilation mode
+---
+*** Gmane has been removed as an nnir backend, since Gmane no longer
+has a search engine.
-*** Messages from CMake are now recognized.
++++
+*** Splitting mail on common mailing list headers has been added.
+See the concept index in the Gnus manual for the 'match-list' entry.
-*** The number of errors, warnings, and informational messages is now
-displayed in the mode line. These are updated as compilation
-proceeds.
++++
+*** nil is no longer an allowed value for 'mm-text-html-renderer'.
-** Grep
++++
+*** 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.
-*** 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'.
+** erc
-*** The grep/rgrep/lgrep functions will now ask about saving files
-before running. This is controlled by the 'grep-save-buffers'
-variable.
+---
+*** 'erc-button-google-url' has been renamed 'erc-button-search-url'
+and its value has been changed to Duck Duck Go.
-** Edebug
+** EUDC
-*** 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'.
+*** XEmacs support has been removed.
-*** New customizable option 'edebug-max-depth'.
-This allows you to enlarge the maximum recursion depth when
-instrumenting code.
+** eww/shr
-*** '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
+*** 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.
- (fset 'edebug-prin1-to-string #'prin1-to-string)
++++
+*** 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.
-** Eshell
+** Htmlfontify
-*** '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.
+*** 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'.
-** EUDC
++++
+** 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.
-*** 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.
+** Smtpmail
-** eww
+Authentication mechanisms can be added via external packages, by
+defining new cl-defmethod of smtpmail-try-auth-method.
-*** New 'M-RET' command for opening a link at point in a new eww buffer.
+** Footnote-mode
-*** A new 's' command for switching to another eww buffer via the minibuffer.
+*** Support Hebrew-style footnotes
+*** Footnote text lines are now aligned.
+Can be controlled via the new variable 'footnote-align-to-fn-text'.
-*** The 'o' command ('shr-save-contents') has moved to 'O' to avoid collision
-with the 'o' command from 'image-map'.
+** CSS mode
-*** 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.
+---
+*** 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'.
-*** 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).
+---
+*** CSS mode, SCSS mode, and Less CSS mode now have support for Imenu.
-*** 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.
+** SGML mode
-** Ido
+---
+*** 'sgml-quote' now handles double quotes and apostrophes
+when escaping text and in addition all numeric entities when
+unescaping text.
-*** 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.
+** Python mode
-** Images
+---
+*** 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.
-*** Images are automatically scaled before displaying based on the
-'image-scaling-factor' variable (if Emacs supports scaling the images
-in question).
+** Dired
-*** 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.)
++++
+*** 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.
-*** 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'.
+** Help
-*** 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.
+---
+*** 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'.
-*** New setf-able function to access and set image parameters is
-provided: 'image-property'.
+---
+*** The list of help commands produced by 'C-h C-h' ('help-for-help')
+can now be searched via 'C-s'.
-*** 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.
+** Ibuffer
-** Image-Dired
+---
+*** New filter ibuffer-filter-by-process; bound to '/E'.
-*** Now provides a minor mode 'image-dired-minor-mode' which replaces
-the function 'image-dired-setup-dired-keybindings'.
+** Search and Replace
-*** Thumbnail generation is now asynchronous.
-The number of concurrent processes is limited by the variable
-'image-dired-queue-active-limit'.
++++
+*** New isearch bindings.
-*** 'image-dired-thumbnail-storage' has a new option 'standard-large'
-for generating 256x256 thumbnails according to the Thumbnail Managing
-Standard.
+'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'.
-*** Inherits movement keys from 'image-mode' for viewing full images.
-This includes the usual char, line, and page movement commands.
++++
+*** 'search-exit-option' provides new options 'move' and 'shift-move'
+to extend the search string by yanking text that ends at the new
+position after moving point in the current buffer. 'shift-move'
+extends the search string by motion commands while holding down
+the shift key.
-*** 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'.
+---
+*** Isearch now remembers the regexp-based search mode for words/symbols
+and case-sensitivity together with search strings in the search ring.
-*** Recognizes more tools by default, including pngnq-s9 and OptiPNG.
+** Debugger
-*** '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 Lisp Debugger is now based on 'backtrace-mode'.
+Backtrace mode adds fontification and commands for changing the
+appearance of backtrace frames. See the node "Backtraces" in the Elisp
+manual for documentation of the new mode and its commands.
-** 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.
+** Edebug
-** 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.
++++
+*** 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.
-** Support for non-string values of 'time-stamp-format' has been removed.
++++
+*** 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 "Backtraces" in the Elisp
+manual for documentation of the new mode and its commands.
-** Message
+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.
-*** 'message-use-idna' now defaults to t (because Emacs comes with
-built-in IDNA support now).
+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.
-*** 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.)
+** Enhanced xterm support
-*** 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.
+*** New variable 'xterm-set-window-title' controls whether Emacs sets
+the XTerm window title. This feature is experimental and is disabled
+by default.
-*** '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.
+** grep
-** Package
++++
+*** 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.
-*** 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.
+** ERT
-*** Deleting a package no longer respects 'delete-by-moving-to-trash'.
++++
+*** New variable 'ert-quiet' allows to make ERT output in batch mode
+less verbose by removing non-essential information.
-** Python
++++
+*** ERT's backtrace buffer now uses 'backtrace-mode'.
+Backtrace mode adds fontification and commands for changing the
+appearance of backtrace frames. See the node "Backtraces" in the Elisp
+manual for documentation of the new mode and its commands.
-*** The new variable 'python-indent-def-block-scale' has been added.
-It controls the depth of indentation of arguments inside multi-line
-function signatures.
+** Gamegrid
-** Tramp
+---
+*** 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.
-*** The method part of remote file names is mandatory now.
-A valid remote file name starts with "/method:host:" or
-"/method:user@host:".
+** Filecache
-*** The new pseudo method "-" is a marker for the default method.
-"/-::" is the shortest remote file name then.
+---
+*** Completing filenames in the minibuffer via 'C-TAB' now uses the
+styles as configured by the variable 'completion-styles'.
-*** The command 'tramp-change-syntax' allows you to choose an
-alternative remote file name syntax.
+** New macros 'thunk-let' and 'thunk-let*'.
+These macros are analogue to 'let' and 'let*', but create bindings that
+are evaluated lazily.
-*** New connection method "sg", which supports editing files under a
-different group ID.
+** next-error
-*** New connection method "doas" for OpenBSD hosts.
++++
+*** 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.
-*** New connection method "gdrive", which allows access to Google
-Drive onsite repositories.
++++
+*** 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'.
-*** Gateway methods in Tramp have been removed.
-Instead, the Tramp manual documents how to configure ssh and PuTTY
-accordingly.
+** nxml-mode
-*** Setting the "ENV" environment variable in
-'tramp-remote-process-environment' enables reading of shell
-initialization files.
+---
+*** 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.
-*** Tramp is able now to send SIGINT to remote asynchronous processes.
+** Eshell
-*** Variable 'tramp-completion-mode' is obsoleted.
+---
+*** Expansion of history event designators is disabled by default.
+To restore the old behavior, use
-** 'auto-revert-use-notify' is set back to t in 'global-auto-revert-mode'.
+ (add-hook 'eshell-expand-input-functions
+ #'eshell-expand-history-references)
-** JS mode
+---
+*** The function 'eshell-uniquify-list' has been renamed from
+'eshell-uniqify-list'.
-*** JS mode now sets 'comment-multi-line' to t.
+*** 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.
-*** 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'.
+** Shell
-** CSS mode
+---
+*** Program name completion inside remote shells works now as expected.
-*** 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.
+** Pcomplete
+*** The function 'pcomplete-uniquify-list' has been renamed from
+'pcomplete-uniqify-list'.
-*** 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'.
+** Auth-source
-*** CSS colors are fontified using the color they represent as the
-background. For instance, #ff0000 would be fontified with a red
-background.
+---
+*** The Secret Service backend supports the :create key now.
-** Emacs now supports character name escape sequences in character and
-string literals. The syntax variants '\N{character name}' and
-'\N{U+code}' are supported.
+** Tramp
-** 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.
++++
+*** New connection method "nextcloud", which allows to access OwnCloud
+or NextCloud hosted files and directories.
-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.
++++
+*** Connection methods "obex" and "synce" are removed, because they
+are obsoleted in GVFS.
-** ERC
++++
+*** Validated passwords are saved by auth-source backends which support this.
-*** New variable 'erc-default-port-tls' used to connect to TLS IRC
-servers.
++++
+*** The user option 'tramp-ignored-file-name-regexp' allows to disable
+Tramp for some look-alike remote file names.
-** URL
+** Register
+---
+*** The return value of method 'register-val-describe' includes the
+names of buffers shown by the windows of a window configuration.
-*** The new function 'url-cookie-delete-cookie' can be used to
-programmatically delete all cookies, or cookies from a specific
-domain.
+---
+** The options.el library has been removed.
+It was obsolete since Emacs 22.1, replaced by customize.
-*** 'url-retrieve-synchronously' now takes an optional timeout parameter.
+** 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.
-*** The URL package now supports HTTPS over proxies supporting CONNECT.
+** Message
-*** 'url-user-agent' now defaults to 'default', and the User-Agent
-string is computed dynamically based on 'url-privacy-level'.
++++
+*** 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'.
-** VC and related modes
+---
+*** 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.
-*** 'vc-dir-mode' now binds 'vc-log-outgoing' to 'O'; and has various
-branch-related commands on a keymap bound to 'B'.
+---
+*** 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.
-*** 'vc-region-history' is now bound to 'C-x v h', replacing the older
-'vc-insert-headers' binding.
++++
+*** 'message-forward-included-headers' has changed its default to
+exclude most headers when forwarding.
-*** New user option 'vc-git-print-log-follow' to follow renames in Git logs
-for a single file.
+** EasyPG
-** CC mode
+---
+*** 'epa-pinentry-mode' is renamed to 'epg-pinentry-mode'.
+It now applies to epg functions as well as epa functions.
-*** 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.
+---
+*** 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.
-** New option 'cpp-message-min-time-interval' to allow user control
-of progress messages in cpp.el.
+** Rmail
-** New DNS mode command 'dns-mode-ipv6-to-nibbles' to convert IPv6 addresses
-to a format suitable for reverse lookup zone files.
++++
+*** 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.
-** Ispell
+*** 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.
-*** 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.)
+** Threads
-** Flymake
++++
+*** 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.
-*** 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').
++++
+*** 'thread-join' returns the result of the finished thread now.
-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.
++++
+*** 'thread-signal' does not propagate errors to the main thread.
+Instead, error messages are just printed in the main thread.
-The old Flymake behavior is preserved in the so-called "legacy
-backend", which has been updated to benefit from the new UI features.
+---
+*** 'thread-alive-p' is now obsolete, use 'thread-live-p' instead.
-** Term
++++
+*** 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'.
-*** '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.
+---
+** 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.
-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
+** Interactive automatic highlighting
-*** 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.
++++
+*** 'highlight-regexp' can now highlight subexpressions.
+The now command accepts a prefix numeric argument to choose the
+subexpression.
-* 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 Modes and Packages in Emacs 27.1
-** New mode 'conf-toml-mode' is a sub-mode of 'conf-mode', specialized
-for editing TOML files.
+** multifile.el lets one setup multifile operations like search&replace
-** 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.
++++
+** 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 chapter "(tramp) Archive file
+names" in the Tramp manual for full documentation of these facilities.
-** New major mode 'less-css-mode' (a minor variant of 'css-mode') for
-editing Less files.
++++
+** 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.
-** New package 'auth-source-pass' integrates 'auth-source' with the
-password manager password-store (http://passwordstore.org).
++++
+** 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 "Backtraces" in the Elisp manual for
+documentation of the new mode and its commands.
-* 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").
+* Incompatible Lisp Changes in Emacs 27.1
+---
+** 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.
+
+** 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.
+** 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.
+
+---
+** 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.
** The function 'display-buffer-in-major-side-window' no longer exists.
It has been renamed as internal function 'window--make-major-side-window',
@@ -1430,469 +946,285 @@ however applications should instead call 'display-buffer-in-side-window'
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'.
+** 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.
-** 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.
+
+* Lisp Changes in Emacs 27.1
-*** The function 'frame-geometry' now also returns the width of a
-frame's outer border.
+** lookup-key can take a list of keymaps as argument.
-*** New frame parameters and changed semantics for older ones:
++++
+** 'condition-case' now accepts 't' to match any error symbol.
-**** 'z-group' positions a frame above or below all others.
++++
+** 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.
-**** 'min-width' and 'min-height' specify the absolute minimum size of a
-frame.
++++
+** 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.
-**** '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.
++++
+** '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.
-**** 'delete-before' triggers deletion of one frame before that of
-another.
++++
+** New function 'time-equal-p' compares time values for equality.
-**** 'mouse-wheel-frame' specifies another frame whose windows shall be
-scrolled instead.
+** define-minor-mode automatically documents the meaning of ARG.
-**** 'no-other-frame' has 'next-frame' and 'previous-frame' skip this
-frame.
++++
+** 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.
-**** 'skip-taskbar' removes a frame's icon from the taskbar and has
-'Alt-<TAB>' skip this frame.
++++
+** 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.
-**** 'no-focus-on-map' avoids that a frame gets input focus when mapped.
++++
+** New macro 'dolist-with-progress-reporter'.
+This works like 'dolist', but reports progress similar to
+'dotimes-with-progress-reporter'.
-**** 'no-accept-focus' means that a frame does not want to get input
-focus via the mouse.
++++
+** 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.
-**** 'undecorated' removes the window manager decorations from a frame.
+---
+** 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.
-**** 'override-redirect' tells the window manager to disregard this
-frame.
++++
+** 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'.
-**** 'width' and 'height' now allow the specification of pixel values
-and ratios.
++++
+** 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.
-**** 'left' and 'top' now allow the specification of ratios.
++++
+** 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 Info node "Face Remapping" of the
+Emacs Lisp Reference manual for more detail.
-**** 'keep-ratio' preserves size and position of child frames when their
-parent frame is resized.
++++
+** Special handling of buffer-local 'window-size-change-functions'.
+A buffer-local value of this hook is now run only if at least one
+window showing the buffer has changed its size.
-**** 'no-special-glyphs' suppresses display of truncation and
-continuation glyphs in a frame.
++++
+** The function assoc-delete-all now takes an optional predicate argument.
-**** 'auto-hide-function' and 'minibuffer-exit' handle auto hiding of
-frames and exiting from minibuffer individually.
++++
+** New function 'string-distance' to calculate the Levenshtein distance
+between two strings.
-**** 'fit-frame-to-buffer-margins' and 'fit-frame-to-buffer-sizes'
-handle fitting a frame to its buffer individually.
+** '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.
-**** '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.
++++
+** Numbers formatted via %o or %x may now be formatted as signed integers.
+This avoids problems in calls like (read (format "#x%x" -1)), and is
+more compatible with bignums, a planned feature. To get this
+behavior, set the experimental variable binary-as-unsigned to nil,
+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")
-**** '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.
++++
+** 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 new function 'frame-list-z-order' returns a list of all frames
-in Z (stacking) order.
+---
+** 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 'x-focus-frame' optionally tries to not activate its
-frame.
++++
+** 'memory-limit' now returns a better estimate of memory consumption.
-*** 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.
++++
+** 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.
-*** The new function 'frame-restack' puts a frame above or below
-another on the display.
+---
+** The function 'get-free-disk-space' returns now a non-nil value for
+remote systems, which support this check.
-*** The new face 'internal-border' specifies the background of a frame's
-internal border.
++++
+** '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 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.
++++
+** 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.
-*** 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.
+** (format "%d" X) no longer mishandles a floating-point number X that
+does not fit in a machine integer.
-*** 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.
++++
+** 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 'display-buffer' alist entry 'window-parameters' allows the
-assignment of window parameters to the window used for displaying the
-buffer.
+** 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 '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
+** Mailcap
-(add-to-list 'display-buffer-alist
- '("\\`\\*Man .*\\*\\'" .
- (display-buffer-reuse-mode-window
- (inhibit-same-window . nil)
- (mode . Man-mode))))
+---
+*** 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 window parameter 'no-delete-other-windows' prevents that
-its window gets deleted by 'delete-other-windows'.
+** URL
-*** New window parameters 'mode-line-format' and 'header-line-format'
-allow the buffer-local formats for this window to be overridden.
+*** 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.
-*** New command 'window-swap-states' swaps the states of two live
-windows.
+** image-mode
-*** 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.
+*** 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.
-*** The new function 'window-lines-pixel-dimensions' returns the pixel
-dimensions of a window's text lines.
+** 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 new function 'window-largest-empty-rectangle' returns the
-dimensions of the largest rectangular area not occupying any text in a
-window's body.
++++
+** 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 semantics of 'mouse-autoselect-window' has changed slightly.
-For details see the section "(elisp) Mouse Window Auto-selection" in
-the ELisp manual.
+---
+** 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.
-*** 'select-frame-by-name' now may return a frame on another display
-if it does not find a suitable one on the current display.
+
+* Changes in Emacs 27.1 on Non-Free Operating Systems
-** 'tcl-auto-fill-mode' is now declared obsolete.
-Its functionality can be replicated simply by setting
-'comment-auto-fill-only-comments'.
+---
+** Battery status is now supported in all Cygwin builds.
+Previously it was supported only in the Cygwin-w32 build.
-** New pcase pattern 'rx' to match against an rx-style regular expression.
-For details, see the doc string of 'rx--pcase-macroexpander'.
+** Emacs now handles key combinations involving the macOS "command"
+and "option" modifier keys more correctly.
-** 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.
+** 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 function 'lgstring-remove-glyph' can be used to modify a
-gstring returned by the underlying layout engine (e.g. m17n-flt,
-uniscribe).
+---
+** 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.
-
-* 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.
++++
+** 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).
----------------------------------------------------------------------
diff --git a/etc/NEWS.1-17 b/etc/NEWS.1-17
index 63ef9a38559..c74cc3de71a 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 153c2f7a0a7..ab76c3c7725 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 12432eacf79..1f84e87cefc 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 31e640fa94e..398148bf573 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..94bb45c6feb
--- /dev/null
+++ b/etc/NEWS.26
@@ -0,0 +1,1880 @@
+GNU Emacs NEWS -- history of user-visible changes.
+
+Copyright (C) 2016-2018 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.)
+
+
+* Startup Changes in Emacs 26.2
+
+
+* Changes in Emacs 26.2
+
+
+* Editing Changes in Emacs 26.2
+
+
+* Changes in Specialized Modes and Packages in Emacs 26.2
+
+** 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.
+
+** 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}")'.
+
+---
+** shadowfile.el has been rewritten to support Tramp file names.
+
+
+* 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
+
+
+* Changes in Emacs 26.2 on Non-Free Operating Systems
+
+
+* 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'.
+
+** 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.
+
+
+* 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/PROBLEMS b/etc/PROBLEMS
index 7dfafe04deb..eba3420fcb8 100644
--- a/etc/PROBLEMS
+++ b/etc/PROBLEMS
@@ -192,22 +192,10 @@ Upgrading to a newer version of Exceed has been reported to prevent
these crashes. You should consider switching to a free X server, such
as Xming or Cygwin/X.
-** Emacs crashes with SIGSEGV in XtInitializeWidgetClass.
-
-It crashes on X, but runs fine when called with option "-nw".
-
-This has been observed when Emacs is linked with GNU ld but without passing
-the -z nocombreloc flag. Emacs normally knows to pass the -z nocombreloc
-flag when needed, so if you come across a situation where the flag is
-necessary but missing, please report it via M-x report-emacs-bug.
-
-On platforms such as Solaris, you can also work around this problem by
-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 +563,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 +590,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 +598,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 +780,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/emacs-buffer.gdb b/etc/emacs-buffer.gdb
index 8a4d6485bf6..6bb37f3c8dd 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 251b133eb8c..bf3e91a8376 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 b61ff5f8032..a3c8e551722 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 908ca967a16..574e5d2c2fd 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 f74e2adcb3e..a6226427f34 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 6019c348417..0c4cfbe88fd 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]{2018} % 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 c4dab28f004..b063708536b 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 5dee4457172..63fdde1abc8 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 b3761535109..415db8a1911 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 c6aa1751f4a..0700f4f23dd 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 793209c055b..bfced43aee7 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 5c0d19ce810..c3c666588b1 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 9935c565fb5..ba00db6a491 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 fe61441d788..ddcaa0bd994 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 42e448d28b9..6c1eec0f421 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 3b6eeb702eb..dae77a5e623 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 a7a79c04adb..4fe2480bc7a 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 287fef82534..c216750cb2d 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 17a86fdbfea..ce9d1a2c3ce 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 9585e3aa6ef..8d34c28bf43 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 5db0ddd68de..fe46cb09280 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 583b8dc3f6f..00f29bb9fa6 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/lib-src/Makefile.in b/lib-src/Makefile.in
index fa37d8ed85d..ecb9208a1cd 100644
--- a/lib-src/Makefile.in
+++ b/lib-src/Makefile.in
@@ -334,7 +334,7 @@ uninstall:
fi
mostlyclean:
- rm -f core *.o *.res
+ rm -f core ./*.o ./*.res
clean: mostlyclean
rm -f ${EXE_FILES}
@@ -345,7 +345,7 @@ distclean: clean
bootstrap-clean maintainer-clean: distclean
extraclean: maintainer-clean
- rm -f *~ \#*
+ rm -f ./*~ \#*
## Test the contents of the directory.
check:
@@ -361,13 +361,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)
diff --git a/lib-src/ebrowse.c b/lib-src/ebrowse.c
index fa78c35a8b4..33af4f02daf 100644
--- a/lib-src/ebrowse.c
+++ b/lib-src/ebrowse.c
@@ -494,7 +494,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);
diff --git a/lib-src/emacsclient.c b/lib-src/emacsclient.c
index b0243f99c26..4fe3a588b19 100644
--- a/lib-src/emacsclient.c
+++ b/lib-src/emacsclient.c
@@ -192,7 +192,7 @@ struct option longopts[] =
/* 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,7 +219,7 @@ xrealloc (void *ptr, size_t size)
}
/* Like strdup but get a fatal error if memory is exhausted. */
-char *xstrdup (const char *);
+char *xstrdup (const char *) ATTRIBUTE_MALLOC;
char *
xstrdup (const char *s)
@@ -261,7 +261,7 @@ get_current_dir_name (void)
#endif
)
{
- buf = (char *) xmalloc (strlen (pwd) + 1);
+ buf = xmalloc (strlen (pwd) + 1);
strcpy (buf, pwd);
}
else
@@ -312,12 +312,15 @@ w32_get_resource (HKEY predefined, const char *key, LPDWORD type)
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 +372,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. */
@@ -833,7 +836,7 @@ 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);
+ char *copy = xmalloc (strlen (str) * 2 + 1);
const char *p;
char *q;
@@ -1845,7 +1848,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);
diff --git a/lib-src/etags.c b/lib-src/etags.c
index 588921bc700..102d867b387 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 61d53dc59d6..23728e7251e 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);
@@ -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)
@@ -1115,7 +1113,7 @@ scan_c_stream (FILE *infile)
continue;
}
- while (c == ' ' || c == '\n' || c == '\r' || c == '\t')
+ while (c_isspace (c))
c = getc (infile);
if (c == '"')
@@ -1125,17 +1123,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 +1185,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 +1248,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 +1393,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 +1425,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 +1463,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 +1607,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/movemail.c b/lib-src/movemail.c
index 4495c38f6ec..7a37e164dd0 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 95512854839..4ca521d2775 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 3818d33e689..649eb04b374 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 201f4b53836..7dba31be711 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/acl-internal.c b/lib/acl-internal.c
index 383c5ddb6f6..c62adb0d9d5 100644
--- a/lib/acl-internal.c
+++ b/lib/acl-internal.c
@@ -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;
}
diff --git a/lib/acl-internal.h b/lib/acl-internal.h
index 6c65e65e5e7..0669d83c469 100644
--- a/lib/acl-internal.h
+++ b/lib/acl-internal.h
@@ -293,10 +293,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/binary-io.h b/lib/binary-io.h
index cce1301d56c..1f21fc051f6 100644
--- a/lib/binary-io.h
+++ b/lib/binary-io.h
@@ -47,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
@@ -59,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/dosname.h b/lib/dosname.h
index 66486d5209d..fef3b6daa1f 100644
--- a/lib/dosname.h
+++ b/lib/dosname.h
@@ -20,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 599f7427a9b..dcbd28051cf 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 c8b49b25e47..c7d176728d4 100644
--- a/lib/dup2.c
+++ b/lib/dup2.c
@@ -29,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 8d2f3074fab..b95c4e9ce76 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 aee693571c9..de5d82b52d5 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/fcntl.c b/lib/fcntl.c
index b8cb271f55c..8e976173c0b 100644
--- a/lib/fcntl.c
+++ b/lib/fcntl.c
@@ -32,7 +32,7 @@
#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>
@@ -329,6 +329,12 @@ rpl_fcntl (int fd, int action, /* arg */...)
result = dupfd (fd, target, O_CLOEXEC);
break;
#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
@@ -343,10 +349,10 @@ rpl_fcntl (int fd, int action, /* arg */...)
if (0 <= result || errno != EINVAL)
{
have_dupfd_cloexec = 1;
-# if REPLACE_FCHDIR
+# if REPLACE_FCHDIR
if (0 <= result)
result = _gl_register_dup (fd, result);
-# endif
+# endif
}
else
{
@@ -357,6 +363,7 @@ rpl_fcntl (int fd, int action, /* arg */...)
}
}
else
+# endif
result = rpl_fcntl (fd, F_DUPFD, target);
if (0 <= result && have_dupfd_cloexec == -1)
{
@@ -376,7 +383,7 @@ rpl_fcntl (int fd, int action, /* arg */...)
#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 +412,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
diff --git a/lib/fcntl.in.h b/lib/fcntl.in.h
index 719a54d0f72..a1e7d35c1b9 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/fpending.c b/lib/fpending.c
index c84e3a5b4ec..de370d4b10f 100644
--- a/lib/fpending.c
+++ b/lib/fpending.c
@@ -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/fsusage.c b/lib/fsusage.c
new file mode 100644
index 00000000000..6920f8530a1
--- /dev/null
+++ b/lib/fsusage.c
@@ -0,0 +1,287 @@
+/* fsusage.c -- return space usage of mounted file systems
+
+ Copyright (C) 1991-1992, 1996, 1998-1999, 2002-2006, 2009-2018 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
+# if HAVE_DUSTAT_H /* AIX PS/2 */
+# include <sys/dustat.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_STATFS2_FS_DATA /* Ultrix */
+
+ struct fs_data fsd;
+
+ if (statfs (file, &fsd) != 1)
+ return -1;
+
+ fsp->fsu_blocksize = 1024;
+ fsp->fsu_blocks = PROPAGATE_ALL_ONES (fsd.fd_req.btot);
+ fsp->fsu_bfree = PROPAGATE_ALL_ONES (fsd.fd_req.bfree);
+ fsp->fsu_bavail = PROPAGATE_TOP_BIT (fsd.fd_req.bfreen);
+ fsp->fsu_bavail_top_bit_set = EXTRACT_TOP_BIT (fsd.fd_req.bfreen) != 0;
+ fsp->fsu_files = PROPAGATE_ALL_ONES (fsd.fd_req.gtot);
+ fsp->fsu_ffree = PROPAGATE_ALL_ONES (fsd.fd_req.gfree);
+
+#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, Dynix, old Irix, old AIX, \
+ Dolphin */
+
+# if !_AIX && !defined _SEQUENT_ && !defined DOLPHIN
+# define f_bavail f_bfree
+# endif
+
+ 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 _AIX || 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;
+}
+
+#if defined _AIX && defined _I386
+/* AIX PS/2 does not supply statfs. */
+
+int
+statfs (char *file, struct statfs *fsb)
+{
+ struct stat stats;
+ struct dustat fsd;
+
+ if (stat (file, &stats) != 0)
+ return -1;
+ if (dustat (stats.st_dev, 0, &fsd, sizeof (fsd)))
+ return -1;
+ fsb->f_type = 0;
+ fsb->f_bsize = fsd.du_bsize;
+ fsb->f_blocks = fsd.du_fsize - fsd.du_isize;
+ fsb->f_bfree = fsd.du_tfree;
+ fsb->f_bavail = fsd.du_tfree;
+ fsb->f_files = (fsd.du_isize - 2) * fsd.du_inopb;
+ fsb->f_ffree = fsd.du_tinode;
+ fsb->f_fsid.val[0] = fsd.du_site;
+ fsb->f_fsid.val[1] = fsd.du_pckno;
+ return 0;
+}
+
+#endif /* _AIX && _I386 */
diff --git a/lib/fsusage.h b/lib/fsusage.h
new file mode 100644
index 00000000000..65daa736765
--- /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-2018 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 a0b12b6ccc7..ecacb0ba25e 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/get-permissions.c b/lib/get-permissions.c
index bb1af5dbdfc..83ba2639a17 100644
--- a/lib/get-permissions.c
+++ b/lib/get-permissions.c
@@ -31,7 +31,7 @@
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;
@@ -57,7 +57,7 @@ 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 */
@@ -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 c6c1136fc55..ac05bc483cc 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/getloadavg.c b/lib/getloadavg.c
index 702338fb9e9..578316e34d8 100644
--- a/lib/getloadavg.c
+++ b/lib/getloadavg.c
@@ -68,7 +68,7 @@
UMAX
UMAX4_3
VMS
- WINDOWS32 No-op for Windows95/NT.
+ _WIN32 Native Windows (possibly also defined on Cygwin)
__linux__ Linux: assumes /proc file system mounted.
Support from Michael K. Johnson.
__CYGWIN__ Cygwin emulates linux /proc/loadavg.
@@ -97,6 +97,10 @@
# include "intprops.h"
+# if defined _WIN32 && ! defined __CYGWIN__ && ! defined WINDOWS32
+# define WINDOWS32
+# endif
+
# if !defined (BSD) && defined (ultrix)
/* Ultrix behaves like BSD on Vaxen. */
# define BSD
@@ -324,7 +328,9 @@
# 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. */
diff --git a/lib/getopt.c b/lib/getopt.c
index 55375ccd40f..11e36eef815 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/gettime.c b/lib/gettime.c
index 9a4e342f18e..171f22476f8 100644
--- a/lib/gettime.c
+++ b/lib/gettime.c
@@ -28,21 +28,24 @@
void
gettime (struct timespec *ts)
{
-#if HAVE_NANOTIME
+#if defined CLOCK_REALTIME && HAVE_CLOCK_GETTIME
+ clock_gettime (CLOCK_REALTIME, ts);
+#elif HAVE_NANOTIME
nanotime (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 39575658264..1bd50fa3d36 100644
--- a/lib/gettimeofday.c
+++ b/lib/gettimeofday.c
@@ -24,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
@@ -33,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;
@@ -45,7 +49,7 @@ initialize (void)
if (kernel32 != NULL)
{
GetSystemTimePreciseAsFileTimeFunc =
- (GetSystemTimePreciseAsFileTimeFuncType) GetProcAddress (kernel32, "GetSystemTimePreciseAsFileTime");
+ (GetSystemTimePreciseAsFileTimeFuncType) GetProcAddress (kernel32, "GetSystemTimePreciseAsFileTime");
}
initialized = TRUE;
}
diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in
index e69ae45bb53..2e265b3068b 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-2018 Free Software Foundation, Inc.
#
# This file is free software; you can redistribute it and/or modify
@@ -21,7 +20,134 @@
# 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=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 \
+# dtoastr \
+# dtotimespec \
+# dup2 \
+# environ \
+# execinfo \
+# explicit_bzero \
+# faccessat \
+# fcntl \
+# fcntl-h \
+# fdatasync \
+# 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,6 +170,7 @@ 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@
@@ -99,16 +226,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 +303,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@
@@ -386,6 +518,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 +549,12 @@ 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_INTTYPES_H = @HAVE_INTTYPES_H@
HAVE_LCHMOD = @HAVE_LCHMOD@
HAVE_LCHOWN = @HAVE_LCHOWN@
@@ -512,7 +647,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 +663,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 +675,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 +698,6 @@ LIBGPM = @LIBGPM@
LIBHESIOD = @LIBHESIOD@
LIBINTL = @LIBINTL@
LIBJPEG = @LIBJPEG@
-LIBLCMS2 = @LIBLCMS2@
LIBMODULES = @LIBMODULES@
LIBOBJS = @LIBOBJS@
LIBOTF_CFLAGS = @LIBOTF_CFLAGS@
@@ -668,6 +807,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,6 +856,7 @@ 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_ISATTY = @REPLACE_ISATTY@
@@ -899,6 +1040,7 @@ gameuser = @gameuser@
gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7 = @gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7@
gl_GNULIB_ENABLED_2049e887c7e5308faad27b3f894bb8c9 = @gl_GNULIB_ENABLED_2049e887c7e5308faad27b3f894bb8c9@
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@
@@ -1145,45 +1287,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))
@@ -1517,6 +1659,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 +1725,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 +1807,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 +1879,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' \
@@ -1932,6 +2112,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 +2160,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' \
@@ -2910,6 +3101,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 +3145,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 +3160,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 +3171,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 +3189,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/ieee754.in.h b/lib/ieee754.in.h
new file mode 100644
index 00000000000..316ac039afe
--- /dev/null
+++ b/lib/ieee754.in.h
@@ -0,0 +1,222 @@
+/* Copyright (C) 1992-2018 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 15e470cbc6e..cdaf6586cb6 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 ca3cec5b477..c7d7968e6e9 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/limits.in.h b/lib/limits.in.h
index 2c809d97ac4..89d7195488a 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/md5.c b/lib/md5.c
index 9dc915e2cf0..554d421c7bf 100644
--- a/lib/md5.c
+++ b/lib/md5.c
@@ -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 d89f819a97b..db031aac04c 100644
--- a/lib/md5.h
+++ b/lib/md5.h
@@ -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/mktime-internal.h b/lib/mktime-internal.h
index 92bdda6f6c3..31cf3a4dab2 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 007adf14e8e..6953e984e5d 100644
--- a/lib/mktime.c
+++ b/lib/mktime.c
@@ -28,6 +28,8 @@
Macro/expression Which gnulib module This compilation unit
should define
+ _LIBC (glibc proper) mktime
+
NEED_MKTIME_WORKING mktime rpl_mktime
|| NEED_MKTIME_WINDOWS
@@ -51,25 +53,70 @@
#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
+#endif /* DEBUG_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 DEBUG_MKTIME
#endif
-#if NEED_MKTIME_WINDOWS /* on native Windows */
-# include <stdlib.h>
-# include <string.h>
+#include "mktime-internal.h"
+
+#ifndef _LIBC
+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://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=");
+# 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
@@ -150,19 +197,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
@@ -304,6 +338,7 @@ ranged_convert (struct tm *(*convert) (const time_t *, struct tm *),
return r;
}
+
/* 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,
@@ -355,6 +390,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;
@@ -372,7 +408,7 @@ __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);
+ INT_SUBTRACT_WRAPV (0, off, &negative_offset_guess);
t0 = ydhms_diff (year, yday, hour, min, sec,
EPOCH_YEAR - TM_YEAR_BASE, 0, 0, 0, negative_offset_guess);
@@ -478,64 +514,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)
diff --git a/lib/nstrftime.c b/lib/nstrftime.c
index 9e7abddc8a3..46e806e6049 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)
@@ -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
@@ -475,12 +476,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
@@ -808,17 +816,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 +837,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;
diff --git a/lib/open.c b/lib/open.c
index b344f13a92a..792e258ba0b 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 807ba6a9f9d..c16d9351ec8 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 40758251ef3..33b2719561f 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 556d5f82302..801e372c329 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..0e4816c89c2
--- /dev/null
+++ b/lib/regcomp.c
@@ -0,0 +1,3935 @@
+/* Extended regular expression matching and search library.
+ Copyright (C) 2002-2018 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]);
+}
+#ifdef _LIBC
+weak_alias (__re_compile_pattern, re_compile_pattern)
+#endif
+
+/* 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;
+}
+#ifdef _LIBC
+weak_alias (__re_set_syntax, re_set_syntax)
+#endif
+
+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;
+}
+#ifdef _LIBC
+weak_alias (__re_compile_fastmap, re_compile_fastmap)
+#endif
+
+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 (BE (preg->fastmap == NULL, 0))
+ 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 (BE (ret == REG_NOERROR, 1))
+ /* 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;
+}
+#ifdef _LIBC
+libc_hidden_def (__regcomp)
+weak_alias (__regcomp, regcomp)
+#endif
+
+/* 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;
+
+ if (BE (errcode < 0
+ || errcode >= (int) (sizeof (__re_error_msgid_idx)
+ / sizeof (__re_error_msgid_idx[0])), 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 + __re_error_msgid_idx[errcode]);
+
+ msg_size = strlen (msg) + 1; /* Includes the null. */
+
+ if (BE (errbuf_size != 0, 1))
+ {
+ size_t cpy_size = msg_size;
+ if (BE (msg_size > errbuf_size, 0))
+ {
+ cpy_size = errbuf_size - 1;
+ errbuf[cpy_size] = '\0';
+ }
+ memcpy (errbuf, msg, cpy_size);
+ }
+
+ return msg_size;
+}
+#ifdef _LIBC
+weak_alias (__regerror, regerror)
+#endif
+
+
+#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 (BE (dfa != NULL, 1))
+ {
+ 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;
+}
+#ifdef _LIBC
+libc_hidden_def (__regfree)
+weak_alias (__regfree, regfree)
+#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
+
+/* 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 (BE (preg->allocated < sizeof (re_dfa_t), 0))
+ {
+ /* 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 (BE (err == REG_NOERROR && lock_init (dfa->lock) != 0, 0))
+ err = REG_ESPACE;
+ if (BE (err != REG_NOERROR, 0))
+ {
+ 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 (BE (err != REG_NOERROR, 0))
+ {
+ 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 (BE (dfa->str_tree == NULL, 0))
+ goto re_compile_internal_free_return;
+
+ /* Analyze the tree and create the nfa. */
+ err = analyze (preg);
+ if (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ {
+ 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 (BE (MIN (IDX_MAX, SIZE_MAX / max_object_size) / 2 <= pat_len, 0))
+ 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 (BE (dfa->sb_char == NULL, 0))
+ 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 (BE (dfa->nodes == NULL || dfa->state_table == NULL, 0))
+ 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 (BE (dfa->map_notascii == 0, 1))
+ {
+ /* 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 (BE (dfa->is_utf8, 1))
+ {
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (dfa->init_state == NULL, 0))
+ 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 (BE (dfa->init_state_word == NULL || dfa->init_state_nl == NULL
+ || dfa->init_state_begbuf == NULL, 0))
+ 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 (BE (dfa->nexts == NULL || dfa->org_indices == NULL || dfa->edests == NULL
+ || dfa->eclosures == NULL, 0))
+ 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 (BE (ret != REG_NOERROR, 0))
+ return ret;
+ ret = postorder (dfa->str_tree, calc_first, dfa);
+ if (BE (ret != REG_NOERROR, 0))
+ return ret;
+ preorder (dfa->str_tree, calc_next, dfa);
+ ret = preorder (dfa->str_tree, link_nfa_nodes, dfa);
+ if (BE (ret != REG_NOERROR, 0))
+ return ret;
+ ret = calc_eclosure (dfa);
+ if (BE (ret != REG_NOERROR, 0))
+ 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 (BE (dfa->inveclosures == NULL, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (tree == NULL || tree1 == NULL || op == NULL || cls == NULL, 0))
+ {
+ *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 (BE (node->node_idx == -1, 0))
+ 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 (BE (clone_dest == -1, 0))
+ return REG_ESPACE;
+ dfa->nexts[clone_node] = dfa->nexts[org_node];
+ ok = re_node_set_insert (dfa->edests + clone_node, clone_dest);
+ if (BE (! ok, 0))
+ 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 (BE (! ok, 0))
+ 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 (BE (clone_dest == -1, 0))
+ return REG_ESPACE;
+ ok = re_node_set_insert (dfa->edests + clone_node, clone_dest);
+ if (BE (! ok, 0))
+ 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 (BE (clone_dest == -1, 0))
+ return REG_ESPACE;
+ ok = re_node_set_insert (dfa->edests + clone_node, clone_dest);
+ if (BE (! ok, 0))
+ return REG_ESPACE;
+ err = duplicate_node_closure (dfa, org_dest, clone_dest,
+ root_node, constraint);
+ if (BE (err != REG_NOERROR, 0))
+ 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 (BE (! ok, 0))
+ return REG_ESPACE;
+ }
+
+ org_dest = dfa->edests[org_node].elems[1];
+ clone_dest = duplicate_node (dfa, org_dest, constraint);
+ if (BE (clone_dest == -1, 0))
+ return REG_ESPACE;
+ ok = re_node_set_insert (dfa->edests + clone_node, clone_dest);
+ if (BE (! ok, 0))
+ 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 (BE (dup_idx != -1, 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 (BE (! ok, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ return err;
+ }
+ else
+ eclosure_elem = dfa->eclosures[edest];
+ /* Merge the epsilon closure of 'edest'. */
+ err = re_node_set_merge (&eclosure, &eclosure_elem);
+ if (BE (err != REG_NOERROR, 0))
+ 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 (BE (! ok, 0))
+ 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 (BE (*err != REG_NOERROR && tree == NULL, 0))
+ 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 (BE (eor == NULL || root == NULL, 0))
+ {
+ *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 (BE (*err != REG_NOERROR && tree == NULL, 0))
+ 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 (BE (*err != REG_NOERROR && branch == NULL, 0))
+ {
+ 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 (BE (tree == NULL, 0))
+ {
+ *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 (BE (*err != REG_NOERROR && tree == NULL, 0))
+ 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 (BE (*err != REG_NOERROR && expr == NULL, 0))
+ {
+ 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 (BE (tree == NULL, 0))
+ {
+ *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 (BE (mbc_remain == NULL || tree == NULL, 0))
+ {
+ *err = REG_ESPACE;
+ return NULL;
+ }
+ }
+ }
+#endif
+ break;
+
+ case OP_OPEN_SUBEXP:
+ tree = parse_sub_exp (regexp, preg, token, syntax, nest + 1, err);
+ if (BE (*err != REG_NOERROR && tree == NULL, 0))
+ return NULL;
+ break;
+
+ case OP_OPEN_BRACKET:
+ tree = parse_bracket_exp (regexp, dfa, token, syntax, err);
+ if (BE (*err != REG_NOERROR && tree == NULL, 0))
+ return NULL;
+ break;
+
+ case OP_BACK_REF:
+ if (!BE (dfa->completed_bkref_map & (1 << token->opr.idx), 1))
+ {
+ *err = REG_ESUBREG;
+ return NULL;
+ }
+ dfa->used_bkref_map |= 1 << token->opr.idx;
+ tree = create_token_tree (dfa, NULL, NULL, token);
+ if (BE (tree == NULL, 0))
+ {
+ *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 (BE (tree == NULL, 0))
+ {
+ *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 (BE (tree_first == NULL || tree_last == NULL || tree == NULL, 0))
+ {
+ *err = REG_ESPACE;
+ return NULL;
+ }
+ }
+ else
+ {
+ tree = create_token_tree (dfa, NULL, NULL, token);
+ if (BE (tree == NULL, 0))
+ {
+ *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 (BE (tree == NULL, 0))
+ {
+ *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 (BE (*err != REG_NOERROR && tree == NULL, 0))
+ return NULL;
+ break;
+
+ case OP_SPACE:
+ case OP_NOTSPACE:
+ tree = build_charclass_op (dfa, regexp->trans,
+ "space",
+ "",
+ token->type == OP_NOTSPACE, err);
+ if (BE (*err != REG_NOERROR && tree == NULL, 0))
+ 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 (BE (*err != REG_NOERROR && dup_tree == NULL, 0))
+ {
+ 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 (BE (*err == REG_NOERROR && token->type != OP_CLOSE_SUBEXP, 0))
+ {
+ if (tree != NULL)
+ postorder (tree, free_tree, NULL);
+ *err = REG_EPAREN;
+ }
+ if (BE (*err != REG_NOERROR, 0))
+ return NULL;
+ }
+
+ if (cur_nsub <= '9' - '1')
+ dfa->completed_bkref_map |= 1 << cur_nsub;
+
+ tree = create_tree (dfa, tree, NULL, SUBEXP);
+ if (BE (tree == NULL, 0))
+ {
+ *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 (BE (start != -2, 1))
+ {
+ /* 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 (BE (start == -2 || end == -2, 0))
+ {
+ /* Invalid sequence. */
+ if (BE (!(syntax & RE_INVALID_INTERVAL_ORD), 0))
+ {
+ 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 (BE ((end != -1 && start > end)
+ || token->type != OP_CLOSE_DUP_NUM, 0))
+ {
+ /* First number greater than second. */
+ *err = REG_BADBR;
+ return NULL;
+ }
+
+ if (BE (RE_DUP_MAX < (end == -1 ? start : end), 0))
+ {
+ *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 (BE (elem == NULL, 0))
+ return NULL;
+ if (BE (start == 0 && end == 0, 0))
+ {
+ postorder (elem, free_tree, NULL);
+ return NULL;
+ }
+
+ /* Extract "<re>{n,m}" to "<re><re>...<re><re>{0,<m-n>}". */
+ if (BE (start > 0, 0))
+ {
+ tree = elem;
+ for (i = 2; i <= start; ++i)
+ {
+ elem = duplicate_tree (elem, dfa);
+ tree = create_tree (dfa, tree, elem, CONCAT);
+ if (BE (elem == NULL || tree == NULL, 0))
+ goto parse_dup_op_espace;
+ }
+
+ if (start == end)
+ return tree;
+
+ /* Duplicate ELEM before it is marked optional. */
+ elem = duplicate_tree (elem, dfa);
+ if (BE (elem == NULL, 0))
+ 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 (BE (tree == NULL, 0))
+ 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 (BE (elem == NULL || tree == NULL, 0))
+ goto parse_dup_op_espace;
+
+ tree = create_tree (dfa, tree, NULL, OP_ALT);
+ if (BE (tree == NULL, 0))
+ 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 (BE (start_elem->type == EQUIV_CLASS || start_elem->type == CHAR_CLASS
+ || end_elem->type == EQUIV_CLASS || end_elem->type == CHAR_CLASS,
+ 0))
+ return REG_ERANGE;
+
+ /* We can handle no multi character collating elements without libc
+ support. */
+ if (BE ((start_elem->type == COLL_SYM
+ && strlen ((char *) start_elem->opr.name) > 1)
+ || (end_elem->type == COLL_SYM
+ && strlen ((char *) end_elem->opr.name) > 1), 0))
+ 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 (BE ((syntax & RE_NO_EMPTY_RANGES) && start_wc > end_wc, 0))
+ 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 (BE (*range_alloc == mbcset->nranges, 0))
+ {
+ /* 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 (BE (new_array_start == NULL || new_array_end == NULL, 0))
+ {
+ 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 (BE (name_len != 1, 0))
+ 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 (BE (start_elem->type == EQUIV_CLASS || start_elem->type == CHAR_CLASS
+ || end_elem->type == EQUIV_CLASS || end_elem->type == CHAR_CLASS,
+ 0))
+ 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 (BE (start_collseq == UINT_MAX || end_collseq == UINT_MAX, 0))
+ return REG_ECOLLATE;
+ if (BE ((syntax & RE_NO_EMPTY_RANGES) && start_collseq > end_collseq, 0))
+ 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 (BE (*range_alloc == mbcset->nranges, 0))
+ {
+ /* 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 (BE (new_array_start == NULL || new_array_end == NULL, 0))
+ 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 (BE (*coll_sym_alloc == mbcset->ncoll_syms, 0))
+ {
+ /* 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 (BE (new_coll_syms == NULL, 0))
+ 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 (BE (name_len != 1, 0))
+ 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 (BE (sbcset == NULL || mbcset == NULL, 0))
+#else
+ if (BE (sbcset == NULL, 0))
+#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 (BE (token->type == END_OF_RE, 0))
+ {
+ *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 (BE (token->type == END_OF_RE, 0))
+ {
+ *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 (BE (ret != REG_NOERROR, 0))
+ {
+ *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 (BE (token->type == END_OF_RE, 0))
+ {
+ *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 (BE (token2.type == END_OF_RE, 0))
+ {
+ *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 (BE (ret != REG_NOERROR, 0))
+ {
+ *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 (BE (*err != REG_NOERROR, 0))
+ 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 (BE (mbchar_alloc == mbcset->nmbchars, 0))
+ {
+ 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 (BE (new_mbchars == NULL, 0))
+ 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 (BE (*err != REG_NOERROR, 0))
+ 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 (BE (*err != REG_NOERROR, 0))
+ 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 (BE (*err != REG_NOERROR, 0))
+ goto parse_bracket_exp_free_return;
+ break;
+ default:
+ assert (0);
+ break;
+ }
+ }
+ if (BE (token->type == END_OF_RE, 0))
+ {
+ *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 (BE (mbc_tree == NULL, 0))
+ 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 (BE (work_tree == NULL, 0))
+ goto parse_bracket_exp_espace;
+
+ /* Then join them by ALT node. */
+ work_tree = create_tree (dfa, work_tree, mbc_tree, OP_ALT);
+ if (BE (work_tree == NULL, 0))
+ 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 (BE (work_tree == NULL, 0))
+ 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 (BE (token->type == OP_CHARSET_RANGE, 0) && !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 (BE (idx1 == 0 || *cp != '\0', 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 (BE (*equiv_class_alloc == mbcset->nequiv_classes, 0))
+ {
+ /* 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 (BE (new_equiv_classes == NULL, 0))
+ 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 (BE (strlen ((const char *) name) != 1, 0))
+ 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 (BE (*char_class_alloc == mbcset->nchar_classes, 0))
+ {
+ /* 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 (BE (new_char_classes == NULL, 0))
+ 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 (BE (trans != NULL, 0)) \
+ { \
+ 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 (BE (sbcset == NULL, 0))
+ {
+ *err = REG_ESPACE;
+ return NULL;
+ }
+#ifdef RE_ENABLE_I18N
+ mbcset = (re_charset_t *) calloc (sizeof (re_charset_t), 1);
+ if (BE (mbcset == NULL, 0))
+ {
+ 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 (BE (ret != REG_NOERROR, 0))
+ {
+ 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 (BE (tree == NULL, 0))
+ 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 (BE (mbc_tree == NULL, 0))
+ goto build_word_op_espace;
+ /* Then join them by ALT node. */
+ tree = create_tree (dfa, tree, mbc_tree, OP_ALT);
+ if (BE (mbc_tree != NULL, 1))
+ 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 (BE (token->type == END_OF_RE, 0))
+ 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 (BE (dfa->str_tree_storage_idx == BIN_TREE_STORAGE_SIZE, 0))
+ {
+ 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..499e1f0e035
--- /dev/null
+++ b/lib/regex.c
@@ -0,0 +1,81 @@
+/* Extended regular expression matching and search library.
+ Copyright (C) 2002-2018 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 <config.h>
+
+# if (__GNUC__ == 4 && 6 <= __GNUC_MINOR__) || 4 < __GNUC__
+# pragma GCC diagnostic ignored "-Wsuggest-attribute=pure"
+# endif
+# if (__GNUC__ == 4 && 3 <= __GNUC_MINOR__) || 4 < __GNUC__
+# 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..f2ac9507adb
--- /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-2018 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..e3ce4abfa6b
--- /dev/null
+++ b/lib/regex_internal.c
@@ -0,0 +1,1740 @@
+/* Extended regular expression matching and search library.
+ Copyright (C) 2002-2018 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 (BE (ret != REG_NOERROR, 0))
+ 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 (BE (ret != REG_NOERROR, 0))
+ 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 (BE (ret != REG_NOERROR, 0))
+ 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 (BE (ret != REG_NOERROR, 0))
+ 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 (BE (MIN (IDX_MAX, SIZE_MAX / max_object_size) < new_buf_len, 0))
+ return REG_ESPACE;
+
+ new_wcs = re_realloc (pstr->wcs, wint_t, new_buf_len);
+ if (BE (new_wcs == NULL, 0))
+ return REG_ESPACE;
+ pstr->wcs = new_wcs;
+ if (pstr->offsets != NULL)
+ {
+ Idx *new_offsets = re_realloc (pstr->offsets, Idx, new_buf_len);
+ if (BE (new_offsets == NULL, 0))
+ 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 (BE (new_mbs == NULL, 0))
+ 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 (BE (pstr->trans != NULL, 0))
+ {
+ 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 (BE (mbclen == (size_t) -1 || mbclen == 0
+ || (mbclen == (size_t) -2 && pstr->bufs_len >= pstr->len), 0))
+ {
+ /* We treat these cases as a singlebyte character. */
+ mbclen = 1;
+ wc = (wchar_t) pstr->raw_mbs[pstr->raw_mbs_idx + byte_idx];
+ if (BE (pstr->trans != NULL, 0))
+ wc = pstr->trans[wc];
+ pstr->cur_state = prev_st;
+ }
+ else if (BE (mbclen == (size_t) -2, 0))
+ {
+ /* 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 (BE (0 < mbclen && mbclen < (size_t) -2, 1))
+ {
+ wchar_t wcu = __towupper (wc);
+ if (wcu != wc)
+ {
+ size_t mbcdlen;
+
+ mbcdlen = __wcrtomb (buf, wcu, &prev_st);
+ if (BE (mbclen == mbcdlen, 1))
+ 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 (BE (mbclen == (size_t) -1, 0))
+ 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 (BE (pstr->trans != NULL, 0))
+ {
+ 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 (BE (0 < mbclen && mbclen < (size_t) -2, 1))
+ {
+ wchar_t wcu = __towupper (wc);
+ if (wcu != wc)
+ {
+ size_t mbcdlen;
+
+ mbcdlen = __wcrtomb ((char *) buf, wcu, &prev_st);
+ if (BE (mbclen == mbcdlen, 1))
+ 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 (BE (pstr->offsets_needed != 0, 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 (BE (pstr->trans != NULL, 0))
+ ch = pstr->trans [ch];
+ pstr->mbs[byte_idx] = ch;
+
+ if (BE (pstr->offsets_needed != 0, 0))
+ pstr->offsets[byte_idx] = src_idx;
+ ++src_idx;
+
+ /* And also cast it to wide char. */
+ pstr->wcs[byte_idx++] = (wchar_t) ch;
+ if (BE (mbclen == (size_t) -1, 0))
+ 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 (BE (mbclen == (size_t) -2 || mbclen == (size_t) -1 || mbclen == 0, 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 (BE (pstr->trans != NULL, 0))
+ 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 (BE (pstr->raw_mbs_idx <= idx, 0))
+ 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 (BE (offset != 0, 1))
+ {
+ /* Should the already checked characters be kept? */
+ if (BE (offset < pstr->valid_raw_len, 1))
+ {
+ /* Yes, move them to the front of the buffer. */
+#ifdef RE_ENABLE_I18N
+ if (BE (pstr->offsets_needed, 0))
+ {
+ 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 (BE (pstr->mbs_allocated, 0))
+ 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 (BE (pstr->offsets_needed, 0))
+ {
+ 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) && BE (pstr->trans == NULL, 1))
+ {
+ 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 (BE (pstr->trans != NULL, 0))
+ {
+ 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 = ((BE (pstr->word_ops_used != 0, 0)
+ && IS_WIDE_WORD_CHAR (wc))
+ ? CONTEXT_WORD
+ : ((IS_WIDE_NEWLINE (wc)
+ && pstr->newline_anchor)
+ ? CONTEXT_NEWLINE : 0));
+ if (BE (pstr->valid_len, 0))
+ {
+ 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 (!BE (pstr->mbs_allocated, 0))
+ 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 (BE (ret != REG_NOERROR, 0))
+ return ret;
+ }
+ else
+ build_wcs_buffer (pstr);
+ }
+ else
+#endif /* RE_ENABLE_I18N */
+ if (BE (pstr->mbs_allocated, 0))
+ {
+ 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 (BE (!pstr->mbs_allocated, 1))
+ 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 (BE (!pstr->mbs_allocated, 1))
+ 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 (BE (idx < 0, 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 (BE (idx == input->len, 0))
+ 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 (BE (input->word_ops_used != 0, 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 (BE (set->elems == NULL, 0) && (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 (BE (set->elems == NULL, 0))
+ {
+ 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 (BE (set->elems == NULL, 0))
+ 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 (BE (dest->elems == NULL, 0))
+ {
+ 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 (BE (new_elems == NULL, 0))
+ 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 (BE (dest->elems == NULL, 0))
+ 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 (BE (new_buffer == NULL, 0))
+ return REG_ESPACE;
+ dest->elems = new_buffer;
+ dest->alloc = new_alloc;
+ }
+
+ if (BE (dest->nelem == 0, 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 BE (re_node_set_init_1 (set, elem) == REG_NOERROR, 1);
+
+ if (BE (set->nelem, 0) == 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 (BE (new_elems == NULL, 0))
+ 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 (BE (new_elems == NULL, 0))
+ 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 (BE (dfa->nodes_len >= dfa->nodes_alloc, 0))
+ {
+ 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 (BE (MIN (IDX_MAX, SIZE_MAX / max_object_size) < new_nodes_alloc, 0))
+ return -1;
+
+ new_nodes = re_realloc (dfa->nodes, re_token_t, new_nodes_alloc);
+ if (BE (new_nodes == NULL, 0))
+ 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 (BE (new_nexts == NULL || new_indices == NULL
+ || new_edests == NULL || new_eclosures == NULL, 0))
+ {
+ 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 (BE (nodes->nelem == 0, 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 (BE (new_state == NULL, 0))
+ *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 (BE (new_state == NULL, 0))
+ *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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (spot->alloc <= spot->num, 0))
+ {
+ Idx new_alloc = 2 * spot->num + 2;
+ re_dfastate_t **new_array = re_realloc (spot->array, re_dfastate_t *,
+ new_alloc);
+ if (BE (new_array == NULL, 0))
+ 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 (BE (newstate == NULL, 0))
+ return NULL;
+ err = re_node_set_init_copy (&newstate->nodes, nodes);
+ if (BE (err != REG_NOERROR, 0))
+ {
+ 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 (BE (err != REG_NOERROR, 0))
+ {
+ 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 (BE (newstate == NULL, 0))
+ return NULL;
+ err = re_node_set_init_copy (&newstate->nodes, nodes);
+ if (BE (err != REG_NOERROR, 0))
+ {
+ 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 (BE (newstate->entrance_nodes == NULL, 0))
+ {
+ 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 (BE (err != REG_NOERROR, 0))
+ {
+ 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..dd0900b719f
--- /dev/null
+++ b/lib/regex_internal.h
@@ -0,0 +1,914 @@
+/* Extended regular expression matching and search library.
+ Copyright (C) 2002-2018 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>
+
+/* Properties of integers. Although Gnulib has intprops.h, glibc does
+ without for now. */
+#ifndef _LIBC
+# include "intprops.h"
+#else
+/* True if the real type T is signed. */
+# define TYPE_SIGNED(t) (! ((t) 0 < (t) -1))
+
+/* True if adding the nonnegative Idx values A and B would overflow.
+ If false, set *R to A + B. A, B, and R may be evaluated more than
+ once, or zero times. Although this is not a full implementation of
+ Gnulib INT_ADD_WRAPV, it is good enough for glibc regex code.
+ FIXME: This implementation is a fragile stopgap, and this file would
+ be simpler and more robust if intprops.h were migrated into glibc. */
+# define INT_ADD_WRAPV(a, b, r) \
+ (IDX_MAX - (a) < (b) ? true : (*(r) = (a) + (b), false))
+#endif
+
+#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
+
+#define BE(expr, val) __builtin_expect (expr, val)
+
+/* 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
+# define attribute_hidden
+#endif /* not _LIBC */
+
+#if __GNUC__ < 3 + (__GNUC_MINOR__ < 1)
+# define __attribute__(arg)
+#endif
+
+#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 __GNUC_PREREQ
+# if defined __GNUC__ && defined __GNUC_MINOR__
+# define __GNUC_PREREQ(maj, min) \
+ ((__GNUC__ << 16) + __GNUC_MINOR__ >= ((maj) << 16) + (min))
+# else
+# define __GNUC_PREREQ(maj, min) 0
+# endif
+#endif
+
+#if __GNUC_PREREQ (3,4)
+# undef __attribute_warn_unused_result__
+# define __attribute_warn_unused_result__ \
+ __attribute__ ((__warn_unused_result__))
+#else
+# define __attribute_warn_unused_result__ /* empty */
+#endif
+
+#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..65913111644
--- /dev/null
+++ b/lib/regexec.c
@@ -0,0 +1,4324 @@
+/* Extended regular expression matching and search library.
+ Copyright (C) 2002-2018 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 (BE ((length1 < 0 || length2 < 0 || stop < 0
+ || INT_ADD_WRAPV (length1, length2, &len)),
+ 0))
+ return -2;
+
+ /* Concatenate the strings. */
+ if (length2 > 0)
+ if (length1 > 0)
+ {
+ s = re_malloc (char, len);
+
+ if (BE (s == NULL, 0))
+ 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 (BE (start < 0 || start > length, 0))
+ return -1;
+ if (BE (length < last_start || (0 <= range && last_start < start), 0))
+ last_start = length;
+ else if (BE (last_start < 0 || (range < 0 && start <= last_start), 0))
+ 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 (BE (bufp->no_sub, 0))
+ regs = NULL;
+
+ /* We need at least 1 register. */
+ if (regs == NULL)
+ nregs = 1;
+ else if (BE (bufp->regs_allocated == REGS_FIXED
+ && regs->num_regs <= bufp->re_nsub, 0))
+ {
+ nregs = regs->num_regs;
+ if (BE (nregs < 1, 0))
+ {
+ /* Nothing can be copied to regs. */
+ regs = NULL;
+ nregs = 1;
+ }
+ }
+ else
+ nregs = bufp->re_nsub + 1;
+ pmatch = re_malloc (regmatch_t, nregs);
+ if (BE (pmatch == NULL, 0))
+ {
+ 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 (BE (bufp->regs_allocated == REGS_UNALLOCATED, 0))
+ rval = -2;
+ }
+
+ if (BE (rval == 0, 1))
+ {
+ 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 (BE (regs->start == NULL, 0))
+ return REGS_UNALLOCATED;
+ regs->end = re_malloc (regoff_t, need_regs);
+ if (BE (regs->end == NULL, 0))
+ {
+ 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 (BE (need_regs > regs->num_regs, 0))
+ {
+ regoff_t *new_start = re_realloc (regs->start, regoff_t, need_regs);
+ regoff_t *new_end;
+ if (BE (new_start == NULL, 0))
+ return REGS_UNALLOCATED;
+ new_end = re_realloc (regs->end, regoff_t, need_regs);
+ if (BE (new_end == NULL, 0))
+ {
+ 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 (BE (preg->used == 0 || dfa->init_state == NULL
+ || dfa->init_state_word == NULL || dfa->init_state_nl == NULL
+ || dfa->init_state_begbuf == NULL, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE ((MIN (IDX_MAX, SIZE_MAX / sizeof (re_dfastate_t *))
+ <= mctx.input.bufs_len), 0))
+ {
+ err = REG_ESPACE;
+ goto free_return;
+ }
+
+ mctx.state_log = re_malloc (re_dfastate_t *, mctx.input.bufs_len + 1);
+ if (BE (mctx.state_log == NULL, 0))
+ {
+ 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 (BE (match_first < right_lim, 1)
+ && !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 (BE (match_first < right_lim, 1)
+ && !fastmap[(unsigned char) string[match_first]])
+ ++match_first;
+
+ forward_match_found_start_or_reached_end:
+ if (BE (match_first == right_lim, 0))
+ {
+ 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 (BE (offset >= (__re_size_t) mctx.input.valid_raw_len, 0))
+ {
+ err = re_string_reconstruct (&mctx.input, match_first,
+ eflags);
+ if (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (match_last == -2, 0))
+ {
+ 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 (BE (err != REG_NOMATCH, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (mctx.input.offsets_needed != 0, 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 (BE (MIN (IDX_MAX, SIZE_MAX / sizeof (re_dfastate_t *)) <= match_last, 0))
+ return REG_ESPACE;
+
+ sifted_states = re_malloc (re_dfastate_t *, match_last + 1);
+ if (BE (sifted_states == NULL, 0))
+ {
+ ret = REG_ESPACE;
+ goto free_return;
+ }
+ if (dfa->nbackref)
+ {
+ lim_states = re_malloc (re_dfastate_t *, match_last + 1);
+ if (BE (lim_states == NULL, 0))
+ {
+ 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 (BE (ret != REG_NOERROR, 0))
+ 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 (BE (ret != REG_NOERROR, 0))
+ 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 (BE (ret != REG_NOERROR, 0))
+ 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 (BE (cur_state == NULL, 0))
+ {
+ 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 (BE (dfa->nbackref, 0))
+ {
+ at_init_state = false;
+ err = check_subexp_matching_top (mctx, &cur_state->nodes, 0);
+ if (BE (err != REG_NOERROR, 0))
+ return err;
+
+ if (cur_state->has_backref)
+ {
+ err = transit_state_bkref (mctx, &cur_state->nodes);
+ if (BE (err != REG_NOERROR, 0))
+ return err;
+ }
+ }
+ }
+
+ /* If the RE accepts NULL string. */
+ if (BE (cur_state->halt, 0))
+ {
+ 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 ((BE (next_char_idx >= mctx->input.bufs_len, 0)
+ && mctx->input.bufs_len < mctx->input.len)
+ || (BE (next_char_idx >= mctx->input.valid_len, 0)
+ && mctx->input.valid_len < mctx->input.len))
+ {
+ err = extend_buffers (mctx, next_char_idx + 1);
+ if (BE (err != REG_NOERROR, 0))
+ {
+ 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 (BE (err != REG_NOERROR, 0))
+ return -2;
+
+ if (mctx->state_log == NULL
+ || (match && !fl_longest_match)
+ || (cur_state = find_recover_state (&err, mctx)) == NULL)
+ break;
+ }
+
+ if (BE (at_init_state, 0))
+ {
+ 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 (BE (! ok, 0))
+ 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 (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 (BE (! ok, 0))
+ 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 (BE (cur_node < 0, 0))
+ {
+ if (BE (cur_node == -2, 0))
+ {
+ 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 (BE (err != REG_NOERROR, 0))
+ return err;
+ err = update_cur_sifted_state (mctx, sctx, str_idx, &cur_dest);
+ if (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (! ok, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ return err;
+ dst[st_idx] = re_acquire_state (&err, dfa, &merged_set);
+ re_node_set_free (&merged_set);
+ if (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ return err;
+ }
+ }
+
+ sctx->sifted_states[str_idx] = re_acquire_state (&err, dfa, dest_nodes);
+ if (BE (err != REG_NOERROR, 0))
+ return err;
+ }
+
+ if (candidates && mctx->state_log[str_idx]->has_backref)
+ {
+ err = sift_states_bkref (mctx, sctx, str_idx, candidates);
+ if (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ return err;
+
+ if (!state->inveclosure.alloc)
+ {
+ err = re_node_set_alloc (&state->inveclosure, dest_nodes->nelem);
+ if (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ {
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (! ok, 0))
+ {
+ err = REG_ESPACE;
+ goto free_return;
+ }
+ cur_state = local_sctx.sifted_states[str_idx];
+ err = sift_states_backward (mctx, &local_sctx);
+ if (BE (err != REG_NOERROR, 0))
+ goto free_return;
+ if (sctx->limited_states != NULL)
+ {
+ err = merge_state_array (dfa, sctx->limited_states,
+ local_sctx.sifted_states,
+ str_idx + 1);
+ if (BE (err != REG_NOERROR, 0))
+ 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
+ could'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 (BE (state->accept_mb, 0))
+ {
+ *err = transit_state_mb (mctx, state);
+ if (BE (*err != REG_NOERROR, 0))
+ 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 (BE (trtable != NULL, 1))
+ return trtable[ch];
+
+ trtable = state->word_trtable;
+ if (BE (trtable != NULL, 1))
+ {
+ 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 (BE (*err != REG_NOERROR, 0))
+ 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 (BE (dfa->nbackref, 0) && 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 (BE (*err != REG_NOERROR, 0))
+ return NULL;
+
+ /* If the next state has back references. */
+ if (next_state->has_backref)
+ {
+ *err = transit_state_bkref (mctx, &next_state->nodes);
+ if (BE (*err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (*err != REG_NOERROR, 0))
+ 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 (BE (*err != REG_NOERROR, 0))
+ {
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (mctx->state_log[dest_idx] == NULL && err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (mctx->state_log[dest_str_idx] == NULL
+ && err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ {
+ 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 (BE (mctx->state_log[dest_str_idx] == NULL
+ && err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ goto free_return;
+ err = transit_state_bkref (mctx, new_dest_nodes);
+ if (BE (err != REG_NOERROR, 0))
+ 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 (BE (bkref_str_off + sl_str_diff > mctx->input.valid_len, 0))
+ {
+ /* 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (bkref_str_off >= mctx->input.valid_len, 0))
+ {
+ /* 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ return err;
+ sub_last = match_ctx_add_sublast (sub_top, cls_node, sl_str);
+ if (BE (sub_last == NULL, 0))
+ return REG_ESPACE;
+ err = get_subexp_sub (mctx, sub_top, sub_last, bkref_node,
+ bkref_str_idx);
+ if (err == REG_NOMATCH)
+ continue;
+ }
+ }
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (path->alloc < last_str + mctx->max_mb_elem_len + 1, 0))
+ {
+ 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 (BE (IDX_MAX - old_alloc < incr_alloc, 0))
+ return REG_ESPACE;
+ new_alloc = old_alloc + incr_alloc;
+ if (BE (SIZE_MAX / sizeof (re_dfastate_t *) < new_alloc, 0))
+ return REG_ESPACE;
+ new_array = re_realloc (path->array, re_dfastate_t *, new_alloc);
+ if (BE (new_array == NULL, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ return err;
+ err = check_arrival_expand_ecl (dfa, &next_nodes, subexp_num, type);
+ if (BE (err != REG_NOERROR, 0))
+ {
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ {
+ re_node_set_free (&next_nodes);
+ return err;
+ }
+ }
+ cur_state = re_acquire_state_context (&err, dfa, &next_nodes, context);
+ if (BE (cur_state == NULL && err != REG_NOERROR, 0))
+ {
+ 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 (BE (err != REG_NOERROR, 0))
+ {
+ 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 (BE (err != REG_NOERROR, 0))
+ {
+ 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 (BE (err != REG_NOERROR, 0))
+ {
+ re_node_set_free (&next_nodes);
+ return err;
+ }
+ err = expand_bkref_cache (mctx, &next_nodes, str_idx,
+ subexp_num, type);
+ if (BE (err != REG_NOERROR, 0))
+ {
+ 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 (BE (cur_state == NULL && err != REG_NOERROR, 0))
+ {
+ 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 (BE (err != REG_NOERROR, 0))
+ {
+ re_node_set_free (&union_set);
+ return err;
+ }
+ }
+ ok = re_node_set_insert (&union_set, next_node);
+ if (BE (! ok, 0))
+ {
+ re_node_set_free (&union_set);
+ return REG_ESPACE;
+ }
+ mctx->state_log[next_idx] = re_acquire_state (&err, dfa,
+ &union_set);
+ if (BE (mctx->state_log[next_idx] == NULL
+ && err != REG_NOERROR, 0))
+ {
+ 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 (BE (! ok, 0))
+ {
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ {
+ 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 (BE (err != REG_NOERROR, 0))
+ {
+ 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 (BE (! ok, 0))
+ return REG_ESPACE;
+ }
+ break;
+ }
+ ok = re_node_set_insert (dst_nodes, cur_node);
+ if (BE (! ok, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (err != REG_NOERROR || err2 != REG_NOERROR
+ || err3 != REG_NOERROR, 0))
+ {
+ 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 (BE (err != REG_NOERROR || ! ok, 0))
+ {
+ 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 (BE (err != REG_NOERROR, 0))
+ return err;
+ }
+ mctx->state_log[to_idx] = re_acquire_state (&err, dfa, &union_set);
+ re_node_set_free (&union_set);
+ if (BE (mctx->state_log[to_idx] == NULL
+ && err != REG_NOERROR, 0))
+ 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 (BE (dests_alloc == NULL, 0))
+ 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 (BE (ndests <= 0, 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 (BE (state->trtable == NULL, 0))
+ return false;
+ return true;
+ }
+ return false;
+ }
+
+ err = re_node_set_alloc (&follows, ndests + 1);
+ if (BE (err != REG_NOERROR, 0))
+ goto out_free;
+
+ /* Avoid arithmetic overflow in size calculation. */
+ if (BE ((((SIZE_MAX - (sizeof (re_node_set) + sizeof (bitset_t)) * SBC_MAX)
+ / (3 * sizeof (re_dfastate_t *)))
+ < ndests),
+ 0))
+ 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 (BE (dest_states == NULL, 0))
+ {
+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 (BE (err != REG_NOERROR, 0))
+ goto out_free;
+ }
+ }
+ dest_states[i] = re_acquire_state_context (&err, dfa, &follows, 0);
+ if (BE (dest_states[i] == NULL && err != REG_NOERROR, 0))
+ 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 (BE (dest_states_word[i] == NULL && err != REG_NOERROR, 0))
+ 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 (BE (dest_states_nl[i] == NULL && err != REG_NOERROR, 0))
+ 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 (!BE (need_word_trtable, 0))
+ {
+ /* 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 (BE (trtable == NULL, 0))
+ 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 (BE (elem & 1, 0))
+ {
+ /* 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 (BE (trtable == NULL, 0))
+ 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 (BE (elem & 1, 0))
+ {
+ /* 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 (BE (err != REG_NOERROR, 0))
+ goto error_return;
+ ++ndests;
+ }
+
+ /* Put the position in the current group. */
+ ok = re_node_set_insert (&dests_node[j], cur_nodes->elems[i]);
+ if (BE (! ok, 0))
+ 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 (BE (err != REG_NOERROR, 0))
+ 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 (BE (node->type == OP_UTF8_PERIOD, 0))
+ {
+ unsigned char c = re_string_byte_at (input, str_idx), d;
+ if (BE (c < 0xc2, 1))
+ 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 (BE (MIN (IDX_MAX, SIZE_MAX / sizeof (re_dfastate_t *)) / 2
+ <= pstr->bufs_len, 0))
+ 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 (BE (ret != REG_NOERROR, 0))
+ 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 (BE (new_array == NULL, 0))
+ 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 (BE (ret != REG_NOERROR, 0))
+ 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 (BE (MIN (IDX_MAX, SIZE_MAX / max_object_size) < n, 0))
+ 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 (BE (mctx->bkref_ents == NULL || mctx->sub_tops == NULL, 0))
+ 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 (BE (new_entry == NULL, 0))
+ {
+ 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 (BE (mctx->nsub_tops == mctx->asub_tops, 0))
+ {
+ 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 (BE (new_array == NULL, 0))
+ 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 (BE (mctx->sub_tops[mctx->nsub_tops] == NULL, 0))
+ 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 (BE (subtop->nlasts == subtop->alasts, 0))
+ {
+ 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 (BE (new_array == NULL, 0))
+ return NULL;
+ subtop->lasts = new_array;
+ subtop->alasts = new_alasts;
+ }
+ new_entry = calloc (1, sizeof (re_sub_match_last_t));
+ if (BE (new_entry != NULL, 1))
+ {
+ 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 4b7371c9b4b..d42335aa502 100644
--- a/lib/set-permissions.c
+++ b/lib/set-permissions.c
@@ -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,7 +483,7 @@ 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;
@@ -503,43 +503,43 @@ 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 */
@@ -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 ce0f0b2e71f..cd79dfa8770 100644
--- a/lib/sha1.c
+++ b/lib/sha1.c
@@ -37,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
@@ -122,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)
@@ -150,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;
@@ -169,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
@@ -194,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 b1db15da1e7..9419750f485 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 85405b20fdf..c518517077c 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 e3449864bb6..19ed3ccd4d0 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 8a6dd4e83ac..e854951eb31 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 6a0aadba02f..2c39ab195cf 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/stat-time.h b/lib/stat-time.h
index 104f5376682..69ebe85df1d 100644
--- a/lib/stat-time.h
+++ b/lib/stat-time.h
@@ -168,7 +168,7 @@ 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>. */
@@ -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 78d896e9f55..393ef0cf58d 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,79 @@
# define _flags pub._flags
# define _r pub._r
# define _w pub._w
+# elif defined __ANDROID__ /* Android */
+ /* 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; \
+ int _flags; \
+ int _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 +172,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 b9a43bb80ca..ff7c9c831ac 100644
--- a/lib/stdio.in.h
+++ b/lib/stdio.in.h
@@ -122,7 +122,7 @@
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 +133,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 b9701d5b287..3bf35bf6b0f 100644
--- a/lib/stdlib.in.h
+++ b/lib/stdlib.in.h
@@ -47,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
@@ -87,7 +90,7 @@ 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_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 Cygwin 1.7.1, only <unistd.h> declares getsubopt. */
diff --git a/lib/strtol.c b/lib/strtol.c
index 55871b4c78c..f6f5c3268de 100644
--- a/lib/strtol.c
+++ b/lib/strtol.c
@@ -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/sys_stat.in.h b/lib/sys_stat.in.h
index d96fde1007d..6ae6ac5fbdc 100644
--- a/lib/sys_stat.in.h
+++ b/lib/sys_stat.in.h
@@ -57,13 +57,13 @@
/* 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__
+#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 +576,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 747371644df..7f8c1c42117 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/time.in.h b/lib/time.in.h
index a2dca89340c..cda16c69d2c 100644
--- a/lib/time.in.h
+++ b/lib/time.in.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_rz.c b/lib/time_rz.c
index c1eca888f2c..5293c7cf8dc 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 7eb5ecbe330..9d9ab111251 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-2018 Free Software
- Foundation, Inc. This file is part of the GNU C Library.
+ Copyright (C) 1994-2018 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 f6a8c38b33d..1913b979edd 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 398a6a5de47..9eac36e51ac 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 eef3030d9c5..cc49668f42a 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 ae59cb2e627..66f254d60f5 100644
--- a/lib/unistd.in.h
+++ b/lib/unistd.in.h
@@ -61,7 +61,7 @@
/* 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__
@@ -94,13 +94,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
@@ -400,6 +400,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 +432,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 +935,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 +1519,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 c0b0704eb29..f6c4fe34c7c 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;
diff --git a/lib/verify.h b/lib/verify.h
index bc7f99dbd73..3b57ddee0ac 100644
--- a/lib/verify.h
+++ b/lib/verify.h
@@ -276,7 +276,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/warn-on-use.h b/lib/warn-on-use.h
index e76c38427d5..72d67cc2348 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/lisp/ChangeLog.2 b/lisp/ChangeLog.2
index 1b0ed4206bb..a5a654ac27f 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 8bdb6baf88c..0374e1ba772 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 566e9b7cd12..3a684212743 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 f534b6e165c..27cbe10a8ae 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 05fca9579f9..c4475982981 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
@@ -319,7 +323,7 @@ compile-targets: $(TARGETS)
compile-main: gen-lisp compile-clean
@(cd $(lisp) && \
els=`echo "${SUBDIRS_REL} " | sed -e 's|/\./|/|g' -e 's|/\. | |g' -e 's| |/*.el |g'`; \
- for el in $$els; do \
+ for el in ${MAIN_FIRST} $$els; do \
test -f $$el || continue; \
test ! -f $${el}c && GREP_OPTIONS= grep '^;.*no-byte-compile: t' $$el > /dev/null && continue; \
echo "$${el}c"; \
@@ -337,7 +341,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
diff --git a/lisp/abbrev.el b/lisp/abbrev.el
index 734cefbb7be..e1fd366ba9e 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."
@@ -899,18 +896,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)
@@ -931,31 +932,38 @@ 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.
-
-Abbrevs marked as \"system abbrevs\" are omitted."
+is inserted.
+
+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. If the
+resulting expression would not define any abbrevs, nothing is
+inserted."
(let ((table (symbol-value name))
(symbols ()))
- (mapatoms (lambda (sym) (if (symbol-value sym) (push sym symbols))) table)
- (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")))
- nil)))
+ (mapatoms (lambda (sym)
+ (if (and (symbol-value sym) (or readable (not (abbrev-get sym :system))))
+ (push sym symbols)))
+ table)
+ (when symbols
+ (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")))
+ nil))))
(defun define-abbrev-table (tablename definitions
&optional docstring &rest props)
diff --git a/lisp/allout-widgets.el b/lisp/allout-widgets.el
index a53776d62a6..5abd9788ddf 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 33317e89dee..a123ece9b95 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
diff --git a/lisp/ansi-color.el b/lisp/ansi-color.el
index 87b15ba4d31..6fb7acf600f 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/arc-mode.el b/lisp/arc-mode.el
index 3973e97d626..50048c0cb39 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)
@@ -748,8 +746,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 +804,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)
@@ -1011,8 +1008,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 +1059,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 +1499,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 +1518,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 +1527,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"))
@@ -1568,10 +1560,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 +1652,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 +1672,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 +1747,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 +1812,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 +1851,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 +1877,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 +1926,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 +1948,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 +1971,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 +1993,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"))
@@ -2043,13 +2018,13 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(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
+ (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))
@@ -2212,8 +2187,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 d783b26b4e3..cebe8c26665 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)
@@ -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)
@@ -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 afb35c8f044..eb262a13df4 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))
@@ -241,7 +242,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")
@@ -380,24 +381,39 @@ 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)
@@ -940,7 +956,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 +969,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 +1320,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 +1501,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 +1518,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 +1577,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 +2175,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 096bdefc1a6..4bf5785c7d4 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 dfa5b603068..cb0d15196f8 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 7b8302695fa..fc3469e03df 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)
@@ -351,9 +351,6 @@ This has been reported by a file notification event.")
;;;###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 +370,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 +390,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 +434,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 +455,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 +478,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 ()
@@ -524,38 +516,31 @@ will use an up-to-date value of `auto-revert-interval'"
(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)
+ ;; `auto-revert-notify-watch-descriptor' are non-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)))
+ (setq auto-revert-notify-watch-descriptor
+ (ignore-errors
+ (if buffer-file-name
(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)))))
+ (expand-file-name buffer-file-name default-directory)
+ '(change attribute-change)
+ 'auto-revert-notify-handler)
+ (file-notify-add-watch
+ (expand-file-name default-directory)
+ '(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 +596,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)
@@ -651,11 +635,9 @@ no more reverts are possible until the next call of
"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 +651,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 +701,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))
@@ -813,7 +796,8 @@ the timer when no buffers need to be checked."
;; Check if we should cancel the timer.
(when (and (not global-auto-revert-mode)
(null auto-revert-buffer-list))
- (cancel-timer auto-revert-timer)
+ (if (timerp auto-revert-timer)
+ (cancel-timer auto-revert-timer))
(setq auto-revert-timer nil)))))
diff --git a/lisp/battery.el b/lisp/battery.el
index ca17ae8fc34..192a6ae8980 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'.
diff --git a/lisp/bindings.el b/lisp/bindings.el
index a1af4389bee..76383ad2cef 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) " " "-"))
@@ -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)
diff --git a/lisp/bookmark.el b/lisp/bookmark.el
index 464324cea01..58a279473d0 100644
--- a/lisp/bookmark.el
+++ b/lisp/bookmark.el
@@ -2254,8 +2254,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/calc/calc-bin.el b/lisp/calc/calc-bin.el
index c05a71a2d7f..a61cecf357c 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 7c88230f86a..f1d3daeed93 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 5feff23f72d..f983ebe414d 100644
--- a/lisp/calc/calc-ext.el
+++ b/lisp/calc/calc-ext.el
@@ -2294,14 +2294,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]
diff --git a/lisp/calc/calc-math.el b/lisp/calc/calc-math.el
index 4b8abbf4f85..483907a325d 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.el b/lisp/calc/calc.el
index 871e65a2cba..c79db821eb6 100644
--- a/lisp/calc/calc.el
+++ b/lisp/calc/calc.el
@@ -2781,13 +2781,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))))))
diff --git a/lisp/calendar/appt.el b/lisp/calendar/appt.el
index 5841cb6a3a3..0259dd1e1e5 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-2018 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 508ae2c995f..00a8e7498af 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-2018 Free Software Foundation, Inc.
@@ -220,29 +220,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
@@ -279,14 +280,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.
@@ -405,7 +403,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 +415,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 +425,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 552832b4834..7ae0ecb7670 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 85a5fc0c2bb..71fb76ce213 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-2018 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 9f2a3334efd..acf4b20d779 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-2018 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)
@@ -1406,30 +1424,30 @@ marks. This is intended to deal with deleted diary entries."
(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 +1550,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 +1669,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 +1832,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 +1842,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 +1871,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 +1890,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 +1969,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 +1994,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 +2006,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 +2028,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 +2049,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 +2247,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 +2336,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 +2369,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 +2383,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 +2416,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 4ba49a9acb1..f38308378d6 100644
--- a/lisp/calendar/holidays.el
+++ b/lisp/calendar/holidays.el
@@ -522,7 +522,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))
diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el
index a725a4e916b..e3e458a4dd7 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
@@ -996,9 +996,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 +1016,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 +1043,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 +1066,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 +1089,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 +1196,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 +1216,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 +1249,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)
@@ -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 c4727339040..d6c1e9ea169 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 on something resembling an RFC2822 string, a la
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
diff --git a/lisp/calendar/solar.el b/lisp/calendar/solar.el
index 1e1656cd319..ddaf7451bd9 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-2018 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 e266dd62dfb..74c607ccb68 100644
--- a/lisp/calendar/time-date.el
+++ b/lisp/calendar/time-date.el
@@ -175,8 +175,7 @@ If DATE lacks timezone information, GMT is assumed."
;;;###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)))))
+ (let ((time (seconds-to-time (* 86400 days))))
(if (integerp days)
(setcdr (cdr time) nil))
time))
@@ -277,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)
@@ -306,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 3b96d427023..b46e7732fd3 100644
--- a/lisp/calendar/timeclock.el
+++ b/lisp/calendar/timeclock.el
@@ -144,6 +144,9 @@ This variable only has effect if set with \\[customize]."
(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)
@@ -271,8 +274,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
diff --git a/lisp/calendar/todo-mode.el b/lisp/calendar/todo-mode.el
index c1c8e196eaf..7d01fe31fb2 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))
@@ -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,10 +2871,14 @@ 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)
@@ -3830,6 +3849,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 +4048,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 +4073,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 +4545,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 +4641,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 +5104,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 +5138,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 +5162,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 +5173,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 +5328,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 +5530,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 +5545,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 +5581,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 +5702,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 +6011,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
@@ -6418,9 +6439,6 @@ 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)
@@ -6435,6 +6453,8 @@ Filtered Items mode following todo (not done) items."
("Fc" todo-show-categories-table)
("S" todo-search)
("X" todo-clear-matches)
+ ("b" todo-backward-category)
+ ("f" todo-forward-category)
("*" todo-toggle-mark-item)
)
"List of key bindings for Todo and Todo Archive modes.")
@@ -6703,32 +6723,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 +6744,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 216b0edeb69..34a4d992762 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/ede.el b/lisp/cedet/ede.el
index 76acf8a9418..1168f268422 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 5b708ae436e..2b5086a1c5a 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))
+ (float-time (time-subtract nil start))
(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 4c21cf44ef6..9600d3dd346 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 c95402e365d..2c474814786 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 862a9e597aa..cb5e739717d 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/pconf.el b/lisp/cedet/ede/pconf.el
index 9368420a740..cba7aaad8ec 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 22aa25a4a73..f0f07e9043f 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 ad2355a8512..553f918f9ec 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 091ea1741b7..f75006d6c57 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 3d390bda46d..fc7205f940d 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 2ef91e767bb..d9b8989ec74 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 849ef14352b..992996a9355 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 d85300c3123..d1a8fce78f1 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 a34d209375b..c6c52ed474e 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 ce1978c618f..215b7914a52 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 5d6ca95d7c5..75d02eccbcb 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 b945d690f95..3931cf63483 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 b616af3a430..71a1c38a522 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 99fe4a5562c..353bec23575 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)
diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el
index 7f175f2d57e..1cd306b89b9 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 a3fa80a6948..e34b51f3521 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 4b2f5d2209a..f0a1e6bb5a8 100644
--- a/lisp/cedet/semantic.el
+++ b/lisp/cedet/semantic.el
@@ -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 1abf785834b..2c50722813d 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/refs.el b/lisp/cedet/semantic/analyze/refs.el
index d4da9e3170e..6268da80650 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/c.el b/lisp/cedet/semantic/bovine/c.el
index 73c8a56dbd8..cb27582fa54 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 9bacee2a9cc..e511b3d2710 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 0eab01b58b1..1746f3e6ff5 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 1da1a319f11..eb25f114279 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 7035939c382..2d55c274cda 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 d3ad5c75376..7cb2ac1e94d 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 c58c295cd5c..789614d511a 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 8a136132b7e..e61eb7183ad 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 40d8dbd58b5..c689e31f03e 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 491752e4398..05484fccc0d 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 d127b6465fe..3c71c209576 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 ea3d63d21bc..77a8471e275 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/ede-grammar.el b/lisp/cedet/semantic/ede-grammar.el
index 617ad7867f5..8c36623b72f 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/idle.el b/lisp/cedet/semantic/idle.el
index 56398d06270..07b7af89423 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 81dfc055f2c..0cc296f09da 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 bc8b1a9ef27..5789881d382 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 739f6742146..443c3839bb7 100644
--- a/lisp/cedet/semantic/sb.el
+++ b/lisp/cedet/semantic/sb.el
@@ -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)))
diff --git a/lisp/cedet/semantic/scope.el b/lisp/cedet/semantic/scope.el
index f18451fd59a..0f171e2fc14 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 0e8ac6392c8..726ef590742 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/list.el b/lisp/cedet/semantic/symref/list.el
index 1be2b0ed393..ab22d0d00a0 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 9769ae89289..1fdfd104a5e 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 54c9578773a..180aca5b60d 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 313f2350a43..0a02b898e34 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 1902006ee5b..21ea7ed0665 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."
@@ -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/python.el b/lisp/cedet/semantic/wisent/python.el
index db2d7c96083..f7944fe539b 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 69282c1a0dd..a0a53a6473a 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 4a84693fe7e..a2410becb02 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 3e2c4ebd12c..276f2ace2f1 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 7c9424945f0..1d419c93ba7 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 76e7e08761d..28e8b3b64ea 100644
--- a/lisp/cedet/srecode/mode.el
+++ b/lisp/cedet/srecode/mode.el
@@ -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 ef1d9e37c05..6c269e0d914 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 3bae20e3554..fdabdc4c8ed 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 ac968a6f9c4..af2e8b178aa 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 9c05e364dfd..86bd6038e36 100644
--- a/lisp/char-fold.el
+++ b/lisp/char-fold.el
@@ -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 d557c9f4eee..b4a8b6e72f9 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 122291bcf9c..5928804fe73 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."
@@ -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))) " "))))
@@ -2232,7 +2248,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 +2297,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 +2358,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 +2383,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
@@ -2643,8 +2662,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 +2680,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 +2692,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 +2710,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)))
diff --git a/lisp/completion.el b/lisp/completion.el
index a5c8158d1b3..66b413f6af5 100644
--- a/lisp/completion.el
+++ b/lisp/completion.el
@@ -518,6 +518,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 +2228,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 +2275,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 +2360,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 76949fb5827..3d4805e8fa0 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 3ede483dade..723cd5010df 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,6 +2431,18 @@ 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))
:foreground "light blue" :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
@@ -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 2b352b3dc60..54f5d51358f 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 8ed0f805d01..e33fe6e5ecf 100644
--- a/lisp/cus-start.el
+++ b/lisp/cus-start.el
@@ -345,6 +345,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 +415,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 +435,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 +547,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
@@ -708,13 +718,15 @@ 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.
diff --git a/lisp/cus-theme.el b/lisp/cus-theme.el
index e5e787771b9..995c55b2b20 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-2018 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 b7539685a89..a08f7fda705 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-2018 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 57ee9a526a9..913b23dc70f 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 5acb23922c2..076d4dc5c3d 100644
--- a/lisp/delim-col.el
+++ b/lisp/delim-col.el
@@ -2,8 +2,8 @@
;; Copyright (C) 1999-2018 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 bfccdc6a4c7..9582272d184 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 00b40826f48..d8f8188eb1e 100644
--- a/lisp/descr-text.el
+++ b/lisp/descr-text.el
@@ -404,12 +404,6 @@ relevant to POS."
(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)
@@ -841,8 +835,6 @@ relevant to POS."
(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 b98319bdcf5..1346fa3241e 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)
@@ -900,8 +888,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 +1031,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 +1074,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 +1087,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 +1096,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 +1129,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 +1232,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 +1258,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 +1303,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 +1332,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 ()
@@ -1564,8 +1546,7 @@ and try to load that."
(setq buffer-display-time
(if buffer-display-time
(time-add buffer-display-time
- (time-subtract (current-time)
- desktop-file-modtime))
+ (time-subtract nil desktop-file-modtime))
(current-time)))
(unless (< desktop-file-version 208) ; Don't misinterpret any old custom args
(dolist (record compacted-vars)
@@ -1609,7 +1590,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 516cd2c5672..1f13204b7cf 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -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))
@@ -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))
@@ -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)
@@ -1032,7 +1038,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)
@@ -1155,7 +1161,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
@@ -1551,22 +1557,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)
@@ -1576,6 +1601,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)
@@ -1745,7 +1771,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'"
@@ -1828,7 +1854,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)))
@@ -1846,28 +1872,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))
@@ -1966,6 +1995,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.
@@ -1974,18 +2016,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))))
@@ -2749,7 +2805,9 @@ Intended to be added to `isearch-mode-hook'."
"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.
@@ -2762,15 +2820,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.
@@ -2780,14 +2838,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)
@@ -2795,7 +2853,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)))
+ (multifile-initialize-search
+ regexp
+ (dired-get-marked-files nil nil #'dired-nondirectory-p)
+ 'default)
+ (multifile-continue))
;;;###autoload
(defun dired-do-query-replace-regexp (from to &optional delimited)
@@ -2808,13 +2870,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)))
+ (multifile-initialize-replace
+ from to (dired-get-marked-files nil nil #'dired-nondirectory-p)
+ (if (equal from (downcase from)) nil 'default)
+ delimited)
+ (multifile-continue))
(declare-function xref--show-xrefs "xref")
(declare-function xref-query-replace-in-results "xref")
@@ -2831,11 +2896,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)
+ (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 a90f1f4adcd..6c19863f7b6 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,12 @@ 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
+ ((bound-and-true-p archive-subfile-mode)
+ (switch-to-buffer archive-superior-buffer))
+ ((bound-and-true-p tar-subfile-mode)
+ (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 +495,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 +771,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 +787,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 +1212,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 579de723df6..5c7bb9599c5 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
@@ -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
@@ -841,17 +850,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 +1092,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
@@ -1433,7 +1447,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)
@@ -1791,6 +1806,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"
@@ -2346,12 +2364,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
@@ -3095,7 +3108,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 "
diff --git a/lisp/dirtrack.el b/lisp/dirtrack.el
index e5e1497c4d0..862268d49b8 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 13d73a98d0b..95224f2b2a4 100644
--- a/lisp/disp-table.el
+++ b/lisp/disp-table.el
@@ -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))
diff --git a/lisp/doc-view.el b/lisp/doc-view.el
index 4a4862f8280..2b2c6874dbc 100644
--- a/lisp/doc-view.el
+++ b/lisp/doc-view.el
@@ -354,9 +354,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
@@ -1752,12 +1749,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)))
@@ -1848,14 +1840,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))))
@@ -1874,9 +1859,6 @@ 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
diff --git a/lisp/dom.el b/lisp/dom.el
index 8750d7fa866..6045a68d14c 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 87f7ed10fea..aeb8da4d480 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 a45a9d1026b..c19aa440165 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 4334a4ca70d..b21fe5bc20f 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 43ab8e691e6..3bfab4743cb 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-2018 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.
@@ -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) (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 78180627950..c3d9bc5a980 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")
diff --git a/lisp/elec-pair.el b/lisp/elec-pair.el
index 97049a7d9d9..7df70982957 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))
@@ -501,7 +508,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,7 +516,7 @@ 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))
@@ -574,9 +581,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 c146b3ceaeb..8730b0752c8 100644
--- a/lisp/electric.el
+++ b/lisp/electric.el
@@ -260,32 +260,43 @@ 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.
+ ;; 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))))
+ ;; 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)
- (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))))))
+ (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))
+ (condition-case-unless-debug ()
+ (indent-according-to-mode)
+ (error (throw 'indent-error nil)))))))))
(put 'electric-indent-post-self-insert-function 'priority 60)
@@ -314,9 +325,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'.
@@ -400,9 +408,7 @@ newline after CHAR but stay in the same place.")
;;;###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
@@ -451,6 +457,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 +475,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 +506,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 +527,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/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el
index 17272328302..04d2fbf444e 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 92ad6155b53..c9ee532ac82 100644
--- a/lisp/emacs-lisp/autoload.el
+++ b/lisp/emacs-lisp/autoload.el
@@ -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..e82d4f5a5a2
--- /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 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 d74446c7479..e062a1867a8 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-subtract nil ,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,7 +74,7 @@ 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"))
@@ -86,7 +84,7 @@ result. The overhead of the `lambda's is accounted for."
(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 c1343765901..3124217303f 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 c90509d131b..4854808fd02 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -656,15 +656,15 @@
((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 +678,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 +839,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,11 +875,10 @@
(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)
@@ -923,9 +886,9 @@
(put 'string< 'byte-optimizer 'byte-optimize-predicate)
(put 'string-lessp '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 +896,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 +929,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 +946,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 +982,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 +1145,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 +1159,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 +1171,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 +1195,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 +1235,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 +1283,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 +1297,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 aa10bd3e804..5edf5a28db8 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 68e2fd1d104..0b8f8824b4c 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -124,17 +124,10 @@
(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"))
+;; 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 +835,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 +925,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)
@@ -1938,17 +1931,7 @@ The value is non-nil if there were no errors, nil if errors."
;; parallel bootstrap), it does not risk getting a
;; half-finished file. (Bug#4196)
(tempfile
- (if (file-name-absolute-p target-file)
- (make-temp-file target-file)
- ;; If target-file is relative and includes
- ;; leading directories, make-temp-file will
- ;; assume those leading directories exist
- ;; under temporary-file-directory, which might
- ;; not be true. So strip leading directories
- ;; from relative file names before calling
- ;; make-temp-file.
- (make-temp-file
- (file-name-nondirectory target-file))))
+ (make-temp-file (expand-file-name target-file)))
(default-modes (default-file-modes))
(temp-modes (logand default-modes #o600))
(desired-modes (logand default-modes #o666))
@@ -2079,14 +2062,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!"
@@ -2449,6 +2426,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
@@ -2508,6 +2495,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)
@@ -2754,15 +2747,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))
@@ -2803,8 +2793,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)
@@ -2855,9 +2845,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)))))
@@ -3128,7 +3119,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)
@@ -3261,7 +3258,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 ())
@@ -3585,7 +3582,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)))))
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 02fe794467b..010026b4166 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."
@@ -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)
@@ -449,8 +456,11 @@ places where they originally did not directly appear."
;defconst, defvar
(`(,(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)
diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el
index f2bf15d72de..83929beb1e0 100644
--- a/lisp/emacs-lisp/checkdoc.el
+++ b/lisp/emacs-lisp/checkdoc.el
@@ -171,6 +171,7 @@
(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
@@ -436,23 +437,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 +459,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 +575,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 +610,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 +642,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 +654,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 +663,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 +678,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 +706,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.")
@@ -1147,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).
@@ -1155,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)
@@ -1171,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
;;
@@ -1265,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
@@ -1342,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.
@@ -1471,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 "[.!?]")
@@ -1796,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))
@@ -2593,12 +2562,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)
@@ -2615,9 +2584,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 36b65f97b07..bea38a05096 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -472,7 +472,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))))
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index c6996bfc15b..173173305b4 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -808,22 +808,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)))))
@@ -1156,45 +1160,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 +1183,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 d7e72ce99a3..592235d2de0 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -531,8 +531,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 ffe88a21a85..29ddd491af0 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--")))
@@ -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)))
@@ -2689,6 +2760,9 @@ non-nil value, that slot cannot be set via `setf'.
(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)))
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 4e73a4a31b7..2a70f9b9248 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 66561ce2644..c63f5ac005c 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/copyright.el b/lisp/emacs-lisp/copyright.el
index 69c5ebd45d6..2f29c196964 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 5aa856f467c..3ec0bd81cf4 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/debug.el b/lisp/emacs-lisp/debug.el
index 821d6748821..7fc2b41c70c 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))
@@ -215,7 +256,8 @@ first will be printed into the backtrace buffer."
(window-total-height debugger-window)))
(error nil)))
(setq debugger-previous-window debugger-window))
- (debugger-mode)
+ (unless (derived-mode-p 'debugger-mode)
+ (debugger-mode))
(debugger-setup-buffer debugger-args)
(when noninteractive
;; If the backtrace is long, save the beginning
@@ -259,127 +301,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 +414,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 +433,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 +460,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 +524,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 +539,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 +593,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 +619,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 +719,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 55fa439ad38..6b47ffea07a 100644
--- a/lisp/emacs-lisp/derived.el
+++ b/lisp/emacs-lisp/derived.el
@@ -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 443e03eb1a3..4d8a5020267 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.
@@ -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)))
@@ -549,6 +566,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 +593,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)))
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 7e4d244f5e2..fb567c9cce0 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)
@@ -894,8 +894,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 +909,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 +1065,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 +1150,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 +1264,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 +1394,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 +1419,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 +1498,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 +1691,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 +1997,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")))
@@ -2181,7 +2293,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.
@@ -2212,7 +2338,7 @@ 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))))
(let* ((edebug-data (get function 'edebug))
(edebug-def-mark (car edebug-data)) ; mark at def start
@@ -2331,22 +2457,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)))
@@ -3495,14 +3626,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 +3691,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 +3949,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 +3982,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 +4285,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 cba6cab1d4f..75709ddc0a8 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -360,32 +360,30 @@ Second, any text properties will be stripped from strings."
proposed-value))))
;; For hash-tables and vectors, the top-level `read' will not
;; "look inside" member values, so we need to do that
- ;; explicitly.
+ ;; explicitly. Because `eieio-override-prin1' is recursive in
+ ;; the case of hash-tables and vectors, we recurse
+ ;; `eieio-persistent-validate/fix-slot-value' here as well.
((hash-table-p proposed-value)
(maphash
(lambda (key value)
- (cond ((class-p (car-safe value))
- (setf (gethash key proposed-value)
- (eieio-persistent-convert-list-to-object
- value)))
- ((and (consp value)
- (eq (car value) 'quote))
- (setf (gethash key proposed-value)
- (cadr value)))))
+ (setf (gethash key proposed-value)
+ (if (class-p (car-safe value))
+ (eieio-persistent-convert-list-to-object
+ value)
+ (eieio-persistent-validate/fix-slot-value
+ class slot value))))
proposed-value)
proposed-value)
((vectorp proposed-value)
(dotimes (i (length proposed-value))
(let ((val (aref proposed-value i)))
- (cond ((class-p (car-safe val))
- (aset proposed-value i
- (eieio-persistent-convert-list-to-object
- (aref proposed-value i))))
- ((and (consp val)
- (eq (car val) 'quote))
- (aset proposed-value i
- (cadr val))))))
+ (aset proposed-value i
+ (if (class-p (car-safe val))
+ (eieio-persistent-convert-list-to-object
+ val)
+ (eieio-persistent-validate/fix-slot-value
+ class slot val)))))
proposed-value)
((stringp proposed-value)
@@ -500,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.el b/lisp/emacs-lisp/eieio.el
index b95f7486f76..98cdd4fd903 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 a662265f4b8..49ba71fb1b8 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
diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el
index b89290ad524..391d3fd0af9 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 954e7aa73ae..012e7cf1cd3 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 15d488f7101..eb9695d0c12 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
@@ -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))))
@@ -2421,20 +2443,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 +2566,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 +2602,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 +2616,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 +2635,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 262d4d85941..52d8451f4bc 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..bbf4c5da7e5
--- /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-2018 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 ed8dc74506f..c5424693eca 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 506df59d8e2..e38c7d91096 100644
--- a/lisp/emacs-lisp/generator.el
+++ b/lisp/emacs-lisp/generator.el
@@ -567,8 +567,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
@@ -700,6 +703,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 e2009bf4c26..194fa1e1c24 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 e210def1a0f..6bfc32c8356 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/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 205c810b978..afb7cbd1dd7 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
@@ -867,9 +879,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
@@ -881,11 +891,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))
diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el
index 68d50e6d0b2..5a89923f8fb 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)))
diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el
index 8260af57278..a61c0adc8fb 100644
--- a/lisp/emacs-lisp/map-ynp.el
+++ b/lisp/emacs-lisp/map-ynp.el
@@ -191,34 +191,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/nadvice.el b/lisp/emacs-lisp/nadvice.el
index e20cc6570db..76a9095e4ae 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -41,13 +41,13 @@
'((: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.
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 207c2e5c489..2ddab653630 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")
@@ -676,6 +681,9 @@ 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
@@ -718,7 +726,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.
@@ -961,17 +972,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.
@@ -1009,6 +1015,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.
@@ -1436,45 +1444,61 @@ 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)
+ (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))
+ (unless package--initialized
+ (package-initialize t))
(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)
- ;; This uses `package--mapc' so it must be called after
- ;; `package--initialized' is t.
- (package--build-compatibility-table))
-
+ (error (message "%s" (error-message-string err)))))))
;;;; Populating `package-archive-contents' from archives
;; This subsection populates the variables listed above from the
@@ -1530,7 +1554,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)
@@ -1867,18 +1891,26 @@ 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))
+ ((not package--initialized) (error "package.el is not yet initialized!"))
+ (t
(or
(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.
@@ -1888,64 +1920,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.
@@ -1987,7 +1961,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)
@@ -2071,12 +2047,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"))))))
@@ -2159,7 +2135,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)
@@ -2193,9 +2171,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))
@@ -2282,12 +2260,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)
@@ -2669,9 +2645,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)
@@ -2697,12 +2673,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)))))
@@ -2995,11 +2970,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.
@@ -3134,7 +3109,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))
@@ -3147,9 +3122,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.
@@ -3172,17 +3147,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.
@@ -3190,16 +3160,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.
@@ -3283,25 +3251,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)))
@@ -3368,11 +3335,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.
@@ -3484,6 +3450,97 @@ The list is displayed in a buffer named `*Packages*'."
(interactive)
(list-packages t))
+;;;; 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
+;; no-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 fa7b1de8b4d..4a69244d265 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -919,7 +919,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
@@ -949,7 +949,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 d76bf024d0a..2491ccea95b 100644
--- a/lisp/emacs-lisp/radix-tree.el
+++ b/lisp/emacs-lisp/radix-tree.el
@@ -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/rx.el b/lisp/emacs-lisp/rx.el
index 5fa0eaf194f..bb759011513 100644
--- a/lisp/emacs-lisp/rx.el
+++ b/lisp/emacs-lisp/rx.el
@@ -106,6 +106,8 @@
;;; Code:
+(require 'cl-lib)
+
;; FIXME: support macros.
(defvar rx-constituents ;Not `const' because some modes extend it.
diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el
index 1788f0d71f7..260ac3683dd 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/subr-x.el b/lisp/emacs-lisp/subr-x.el
index 7fab9083e85..20eb0d5d05c 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)
@@ -211,7 +211,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")
@@ -219,17 +219,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.
diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el
index 9c293117c62..21bc2ce6d43 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 dff990ea401..d48c79cd770 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..b4644024583
--- /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 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 f12633e6de1..823d4960aa0 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.el b/lisp/emacs-lisp/timer.el
index b1e12b1fd56..74d37b0eaed 100644
--- a/lisp/emacs-lisp/timer.el
+++ b/lisp/emacs-lisp/timer.el
@@ -102,14 +102,14 @@ 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)
+ (let* ((trillion 1000000000000)
(time-sec (+ (nth 1 time)
- (* 65536.0 (nth 0 time))))
+ (* 65536 (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))))
+ (next-sec (+ time-sec (floor delta-sec)))
+ (next-sec-psec (floor (* trillion (mod delta-sec 1))))
(sub-time-psec (+ (or (nth 3 time) 0)
- (* 1e6 (nth 2 time))))
+ (* 1000000 (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
@@ -141,20 +141,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)
diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el
index f6b569bc7fe..03f22ebf1a1 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 489611d4d16..c4d97ceab03 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 1c13d0ef975..1ff69cc7fc7 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 a737bb6c11c..f1143425eb8 100644
--- a/lisp/emulation/cua-base.el
+++ b/lisp/emulation/cua-base.el
@@ -852,8 +852,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 +882,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)))))))
@@ -1322,9 +1318,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 fe57535a14b..3b617a42abc 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
@@ -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)
diff --git a/lisp/emulation/viper-ex.el b/lisp/emulation/viper-ex.el
index 347e66f8ff1..d95a828614e 100644
--- a/lisp/emulation/viper-ex.el
+++ b/lisp/emulation/viper-ex.el
@@ -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))
diff --git a/lisp/emulation/viper-keym.el b/lisp/emulation/viper-keym.el
index e72842232e4..cc0b7ebc379 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-2018 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 247180c803c..cfb46cc19a8 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-2018 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 f0540401803..aa456551a68 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-2018 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 c8eca30e88b..8dd150bf7c8 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 e47eb57836f..7007ba33e58 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 1de2f9ba2d8..866a4ae03a7 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 135c956c3f4..19f131cc33b 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 077666ac897..008593712bd 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))
@@ -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 f2989b314a2..c3938e90a71 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"
@@ -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 d30ebea2d66..fb866df3920 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 dc0e2df5838..8f26cd34ee4 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))
@@ -1196,7 +1180,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 +1337,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 +1374,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 +1445,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 +1457,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 +1534,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 +1571,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 +1642,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 +1662,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 +1744,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 +1769,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 +1819,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 4baa1b3cb80..80cb6abe59d 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 ca37ee8f0c9..814ecfae85a 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."
diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el
index cdc8046c086..7599053e9d3 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 278eaf2506f..85f18fd5e88 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 15de703d803..ce66ff9007f 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 2ca6a92b66f..8de00070583 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)))
@@ -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.
@@ -1091,14 +1081,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)
@@ -1257,5 +1247,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 f44a6978031..84db0f58e46 100644
--- a/lisp/erc/erc-desktop-notifications.el
+++ b/lisp/erc/erc-desktop-notifications.el
@@ -98,3 +98,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 e698cea847e..58697506185 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 f980d356e25..5efb8540b61 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 d39a58df204..d710d95cde8 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 05fe1c6738e..f038216cea6 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 a6bf6518ea8..d7ae93316cd 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 bdc51e77ae7..0bb962dece5 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 babcb5f68ff..584f566f049 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 c7ba5adace1..534a5b74205 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
@@ -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 e10a8e193d0..4270ec6d993 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 0eedd54dde7..885fc49bce5 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 267aecdbb0d..2666598436a 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 e47f471641f..4d78a8c7214 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 64b535d78e1..db0359c9afc 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 4efb9a74b9e..f321ae0228d 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 5a7282dd965..7e315d3b6ed 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 75ae9b51912..ac49a3e12ef 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-2018 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 e68668c5d03..8df8ded44f3 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 109ef281d36..58eefd83cfb 100644
--- a/lisp/erc/erc-speedbar.el
+++ b/lisp/erc/erc-speedbar.el
@@ -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 89f75f13aa2..3a34ea37397 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 17ee2cb17d0..6a648e74358 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 a45777cb773..cae18f60937 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:
@@ -974,6 +971,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 37744ebfd44..d4359c5c6b3 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 4f1ebe4fad0..0d66fe51069 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 dbf3dac0941..a7e27424f29 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -67,12 +67,15 @@
;;; 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 +402,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 +431,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 +505,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 +1278,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 +1361,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 +1609,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."
@@ -2549,9 +2568,7 @@ consumption for long-lived IRC or Emacs sessions."
(maphash
(lambda (nick last-PRIVMSG-time)
(when
- (> (float-time (time-subtract
- (current-time)
- last-PRIVMSG-time))
+ (> (float-time (time-subtract nil last-PRIVMSG-time))
erc-lurker-threshold-time)
(remhash nick hash)))
hash)
@@ -2618,7 +2635,7 @@ server within `erc-lurker-threshold-time'. See also
(gethash server erc-lurker-state (make-hash-table)))))
(or (null last-PRIVMSG-time)
(> (float-time
- (time-subtract (current-time) last-PRIVMSG-time))
+ (time-subtract nil last-PRIVMSG-time))
erc-lurker-threshold-time))))
(defcustom erc-common-server-suffixes
@@ -3677,8 +3694,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)
@@ -6021,8 +6040,7 @@ 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."
+ "Convert the long number represented by STRING into an Emacs timestamp."
(let* ((n (string-to-number (concat string ".0"))))
(list (truncate (/ n 65536))
(truncate (mod n 65536)))))
diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el
index f4b7872f8c9..e79b49095f2 100644
--- a/lisp/eshell/em-cmpl.el
+++ b/lisp/eshell/em-cmpl.el
@@ -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)
@@ -437,7 +438,7 @@ 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
diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el
index ba3bdb5cd53..b7d13ee27b7 100644
--- a/lisp/eshell/em-dirs.el
+++ b/lisp/eshell/em-dirs.el
@@ -207,7 +207,7 @@ Thus, this does not include the current directory.")
(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)))
@@ -282,7 +282,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,14 +293,14 @@ 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)))
@@ -314,16 +314,18 @@ Thus, this does not include the current directory.")
path)))
(defun eshell-expand-multiple-dots (path)
+ ;; 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)))"
+ (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 "\\(?:^\\|/\\)\\.\\.\\(\\.+\\)\\(?:$\\|/\\)" path)
(let* ((extra-dots (match-string 1 path))
(len (length extra-dots))
diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el
index 3f863171bd9..62e2f57d0fd 100644
--- a/lisp/eshell/em-hist.el
+++ b/lisp/eshell/em-hist.el
@@ -218,9 +218,6 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil."
(defun eshell-hist-initialize ()
"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))
@@ -584,21 +581,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 +639,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 (.
diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el
index 2b568a991a2..53de7f7ec63 100644
--- a/lisp/eshell/em-ls.el
+++ b/lisp/eshell/em-ls.el
@@ -183,9 +183,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 +193,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)
@@ -437,7 +437,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 +503,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 +585,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 +700,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 +766,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 2c12cacfff8..c3b942d25a7 100644
--- a/lisp/eshell/em-pred.el
+++ b/lisp/eshell/em-pred.el
@@ -89,10 +89,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 +133,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))
@@ -460,7 +462,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 +491,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 +521,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 +549,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 da2cfe4dfdd..e61b0eb1c87 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."
diff --git a/lisp/eshell/em-script.el b/lisp/eshell/em-script.el
index 1b0b220d5bc..a5d8e96ba84 100644
--- a/lisp/eshell/em-script.el
+++ b/lisp/eshell/em-script.el
@@ -61,7 +61,7 @@ This includes when running `eshell-command'."
"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)
diff --git a/lisp/eshell/em-tramp.el b/lisp/eshell/em-tramp.el
index c45453bf288..9475f4ed949 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)
@@ -106,6 +107,7 @@ Uses the system sudo through TRAMP's sudo method."
'((?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 b569f909938..3aecebc2ebf 100644
--- a/lisp/eshell/em-unix.el
+++ b/lisp/eshell/em-unix.el
@@ -370,12 +370,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 +399,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
@@ -612,7 +614,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")))
@@ -843,19 +846,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
@@ -926,7 +929,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)))
@@ -975,7 +978,7 @@ Show wall-clock time elapsed during execution of COMMAND.")
(eshell-stringify-list
(eshell-flatten-list (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)))
diff --git a/lisp/eshell/em-xtra.el b/lisp/eshell/em-xtra.el
index ce73474fb73..cc84d198544 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
diff --git a/lisp/eshell/esh-ext.el b/lisp/eshell/esh-ext.el
index fdb77d32265..244cc7ff1f3 100644
--- a/lisp/eshell/esh-ext.el
+++ b/lisp/eshell/esh-ext.el
@@ -37,8 +37,8 @@
(eval-when-compile
(require 'cl-lib)
- (require 'esh-io)
(require 'esh-cmd))
+(require 'esh-io)
(require 'esh-arg)
(require 'esh-opt)
(require 'esh-proc)
diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el
index bbb74c3d86f..0c25f412c2a 100644
--- a/lisp/eshell/esh-mode.el
+++ b/lisp/eshell/esh-mode.el
@@ -182,10 +182,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
@@ -884,8 +885,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))))
diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el
index 7d0b362b4c4..d7a449450f9 100644
--- a/lisp/eshell/esh-opt.el
+++ b/lisp/eshell/esh-opt.el
@@ -80,6 +80,10 @@ arguments, some do not. The recognized :KEYWORDS are:
If present, do not pass MACRO-ARGS through `eshell-flatten-list'
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,8 +99,8 @@ 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))
@@ -111,6 +115,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:
@@ -194,11 +200,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 +245,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)
diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el
index 94401c5daa5..3735f30c304 100644
--- a/lisp/eshell/esh-proc.el
+++ b/lisp/eshell/esh-proc.el
@@ -158,7 +158,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 +167,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 +179,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 +199,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."
@@ -279,11 +282,10 @@ See `eshell-needs-pipe'."
(let ((process-connection-type
(unless (eshell-needs-pipe-p command)
process-connection-type))
- (command (file-local-name command)))
+ ;; `start-process' can't deal with relative filenames.
+ (command (file-local-name (expand-file-name command))))
(apply 'start-file-process
- (file-name-nondirectory command) nil
- ;; `start-process' can't deal with relative filenames.
- (append (list (expand-file-name command)) args))))
+ (file-name-nondirectory command) nil command args)))
(eshell-record-process-object proc)
(set-process-buffer proc (current-buffer))
(if (eshell-interactive-output-p)
diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el
index 5d38c27eb1d..8fe8c461fdb 100644
--- a/lisp/eshell/esh-util.el
+++ b/lisp/eshell/esh-util.el
@@ -295,7 +295,7 @@ Prepend remote identification of `default-directory', if any."
(nconc new-list (list a))))
(cdr new-list)))
-(defun eshell-uniqify-list (l)
+(defun eshell-uniquify-list (l)
"Remove occurring multiples in L. You probably want to sort first."
(let ((m l))
(while m
@@ -305,6 +305,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."
@@ -444,7 +447,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))))
@@ -498,7 +501,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-hosts-file file))
(set timestamp-var (current-time))))
diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el
index 1af03d367c3..b5dce80de8c 100644
--- a/lisp/eshell/esh-var.el
+++ b/lisp/eshell/esh-var.el
@@ -343,6 +343,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)
diff --git a/lisp/face-remap.el b/lisp/face-remap.el
index 476736773bf..c6a976deb00 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 be5a18c8cc7..7c10d6097c5 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/ffap.el b/lisp/ffap.el
index 22be2f85369..b51929d2602 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 eaf2cfc92e0..9dd631001da 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-2018 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/filenotify.el b/lisp/filenotify.el
index 21c9cc23df9..59a8c0e88aa 100644
--- a/lisp/filenotify.el
+++ b/lisp/filenotify.el
@@ -307,12 +307,12 @@ FILE is the name of the file whose event is being reported."
(unless (functionp callback)
(signal 'wrong-type-argument `(,callback)))
- (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)
+ (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)))
@@ -363,6 +363,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
diff --git a/lisp/files-x.el b/lisp/files-x.el
index 92532e85f4f..9af399c87ba 100644
--- a/lisp/files-x.el
+++ b/lisp/files-x.el
@@ -492,15 +492,32 @@ 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)
+ (cdr variable-value)))
+ (cdr mode-variables) "\n"))))
+ variables "\n")))
;;;###autoload
(defun add-dir-local-variable (mode variable value)
diff --git a/lisp/files.el b/lisp/files.el
index 9a8ed64e702..b8f6c461467 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
@@ -969,7 +969,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
@@ -1024,13 +1025,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.
@@ -1132,7 +1153,8 @@ 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
@@ -1807,7 +1829,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.
@@ -2010,15 +2036,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."
@@ -2098,8 +2156,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)
@@ -2234,8 +2295,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 ()
@@ -2304,7 +2364,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)))
@@ -2313,7 +2374,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)))
@@ -3322,7 +3384,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")
@@ -3632,7 +3694,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.
@@ -3798,8 +3861,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.")
@@ -4003,7 +4066,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.
@@ -4017,13 +4082,15 @@ 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)
@@ -4033,17 +4100,25 @@ Return the new class name, which is a symbol named DIR."
(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
+ (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)
@@ -4378,7 +4453,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)))))
@@ -4470,32 +4545,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\".
@@ -4534,8 +4613,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)))))
@@ -5215,9 +5294,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.
@@ -5447,6 +5531,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 \"..\".")
@@ -5635,7 +5734,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))))))
@@ -5917,7 +6017,11 @@ an auto-save file."
(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"
@@ -6449,58 +6553,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
@@ -6950,8 +7028,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
@@ -6991,20 +7070,27 @@ 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
+ shell-command temporary-file-directory))
(directory-file-name
(expand-file-name
(unhandled-file-name-directory default-directory)))
@@ -7012,35 +7098,49 @@ 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)))
+ ;; 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.
@@ -7051,22 +7151,21 @@ only these files will be asked to be saved."
(save-match-data
(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)))
+ (`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))))))
+ (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.
@@ -7075,32 +7174,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)))
@@ -7201,7 +7341,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)
@@ -7381,27 +7521,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)
@@ -7411,20 +7548,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 63f7c75b65b..c1e6ef10d5d 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
diff --git a/lisp/find-dired.el b/lisp/find-dired.el
index 4dda3c425c3..9a798b0e399 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.
@@ -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 0070e590c36..a3e4511d72d 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)
" "
diff --git a/lisp/foldout.el b/lisp/foldout.el
index ead5368bad2..34e3c6da66b 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 7942901bb4f..e2d3a11b654 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.
@@ -383,9 +383,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 +418,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)
@@ -438,10 +435,7 @@ Keys specific to Follow mode:
(setq pos-visible-in-window-group-p-function
'follow-pos-visible-in-window-p)
(setq selected-window-group-function 'follow-all-followers)
- (setq move-to-window-group-line-function 'follow-move-to-window-line)
-
- ;; Crude workaround for bug #32848 for the emacs-26 branch, 2018-09-30.
- (setq-local make-cursor-line-fully-visible nil))
+ (setq move-to-window-group-line-function 'follow-move-to-window-line))
;; Remove globally-installed hook functions only if there is no
;; other Follow mode buffer.
@@ -451,12 +445,9 @@ 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)))
- ;; Second part of crude workaround for bug #32848.
- (kill-local-variable 'make-cursor-line-fully-visible)
-
(kill-local-variable 'move-to-window-group-line-function)
(kill-local-variable 'selected-window-group-function)
(kill-local-variable 'pos-visible-in-window-group-p-function)
@@ -1269,10 +1260,27 @@ 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
+
+;; 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'.
-;; The magic little box. This function is called after every command.
+(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.
@@ -1293,6 +1301,12 @@ 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)))
diff --git a/lisp/font-core.el b/lisp/font-core.el
index ace1476edac..c5b036e04fa 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 29d3bc58646..be9fb4dc93f 100644
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
@@ -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.
diff --git a/lisp/format-spec.el b/lisp/format-spec.el
index 31caf931edb..38ce69b6c4d 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 9f109e1aa1e..49d3c718abc 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 29c31f41cb1..56b8c5487c8 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.
@@ -614,9 +699,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.")
@@ -1147,8 +1229,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
@@ -1302,9 +1382,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
@@ -1322,9 +1399,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
@@ -2113,10 +2187,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
@@ -2221,9 +2291,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
@@ -2322,7 +2389,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'.
@@ -2344,22 +2410,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
@@ -2377,19 +2458,18 @@ terminals, cursor blinking is controlled by the terminal."
: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
@@ -2404,19 +2484,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'
@@ -2431,18 +2511,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 0e3363d7ae3..0d7e8025abd 100644
--- a/lisp/frameset.el
+++ b/lisp/frameset.el
@@ -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
diff --git a/lisp/generic-x.el b/lisp/generic-x.el
index ea2a100a586..d8a7fe3a735 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
@@ -1610,7 +1591,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 +1600,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 7c657ead78d..0bd47cdde9a 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 d2bc87caa27..6286c535ca2 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 c69d64546c5..18e6174fa02 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")
@@ -332,9 +331,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 +360,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)
@@ -1108,7 +1103,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 +1118,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)
@@ -1513,7 +1508,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))
@@ -1608,7 +1603,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 +2097,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))))))
@@ -2180,7 +2180,7 @@ article counts for each of the method's subscribed groups."
'gnus-agent-file-loading-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)
@@ -2833,7 +2833,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)
@@ -3089,7 +3089,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))
@@ -3352,10 +3352,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 +3369,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
@@ -3431,9 +3432,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)))))))
@@ -3805,7 +3806,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 +3825,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 +3951,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
@@ -4110,23 +4113,25 @@ 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)
@@ -4143,11 +4148,11 @@ modified."
(gnus-sethash 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)))))
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index 15e88a34227..1b0dde94551 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))
@@ -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)))))))
@@ -2948,7 +2937,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)
@@ -3031,9 +3021,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)."
@@ -3638,8 +3625,7 @@ 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))
+ (let* ((real-time (time-subtract nil time))
(real-sec (and real-time
(+ (* (float (car real-time)) 65536)
(cadr real-time))))
@@ -4727,6 +4713,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))))))
@@ -5230,7 +5221,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)))))
@@ -6698,7 +6689,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
@@ -6764,7 +6755,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)
@@ -7062,9 +7054,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
@@ -8240,7 +8231,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 7003aef24f7..ad25f805ca1 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)
@@ -183,7 +183,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)))
@@ -290,7 +290,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)
diff --git a/lisp/gnus/gnus-bcklg.el b/lisp/gnus/gnus-bcklg.el
index 8afc31327d7..95cb1ca5ecc 100644
--- a/lisp/gnus/gnus-bcklg.el
+++ b/lisp/gnus/gnus-bcklg.el
@@ -24,8 +24,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
-
(require 'gnus)
;;;
diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el
index c3e77ca59b0..a16b61a3bd1 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)
@@ -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)
@@ -735,7 +736,7 @@ If LOW, update the lower bound instead."
;; `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))
+ (cons (car nums) (car (last nums)))
gnus-cache-active-hashtb))
;; Go through all the other files.
(dolist (file alphs)
@@ -854,7 +855,7 @@ supported."
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,12 +863,12 @@ 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
@@ -877,7 +878,7 @@ supported."
(gnus-sethash 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)))
diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el
index 386593be026..bbf9e527db7 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
@@ -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))
diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el
index d5970f31265..1aa8e71ae1e 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 0bac2cb1ada..f4c0aa73327 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-demon.el b/lisp/gnus/gnus-demon.el
index 72b0f5cecff..2405c705651 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)
@@ -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))))))
diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el
index 7a37a86fb6f..7d4be47e41b 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 d1335fc8c16..a03c6c140cd 100644
--- a/lisp/gnus/gnus-dup.el
+++ b/lisp/gnus/gnus-dup.el
@@ -29,8 +29,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
-
(require 'gnus)
(require 'gnus-art)
diff --git a/lisp/gnus/gnus-fun.el b/lisp/gnus/gnus-fun.el
index 40c6d511115..f1fd51d5509 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 fea09ea21a5..6af27afbfaa 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)
@@ -46,6 +43,8 @@
(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")
@@ -1086,6 +1085,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'.
@@ -1152,7 +1153,7 @@ The following commands are available:
(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)
@@ -1359,6 +1360,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
@@ -1898,7 +1901,7 @@ If FIRST-TOO, the current line is also eligible as a target."
(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))
@@ -2548,65 +2551,70 @@ 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)))
+ (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.
+ (if (gnus-goto-char
+ (text-property-any
+ (point-min) (point-max)
+ 'gnus-group (gnus-intern-safe group gnus-active-hashtb)))
+ (point)
+ (goto-char start)
+ nil))))))
(defun gnus-group-next-group (n &optional silent)
"Go to next N'th newsgroup.
@@ -2998,7 +3006,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 +3029,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)))))
@@ -3553,7 +3561,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)))
@@ -3921,7 +3929,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)
@@ -4102,9 +4110,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 +4130,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
@@ -4367,6 +4381,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 +4395,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."
@@ -4565,7 +4594,7 @@ or `gnus-group-catchup-group-hook'."
"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)))
+ (delta (time-subtract nil time)))
(+ (* (nth 0 delta) 65536.0)
(nth 1 delta))))
diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el
index fc0b36b0db1..f097028cb3e 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 d878e7695a9..3365c826e11 100644
--- a/lisp/gnus/gnus-icalendar.el
+++ b/lisp/gnus/gnus-icalendar.el
@@ -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
@@ -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,7 +238,7 @@
"\\\\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))
@@ -443,7 +443,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 .:.
diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el
index a17741b577c..5d5f9ebb670 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)
diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el
index fd5935b87f8..60732c11d54 100644
--- a/lisp/gnus/gnus-kill.el
+++ b/lisp/gnus/gnus-kill.el
@@ -25,8 +25,6 @@
;;; Code:
-(eval-when-compile (require 'cl))
-
(require 'gnus)
(require 'gnus-art)
(require 'gnus-range)
diff --git a/lisp/gnus/gnus-logic.el b/lisp/gnus/gnus-logic.el
index e0dba06d397..2076d8aebe7 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)
diff --git a/lisp/gnus/gnus-ml.el b/lisp/gnus/gnus-ml.el
index f78efdee65b..1c67f5ffba0 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 eeb65e67e88..599b9c61dcf 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 effbe2cc5f4..660bdf73cdf 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)
@@ -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 8f3efa41675..b6bb5c9c2b7 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 c8ba7ae5c15..dd3793593e0 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 4c0d5218ab8..229d057946e 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 a80bb5b7037..aff841760ae 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.
@@ -552,7 +552,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 +734,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 +784,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 a6536797662..327cc69392d 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))
@@ -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))
@@ -2318,7 +2317,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)
@@ -2517,7 +2516,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 +2552,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 +2675,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 +2734,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 +3065,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 +3077,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 082ebf15529..379a7f2b5c3 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)
@@ -285,15 +285,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 f9795628cc0..dfca5e9d2cb 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)
@@ -142,7 +142,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]
@@ -189,7 +189,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 +200,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 +221,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 +229,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 +236,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 +243,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)
@@ -452,7 +437,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 +594,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 +628,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
@@ -821,12 +808,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 +820,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))
@@ -982,7 +967,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 +1112,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 +1132,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 +1142,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 2a7a303408e..f15d645a534 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)
@@ -1231,14 +1230,14 @@ for new groups, and subscribe the new groups as zombies."
(let ((do-sub (gnus-matches-options-n group)))
(cond
((eq do-sub 'subscribe)
- (incf groups)
+ (cl-incf groups)
(gnus-sethash group group gnus-killed-hashtb)
(gnus-call-subscribe-functions
gnus-subscribe-options-newsgroup-method group))
((eq do-sub 'ignore)
nil)
(t
- (incf groups)
+ (cl-incf groups)
(gnus-sethash group group gnus-killed-hashtb)
(if gnus-subscribe-hierarchical-interactive
(push group new-newsgroups)
@@ -1700,7 +1699,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 +1722,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 +1739,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 +1770,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 +1794,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
@@ -1990,15 +1989,10 @@ backend check whether the group actually exists."
;; 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 4096))))
+ (dolist (list (list gnus-killed-list gnus-zombie-list))
+ (dolist (group list)
+ (gnus-sethash group nil hashtb)))))
(defun gnus-get-killed-groups ()
"Go through the active hashtb and mark all unknown groups as killed."
@@ -2456,10 +2450,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
@@ -2829,73 +2819,78 @@ 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)))))
@@ -3061,11 +3056,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)))
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index a39af45e92e..f56b822ac57 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -24,7 +24,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(require 'cl-lib)
(defvar tool-bar-mode)
(defvar gnus-tmp-header)
@@ -1266,9 +1266,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
@@ -2366,7 +2370,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]))))
@@ -2625,6 +2629,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"]
@@ -2940,6 +2945,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'.
@@ -3803,7 +3810,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))))
@@ -3992,7 +3999,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.
@@ -4303,10 +4310,10 @@ If SELECT-ARTICLES, only select those articles from GROUP."
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))
@@ -4405,7 +4412,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)))
@@ -4426,7 +4433,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 ()
@@ -4719,7 +4726,7 @@ 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)))
@@ -5463,7 +5470,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
@@ -5737,7 +5744,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)))))
@@ -5914,7 +5921,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
@@ -6076,12 +6083,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
@@ -6111,7 +6118,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)
@@ -6303,6 +6310,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)
@@ -6651,7 +6659,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")
@@ -7056,12 +7064,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."
@@ -7274,12 +7290,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
@@ -7343,7 +7360,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
@@ -7796,7 +7813,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)
@@ -7805,10 +7823,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)
@@ -8555,14 +8574,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
@@ -8755,7 +8782,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)))
@@ -8887,7 +8914,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))
@@ -8912,7 +8939,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))
@@ -8964,7 +8991,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))
@@ -8980,7 +9007,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)
@@ -10313,16 +10340,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))
@@ -11142,7 +11172,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)))
@@ -11722,7 +11752,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)
@@ -11794,7 +11824,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))
@@ -11962,7 +11992,7 @@ 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")
@@ -11981,7 +12011,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)
@@ -12000,7 +12031,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.
@@ -12270,21 +12303,27 @@ save those articles instead."
(if (> (length articles) 1)
(format "these %d articles" (length articles))
"this article")))
+ valid-names
(to-newsgroup
- (cond
- ((null split-name)
- (gnus-group-completing-read
- prom
- (gnus-remove-if-not 'gnus-valid-move-group-p gnus-active-hashtb t)
- 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)
- nil prefix 'gnus-group-history (car split-name)))
- (t
- (gnus-completing-read
- prom (nreverse split-name) nil nil 'gnus-group-history))))
+ (progn
+ (mapatoms (lambda (g)
+ (when (gnus-valid-move-group-p g)
+ (push g valid-names)))
+ gnus-active-hashtb)
+ (cond
+ ((null split-name)
+ (gnus-group-completing-read
+ prom
+ valid-names
+ nil prefix nil default))
+ ((= 1 (length split-name))
+ (gnus-group-completing-read
+ prom
+ valid-names
+ nil prefix 'gnus-group-history (car split-name)))
+ (t
+ (gnus-completing-read
+ prom (nreverse split-name) nil nil 'gnus-group-history)))))
(to-method (gnus-server-to-method (gnus-group-method to-newsgroup)))
encoded)
(when to-newsgroup
@@ -12359,7 +12398,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))))))
@@ -12532,7 +12571,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)
@@ -12691,6 +12730,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)
@@ -12915,7 +12955,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))))
@@ -13002,12 +13042,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 0ff25ecd3b5..111f2ae28a4 100644
--- a/lisp/gnus/gnus-topic.el
+++ b/lisp/gnus/gnus-topic.el
@@ -25,7 +25,7 @@
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'gnus)
(require 'gnus-group)
@@ -128,7 +128,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)
@@ -220,6 +220,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 +304,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,7 +460,7 @@ 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)))
not-in-list)
@@ -508,7 +510,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)))
@@ -562,7 +564,7 @@ articles in the topic and its subtopics."
(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)
@@ -728,10 +730,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 +774,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
diff --git a/lisp/gnus/gnus-undo.el b/lisp/gnus/gnus-undo.el
index 8144e0cadc8..d487262c931 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 1c42d7d0ef8..2e4b054a9f9 100644
--- a/lisp/gnus/gnus-util.el
+++ b/lisp/gnus/gnus-util.el
@@ -32,8 +32,7 @@
;;; Code:
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(require 'time-date)
@@ -142,7 +141,7 @@ This is a compatibility function for different Emacsen."
"Extract address components from a From header.
Given an RFC-822 address FROM, extract full name and canonical 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
@@ -278,10 +277,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.
@@ -1117,41 +1113,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."
@@ -1440,7 +1404,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 +1431,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 +1612,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 f660b861f7b..a171a385956 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 f0c48db10d6..24235d9c718 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 28fd66ca75e..ff3073a6794 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 4af818d9165..2786323f671 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-2018 Free Software
;; Foundation, Inc.
@@ -29,10 +29,11 @@
(run-hooks 'gnus-load-hook)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(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 +336,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 +347,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 +364,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 +381,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 +398,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 +415,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 +432,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 +449,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 +463,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 +480,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 +500,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 +517,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 +546,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 +568,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 +588,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,9 +626,16 @@ 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)
;;;
@@ -946,9 +695,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 +752,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 +853,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 +2225,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 +2233,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 +2303,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 +2340,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/")
@@ -2755,7 +2505,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 +2651,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)
@@ -3179,9 +2927,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 +2982,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 +3003,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 +3095,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
@@ -3463,16 +3213,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 +3323,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 +3730,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
@@ -4024,13 +3772,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 +4020,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 +4133,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 abb5e2d1231..5af292091e8 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))
@@ -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 461f61f144d..66356b6fda2 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"
@@ -1341,7 +1352,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"
@@ -1436,8 +1448,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)
@@ -1450,8 +1460,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)
@@ -1464,8 +1472,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)
@@ -1478,8 +1484,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)
@@ -1492,8 +1496,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)
@@ -1506,8 +1508,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)
@@ -1520,8 +1520,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)
@@ -1534,8 +1532,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)
@@ -1548,8 +1544,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)
@@ -1562,53 +1556,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) "\\)$")
@@ -2436,7 +2427,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
@@ -2461,10 +2452,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."
@@ -2607,6 +2598,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)))
+
;;;
@@ -2844,8 +2865,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 '(":-)" ":)"
@@ -2952,7 +2972,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
@@ -2960,7 +2980,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)
@@ -3094,17 +3116,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
@@ -3123,12 +3143,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 ()
@@ -3219,13 +3239,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)
@@ -3545,7 +3565,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))))))
@@ -3586,7 +3606,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)
@@ -3754,13 +3774,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?
@@ -4278,7 +4298,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:
@@ -4310,7 +4330,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.
@@ -4383,7 +4403,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)
@@ -4605,9 +4625,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)
@@ -4672,9 +4692,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))))))
@@ -4761,7 +4783,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)
@@ -4792,7 +4814,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)
@@ -5315,7 +5337,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? ")
@@ -5417,7 +5441,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)
@@ -5540,7 +5564,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)))
@@ -5555,9 +5579,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.
@@ -5842,10 +5866,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
@@ -6194,7 +6218,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
@@ -6719,9 +6743,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
@@ -6859,6 +6883,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.
@@ -6889,6 +6916,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
@@ -7403,7 +7439,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)))))
@@ -7877,6 +7914,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'.
@@ -7903,6 +7942,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\\):"
@@ -8126,11 +8166,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))
@@ -8226,16 +8267,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)
@@ -8248,6 +8292,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---
@@ -8355,6 +8413,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"
@@ -8370,6 +8431,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 faf887cbb9d..e292dac16fe 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 87941b88450..3e6883b2a4b 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-2018 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)
@@ -323,10 +320,12 @@ 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)
@@ -761,7 +760,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 t)
@@ -773,15 +772,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")
@@ -961,15 +961,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 +982,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 +1032,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 +1165,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 +1297,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 +1441,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 +1776,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 +1835,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 +1856,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 2eec32b9ac0..361e85fbe1f 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 b7c602030d7..fbae669ce94 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-2018 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 b380fae7666..51dc8b89e3a 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 1715097d4f8..1008c60a173 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 fcd97f2b27c..25b156803a6 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-2018 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)
@@ -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,17 +821,18 @@ 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)
(buffer-string)
- (erase-buffer)) t)
+ (erase-buffer))
+ t)
" ")
"\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
@@ -898,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 e15eba75924..cf6d6d17ed5 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 c11af7060b7..15eac11fb9e 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
@@ -450,7 +452,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)
@@ -496,10 +498,18 @@ If MODE is not set, try to find mode automatically."
(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 (1- (point))))
+ (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
@@ -561,7 +571,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 099e5372b48..9a64853edf6 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)))))
@@ -903,7 +904,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 f91aa140e7b..9df33d09377 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 3c9476333fa..9fd72a93d5b 100644
--- a/lisp/gnus/mml.el
+++ b/lisp/gnus/mml.el
@@ -27,7 +27,7 @@
(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))
(autoload 'message-make-message-id "message")
@@ -548,6 +548,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 +798,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 +815,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 +835,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))))
diff --git a/lisp/gnus/mml1991.el b/lisp/gnus/mml1991.el
index 4198f2c0c54..b2056b2fd0d 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 b220a960983..403b5e1af6a 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 44b010c29b6..1b2b13ebe4d 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 faa797aae45..9f80a755713 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))))
diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el
index 2d3d3d16a84..0b300c1a16f 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.")
@@ -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 28c903cb913..6dc6c338082 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 53864d1bc1b..76e785d2ad6 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.
@@ -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 e984bcb382a..cee7c92b3f1 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 9b6a92f10e7..10ac7025505 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 (zerop (float-time (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 565c9856051..8ef6f2a0582 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 b05c4e88073..8b7898c1893 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 77afb09a2a8..83a9c3f3e17 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 <.*>
@@ -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)
@@ -1071,14 +1071,11 @@ 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)
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index cab1513a164..12892c516a7 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)))
@@ -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)
@@ -442,7 +464,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 +498,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 +517,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 +552,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 +572,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")
@@ -794,7 +826,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 +867,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 +900,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 +914,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 +974,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 +1041,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 +1166,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 +1177,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
@@ -1189,7 +1221,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 +1301,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 +1323,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 +1358,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 +1430,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 +1449,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 +1513,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 +1585,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 +1768,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 +1886,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 +1904,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 +1914,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 +2144,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 +2160,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 +2211,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 +2223,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 55e00a0b69f..7e5f56e4dd0 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).
@@ -530,8 +530,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 +559,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
@@ -644,7 +642,7 @@ skips all prompting."
(add-hook 'gnus-summary-mode-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 +667,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 +716,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 +755,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 +805,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 +821,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 +959,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))))
@@ -1177,7 +1180,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 +1270,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 +1436,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,7 +1505,7 @@ 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 _group)
"Run QUERY against notmuch.
Returns a vector of (group name, file name) pairs (also vectors,
actually)."
@@ -1662,54 +1665,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 +1764,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 +1772,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 +1803,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 +1838,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 +1859,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 88156d1af82..13c4303291c 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)))
@@ -665,7 +666,7 @@ nn*-request-list should have been called before calling this function."
(setq group (symbol-name group)))
(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 ()
@@ -1836,8 +1838,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 +1885,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-subtract nil days)
(ignore-errors (time-less-p days (time-since time)))))))))
(declare-function gnus-group-mark-article-read "gnus-group" (group article))
@@ -1899,7 +1901,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 +2036,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..afaf3dcfcff 100644
--- a/lisp/gnus/nnmaildir.el
+++ b/lisp/gnus/nnmaildir.el
@@ -68,8 +68,7 @@
(require 'message)
(require 'nnmail)
-(eval-when-compile
- (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defconst nnmaildir-version "Gnus")
@@ -165,14 +164,14 @@ 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
+(cl-defstruct nnmaildir--grp
(name nil :type string) ;; "group.name"
(new nil :type list) ;; new/ modtime
(cur nil :type list) ;; cur/ modtime
@@ -186,7 +185,7 @@ This variable is set by `nnmaildir-request-article'.")
(mmth nil :type vector)) ;; obarray 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:"
@@ -319,15 +318,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
@@ -393,8 +392,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 +412,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 +437,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)
@@ -652,7 +651,7 @@ This variable is set by `nnmaildir-request-article'.")
(funcall func (cdr entry)))))))
(defun nnmaildir--up2-1 (n)
- (if (zerop n) 1 (1- (lsh 1 (1+ (logb n))))))
+ (if (zerop n) 1 (1- (ash 1 (1+ (logb n))))))
(defun nnmaildir--system-name ()
(replace-regexp-in-string
@@ -765,7 +764,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 (- (float-time) 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 +794,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)))
@@ -856,7 +859,7 @@ 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))
@@ -904,7 +907,7 @@ This variable is set by `nnmaildir-request-article'.")
(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))
+ (setq x (file-attribute-modification-time (file-attributes srv-dir))
scan-group (null scan-group))
(if (equal x (nnmaildir--srv-mtime nnmaildir--cur-server))
(if scan-group
@@ -915,7 +918,7 @@ This variable is set by `nnmaildir-request-article'.")
(setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort)
dirs (if (zerop (length target-prefix))
dirs
- (gnus-remove-if
+ (seq-remove
(lambda (dir)
(and (>= (length dir) (length target-prefix))
(string= (substring dir 0
@@ -937,7 +940,7 @@ This variable is set by `nnmaildir-request-article'.")
(dolist (grp x)
(unintern grp groups))
(setf (nnmaildir--srv-mtime nnmaildir--cur-server)
- (nth 5 (file-attributes srv-dir))))
+ (file-attribute-modification-time (file-attributes srv-dir))))
(and scan-group
(nnmaildir--srv-gnm nnmaildir--cur-server)
(nnmail-get-new-mail 'nnmaildir nil nil))))))
@@ -994,7 +997,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)
@@ -1047,7 +1050,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)
@@ -1464,9 +1467,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 "M" (number-to-string (caddr time))))
(setq file (concat file nnmaildir--delivery-pid)
file (concat file "Q" (number-to-string nnmaildir--delivery-count))
file (concat file "." (nnmaildir--system-name))
@@ -1602,7 +1603,7 @@ This variable is set by `nnmaildir-request-article'.")
(nnmaildir--expired-article group article))
((and no-force
(progn
- (setq time (nth 5 time)
+ (setq time (file-attribute-modification-time time)
bound-iter boundary)
(while (and bound-iter time
(= (car bound-iter) (car time)))
@@ -1732,7 +1733,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)
@@ -1779,14 +1780,11 @@ This variable is set by `nnmaildir-request-article'.")
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)))
+ (nnmaildir--prepare server nil)
+ (when nnmaildir--cur-server
+ (setq server nnmaildir--cur-server
+ nnmaildir--cur-server nil)
+ (unintern (nnmaildir--srv-address server) nnmaildir--servers))
t)
(defun nnmaildir-request-close ()
diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el
index 3a0035a3116..24188f5c740 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)
diff --git a/lisp/gnus/nnmbox.el b/lisp/gnus/nnmbox.el
index 57d8d2125f5..05342dae001 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 b8dd3835520..d0f8ec256e7 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 a1b7d417ab4..e7a5b99835f 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")
@@ -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)))
diff --git a/lisp/gnus/nnoo.el b/lisp/gnus/nnoo.el
index 6a61d3d09f2..1e69af65a3b 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 3ab7d0893b9..f80e2c51078 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
@@ -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)
@@ -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)))
@@ -645,7 +645,7 @@ which RSS 2.0 allows."
nnrss-directory))))
(setq xml (nnrss-fetch file t))
(setq url (or (nth 2 (assoc group nnrss-server-data))
- (second (assoc group nnrss-group-alist))))
+ (cadr (assoc group nnrss-group-alist))))
(unless url
(setq url
(cdr
@@ -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))
@@ -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 (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 c3fc25047b0..2f16b653924 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))))
diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el
index d0d13849370..be9e4955105 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 397d44ee2ac..777c5c1bbe0 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)
@@ -774,13 +774,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 cac2dae8ebb..a64f10f98a7 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)
@@ -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 9ef0598ee09..9bceb4ead90 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 389ae67d1a4..226a4cecdcb 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 3e722d2d82d..ab2a5b0f813 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 92052952605..3625132f8fe 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 1c2b3467237..710e0e83cf9 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))))
@@ -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
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 9ffb7ff59cd..ec46a479ed8 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -181,8 +181,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)
@@ -642,6 +642,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 +723,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.
@@ -1287,7 +1293,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 +1326,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 a13494aa460..56cb080e200 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 77e32848318..28288e57f6e 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-2018 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
@@ -455,6 +452,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 +464,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 +474,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 +592,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 +628,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 +715,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 +732,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 +908,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 +971,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 +1067,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 +1089,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 +1107,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 2c1a7de48a7..230b64d9f23 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.
diff --git a/lisp/hfy-cmap.el b/lisp/hfy-cmap.el
index 6dea345f286..ee6e18edb0a 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-2018 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 f3a329f4678..08b58117dd0 100644
--- a/lisp/hi-lock.el
+++ b/lisp/hi-lock.el
@@ -289,9 +289,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 +429,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 +443,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)
@@ -689,11 +689,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 +718,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 b8c1fc5a99b..70bf6b44b9d 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 fc75b478c86..f0ee22a1da1 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 6ddbbc99f91..10cfca33700 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 a3143e5e29a..32ec91db970 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"))
@@ -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 ()
@@ -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
diff --git a/lisp/ibuf-macs.el b/lisp/ibuf-macs.el
index 6f7b492b821..72a35a53315 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 08b0801cb51..78dab1c93e5 100644
--- a/lisp/ibuffer.el
+++ b/lisp/ibuffer.el
@@ -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
@@ -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"))))
@@ -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 b37db8869bd..ad5a9d017d6 100644
--- a/lisp/icomplete.el
+++ b/lisp/icomplete.el
@@ -194,9 +194,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
diff --git a/lisp/ido.el b/lisp/ido.el
index 761f02ea782..7bf4a92b229 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.")
@@ -1515,9 +1518,7 @@ Removes badly formatted data and ignored directories."
(consp time)
(cond
((integerp (car time))
- (and (/= (car time) 0)
- (integerp (car (cdr time)))
- (/= (car (cdr time)) 0)
+ (and (not (zerop (float-time time)))
(ido-may-cache-directory dir)))
((eq (car time) 'ftp)
(and (numberp (cdr time))
@@ -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)
@@ -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
@@ -4852,10 +4853,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 fb285e80f6e..8d1efcdc3bf 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 1acb31928b4..17e566d5b15 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 8a04afc25ff..19dc7878a50 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 c0186f07a1d..19fa28d4401 100644
--- a/lisp/image-mode.el
+++ b/lisp/image-mode.el
@@ -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))
@@ -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'.
@@ -758,7 +733,7 @@ was inserted."
(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)))
(image (if (not edges)
@@ -780,7 +755,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,
@@ -803,6 +778,12 @@ 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 (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 db820949eda..74a23046e94 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))
@@ -973,17 +975,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)
+ (unless (or (fboundp 'imagemagick-types) (featurep 'ns))
(error "Cannot rescale images without ImageMagick support"))
(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)
@@ -1003,6 +1007,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
@@ -1025,10 +1031,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 a6e65c39c9d..e7c472db1df 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 2608eb259a2..09d50daacc2 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 398585e1f90..73a7d0ef4eb 100644
--- a/lisp/indent.el
+++ b/lisp/indent.el
@@ -292,7 +292,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 +301,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 858e246ad2e..dec16cf44cd 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.el b/lisp/info.el
index 30df4bfe5c1..f2e29578f89 100644
--- a/lisp/info.el
+++ b/lisp/info.el
@@ -654,9 +654,11 @@ Do the right thing if the file has been compressed or zipped."
;; 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))))
@@ -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)
@@ -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]+"
diff --git a/lisp/international/ccl.el b/lisp/international/ccl.el
index d2f490d59cd..a80452f742f 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/fontset.el b/lisp/international/fontset.el
index 23db54a4a3b..529262a1e7d 100644
--- a/lisp/international/fontset.el
+++ b/lisp/international/fontset.el
@@ -487,7 +487,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)))
@@ -867,7 +867,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)))
@@ -1155,6 +1155,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)
@@ -1231,11 +1233,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 0103d934b21..bcb285eda06 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/latin1-disp.el b/lisp/international/latin1-disp.el
index 657f79097cd..df2c1dc9a82 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 333fe2aa917..817a26b1feb 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.
@@ -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)
@@ -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."
@@ -2665,12 +2649,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
diff --git a/lisp/international/mule-conf.el b/lisp/international/mule-conf.el
index 2af10ac7fe6..b08150a1499 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"
@@ -1576,6 +1575,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 b5a78338f63..c9829e352ec 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 661001afead..cf2b29c04c4 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)))
diff --git a/lisp/international/mule.el b/lisp/international/mule.el
index 14888100020..a4f344192cd 100644
--- a/lisp/international/mule.el
+++ b/lisp/international/mule.el
@@ -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))))
@@ -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))))
diff --git a/lisp/international/quail.el b/lisp/international/quail.el
index eece836354c..ec15ccaaf76 100644
--- a/lisp/international/quail.el
+++ b/lisp/international/quail.el
@@ -1394,12 +1394,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 +1409,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 +1459,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 +1483,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/isearch.el b/lisp/isearch.el
index 3725779703e..1e785a44c51 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -67,8 +67,28 @@
(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 `move', extend the search string by motion commands
+that have the `isearch-move' property on their symbols
+equal to `enabled', or the shift-translated command is
+not disabled by the value `disabled' of the same property.
+If `shift-move', extend the search string by motion commands
+while holding down the shift key.
+Both `move' and `shift-move' extend the search string by yanking text
+that ends at the new position after moving point in the current buffer.
+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 "Extend the search string by motion commands" move)
+ (const :tag "Extend the search string by shifted motion keys" shift-move)
+ (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.
@@ -305,10 +325,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
@@ -316,28 +332,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;
@@ -480,7 +484,8 @@ 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)
@@ -520,6 +525,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)
@@ -555,6 +562,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
@@ -566,9 +576,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.
@@ -589,8 +596,8 @@ 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
- ERROR WRAPPED BARRIER CASE-FOLD-SEARCH]")
+ [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.
(defvar isearch-message "") ; text-char-description version of isearch-string
@@ -1042,13 +1049,12 @@ 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)
@@ -1119,19 +1125,29 @@ NOPUSH is t and EDIT is t."
(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.
@@ -1225,13 +1241,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.
@@ -1299,6 +1318,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.
@@ -1313,6 +1334,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
@@ -1331,6 +1354,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)
@@ -1374,6 +1399,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
)))
@@ -1396,7 +1422,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)
@@ -1565,7 +1593,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))
@@ -1574,10 +1601,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
@@ -1764,8 +1791,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)
@@ -1824,7 +1849,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
@@ -1837,20 +1864,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)))
@@ -1913,7 +1940,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" ())
@@ -2008,6 +2036,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 ()
@@ -2081,22 +2110,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."
@@ -2378,6 +2411,7 @@ the bottom."
(goto-char isearch-point))
(defvar isearch-pre-scroll-point nil)
+(defvar isearch-pre-move-point nil)
(defun isearch-pre-command-hook ()
"Decide whether to exit Isearch mode before executing the command.
@@ -2385,8 +2419,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
@@ -2414,22 +2449,51 @@ before the command is executed globally with terminated Isearch."
;; Swallow the up-event.
(read-event)
(setq this-command 'isearch-edit-string))
+ ;; Don't terminate the search for motion commands.
+ ((or (and (eq search-exit-option 'move)
+ (symbolp this-command)
+ (or (eq (get this-command 'isearch-move) 'enabled)
+ (and (not (eq (get this-command 'isearch-move) 'disabled))
+ (stringp (nth 1 (interactive-form this-command)))
+ (string-match-p "^^" (nth 1 (interactive-form this-command))))))
+ (and (eq search-exit-option 'shift-move)
+ 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
+ (cond
+ (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)))
+ (isearch-update))
+ ((memq search-exit-option '(move shift-move))
+ (when (and isearch-pre-move-point
+ (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))))
(defun isearch-quote-char (&optional count)
"Quote special characters for incremental search.
@@ -2514,7 +2578,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
@@ -2628,12 +2693,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
@@ -2676,6 +2745,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)
@@ -2703,11 +2774,12 @@ the word mode."
'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" "")
+ (if isearch-error
+ (concat " [" isearch-error "]")
+ "")
+ (or isearch-message-suffix-add ""))
+ 'face 'minibuffer-prompt))
;; Searching
@@ -2730,11 +2802,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."
@@ -2746,25 +2815,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.
@@ -2851,7 +2913,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)
@@ -2890,8 +2952,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)))
@@ -3122,9 +3182,9 @@ since they have special meaning in a regexp."
(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)
@@ -3144,10 +3204,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.
diff --git a/lisp/jit-lock.el b/lisp/jit-lock.el
index df7272c12e4..2b13c60bc65 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 cca8ef703ff..d800b605134 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 d374f452e6b..112f26944bf 100644
--- a/lisp/json.el
+++ b/lisp/json.el
@@ -370,7 +370,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."
@@ -609,8 +609,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
@@ -723,12 +722,12 @@ 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
@@ -743,6 +742,8 @@ Advances point just past JSON object."
(interactive "r")
(atomic-change-group
(let ((json-encoding-pretty-print t)
+ ;; Distinguish an empty objects from 'null'
+ (json-null :json-null)
;; Ensure that ordering is maintained
(json-object-type 'alist)
(txt (delete-and-extract-region begin end)))
diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el
new file mode 100644
index 00000000000..14d730abb21
--- /dev/null
+++ b/lisp/jsonrpc.el
@@ -0,0 +1,700 @@
+;;; jsonrpc.el --- JSON-RPC library -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018 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.6
+
+;; 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)
+ do
+ (delete-process proc)
+ (accept-process-output nil 0.1)
+ while (not (process-get proc 'jsonrpc-sentinel-done))
+ do (jsonrpc--warn
+ "Sentinel for %s still hasn't run, deleting it!" proc))
+ (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))
+ (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))
+ (process-put proc 'jsonrpc-sentinel-done t)
+ (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 7abd8aed79a..08a27aef5c6 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
@@ -268,7 +261,7 @@ current value of `kmacro-counter', but do not increment it."
(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))))
@@ -287,8 +280,8 @@ current value of `kmacro-counter', but do not increment it."
(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.
@@ -790,19 +783,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]
@@ -831,7 +823,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)
@@ -843,6 +835,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.
@@ -853,14 +852,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))
@@ -1219,7 +1222,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)
@@ -1239,17 +1242,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))))
@@ -1272,9 +1275,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/thai-util.el b/lisp/language/thai-util.el
index b550b65a563..d6c9732a9e8 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/ldefs-boot.el b/lisp/ldefs-boot.el
index 2ff94d333ba..5ff089812bb 100644
--- a/lisp/ldefs-boot.el
+++ b/lisp/ldefs-boot.el
@@ -176,12 +176,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 +210,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.
@@ -251,7 +257,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-")))
;;;***
@@ -570,10 +576,6 @@ 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.
@@ -581,9 +583,11 @@ Return t if `allout-mode' is active in current buffer.
(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 +898,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 +947,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")))
;;;***
@@ -1294,7 +1300,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 +1310,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,7 +1563,7 @@ 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.
@@ -1575,9 +1586,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 +1619,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
@@ -1667,9 +1677,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.
@@ -1730,7 +1742,7 @@ should be non-nil).
\(fn)" 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 +1751,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
@@ -1766,9 +1780,11 @@ This function is designed to be added to hooks, for example:
(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
@@ -1807,9 +1823,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 +1900,21 @@ 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'.
+
+\(fn)" 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
@@ -1925,9 +1958,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 +2018,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 +2278,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-")))
;;;***
@@ -2646,8 +2681,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'.
@@ -2899,15 +2936,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-")))
@@ -3042,7 +3086,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-file-regexp" "no-byte-compile")))
;;;***
@@ -3050,7 +3094,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 +3104,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 +3112,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 +3125,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 +3133,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 +3148,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 +3163,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 +3178,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 +3186,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 +3208,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 +3310,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 +3318,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 +3382,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 +3431,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 +3445,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 +3502,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 +3530,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 +3544,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 +3577,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 +3599,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-")))
;;;***
@@ -3626,7 +3670,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 +3703,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 +3725,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")))
;;;***
@@ -3701,7 +3745,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 +3865,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.
@@ -3990,7 +4035,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 +4099,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-")))
;;;***
@@ -4693,9 +4738,11 @@ Prefix argument is the same as for `checkdoc-defun'
(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
@@ -4750,7 +4797,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")))
;;;***
@@ -4791,14 +4838,14 @@ and runs the normal hook `command-history-hook'.
\(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")))
;;;***
@@ -4899,7 +4946,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-")))
;;;***
@@ -4935,6 +4982,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-")))
@@ -4962,6 +5014,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
@@ -4976,6 +5035,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")))
;;;***
@@ -5028,7 +5105,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")))
;;;***
@@ -5152,7 +5229,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-")))
;;;***
@@ -5233,11 +5310,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,
@@ -5353,9 +5425,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
@@ -5366,9 +5440,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
@@ -5382,7 +5458,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")))
;;;***
@@ -5401,13 +5477,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-")))
;;;***
@@ -5765,7 +5843,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
@@ -5966,9 +6044,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
@@ -6013,6 +6093,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-")))
@@ -6028,6 +6113,11 @@ Activates the region if needed. Only lasts until the region is deactivated.
(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" "\
@@ -6038,6 +6128,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-")))
@@ -6428,16 +6523,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")
@@ -6464,7 +6560,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")))
;;;***
@@ -6530,7 +6626,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.
@@ -6856,12 +6952,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
@@ -7013,9 +7108,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
@@ -7198,14 +7295,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
@@ -7310,7 +7399,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-")))
;;;***
@@ -7386,9 +7475,11 @@ a diff with \\[diff-reverse-direction].
(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}
@@ -7407,7 +7498,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")))
;;;***
@@ -7564,9 +7655,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
@@ -7738,6 +7831,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.
@@ -7871,9 +7969,11 @@ to the next best mode.
(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.
@@ -7924,7 +8024,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-")))
;;;***
@@ -7933,9 +8033,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.
@@ -7990,7 +8092,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.
@@ -8103,12 +8207,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-")))
;;;***
@@ -8250,7 +8358,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-")))
;;;***
@@ -8337,7 +8445,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.
@@ -8459,7 +8567,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.
@@ -8716,7 +8824,7 @@ Display statistics for a class tree.
\(fn)" 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")))
;;;***
@@ -8751,7 +8859,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-")))
;;;***
@@ -8796,16 +8904,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")))
;;;***
@@ -8852,7 +8962,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")))
;;;***
@@ -8968,7 +9078,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")))
;;;***
@@ -9144,7 +9254,7 @@ Toggle edebugging of all forms.
\(fn)" 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-")))
;;;***
@@ -9714,7 +9824,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-")))
;;;***
@@ -9722,7 +9832,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")))
;;;***
@@ -9738,7 +9848,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-")))
;;;***
@@ -9757,7 +9867,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")))
;;;***
@@ -9808,9 +9918,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
@@ -9825,6 +9937,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-")))
@@ -10054,7 +10171,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")))
;;;***
@@ -10064,9 +10181,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);
@@ -10086,7 +10201,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")))
;;;***
@@ -10175,9 +10290,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'.
@@ -10446,9 +10562,11 @@ 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)
@@ -10511,9 +10629,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)
@@ -10559,8 +10679,13 @@ Return a list of internal configuration parameters of `epg-gpg-program'.
(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.
@@ -10618,14 +10743,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")))
@@ -10638,144 +10762,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-")))
@@ -10795,44 +10832,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-")))
@@ -10841,114 +10859,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,176 +10923,105 @@ Interactively select a server to connect to using `erc-server-alist'.
;;;***
-;;;### (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-")))
@@ -11573,7 +11451,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
@@ -11593,40 +11473,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 'multifile-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.
-
-If FILE-LIST-FORM is non-nil, it is a form to evaluate to
-produce the list of files to search.
+For non-interactive use, superceded by `multifile-initialize-replace'.
-See also the documentation of the variable `tags-file-name'.
+\(fn FROM TO &optional DELIMITED FILES)" t nil)
-\(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.
@@ -11663,7 +11535,7 @@ for \\[find-tag] (which see).
\(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-")))
;;;***
@@ -11834,7 +11706,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")))
;;;***
@@ -11888,7 +11760,9 @@ This does nothing except loading eudc by autoload side-effect.
\(fn)" t nil)
-(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)))))))))))
+(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))
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eudc" '("eudc-")))
@@ -12348,10 +12222,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)
@@ -12392,7 +12270,50 @@ 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.
+
+\(fn)" 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.
+
+\(fn)" 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-")))
;;;***
@@ -12514,7 +12435,7 @@ Evaluate the forms in variable `ffap-bindings'.
\(fn)" 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")))
;;;***
@@ -12555,7 +12476,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
@@ -12704,7 +12625,7 @@ Execute BODY, and unwind connection-local variables.
(function-put 'with-connection-local-profiles 'lisp-indent-function '1)
-(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")))
;;;***
@@ -12781,7 +12702,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")))
;;;***
@@ -12873,7 +12794,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")))
;;;***
@@ -13153,7 +13074,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)) package--builtin-versions)
(autoload 'flymake-log "flymake" "\
Log, at level LEVEL, the message MSG formatted with ARGS.
@@ -13166,10 +13087,11 @@ 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.
-\(fn BUFFER BEG END TYPE TEXT)" nil nil)
+\(fn BUFFER BEG END TYPE TEXT &optional DATA)" nil nil)
(autoload 'flymake-diagnostics "flymake" "\
Get Flymake diagnostics in region determined by BEG and END.
@@ -13189,9 +13111,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,
@@ -13210,7 +13134,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,10 +13165,26 @@ Turn Flymake mode off.
;;;***
+;;;### (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-")))
@@ -13259,9 +13201,11 @@ Turn on `flyspell-mode' for comments and strings.
(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
@@ -13346,9 +13290,11 @@ Turn off Follow mode. Please see the function `follow-mode'.
(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:
@@ -13459,7 +13405,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-")))
;;;***
@@ -13469,9 +13415,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,
@@ -13480,7 +13428,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-")))
;;;***
@@ -13893,6 +13841,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" "\
@@ -13955,7 +13908,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-" "nil")))
;;;***
@@ -14052,7 +14005,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-")))
;;;***
@@ -14061,10 +14014,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)
@@ -14124,7 +14081,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-")))
;;;***
@@ -14280,7 +14237,7 @@ Make the current buffer look like a nice article.
\(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-")))
;;;***
@@ -14370,7 +14327,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")))
;;;***
@@ -14384,7 +14341,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-")))
;;;***
@@ -14671,6 +14628,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)
@@ -15137,8 +15099,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
@@ -15162,15 +15122,22 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and
(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-")))
@@ -15228,7 +15195,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.")
@@ -15365,14 +15332,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")))
;;;***
@@ -15470,9 +15437,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)
@@ -15809,7 +15778,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")))
;;;***
@@ -15899,7 +15868,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-")))
;;;***
@@ -16018,7 +15987,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-")))
;;;***
@@ -16042,7 +16011,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")))
;;;***
@@ -16138,7 +16107,7 @@ This discards the buffer's undo information.
\(fn)" 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-")))
;;;***
@@ -16155,9 +16124,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].
@@ -16258,13 +16229,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)
@@ -16325,9 +16298,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
@@ -16365,7 +16340,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")))
;;;***
@@ -16402,9 +16377,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 +16415,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
@@ -16461,9 +16440,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
@@ -16563,7 +16544,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-")))
;;;***
@@ -16597,7 +16578,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-")))
;;;***
@@ -16606,9 +16587,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
@@ -16636,9 +16619,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
@@ -16649,7 +16634,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-")))
;;;***
@@ -16775,7 +16760,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-")))
;;;***
@@ -16819,7 +16804,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")))
;;;***
@@ -16918,6 +16903,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
@@ -16977,7 +16965,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")))
;;;***
@@ -17018,7 +17006,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,
@@ -17031,7 +17019,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-")))
@@ -17052,9 +17040,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
@@ -17117,7 +17107,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")))
;;;***
@@ -17159,7 +17149,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-")))
@@ -17557,6 +17547,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)
@@ -17601,12 +17593,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")))
;;;***
@@ -17624,9 +17617,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)
@@ -17919,6 +17915,11 @@ 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")
@@ -18022,9 +18023,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
@@ -18051,9 +18054,11 @@ Key bindings:
(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
@@ -18296,7 +18301,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.
@@ -18486,7 +18491,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-")))
;;;***
@@ -18867,18 +18872,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")))))
+(fset 'ispell-menu-map (symbol-value 'ispell-menu-map))
-(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))))
-
-(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:
@@ -18887,7 +18886,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{}.
@@ -18895,7 +18894,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
@@ -19039,9 +19038,11 @@ available on the net.
(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
@@ -19078,7 +19079,7 @@ You can bind this to the key C-c i in GNUS or mail by adding to
\(fn)" 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-")))
;;;***
@@ -19086,7 +19087,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-")))
;;;***
@@ -19199,7 +19200,7 @@ by `jka-compr-installed'.
\(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-")))
;;;***
@@ -19240,6 +19241,14 @@ locally, like so:
;;;***
+;;;### (autoloads nil "jsonrpc" "jsonrpc.el" (0 0 0 0))
+;;; Generated autoloads from jsonrpc.el
+(push (purecopy '(jsonrpc 1 0 6)) 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
@@ -19481,7 +19490,7 @@ The kind of Korean keyboard for Korean input method.
\(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")))
;;;***
@@ -19717,9 +19726,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.
@@ -19788,7 +19799,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-")))
;;;***
@@ -20011,7 +20022,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-")))
;;;***
@@ -20030,13 +20041,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.
@@ -20137,6 +20142,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" "\
@@ -20216,7 +20227,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)
@@ -20292,9 +20303,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
@@ -20325,7 +20338,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")))
;;;***
@@ -20346,7 +20359,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
@@ -20380,7 +20393,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-")))
;;;***
@@ -20638,9 +20651,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:
@@ -20672,9 +20687,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
@@ -20877,7 +20894,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")))
;;;***
@@ -20929,7 +20946,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")))
;;;***
@@ -21061,7 +21078,7 @@ Display version information about MH-E and the MH mail handling system.
\(fn)" 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-")))
;;;***
@@ -21302,6 +21319,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" "\
@@ -21325,7 +21347,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-")))
;;;***
@@ -21344,9 +21366,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
@@ -21520,7 +21544,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-")))
;;;***
@@ -21768,7 +21792,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-")))
;;;***
@@ -21803,7 +21827,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")))
;;;***
@@ -21830,7 +21854,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")))
;;;***
@@ -21929,9 +21953,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'.
@@ -22080,7 +22106,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")))
;;;***
@@ -22240,6 +22266,41 @@ QUALITY can be:
;;;***
+;;;### (autoloads nil "multifile" "multifile.el" (0 0 0 0))
+;;; Generated autoloads from multifile.el
+
+(autoload 'multifile-initialize "multifile" "\
+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 'multifile-initialize-search "multifile" "\
+
+
+\(fn REGEXP FILES CASE-FOLD)" nil nil)
+
+(autoload 'multifile-initialize-replace "multifile" "\
+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 `multifile-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 "multifile" '("multifile-")))
+
+;;;***
+
;;;### (autoloads nil "mwheel" "mwheel.el" (0 0 0 0))
;;; Generated autoloads from mwheel.el
@@ -22358,7 +22419,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-")))
;;;***
@@ -22664,21 +22725,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-")))
;;;***
@@ -22739,7 +22800,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-")))
;;;***
@@ -22795,8 +22856,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.")
@@ -22846,7 +22905,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-")))
;;;***
@@ -22916,11 +22975,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.
@@ -23037,7 +23095,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-")))
;;;***
@@ -23117,7 +23175,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-")))
;;;***
@@ -23188,7 +23246,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-")))
;;;***
@@ -23427,7 +23485,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-")))
;;;***
@@ -23600,6 +23658,11 @@ 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" "\
@@ -24512,9 +24575,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.
@@ -24626,13 +24691,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)
@@ -24640,17 +24709,29 @@ 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.
+
+\(fn)" nil nil)
+
(autoload 'package-import-keyring "package" "\
Import keys from FILE.
@@ -24739,7 +24820,7 @@ 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")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "package" '("bad-signature" "define-package" "describe-package-1" "package-")))
;;;***
@@ -24754,7 +24835,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-")))
;;;***
@@ -24773,9 +24854,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
@@ -24799,7 +24882,8 @@ STRING should be on something resembling an RFC2822 string, a la
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)
@@ -24854,7 +24938,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-")))
;;;***
@@ -25059,7 +25143,7 @@ Completion for GNU/Linux `mount'.
\(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")))
;;;***
@@ -25288,7 +25372,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")))
@@ -25393,7 +25477,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-")))
;;;***
@@ -25494,9 +25578,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)
@@ -26203,7 +26289,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-")))
;;;***
@@ -26301,6 +26387,20 @@ recognized.
\(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 \\[multifile-continue].
+
+\(fn REGEXP)" t nil)
+
+(autoload 'project-query-replace "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 \\[multifile-continue].
+
+\(fn FROM TO)" t nil)
+
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "project" '("project-")))
;;;***
@@ -26336,7 +26436,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-")))
;;;***
@@ -26644,7 +26744,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))
@@ -26677,7 +26777,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")))
;;;***
@@ -26953,7 +27053,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")))
;;;***
@@ -27044,7 +27144,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.
@@ -27153,13 +27253,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-")))
;;;***
@@ -27180,7 +27282,7 @@ matching parts of the target buffer will be highlighted.
\(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-")))
;;;***
@@ -27199,9 +27301,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
@@ -27351,11 +27455,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-")))
;;;***
@@ -27378,9 +27488,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
@@ -27410,6 +27522,11 @@ Turn on RefTeX mode.
(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]'.
@@ -27754,9 +27871,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.
@@ -27777,9 +27896,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)
@@ -28095,7 +28215,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-")))
;;;***
@@ -28152,9 +28272,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
@@ -28491,9 +28617,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
@@ -28540,9 +28668,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)
@@ -28926,9 +29056,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, 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
periodically and when exiting Emacs. When Savehist mode is
@@ -28963,6 +29095,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" "\
@@ -28971,8 +29108,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:
@@ -28981,14 +29120,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-")))
;;;***
@@ -29029,7 +29168,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-")))
;;;***
@@ -29063,9 +29202,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.
@@ -29079,7 +29220,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-")))
;;;***
@@ -29088,12 +29229,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)
@@ -29152,9 +29297,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
@@ -29166,7 +29313,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-")))
;;;***
@@ -29222,7 +29369,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")))
;;;***
@@ -29238,7 +29385,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-")))
;;;***
@@ -29267,7 +29414,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-")))
;;;***
@@ -29323,7 +29470,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-")))
;;;***
@@ -29331,7 +29478,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-")))
;;;***
@@ -29363,7 +29510,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-")))
;;;***
@@ -29419,7 +29566,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-")))
;;;***
@@ -29427,7 +29574,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-")))
;;;***
@@ -29523,7 +29670,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-")))
;;;***
@@ -29547,7 +29694,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-")))
;;;***
@@ -29555,7 +29702,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-")))
;;;***
@@ -29563,7 +29710,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-")))
;;;***
@@ -29715,7 +29862,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-")))
;;;***
@@ -29760,7 +29907,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-")))
;;;***
@@ -29768,14 +29915,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:
@@ -29803,9 +29950,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)
@@ -29838,7 +29985,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.")
@@ -29890,7 +30037,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.
@@ -29952,8 +30099,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.
@@ -30006,13 +30153,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
@@ -30072,13 +30219,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.")
-
-(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
@@ -30120,9 +30260,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
@@ -30185,7 +30327,7 @@ formula:
\(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")))
;;;***
@@ -30462,7 +30604,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-")))
;;;***
@@ -30745,9 +30887,12 @@ 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)
@@ -30784,7 +30929,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-")))
;;;***
@@ -30904,7 +31049,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-")))
;;;***
@@ -31525,6 +31670,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.
@@ -31926,7 +32104,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-")))
;;;***
@@ -31946,31 +32124,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
@@ -32052,9 +32205,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.
@@ -32110,7 +32265,7 @@ Studlify-case the current buffer.
;;;### (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--" "string-" "thread-" "when-let")))
;;;***
@@ -32121,9 +32276,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
@@ -32169,9 +32326,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
@@ -32204,7 +32363,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")))
;;;***
@@ -32266,9 +32425,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.
@@ -32666,6 +32827,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" "\
@@ -32884,7 +33050,7 @@ converts a table into plain text without frames. It is a companion to
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "table" '("table-" "*table--")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "table" '("*table--" "table-")))
;;;***
@@ -32983,7 +33149,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-")))
;;;***
@@ -33026,7 +33192,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-")))
;;;***
@@ -33079,7 +33245,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-")))
;;;***
@@ -33088,10 +33254,8 @@ 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)
@@ -33430,7 +33594,7 @@ 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-")))
;;;***
@@ -33569,6 +33733,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
@@ -33614,7 +33786,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)
@@ -33623,7 +33795,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
@@ -33638,7 +33810,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,
@@ -33666,10 +33838,32 @@ Return the number at point, or nil if none is found.
(autoload 'list-at-point "thingatpt" "\
Return the Lisp list at point, or nil if none is found.
+If IGNORE-COMMENT-OR-STRING is non-nil comments and strings are
+treated as white space.
-\(fn)" nil nil)
+\(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.
+
+\(fn)" 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-")))
;;;***
@@ -33846,6 +34040,11 @@ This function is meant to be used as a `post-self-insert-hook'.
(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
@@ -33891,9 +34090,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
@@ -33922,7 +34123,7 @@ Return a string giving the duration of the Emacs initialization.
\(fn)" 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")))
;;;***
@@ -34013,8 +34214,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" "\
@@ -34022,7 +34221,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")))
;;;***
@@ -34223,14 +34422,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" "py-converter" "quail-" "quick-" "tit-" "tsang-" "ziranma-converter")))
;;;***
@@ -34483,12 +34675,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 1 -1)) package--builtin-versions)
(defvar tramp-mode t "\
Whether Tramp is enabled.
@@ -34506,6 +34699,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
@@ -34513,14 +34711,14 @@ 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." (if tramp-mode (let ((default-directory temporary-file-directory)) (load "tramp" 'noerror 'nomessage)) (tramp-unload-file-name-handlers)) (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 '(tramp-file-name-handler tramp-completion-file-name-handler tramp-archive-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)))))
(defvar tramp-completion-mode nil "\
If non-nil, external packages signal that they are in file name completion.")
@@ -34541,6 +34739,35 @@ 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) "\\)*" "\\)" "\\(" "/" ".*" "\\)" "\\'"))
+
+(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-autoload-file-name-handler)) (put 'tramp-archive-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
@@ -34578,7 +34805,7 @@ 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-")))
;;;***
@@ -34605,7 +34832,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 4 26 2)) package--builtin-versions)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "trampver" '("tramp-")))
@@ -34723,6 +34949,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
@@ -34731,9 +34962,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.
@@ -34985,7 +35213,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-")))
;;;***
@@ -35257,9 +35485,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)
@@ -35758,6 +35988,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-")))
;;;***
@@ -35800,7 +36039,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")))
;;;***
@@ -36410,7 +36649,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-")))
@@ -36652,7 +36891,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-")))
;;;***
@@ -37395,9 +37634,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
@@ -37514,7 +37755,7 @@ Exit View mode and make the current buffer editable.
\(fn)" t nil)
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "view" '("view-" "View-")))
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "view" '("View-" "view-")))
;;;***
@@ -37533,7 +37774,7 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'.
\(fn)" 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-")))
;;;***
@@ -37564,7 +37805,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-")))
;;;***
@@ -37572,7 +37813,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-")))
;;;***
@@ -37709,7 +37950,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-")))
;;;***
@@ -37771,9 +38012,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,
@@ -37791,11 +38034,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'.
@@ -37804,11 +38047,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
@@ -37831,11 +38074,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'.
@@ -37854,11 +38097,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
@@ -38180,9 +38423,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)
@@ -38220,7 +38465,7 @@ 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.")
@@ -38279,10 +38524,11 @@ If no window is at the desired location, an error is signaled.
(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 MODIFIER)" t nil)
+\(fn &optional MODIFIERS)" t nil)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "windmove" '("windmove-")))
@@ -38303,9 +38549,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
@@ -38367,7 +38615,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")))
;;;***
@@ -38439,6 +38687,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-")))
;;;***
@@ -38513,6 +38767,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'.
@@ -38539,7 +38799,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-")))
;;;***
@@ -38565,9 +38825,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
@@ -38677,52 +38939,70 @@ 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"
-;;;;;; "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"
-;;;;;; "org/ob-lob.el" "org/ob-matlab.el" "org/ob-tangle.el" "org/ob.el"
-;;;;;; "org/org-archive.el" "org/org-attach.el" "org/org-bbdb.el"
-;;;;;; "org/org-clock.el" "org/org-datetree.el" "org/org-element.el"
-;;;;;; "org/org-feed.el" "org/org-footnote.el" "org/org-id.el" "org/org-indent.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/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" "org/ob-lob.el"
+;;;;;; "org/ob-matlab.el" "org/ob-tangle.el" "org/ob.el" "org/org-archive.el"
+;;;;;; "org/org-attach.el" "org/org-bbdb.el" "org/org-clock.el"
+;;;;;; "org/org-datetree.el" "org/org-element.el" "org/org-feed.el"
+;;;;;; "org/org-footnote.el" "org/org-id.el" "org/org-indent.el"
;;;;;; "org/org-install.el" "org/org-irc.el" "org/org-mobile.el"
;;;;;; "org/org-plot.el" "org/org-table.el" "org/org-timer.el" "org/ox-ascii.el"
;;;;;; "org/ox-beamer.el" "org/ox-html.el" "org/ox-icalendar.el"
diff --git a/lisp/leim/quail/latin-post.el b/lisp/leim/quail/latin-post.el
index de321d64193..8b0253f36e3 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 38011d485ba..9d343e79c35 100644
--- a/lisp/leim/quail/latin-pre.el
+++ b/lisp/leim/quail/latin-pre.el
@@ -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" ?ü)
@@ -1175,6 +1176,7 @@ of characters from a single Latin-N charset.
("\"E" ?Ë)
("\"I" ?Ï)
("\"O" ?Ö)
+ ("\"S" ?ẞ)
("\"U" ?Ü)
("\"W" ?Ẅ)
("\"Y" ?Ÿ)
@@ -1283,4 +1285,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/linum.el b/lisp/linum.el
index 9df0c5d0236..6e673e58b09 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 e2b2ccd510e..566d51a319c 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'
@@ -141,8 +143,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/ls-lisp.el b/lisp/ls-lisp.el
index adb86dd05b1..95f3163ddf2 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,7 +474,7 @@ 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)
+ fattr (file-attribute-size fattr)
switches time-index))
(message "%s: doesn't exist or is inaccessible" file)
(ding) (sit-for 2))))) ; to show user the message!
@@ -659,10 +659,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 +718,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 +772,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 +796,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 +811,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 29314d53c29..4078b983ec6 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-2018 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 04044042e9a..fa2ea3d8471 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-2018 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 8261f175ad8..62e9873b493 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 503919106f0..8cacad8726d 100644
--- a/lisp/mail/emacsbug.el
+++ b/lisp/mail/emacsbug.el
@@ -116,6 +116,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")
@@ -232,13 +314,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 +345,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 e0bd4590b13..2b63343239b 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)
@@ -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 65f2421cb9a..db2a30ad15e 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-2018 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 5a04eea25ac..f5d280ae1ea 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-2018 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,70 @@ 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
+ (concat "[" (apply #'concat (apply #'append footnote-hebrew-numeric)) "']+"))
+;; (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 +428,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 +437,36 @@ 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)
+(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 +485,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 +504,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 +520,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 +554,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 +562,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 +603,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 +616,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 +631,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 +641,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 +659,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 +780,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 +814,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 +839,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 +850,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 +873,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 +888,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 +913,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 +927,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 +945,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 +953,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 +968,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 aa2e0cb3e74..37b2d94e5f5 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-2018 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)
@@ -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 1b72d39126d..0af3221fc33 100644
--- a/lisp/mail/ietf-drums.el
+++ b/lisp/mail/ietf-drums.el
@@ -1,4 +1,4 @@
-;;; ietf-drums.el --- Functions for parsing RFC822bis headers
+;;; ietf-drums.el --- Functions for parsing RFC822bis headers -*- lexical-binding:t -*-
;; Copyright (C) 1998-2018 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.
diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el
index 3e8a41fb24c..0175c687b26 100644
--- a/lisp/mail/mail-extr.el
+++ b/lisp/mail/mail-extr.el
@@ -712,7 +712,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 fc9f8ddab1d..463cec0f539 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 99c0671b9ba..e5456d92afb 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 424ae675b1a..17b4cdfa4bd 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 aa91f36a67f..2e8765eb67c 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 dbfde57224a..282fd3846ab 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 fb03ab4f220..103af55248a 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-2018 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 ab0417bb5c1..99c1a1c3628 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 6b0c93d60cb..73a17ee15e2 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.
@@ -3399,21 +3392,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.
@@ -3802,7 +3789,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")
@@ -3836,7 +3823,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) ""))))))
@@ -4139,6 +4126,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.")
@@ -4287,7 +4275,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))))))
@@ -4527,7 +4515,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)))
diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el
index eee8805ab4c..824b1a59fb9 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 692f67b87d2..10345b63ae2 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 b6d0b53ce06..6fc91a3acd9 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-2018 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
@@ -1142,7 +1145,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))))))
@@ -1227,7 +1230,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
@@ -1239,7 +1242,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)
@@ -1302,9 +1305,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)))
@@ -1378,8 +1381,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."
@@ -1391,7 +1394,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)
@@ -1470,7 +1473,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)))
@@ -1491,7 +1494,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
@@ -1526,7 +1529,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)
@@ -1534,20 +1537,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."
@@ -1718,8 +1721,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.
@@ -1788,9 +1789,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.
@@ -1854,13 +1853,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
@@ -1959,6 +1958,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 571089d2144..8bc3cc78d95 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-2018 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)
@@ -179,9 +179,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.")
@@ -319,11 +321,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
@@ -508,8 +510,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
@@ -530,7 +531,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)
@@ -539,51 +543,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
@@ -662,7 +667,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
@@ -679,7 +683,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
@@ -716,9 +722,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)))
@@ -941,8 +946,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"))
@@ -988,9 +992,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)
@@ -1023,14 +1027,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 60669a0212c..ce061e2d8c2 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 b948acfd522..dfe5c9c902b 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 e1ed1c9eb8e..b8f74e3a839 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-2018 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 4e3eea729a9..25b4ebb9bda 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-2018 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 c62a61c708d..1a6eda13b7f 100644
--- a/lisp/man.el
+++ b/lisp/man.el
@@ -1526,16 +1526,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 ()
@@ -1816,7 +1816,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 4891c07166a..71768979024 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 e75e497999e..84c73cadfa5 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 09b54fc9a7f..788846ab35a 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 280fb9354d5..7f3698850d0 100644
--- a/lisp/menu-bar.el
+++ b/lisp/menu-bar.el
@@ -300,7 +300,7 @@
menu-bar-separator)
(bindings--define-key menu [tags-continue]
- '(menu-item "Continue Tags Search" tags-loop-continue
+ '(menu-item "Continue Tags Search" multifile-continue
:help "Continue last tags search operation"))
(bindings--define-key menu [tags-srch]
'(menu-item "Search Tagged Files..." tags-search
@@ -349,7 +349,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" multifile-continue
:help "Continue last tags replace operation"))
(bindings--define-key menu [tags-repl]
'(menu-item "Replace in Tagged Files..." tags-query-replace
@@ -1379,11 +1379,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 +1693,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 +2135,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 +2161,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 +2285,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."
diff --git a/lisp/mh-e/mh-acros.el b/lisp/mh-e/mh-acros.el
index ac31127ce64..fb8a16bd81d 100644
--- a/lisp/mh-e/mh-acros.el
+++ b/lisp/mh-e/mh-acros.el
@@ -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)
diff --git a/lisp/mh-e/mh-alias.el b/lisp/mh-e/mh-alias.el
index fa91042fd9a..257d6b31cc3 100644
--- a/lisp/mh-e/mh-alias.el
+++ b/lisp/mh-e/mh-alias.el
@@ -78,7 +78,8 @@ 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)))
+ (setq stamp (file-attribute-modification-time
+ (file-attributes file)))
(or (> (car stamp) (car mh-alias-tstamp))
(and (= (car stamp) (car mh-alias-tstamp))
(> (cadr stamp) (cadr mh-alias-tstamp)))))))
diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el
index aa22df8b187..5c474b4b90c 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))
@@ -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 23078127368..ffeb6937f72 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 05ff672da52..4515144d148 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-funcs.el b/lisp/mh-e/mh-funcs.el
index 661d0ec7569..3574f8c801d 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 fd7c2b83fe7..a1eb22ff18e 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 61226066ed3..0a50e027ce0 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 3f88836ddab..71a4623d1f9 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-show.el b/lisp/mh-e/mh-show.el
index 90e2411282c..dae8de00bb8 100644
--- a/lisp/mh-e/mh-show.el
+++ b/lisp/mh-e/mh-show.el
@@ -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-thread.el b/lisp/mh-e/mh-thread.el
index 41a79b6f0b4..ff8e6602e50 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 66d87262bc9..7bda0a68472 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/minibuf-eldef.el b/lisp/minibuf-eldef.el
index 07663ea6a6e..a81e6635894 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 7e7856f3a96..a7e6a8761ff 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -729,7 +729,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)))
@@ -1320,7 +1321,7 @@ Repeated uses step through the possible completions."
(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 ()
@@ -1824,12 +1825,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'
@@ -1837,7 +1833,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.
@@ -2726,17 +2722,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)
@@ -2962,6 +2950,8 @@ 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)))
@@ -2993,6 +2983,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'."
@@ -3024,7 +3025,8 @@ PATTERN is as returned by `completion-pcm--string->pattern'."
(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)
@@ -3032,8 +3034,16 @@ 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)))
+ (while md
+ (put-text-property start (pop md)
+ 'font-lock-face 'completions-common-part
+ str)
+ (setq start (pop md)))
+ (put-text-property start end
'font-lock-face 'completions-common-part
str)
(if (> (length str) pos)
diff --git a/lisp/mouse.el b/lisp/mouse.el
index d14b5cbea4d..cb63ca51c54 100644
--- a/lisp/mouse.el
+++ b/lisp/mouse.el
@@ -41,8 +41,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 +49,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 +81,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 +90,62 @@ 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) (float-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) #'> #'<)
+ (- (float-time) (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.
@@ -921,7 +922,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 +1027,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 +1036,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.
@@ -1144,19 +1142,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
@@ -1953,8 +1947,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 +1957,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 +2354,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 +2363,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 +2373,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 +2382,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.
diff --git a/lisp/mpc.el b/lisp/mpc.el
index 3941492fa28..81bb5ac35a8 100644
--- a/lisp/mpc.el
+++ b/lisp/mpc.el
@@ -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 ()
diff --git a/lisp/msb.el b/lisp/msb.el
index 383f075bf98..91d83d2e4ad 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/multifile.el b/lisp/multifile.el
new file mode 100644
index 00000000000..712da5cc774
--- /dev/null
+++ b/lisp/multifile.el
@@ -0,0 +1,217 @@
+;;; multifile.el --- Operations on multiple files -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018 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 multifile--* 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 multifile-search while in the
+;; middle of a multifile-replace and later go back to that
+;; multifile-replace.
+;; - Make multi-isearch work on top of this library (might require changes
+;; to this library, of course).
+
+;;; Code:
+
+(require 'generator)
+
+(defgroup multifile nil
+ "Operations on multiple files."
+ :group 'tools)
+
+(defcustom multifile-revert-buffers 'silent
+ "Whether to revert files during multifile 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 multifile--list-to-iterator (list)
+ (while list (iter-yield (pop list))))
+
+(defvar multifile--iterator iter-empty)
+(defvar multifile--scan-function
+ (lambda () (user-error "No operation in progress")))
+(defvar multifile--operate-function #'ignore)
+(defvar multifile--freshly-initialized nil)
+
+;;;###autoload
+(defun multifile-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 multifile--iterator
+ (if (and (listp files) (not (functionp files)))
+ (multifile--list-to-iterator files)
+ files))
+ (setq multifile--scan-function scan-function)
+ (setq multifile--operate-function operate-function)
+ (setq multifile--freshly-initialized t))
+
+(defun multifile-next-file (&optional novisit)
+ ;; FIXME: Should we provide an interactive command, like tags-next-file?
+ (let ((next (condition-case nil
+ (iter-next multifile--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 multifile-revert-buffers
+ (not (verify-visited-file-modtime buffer))
+ (if (eq multifile-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 multifile-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 multifile--freshly-initialized file-finished
+ (save-restriction
+ (widen)
+ (not (funcall multifile--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 (multifile-next-file t))
+
+ ;; If NEW is non-nil, we got a temp buffer,
+ ;; and NEW is the file name.
+ (when (or messaged
+ (and (not multifile--freshly-initialized)
+ (> baud-rate search-slow-speed)
+ (setq messaged t)))
+ (message "Scanning file %s..." (or new buffer-file-name)))
+
+ (setq multifile--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 multifile--operate-function)))
+ (setq file-finished t))))
+
+;;;###autoload
+(defun multifile-initialize-search (regexp files case-fold)
+ (let ((last-buffer (current-buffer)))
+ (multifile-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 multifile-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 `multifile-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.
+ (multifile-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 'multifile)
+;;; multifile.el ends here
diff --git a/lisp/mwheel.el b/lisp/mwheel.el
index 44c4989ad06..876659f1f71 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 9b23b8a4d89..1aa794477a9 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-2018 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)
@@ -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
@@ -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)
@@ -4430,6 +4444,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
(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)
+(put 'exec-path 'ange-ftp 'ignore)
;;; Define ways of getting at unmodified Emacs primitives,
;;; turning off our handler.
@@ -4469,6 +4484,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 +4494,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 +5218,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 a84a7b1c716..bf179c8782a 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 5f44c360342..4397817032f 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 057ae3219ee..b3b430d2ba8 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
diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el
index 584d1a9d0d8..f63e807b688 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 a739561c7dc..0762445c237 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 8d1071af727..a28fa6aa17a 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-2018 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 fb618d12098..ac4814a25cb 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 a21348480e0..a69c77b7235 100644
--- a/lisp/net/eudcb-mab.el
+++ b/lisp/net/eudcb-mab.el
@@ -53,7 +53,8 @@ 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)
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index 66b1767b563..64cc1a51f69 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))
@@ -250,7 +256,7 @@ word(s) will be searched for via `eww-search-prefix'."
(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))))
(setq url (eww--dwim-expand-url url))
(pop-to-buffer-same-window
(if (eq major-mode 'eww-mode)
@@ -263,8 +269,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 +283,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 +360,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 +372,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
@@ -460,7 +475,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 +561,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 +749,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 +1257,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 +1504,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)))
@@ -1651,7 +1667,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 +1813,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 35fe680592a..315932b7e69 100644
--- a/lisp/net/gnutls.el
+++ b/lisp/net/gnutls.el
@@ -36,6 +36,7 @@
;;; Code:
(require 'cl-lib)
+(require 'puny)
(defgroup gnutls nil
"Emacs interface to the GnuTLS library."
@@ -69,9 +70,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.
@@ -175,12 +176,12 @@ trust and key files, and priority string."
(cons 'gnutls-x509pki
(gnutls-boot-parameters
:type 'gnutls-x509pki
- :hostname host))))))
+ :hostname (puny-encode-domain host)))))))
(if nowait
process
(gnutls-negotiate :process process
:type 'gnutls-x509pki
- :hostname host))))
+ :hostname (puny-encode-domain host)))))
(define-error 'gnutls-error "GnuTLS error")
@@ -303,13 +304,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 ed615d10eb6..db59df374b1 100644
--- a/lisp/net/goto-addr.el
+++ b/lisp/net/goto-addr.el
@@ -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
@@ -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/imap.el b/lisp/net/imap.el
index 3d2a4f948bc..042b0f9a2c9 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-2018 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)
@@ -1956,7 +1938,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 +2127,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 +2200,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 +2441,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 +2575,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 +2584,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 +2669,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 +2698,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 +2795,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 +2861,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/mailcap.el b/lisp/net/mailcap.el
index f0694b79ea0..a8ade01e818 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 9edd42b857a..c9e80804bd3 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 ec743dcff0c..7b974ebf616 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 f55f5486b62..a0589e25a44 100644
--- a/lisp/net/network-stream.el
+++ b/lisp/net/network-stream.el
@@ -42,14 +42,20 @@
;;; Code:
-(require 'tls)
-(require 'starttls)
(require 'auth-source)
(require 'nsm)
(require 'puny)
+(declare-function starttls-available-p "starttls" ())
+(declare-function starttls-negotiate "starttls" (process))
+
(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)
@@ -255,7 +261,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 +302,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 +343,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
@@ -372,6 +381,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
(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))
@@ -379,6 +390,7 @@ gnutls-boot (as returned by `gnutls-boot-parameters')."
(if (gnutls-available-p)
(open-gnutls-stream name buffer host service
(plist-get parameters :nowait))
+ (require 'tls)
(open-tls-stream name buffer host service)))
(eoc (plist-get parameters :end-of-command)))
(if (plist-get parameters :nowait)
@@ -405,6 +417,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 71a1e31d73a..b6fbdfb766c 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-2018 Free Software Foundation, Inc.
@@ -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,8 +1799,9 @@ 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))
+ (time-less-p nil
+ (time-add (file-attribute-modification-time
+ (file-attributes image-name))
(seconds-to-time 86400))))
(newsticker--debug-msg "%s: Getting image for %s skipped"
(format-time-string "%A, %H:%M")
@@ -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")
@@ -2008,7 +1997,7 @@ older than TIME."
(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))
+ (when (time-less-p exp-time nil)
(newsticker--debug-msg
"Item `%s' from %s has expired on %s"
(newsticker--title item)
@@ -2020,7 +2009,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
@@ -2293,9 +2282,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 +2350,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 +2396,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 +2488,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 1e37276a242..889404ef098 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 7f3d5d75fdb..59a57293ee8 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 3f33e822d04..e857e64be84 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 8366bc14e95..217f0b859f2 100644
--- a/lisp/net/ntlm.el
+++ b/lisp/net/ntlm.el
@@ -411,9 +411,9 @@ a string KEY of length 8. FORW is t or nil."
(key2 (ntlm-smb-str-to-key key))
(i 0) aa)
(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))
@@ -422,7 +422,7 @@ a string KEY of length 8. FORW is t or nil."
(unless (zerop (aref outb i))
(setq aa (aref out (/ i 8)))
(aset out (/ i 8)
- (logior aa (lsh 1 (- 7 (% i 8))))))
+ (logior aa (ash 1 (- 7 (% i 8))))))
(setq i (1+ i)))
out))
@@ -430,28 +430,28 @@ a string KEY of length 8. FORW is t or nil."
"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))
@@ -619,16 +619,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)))
diff --git a/lisp/net/pop3.el b/lisp/net/pop3.el
index c2385f7f7e5..2a6807e1aca 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-2018 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)
@@ -237,8 +237,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 +249,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 +269,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 +279,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 +367,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)
@@ -399,7 +397,7 @@ 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))
@@ -424,7 +422,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 +438,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))
@@ -620,10 +618,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)
@@ -785,7 +781,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 4bf1a372cb4..efa11cf178d 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 abfca383e09..a5ba26bcdc5 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
diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el
index c09bff765b2..fe9c71a21c2 100644
--- a/lisp/net/rcirc.el
+++ b/lisp/net/rcirc.el
@@ -182,11 +182,10 @@ underneath each nick."
:type '(repeat string)
:group 'rcirc)
+(defvar rcirc-prompt-start-marker nil)
+
(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'."
@@ -401,7 +400,6 @@ will be killed."
(defvar rcirc-nick nil)
-(defvar rcirc-prompt-start-marker nil)
(defvar rcirc-prompt-end-marker nil)
(defvar rcirc-nick-table nil)
@@ -1352,10 +1350,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
@@ -1866,10 +1861,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
@@ -2795,10 +2787,7 @@ 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"))
+ (idle-string (format-seconds "%yy %dd %hh %mm %z%ss" idle-secs))
(signon-time (seconds-to-time (string-to-number (nth 3 args))))
(signon-string (format-time-string "%c" signon-time))
(message (format "%s idle for %s, signed on %s"
diff --git a/lisp/net/rfc2104.el b/lisp/net/rfc2104.el
index d974ab6a772..57bca2e8788 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-2018 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 3bfc4d7f356..015e04f4075 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-2018 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 b4f0fffc716..ca0b66b2fb6 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 c4685483161..ca75d953c43 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 ca7d1ce55a4..6303141c898 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-2018 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 364f289e1ab..7ef1e18a1a0 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.
diff --git a/lisp/net/sieve-manage.el b/lisp/net/sieve-manage.el
index e6a1e8401d2..8c70ae037ab 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-2018 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/soap-client.el b/lisp/net/soap-client.el
index 17f83082f8d..f5de05dc3d7 100644
--- a/lisp/net/soap-client.el
+++ b/lisp/net/soap-client.el
@@ -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))))
@@ -2881,6 +2884,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 32362e25434..5ee6eea933f 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-2018 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 0576cbe9636..36374f88e0d 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -68,7 +68,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
@@ -107,11 +107,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)
+ (exec-path . tramp-adb-handle-exec-path)
(expand-file-name . tramp-adb-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)
@@ -196,11 +197,13 @@ pass to the OPERATION."
(with-temp-buffer
;; `call-process' does not react on timer under MS Windows.
;; That's why we use `start-process'.
+ ;; We don't know yet whether we need a user or host name for the
+ ;; connection vector. We assume we don't, it will be OK in most
+ ;; of the cases. Otherwise, there might be an additional trace
+ ;; buffer, which doesn't hurt.
(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))
+ (v (make-tramp-file-name :method tramp-adb-method))
result)
(tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " "))
(process-put p 'adjust-window-size-function 'ignore)
@@ -242,16 +245,8 @@ pass to the OPERATION."
;; 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))
+ v (tramp-drop-volume-letter
+ (tramp-run-real-handler 'expand-file-name (list localname))))))))
(defun tramp-adb-handle-file-system-info (filename)
"Like `file-system-info' for Tramp files."
@@ -270,12 +265,12 @@ pass to the OPERATION."
"[[: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?
@@ -287,7 +282,7 @@ pass to the OPERATION."
'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)))
@@ -316,12 +311,10 @@ pass to the OPERATION."
(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)
@@ -418,9 +411,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
@@ -474,13 +467,19 @@ pass to the OPERATION."
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.
@@ -557,8 +556,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 +567,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 +582,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)))
@@ -677,8 +676,8 @@ 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))
@@ -717,16 +716,18 @@ 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)))
(tramp-adb-send-command-and-check
@@ -761,8 +762,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 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 +797,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)
@@ -840,10 +842,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(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
@@ -878,8 +880,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 +913,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,7 +957,7 @@ 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)
@@ -999,7 +999,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(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")))
+ (tramp-user-error p "Shell command in progress")))
(if current-buffer-p
(progn
@@ -1116,8 +1116,23 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(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-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'.
+ `(,(file-remote-p default-directory 'localname))))
(defun tramp-adb-get-device (vec)
"Return full host name from VEC to be used in shell execution.
@@ -1126,7 +1141,7 @@ 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))
@@ -1271,10 +1286,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.
@@ -1304,7 +1315,7 @@ connection if a previous connection has died for some reason."
(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 'vector vec)
(process-put p 'adjust-window-size-function 'ignore)
(set-process-query-on-exit-flag p nil)
@@ -1343,22 +1354,10 @@ 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)
diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
new file mode 100644
index 00000000000..5d7562f707e
--- /dev/null
+++ b/lisp/net/tramp-archive.el
@@ -0,0 +1,646 @@
+;;; tramp-archive.el --- Tramp archive manager -*- lexical-binding:t -*-
+
+;; Copyright (C) 2017-2018 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))
+(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 . ignore)
+ (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)
+ ;; `find-file-noselect' performed by default handler.
+ ;; `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-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)
+ (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
+(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-autoload-file-name-handler))
+ (put 'tramp-archive-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)
+ (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 url-handler-regexp archive)
+ (string-match "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)))
+
+;;;###tramp-autoload
+(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 'kill-emacs-hook 'tramp-archive-cleanup-hash)
+(add-hook 'tramp-archive-unload-hook
+ (lambda ()
+ (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-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."
+ (with-parsed-tramp-file-name
+ (tramp-archive-gvfs-file-name filename) nil
+ (tramp-check-cached-permissions v ?r)))
+
+(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 1db93eadf6b..ebb4254dab4 100644
--- a/lisp/net/tramp-cache.el
+++ b/lisp/net/tramp-cache.el
@@ -96,10 +96,7 @@ matching entries of `tramp-connection-properties'."
(dolist (elt tramp-connection-properties)
(when (string-match
(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)))
@@ -115,16 +112,14 @@ Returns DEFAULT if not set."
(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))
+ (<= (tramp-time-diff (current-time) (car value))
+ remote-file-name-inhibit-cache))
(and (consp remote-file-name-inhibit-cache)
(time-less-p
remote-file-name-inhibit-cache (car value)))))
@@ -167,7 +162,22 @@ 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)))
@@ -182,10 +192,10 @@ 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))
@@ -204,7 +214,7 @@ Remove also properties of all files in subdirectories."
;; 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
@@ -223,7 +233,7 @@ This is suppressed for temporary buffers."
(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)
@@ -292,7 +302,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
@@ -385,6 +412,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)))
diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el
index 7adac135ae7..b05f475f2fd 100644
--- a/lisp/net/tramp-cmds.el
+++ b/lisp/net/tramp-cmds.el
@@ -80,16 +80,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
@@ -113,13 +104,13 @@ When called interactively, a Tramp connection has to be selected."
(when keep-password (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
@@ -152,6 +143,10 @@ This includes password cache, file cache, connection cache, buffers."
;; Flush file and connection cache.
(clrhash tramp-cache-data)
+ ;; Cleanup local copies of archives.
+ (when (bound-and-true-p tramp-archive-enabled)
+ (tramp-archive-cleanup-hash))
+
;; Remove buffers.
(dolist (name (tramp-list-tramp-buffers))
(when (bufferp (get-buffer name)) (kill-buffer name))))
@@ -186,7 +181,9 @@ 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
diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el
index 5bf57638ff8..c3777e6e737 100644
--- a/lisp/net/tramp-compat.el
+++ b/lisp/net/tramp-compat.el
@@ -40,7 +40,6 @@
(require 'timer)
(require 'ucs-normalize)
-(require 'trampver)
(require 'tramp-loaddefs)
;; For not existing functions, obsolete functions, or functions with a
@@ -98,13 +97,6 @@ Add the extension of F, if existing."
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))
@@ -150,15 +142,15 @@ returned."
(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)
(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)
@@ -190,11 +182,6 @@ 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.
(eval-and-compile
@@ -243,6 +230,36 @@ If NAME is a remote file name, the local part of NAME is unquoted."
`(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)))))
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-loaddefs 'force)
+ (unload-feature 'tramp-compat 'force)))
+
(provide 'tramp-compat)
;;; TODO:
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index 39962de8342..c150edf3f13 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
@@ -71,23 +73,21 @@
;; :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,21 +109,41 @@
(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
@@ -132,8 +153,6 @@
`("\\`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-autoload
(defcustom tramp-gvfs-zeroconf-domain "local"
@@ -156,16 +175,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 +296,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>
-(defvar tramp-bluez-discovery nil
- "Indicator for a running bluetooth device discovery.
-It keeps the timestamp of last discovery.")
+(defconst tramp-goa-interface-chat "org.gnome.OnlineAccounts.Chat"
+ "The chat 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.Chat'>
+;; </interface>
-(defconst tramp-hal-service "org.freedesktop.Hal"
- "The well known name of the HAL service.")
+(defconst tramp-goa-interface-photos "org.gnome.OnlineAccounts.Photos"
+ "The photos interface of the GNOME Online Accounts.")
-(defconst tramp-hal-path-manager "/org/freedesktop/Hal/Manager"
- "The object path of the HAL daemon manager.")
+;; <interface name='org.gnome.OnlineAccounts.Photos'>
+;; </interface>
-(defconst tramp-hal-interface-manager "org.freedesktop.Hal.Manager"
- "The manager interface of the HAL daemon.")
+(defconst tramp-goa-path-manager (concat tramp-goa-path "/Manager")
+ "The object path of the GNOME Online Accounts manager.")
+
+(defconst tramp-goa-interface-documents "org.gnome.OnlineAccounts.Manager"
+ "The manager interface of the GNOME Online Accounts.")
+
+;; <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 +460,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,6 +511,13 @@ 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
@@ -488,11 +536,12 @@ 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)
@@ -564,7 +613,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))
@@ -601,12 +650,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))
((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 +676,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))
(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 +712,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
@@ -672,6 +745,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)
@@ -735,13 +809,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 +849,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 +864,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")
@@ -844,8 +918,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."
@@ -945,6 +1018,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
@@ -1040,11 +1125,6 @@ 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
@@ -1080,9 +1160,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))
@@ -1097,67 +1178,78 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(p (apply
'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)
+ (process-put p 'vector v)
(process-put p 'events events)
(process-put p 'watch-name localname)
(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)
(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 "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]+")
+ (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)))
+ (setq file (url-unhex-string file)))
+ (when (string-match ddu (or file1 ""))
+ (setq file1 (replace-match dd nil nil file1)))
+ (while (string-match "%\\([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))
@@ -1175,16 +1267,15 @@ file-notify events."
(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")))))))
+ (list (string-to-number size)
+ (- (string-to-number size) (string-to-number used))
+ (string-to-number free))))))
(defun tramp-gvfs-handle-file-writable-p (filename)
"Like `file-writable-p' for Tramp files."
@@ -1200,8 +1291,8 @@ file-notify events."
"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
@@ -1257,8 +1348,8 @@ file-notify events."
(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)
+ (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))
@@ -1277,7 +1368,7 @@ file-notify events."
(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 +1379,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 +1407,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 +1438,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 +1477,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 +1518,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,34 +1534,37 @@ 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
+ 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
@@ -1529,6 +1604,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,39 +1620,55 @@ 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
+ 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))
+ (string-match (concat "^/" (regexp-quote (or share "")))
(tramp-file-name-unquote-localname vec)))
- ;; Set prefix, mountpoint and location.
- (unless (string-equal prefix "/")
- (tramp-set-file-property vec "/" "prefix" prefix))
+ ;; 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})\"."
@@ -1595,7 +1687,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 "^davs\\|^nextcloud" method) "true" "false"))
(mount-spec
`(:array
,@(cond
@@ -1603,11 +1695,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 "^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 +1706,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 "^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 +1726,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 "^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 +1741,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 +1757,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,18 +1801,16 @@ 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 "/"))
@@ -1744,7 +1844,8 @@ connection if a previous connection has died for some reason."
tramp-gvfs-interface-mountoperation "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"
@@ -1791,6 +1892,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)
@@ -1834,86 +1938,64 @@ is applied, and it returns t if the return code is zero."
(erase-buffer)
(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 +2079,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 +2087,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-sh.el b/lisp/net/tramp-sh.el
index 3f83697c6bf..956fe2ddb73 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.
@@ -321,7 +322,6 @@ The string is used in `tramp-methods'.")
(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
@@ -694,7 +694,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 +707,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.
@@ -954,15 +953,16 @@ busybox awk '{}' </dev/null"
(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 \")\""
@@ -989,6 +989,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)
@@ -1096,8 +1097,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
@@ -1124,7 +1125,7 @@ component is used as the target of the symlink."
'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))
@@ -1176,12 +1177,13 @@ component is used as the target of the symlink."
(tramp-compat-file-attribute-type
(file-attributes
(tramp-make-tramp-file-name
- method user domain host port
+ v
(mapconcat 'identity
(append '("")
(reverse result)
(list thisstep))
- "/")))))
+ "/")
+ 'nohop))))
(cond ((string= "." thisstep)
(tramp-message v 5 "Ignoring step `.'"))
((string= ".." thisstep)
@@ -1225,7 +1227,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.
@@ -1266,6 +1269,13 @@ component is used as the target of the symlink."
;; 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."
(let (symlinkp dirp
@@ -1291,12 +1301,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 +1334,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 "\"")
(read (current-buffer))
(buffer-substring (point) (point-at-eol)))))
;; Return data gathered.
@@ -1343,13 +1348,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.
@@ -1387,7 +1389,7 @@ component is used as the target of the symlink."
;; `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%%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)
@@ -1396,9 +1398,9 @@ 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" (concat tramp-stat-marker "%U" tramp-stat-marker))
(if (eq id-format 'integer)
- "%ge0" (concat tramp-stat-marker "%G" tramp-stat-marker))
+ "%g" (concat tramp-stat-marker "%G" tramp-stat-marker))
tramp-stat-marker tramp-stat-marker
(tramp-shell-quote-argument localname)
tramp-stat-quoted-marker)))
@@ -1415,13 +1417,10 @@ component is used as the target of the symlink."
(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)))
+ (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
@@ -1450,7 +1449,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 +1460,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 +1479,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 +1496,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"
@@ -1596,8 +1592,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 +1632,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.
@@ -1681,11 +1676,13 @@ be non-negative integers."
(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))))
+ (tramp-compat-time-equal-p
+ (tramp-compat-file-attribute-modification-time fa2)
+ tramp-time-dont-know)))
(> 0 (tramp-time-diff
(tramp-compat-file-attribute-modification-time fa2)
(tramp-compat-file-attribute-modification-time fa1)))
@@ -1820,25 +1817,20 @@ be non-negative integers."
;; 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)' "
+ "'(%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" (concat tramp-stat-marker "%U" tramp-stat-marker))
(if (eq id-format 'integer)
- "%ge0" (concat tramp-stat-marker "%G" tramp-stat-marker))
+ "%g" (concat tramp-stat-marker "%G" tramp-stat-marker))
tramp-stat-marker tramp-stat-marker
tramp-stat-quoted-marker)))
@@ -1931,8 +1923,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
@@ -1998,8 +1990,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)
@@ -2048,6 +2040,7 @@ 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)))))
@@ -2126,14 +2119,16 @@ file names."
;; 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.
@@ -2357,15 +2352,6 @@ 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)
@@ -2510,7 +2496,7 @@ 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 'vector orig-vec)
(process-put p 'adjust-window-size-function 'ignore)
(set-process-query-on-exit-flag p nil)
@@ -2521,8 +2507,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,7 +2539,11 @@ 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))
+ ;; 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)))
(save-excursion
(tramp-barf-unless-okay
v (format "%s %s"
@@ -2565,8 +2555,8 @@ The method used must be an out-of-band method."
"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 +2568,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,7 +2582,7 @@ 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)
+ (tramp-flush-file-properties v localname)
(save-excursion
(let ((suffixes dired-compress-file-suffixes)
suffix)
@@ -2641,10 +2631,12 @@ 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
@@ -2814,22 +2806,20 @@ 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)))
+ (let ((vec (process-get proc 'vector)))
(when vec
(tramp-message vec 5 "Sentinel called: `%S' `%s'" proc event)
- (tramp-flush-connection-property proc)
- (tramp-flush-directory-property vec "")))))
+ (tramp-flush-connection-properties proc)
+ (tramp-flush-directory-properties vec "")))))
;; We use BUFFER also as connection buffer during setup. Because of
;; this, its original contents must be saved, and restored once
@@ -2863,13 +2853,7 @@ the result will be a local, non-Tramp, file name."
;; 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-make-tramp-file-name v nil 'nohop)
tramp-initial-end-of-output))
;; We use as environment the difference to toplevel
;; `process-environment'.
@@ -2971,8 +2955,8 @@ the result will be a local, non-Tramp, file name."
(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))))))
+ (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)
@@ -3013,8 +2997,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 +3030,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 +3076,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'.
+ `(,(file-remote-p default-directory 'localname))))
+
(defun tramp-sh-handle-file-local-copy (filename)
"Like `file-local-copy' for Tramp files."
(with-parsed-tramp-file-name filename nil
@@ -3398,8 +3387,8 @@ the result will be a local, non-Tramp, file name."
(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.
@@ -3572,19 +3561,7 @@ 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
events
@@ -3602,6 +3579,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
@@ -3621,7 +3622,7 @@ Fall back to normal file name handler if no Tramp handler exists."
"`%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)
+ (process-put p 'vector v)
;; Needed for process filter.
(process-put p 'events events)
(process-put p 'watch-name localname)
@@ -3632,9 +3633,67 @@ Fall back to normal file name handler if no Tramp handler exists."
(tramp-accept-process-output p 1)
(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 "Monitoring not supported\\|No locations given" string)
+ (delete-process proc))
+
+ (while (string-match
+ (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,8 +3709,6 @@ 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]*"
@@ -3697,12 +3754,11 @@ 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
+ (concat "^[^[:blank:]]+"
+ "[[:blank:]]+\\([^[:blank:]]+\\)+"
+ "\\([[:blank:]]+\\([^\n\r]+\\)\\)?")
+ line)
(tramp-error proc 'file-notify-error "%s" line))
(let ((object
@@ -3742,12 +3798,12 @@ file-notify events."
(concat "[[:space:]]*\\([[:digit:]]+\\)"
"[[:space:]]+\\([[:digit:]]+\\)"
"[[:space:]]+\\([[:digit:]]+\\)"))
- (list (string-to-number (concat (match-string 1) "e0"))
+ (list (string-to-number (match-string 1))
;; 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")))))))))
+ (- (string-to-number (match-string 1))
+ (string-to-number (match-string 2)))
+ (string-to-number (match-string 3)))))))))
;;; Internal Functions:
@@ -4036,7 +4092,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
@@ -4574,25 +4630,24 @@ Goes through the list `tramp-inline-compress-commands'."
"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 previous-host host))
+ (tramp-user-error
+ item "Host name `%s' does not match `%s'" host previous-host))
+ (setq previous-host (concat "^" (regexp-quote host) "$")))))
;; Result.
target-alist))
@@ -4726,7 +4781,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))
@@ -4749,13 +4805,12 @@ 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 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) " "))
@@ -4809,16 +4864,16 @@ 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 elt current-host)
(setq r-shell t)))
+ (setq current-host l-host)
- ;; 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)
+ ;; 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))
;; Add login environment.
(when login-env
@@ -5054,19 +5109,13 @@ Return ATTR."
(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)))))
+ (setcar (nthcdr 4 attr) (seconds-to-time (nth 4 attr))))
;; 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)))))
+ (setcar (nthcdr 5 attr) (seconds-to-time (nth 5 attr))))
;; 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)))))
+ (setcar (nthcdr 6 attr) (seconds-to-time (nth 6 attr))))
;; Convert file size.
(when (< (nth 7 attr) 0)
(setcar (nthcdr 7 attr) -1))
@@ -5082,11 +5131,12 @@ Return ATTR."
(when (string-match "^d" (nth 8 attr))
(setcar attr t))
;; Convert symlink from `tramp-do-file-attributes-with-stat'.
+ ;; Decode also multibyte string.
(when (consp (car attr))
- (if (and (stringp (caar attr))
- (string-match ".+ -> .\\(.+\\)." (caar attr)))
- (setcar attr (match-string 1 (caar attr)))
- (setcar attr nil)))
+ (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))
@@ -5096,7 +5146,7 @@ Return ATTR."
(nth 3 attr)
(tramp-get-remote-gid vec 'string)))))
;; Convert inode.
- (unless (listp (nth 10 attr))
+ (when (floatp (nth 10 attr))
(setcar (nthcdr 10 attr)
(condition-case nil
(let ((high (nth 10 attr))
@@ -5243,14 +5293,7 @@ Nonexistent directories are removed from spec."
(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)
- x))
+ (file-directory-p (tramp-make-tramp-file-name vec x 'nohop))
x))
remote-path)))))
@@ -5284,7 +5327,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
@@ -5297,36 +5340,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."
@@ -5470,6 +5500,12 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil."
vec (format "%s --block-size=1 --output=size,used,avail /" result))
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."
(with-tramp-connection-property vec "gvfs-monitor-dir"
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index 5bcb082626f..a97b8017300 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 ...
@@ -119,6 +120,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 +131,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"
@@ -149,6 +152,7 @@ call, letting the SMB client use the default one."
"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"
@@ -225,11 +229,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)
@@ -365,8 +370,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
@@ -444,13 +449,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
@@ -521,7 +519,7 @@ pass to the OPERATION."
(tramp-message
v 6 "%s" (mapconcat 'identity (process-command p) " "))
- (tramp-set-connection-property p "vector" v)
+ (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 +529,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,8 +547,8 @@ 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
@@ -595,8 +593,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 +628,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 +654,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\""
@@ -718,8 +716,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
;; 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."
@@ -741,64 +738,58 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(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"))))
-
- (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)))
+ (if (not (zerop (length user)))
+ (setq args (append args (list "-U" user)))
+ (setq args (append args (list "-N"))))
- (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."
@@ -826,18 +817,18 @@ 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
+ 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 +906,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
@@ -975,18 +959,15 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(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")))))
+ (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)))))))
@@ -1104,8 +1085,9 @@ 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")
(nth 3 x))))) ; date
@@ -1168,8 +1150,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(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))
+ (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))))))
@@ -1215,8 +1197,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 +1208,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 +1233,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)))
@@ -1333,14 +1314,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 +1357,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))
@@ -1409,15 +1390,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)))
@@ -1459,7 +1434,7 @@ component is used as the target of the symlink."
(tramp-message
v 6 "%s" (mapconcat 'identity (process-command p) " "))
- (tramp-set-connection-property p "vector" v)
+ (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)
@@ -1478,14 +1453,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
@@ -1540,8 +1515,8 @@ component is used as the target of the symlink."
(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.
@@ -1574,8 +1549,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))
@@ -1644,6 +1619,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 "\\. \\|\\.$\\| $" 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
@@ -1835,7 +1817,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 +1890,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)))
@@ -1986,17 +1968,10 @@ If ARGUMENT is non-nil, use it as argument for
(tramp-message
vec 6 "%s" (mapconcat 'identity (process-command p) " "))
- (tramp-set-connection-property p "vector" vec)
+ (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.
@@ -2017,8 +1992,8 @@ If ARGUMENT is non-nil, use it as argument for
smbserver-version
(tramp-get-connection-property
vec "smbserver-version" smbserver-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 "smbserver-version" smbserver-version))))
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 452e70ec353..e1602db1492 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.1-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,6 +56,7 @@
;;; Code:
(require 'tramp-compat)
+(require 'trampver)
;; Pacify byte-compiler.
(require 'cl-lib)
@@ -411,13 +412,18 @@ host runs a registered shell, it shall be added to this list, too."
: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.
@@ -660,7 +666,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" tramp-syntax))
;; Cleanup existing buffers.
(unless (eq (symbol-value symbol) value)
(tramp-cleanup-all-buffers))
@@ -882,7 +888,7 @@ Used in `tramp-make-tramp-file-name'.")
"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"
@@ -956,6 +962,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
"\\`/\\("
@@ -1149,24 +1162,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)
@@ -1249,12 +1252,15 @@ entry does not exist, return nil."
;;;###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))
@@ -1329,7 +1335,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))
@@ -1359,7 +1365,7 @@ default values are used."
(make-tramp-file-name
:method method :user user :domain domain :host host :port port
- :localname (or localname "") :hop hop)))))
+ :localname localname :hop hop)))))
(defun tramp-buffer-name (vec)
"A name for the connection buffer VEC."
@@ -1370,31 +1376,65 @@ 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."
- (when (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))))
+
+ (when (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
+ localname)))
(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
@@ -1421,15 +1461,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)
@@ -1515,7 +1548,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.
+ (set-keymap-parent (current-local-map) special-mode-map))
(current-buffer)))
(defsubst tramp-debug-message (vec fmt-string &rest arguments)
@@ -1560,12 +1595,12 @@ ARGUMENTS to actually emit the message (if applicable)."
(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")
+ "tramp-message"
+ "tramp-user-error")
t)
"$")
fn)))
@@ -1620,17 +1655,18 @@ applicable)."
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))))
- ;; Append connection buffer for error messages.
- (when (= level 1)
- (let ((tramp-verbose 0))
- (with-current-buffer (tramp-get-connection-buffer vec-or-proc)
+ (let ((tramp-verbose 0))
+ ;; Append connection buffer for error messages.
+ (when (= level 1)
+ (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)))))))
+ 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
@@ -1642,10 +1678,11 @@ applicable)."
"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.
@@ -1704,6 +1741,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
@@ -2028,6 +2090,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
.
@@ -2105,7 +2168,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))
default-directory)
;; PROC.
((member operation
@@ -2172,7 +2237,7 @@ preventing reentrant calls of Tramp.")
"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))
+ (if (tramp-tramp-file-p filename)
(save-match-data
(setq filename (tramp-replace-environment-variables filename))
(with-parsed-tramp-file-name filename nil
@@ -2193,6 +2258,8 @@ Falls back to normal file name handler if no Tramp file name handler exists."
(let ((default-directory
(tramp-compat-temporary-file-directory)))
(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
@@ -2216,6 +2283,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
@@ -2328,15 +2397,19 @@ remote 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.
+ ;; if `tramp-syntax' has been changed. We cannot call
+ ;; `tramp-unload-file-name-handlers', this would result in recursive
+ ;; loading of Tramp.
(dolist (fnh '(tramp-file-name-handler
tramp-completion-file-name-handler
+ tramp-archive-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))))
;; 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))
@@ -2350,6 +2423,12 @@ remote file names."
(put 'tramp-completion-file-name-handler 'operations
(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'.
(dolist (fnh '(epa-file-handler jka-compr-handler))
@@ -2403,6 +2482,7 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'."
"Unload Tramp file name handlers from `file-name-handler-alist'."
(dolist (fnh '(tramp-file-name-handler
tramp-completion-file-name-handler
+ tramp-archive-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))))))
@@ -2464,7 +2544,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.
@@ -2902,8 +2981,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)))
@@ -2947,13 +3026,19 @@ 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-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
@@ -2994,17 +3079,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."
@@ -3063,10 +3142,6 @@ User is always nil."
(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
@@ -3087,19 +3162,14 @@ 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."
@@ -3138,13 +3208,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."
@@ -3178,7 +3248,7 @@ User is always nil."
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
+ v2
(funcall
(if (tramp-compat-file-name-quoted-p v2-localname)
'tramp-compat-file-name-quote 'identity)
@@ -3189,7 +3259,8 @@ User is always nil."
(tramp-compat-file-name-quote symlink-target))
(expand-file-name
symlink-target (file-name-directory v2-localname)))
- v2-localname)))))
+ v2-localname))
+ 'nohop)))
(when (>= numchase numchase-limit)
(tramp-error
v1 'file-error
@@ -3208,8 +3279,7 @@ 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)))
@@ -3314,7 +3384,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)
@@ -3358,9 +3428,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)
@@ -3453,7 +3521,7 @@ support symbolic links."
(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")))
+ (tramp-user-error p "Shell command in progress")))
(if current-buffer-p
(progn
@@ -3504,17 +3572,28 @@ 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))))
(defun tramp-handle-set-visited-file-modtime (&optional time-list)
"Like `set-visited-file-modtime' for Tramp files."
@@ -3523,13 +3602,11 @@ 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-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)
@@ -3548,34 +3625,32 @@ 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))))))))
+
+;; 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
@@ -3607,17 +3682,16 @@ 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))))
(defun tramp-action-password (proc vec)
"Query the user for a password."
@@ -3741,12 +3815,10 @@ 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."
;; 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
@@ -3765,7 +3837,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
@@ -4034,13 +4108,13 @@ This is used to map a mode number to a permission string.")
(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"))
@@ -4116,15 +4190,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))
@@ -4166,11 +4232,12 @@ be granted."
;;;###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)
+ (stringp tramp-local-host-regexp) (stringp host)
(string-match tramp-local-host-regexp host)
;; A port is an indication for an ssh tunnel or alike.
(null port)
@@ -4181,11 +4248,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
@@ -4195,14 +4258,9 @@ 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-error vec 'file-error "Directory %s not accessible" dir))
@@ -4315,15 +4373,10 @@ 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)))
(destination (if (eq destination t) (current-buffer) destination))
output error result)
(tramp-message
- v 6 "`%s %s' %s %s"
+ vec 6 "`%s %s' %s %s"
program (mapconcat 'identity args " ") infile destination)
(condition-case err
(with-temp-buffer
@@ -4341,8 +4394,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
@@ -4352,15 +4405,10 @@ 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)))
(buffer (if (eq buffer t) (current-buffer) buffer))
result)
(tramp-message
- v 6 "`%s %s' %s %s %s %s"
+ vec 6 "`%s %s' %s %s %s %s"
program (mapconcat 'identity args " ") start end delete buffer)
(condition-case err
(progn
@@ -4373,11 +4421,11 @@ are written with verbosity of 6."
(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))
;;;###tramp-autoload
@@ -4387,19 +4435,26 @@ 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.
@@ -4408,38 +4463,41 @@ 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))))
@@ -4447,11 +4505,7 @@ Invokes `password-read' if available, `read-passwd' else."
(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
@@ -4466,20 +4520,21 @@ Invokes `password-read' if available, `read-passwd' else."
(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 ""))))
+ (password-cache-remove (tramp-make-tramp-file-name vec 'noloc 'nohop))))
-;; Snarfed code from time-date.el.
+;;;###tramp-autoload
+(defconst tramp-time-dont-know '(0 0 0 1000)
+ "An invalid time value, used as \"Don’t know\" value.")
-(defconst tramp-half-a-year '(241 17024)
-"Evaluated by \"(days-to-time 183)\".")
+;;;###tramp-autoload
+(defconst tramp-time-doesnt-exist '(-1 65535)
+ "An invalid time value, used as \"Doesn’t exist\" value.")
;;;###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."
@@ -4544,7 +4599,7 @@ Only works for Bourne-like shells."
;; 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.
@@ -4569,19 +4624,11 @@ Only works for Bourne-like shells."
;; 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
- (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.
- (tramp-get-connection-property
- (tramp-get-connection-process v) "remote-path" nil)
- (tramp-get-connection-property v "remote-path" nil))
- ":"))
- (getenv "PATH"))))
+ (mapconcat
+ 'identity (butlast (tramp-compat-exec-path)) path-separator)))
(eval-after-load "esh-util"
'(progn
diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el
index 6454b5b8f8b..1956ab648b3 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.4.26.2
;; This file is part of GNU Emacs.
@@ -33,7 +32,7 @@
;; should be changed only there.
;;;###tramp-autoload
-(defconst tramp-version "2.3.4.26.2"
+(defconst tramp-version "2.4.1-pre"
"This version of Tramp.")
;;;###tramp-autoload
@@ -53,12 +52,11 @@
(replace-regexp-in-string "\n" "" (buffer-string))))))))
;; Check for Emacs version.
-(let ((x (if (>= emacs-major-version 24)
- "ok"
- (format "Tramp 2.3.4.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.1-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.
(add-to-list
diff --git a/lisp/net/zeroconf.el b/lisp/net/zeroconf.el
index 351fc9fc305..0a3f2777b9a 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
diff --git a/lisp/newcomment.el b/lisp/newcomment.el
index 9827a5d1d9c..cd722663dad 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/novice.el b/lisp/novice.el
index b9cd568ace9..aaad4fabfe2 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-mode.el b/lisp/nxml/nxml-mode.el
index 7dc0be8c8ed..e2b51bc01ab 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 a9a1950822d..75d983189a5 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 46ab3a58f50..2b7d9cca082 100644
--- a/lisp/nxml/rng-maint.el
+++ b/lisp/nxml/rng-maint.el
@@ -226,11 +226,10 @@
(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)))
+ (float-time (time-subtract nil start)))
val))
(defun rng-time-tokenize-buffer ()
diff --git a/lisp/obsolete/assoc.el b/lisp/obsolete/assoc.el
index 899c9d7a563..66cf67713d1 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 ee6af770290..f5e4328d33c 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 1d09d9e223f..4bd555a72ed 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
diff --git a/lisp/obsolete/fast-lock.el b/lisp/obsolete/fast-lock.el
index e15dfd631ce..21db32148f7 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 ec92b96899a..6192368f8b1 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 010b7ae0f31..54dc799c1f2 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 7fb3be83ee2..48afe7551de 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 e3121dbd87e..d07f7bf34bf 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 6caaea217df..f54bcf01c99 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 86dd5dc8422..0c9fc321184 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 41637a6ecf3..00000000000
--- a/lisp/obsolete/options.el
+++ /dev/null
@@ -1,140 +0,0 @@
-;;; options.el --- edit Options command for Emacs
-
-;; Copyright (C) 1985, 2001-2018 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 1bc23cad468..3b890727d14 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 e29dfce43f0..a7470246492 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,9 +116,9 @@
)
(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))
@@ -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 7f9e764959f..ae75377783e 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 c6294f4368f..af8205525f6 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 57e9197a911..fd35f7d333e 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)
diff --git a/lisp/obsolete/sregex.el b/lisp/obsolete/sregex.el
index 6ff5133ca02..1099b878e68 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 e2dff2d53d6..0dc2663870a 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.
diff --git a/lisp/net/tls.el b/lisp/obsolete/tls.el
index b02a2654d41..fb7c20c843a 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 83b713d9277..c047381ef71 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 8739e1b2152..21006ff005f 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 414ae77fc6a..9860c9d3faa 100644
--- a/lisp/obsolete/vc-arch.el
+++ b/lisp/obsolete/vc-arch.el
@@ -304,8 +304,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)))))))))
@@ -402,7 +403,7 @@ CALLBACK expects (ENTRIES &optional MORE-TO-COME); see
(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..7d44f561d46 100644
--- a/lisp/obsolete/vi.el
+++ b/lisp/obsolete/vi.el
@@ -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 c0779acc5ea..1d1eccbf241 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.
diff --git a/lisp/obsolete/xesam.el b/lisp/obsolete/xesam.el
index 1f3661d924a..3e91b2c8dfc 100644
--- a/lisp/obsolete/xesam.el
+++ b/lisp/obsolete/xesam.el
@@ -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."
diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el
index 5d5faaa6fd0..a5449fe35e9 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
diff --git a/lisp/org/ob-eval.el b/lisp/org/ob-eval.el
index 2bfaa08a609..f8cb285dd3e 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/org-agenda.el b/lisp/org/org-agenda.el
index 5bbf5e34ee5..98e89eb1c4e 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
@@ -7005,15 +7009,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."
diff --git a/lisp/org/org-attach.el b/lisp/org/org-attach.el
index 9774e3a7975..203e71e9549 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-clock.el b/lisp/org/org-clock.el
index ff32e28d1e8..9be0d5bc1ff 100644
--- a/lisp/org/org-clock.el
+++ b/lisp/org/org-clock.el
@@ -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? "))
diff --git a/lisp/org/org-ctags.el b/lisp/org/org-ctags.el
index 72ea76fe751..48981743755 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-element.el b/lisp/org/org-element.el
index d9c6522e2f0..b8f14670226 100644
--- a/lisp/org/org-element.el
+++ b/lisp/org/org-element.el
@@ -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)))
diff --git a/lisp/org/org-footnote.el b/lisp/org/org-footnote.el
index c6376ca5dc0..5d472bdb184 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-indent.el b/lisp/org/org-indent.el
index 84bac2aa799..bf4e998199e 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)
diff --git a/lisp/org/org-macro.el b/lisp/org/org-macro.el
index 1033db2af46..e50b2f99842 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
diff --git a/lisp/org/org-macs.el b/lisp/org/org-macs.el
index 510ece1cb19..583633605f4 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-pcomplete.el b/lisp/org/org-pcomplete.el
index 88a2e10d854..a9b909d3ae7 100644
--- a/lisp/org/org-pcomplete.el
+++ b/lisp/org/org-pcomplete.el
@@ -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.el b/lisp/org/org.el
index 1373861ad1b..873ae6b8209 100644
--- a/lisp/org/org.el
+++ b/lisp/org/org.el
@@ -230,8 +230,9 @@ file to byte-code before it is loaded."
(let* ((age (lambda (file)
(float-time
(time-subtract (current-time)
- (nth 5 (or (file-attributes (file-truename file))
- (file-attributes file)))))))
+ (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
@@ -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."
@@ -10056,7 +10059,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
@@ -19324,6 +19327,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.
@@ -22376,7 +22382,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)
@@ -22922,7 +22930,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)
diff --git a/lisp/org/ox-html.el b/lisp/org/ox-html.el
index 39f7d83e14a..6166a4ad019 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-odt.el b/lisp/org/ox-odt.el
index a1145a9821c..b878171c51b 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 8901dba34cf..80ef239b679 100644
--- a/lisp/org/ox-publish.el
+++ b/lisp/org/ox-publish.el
@@ -794,8 +794,8 @@ Default for SITEMAP-FILENAME is `sitemap.org'."
((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))))
+ (A (+ (ash (car adate) 16) (cadr adate)))
+ (B (+ (ash (car bdate) 16) (cadr bdate))))
(setq retval
(if (eq sort-files 'chronologically)
(<= A B)
@@ -879,7 +879,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 +890,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 +1350,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))))))
+ (floor (float-time (file-attribute-modification-time attr))))))
(provide 'ox-publish)
diff --git a/lisp/outline.el b/lisp/outline.el
index 7cf56abd23a..59169e41897 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 467e5e985d6..1cab6eb2be3 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 a3e2b2f5b3c..dedc0072237 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 505d10c1641..c4e5a677d0c 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 ce42486fda7..18cc647aac5 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 d3250babe6a..7f164c9f2be 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 90dde265999..1b11afd36bb 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 6078dfd7443..6bdea68c0b9 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 ()
@@ -950,7 +983,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 +1047,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 +1269,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 +1280,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 d362419e0fc..227580f4d42 100644
--- a/lisp/pixel-scroll.el
+++ b/lisp/pixel-scroll.el
@@ -105,10 +105,7 @@ function returns nil."
;;;###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 ee2135b9bbe..a54682fff22 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-2018 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 ()
@@ -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)
@@ -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 5ae2cb432e8..7a6a56b1913 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 f22cc240c04..2b8bd9d6b8a 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 74ace06c011..740f436711a 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 193b7da3bd7..6edd085b59a 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-2018 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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -228,13 +336,13 @@ static unsigned char gamegrid_bits[] = {
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
diff --git a/lisp/play/gametree.el b/lisp/play/gametree.el
index de8abd7abe4..5b05ae13e2f 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/printing.el b/lisp/printing.el
index 20b0790670d..2fc2323028f 100644
--- a/lisp/printing.el
+++ b/lisp/printing.el
@@ -2,8 +2,8 @@
;; Copyright (C) 2000-2001, 2003-2018 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.
diff --git a/lisp/profiler.el b/lisp/profiler.el
index eaeb69793fb..41dea68bd13 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 76c9be93d03..fd6a2b0b2da 100644
--- a/lisp/progmodes/ada-mode.el
+++ b/lisp/progmodes/ada-mode.el
@@ -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/antlr-mode.el b/lisp/progmodes/antlr-mode.el
index 1d4fd4f2bce..775fd878725 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/bat-mode.el b/lisp/progmodes/bat-mode.el
index 2910a7a1043..51acc6a949f 100644
--- a/lisp/progmodes/bat-mode.el
+++ b/lisp/progmodes/bat-mode.el
@@ -84,6 +84,8 @@
. '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 d2b3af19724..75bd0ba51e0 100644
--- a/lisp/progmodes/bug-reference.el
+++ b/lisp/progmodes/bug-reference.el
@@ -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 09887b02f3b..1b48a5a66c9 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:
diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el
index 9315ce400be..4f256e1008f 100644
--- a/lisp/progmodes/cc-cmds.el
+++ b/lisp/progmodes/cc-cmds.el
@@ -1383,7 +1383,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 +1397,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 +1441,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 +1473,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 +1495,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.
@@ -1817,251 +1844,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 +2113,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)))))
@@ -4737,7 +4782,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 613e2b303d9..f41a7cf028c 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))))
@@ -219,6 +219,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
@@ -254,6 +255,16 @@ to it is returned. This function does not modify the point or the mark."
(end-of-line)
(point))))
+ ((eq position 'eoll)
+ `(save-excursion
+ ,@(if point `((goto-char ,point)))
+ (while (progn
+ (end-of-line)
+ (prog1 (eq (logand 1 (skip-chars-backward "\\\\")) 1)))
+ (beginning-of-line 2))
+ (end-of-line)
+ (point)))
+
((eq position 'boi)
`(save-excursion
,@(if point `((goto-char ,point)))
@@ -453,6 +464,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.
@@ -1775,10 +1793,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)
@@ -1840,7 +1858,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 317968aafd3..3ec7dbcc906 100644
--- a/lisp/progmodes/cc-engine.el
+++ b/lisp/progmodes/cc-engine.el
@@ -870,7 +870,7 @@ 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.
@@ -1124,7 +1124,16 @@ comment at the start of cc-engine.el for more info."
(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))
+ (not (looking-at
+ c-opt-block-decls-with-vars-key)))))
(save-excursion
(c-forward-sexp) (point)))
;; Just gone back over some paren block?
@@ -1273,7 +1282,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)))
@@ -4286,6 +4295,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 +4341,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 +4744,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 +4760,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
@@ -5177,6 +5146,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 +5158,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 +5178,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 +5226,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 +5237,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
@@ -7138,7 +7120,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 +7670,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 +7682,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 +7807,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 +7862,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 ":"
@@ -8548,7 +8576,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))
@@ -8605,6 +8633,7 @@ 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) ?\)))))
(if (eq (char-after) ?\))
@@ -8634,31 +8663,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))
@@ -9527,11 +9564,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
@@ -9829,9 +9865,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))))
@@ -9901,11 +9943,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
@@ -9998,28 +10039,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)))))
@@ -10034,10 +10072,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)
@@ -10058,34 +10093,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)
@@ -10165,7 +10198,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
@@ -10516,6 +10549,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.
@@ -10554,9 +10591,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
@@ -10631,7 +10673,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)
@@ -10921,7 +10964,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)))))
@@ -11256,9 +11299,7 @@ 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))
@@ -11350,10 +11391,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
@@ -11464,17 +11504,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) ?<))
@@ -12134,21 +12172,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) ?<))
@@ -12172,8 +12227,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)
@@ -12280,7 +12334,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))
@@ -12428,6 +12493,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
@@ -12602,23 +12672,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
@@ -12628,7 +12705,11 @@ 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)))
+ (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)
(c-add-stmt-syntax 'brace-list-intro nil t lim paren-state)))
diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el
index fa9b8f354ef..9d2517f2524 100644
--- a/lisp/progmodes/cc-fonts.el
+++ b/lisp/progmodes/cc-fonts.el
@@ -682,33 +682,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 +722,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
@@ -1234,10 +1203,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))
diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el
index 271cc2f8464..1b44c75fe6c 100644
--- a/lisp/progmodes/cc-langs.el
+++ b/lisp/progmodes/cc-langs.el
@@ -208,9 +208,9 @@ the evaluated constant value at compile time."
;; 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.
@@ -392,27 +392,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 +451,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,14 +496,17 @@ 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-re-mark-unbalanced-strings
c-change-expand-fl-region)
(c objc) '(c-depropertize-new-text
c-parse-quotes-after-change
+ c-after-change-re-mark-unbalanced-strings
c-extend-font-lock-region-for-macros
c-neutralize-syntax-in-CPP
c-change-expand-fl-region)
c++ '(c-depropertize-new-text
c-parse-quotes-after-change
+ c-after-change-re-mark-unbalanced-strings
c-extend-font-lock-region-for-macros
c-after-change-re-mark-raw-strings
c-neutralize-syntax-in-CPP
@@ -529,6 +514,7 @@ parameters \(point-min) and \(point-max).")
c-change-expand-fl-region)
java '(c-depropertize-new-text
c-parse-quotes-after-change
+ c-after-change-re-mark-unbalanced-strings
c-restore-<>-properties
c-change-expand-fl-region)
awk '(c-depropertize-new-text
@@ -611,12 +597,31 @@ 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."
+ 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 +855,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 "#"
@@ -1274,7 +1301,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,7 +1524,7 @@ 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))
@@ -1516,7 +1543,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 +1552,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 +1567,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 +2128,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 +2189,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 +2494,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 +2624,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 +3038,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 +3219,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 "\\("
@@ -3191,7 +3257,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 +3416,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 +3472,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 +3588,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 664f01012b8..09c30e2bd1b 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.
@@ -996,9 +999,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 +1011,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 +1075,292 @@ 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
+ "\"\\|\\s|" (point-max) t t)
+ (progn
+ (c-clear-char-property (1- (point)) 'syntax-table)
+ (not (eq (char-before) ?\")))))
+ (eq (char-before) ?\"))
+ (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 "\\\\*\"")
+ (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))))
+
+ ((< c-new-END (point-max))
+ (goto-char (1+ c-new-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 (min (1+ (point)) (point-max)))
+ (goto-char c-new-END)
+ (if (equal (c-get-char-property (1- (point)) 'syntax-table) '(15))
+ (if (memq (char-before) '(?\n ?\r))
+ ;; Normally terminated invalid string.
+ (progn
+ (backward-sexp)
+ (c-clear-char-property (1- c-new-END) 'syntax-table)
+ (c-clear-char-property (point) 'syntax-table))
+ ;; Opening " at EOB.
+ (c-clear-char-property (1- (point)) 'syntax-table))
+ (if (c-search-backward-char-property 'syntax-table '(15) c-new-BEG)
+ ;; Opening " on last line of text (without EOL).
+ (c-clear-char-property (point) 'syntax-table))))
+
+ (t (goto-char c-new-END)
+ (if (c-search-backward-char-property 'syntax-table '(15) c-new-BEG)
+ (c-clear-char-property (point) 'syntax-table))))
+
+ (unless (and c-multiline-string-start-char
+ (not (c-characterp c-multiline-string-start-char)))
+ (when (eq end-literal-type 'string)
+ (c-clear-char-property (1- (cdr end-limits)) 'syntax-table))
+
+ (when (eq beg-literal-type 'string)
+ (setq c-new-BEG (min c-new-BEG (car beg-limits)))
+ (c-clear-char-property (car beg-limits) 'syntax-table)))))
+
+(defun c-after-change-re-mark-unbalanced-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)
+ (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 (not (nth 3 s))
+ (< (point) c-new-END)
+ (not (memq (char-before) c-string-delims)))))
+ ;; We're at the start of a string.
+ (memq (char-before) c-string-delims)))
+ (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.
;;
@@ -1418,7 +1709,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))
@@ -1829,6 +2121,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
@@ -1916,6 +2209,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))
@@ -1994,7 +2288,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-vars.el b/lisp/progmodes/cc-vars.el
index ecf034846bd..047511406d9 100644
--- a/lisp/progmodes/cc-vars.el
+++ b/lisp/progmodes/cc-vars.el
@@ -1647,8 +1647,9 @@ 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\\`")
+(defvar c-noise-macro-name-re "a\\`")
(defcustom c-noise-macro-names nil
"A list of names of macros which expand to nothing, or compiler extensions
@@ -1677,7 +1678,7 @@ These are recognized by CC Mode only in declarations."
;; 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 +1687,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/cmacexp.el b/lisp/progmodes/cmacexp.el
index 742ac80be1e..7dcfb10af0a 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 422974379ba..7e7c18fb30e 100644
--- a/lisp/progmodes/compile.el
+++ b/lisp/progmodes/compile.el
@@ -100,16 +100,6 @@ 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")
-
-;;;###autoload
(defvar compilation-finish-functions nil
"Functions to call when a compilation process finishes.
Each function is called with two arguments: the compilation buffer,
@@ -2101,7 +2091,6 @@ by replacing the first word, e.g., `compilation-scroll-output' from
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
@@ -2175,9 +2164,6 @@ 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
@@ -2192,9 +2178,6 @@ 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
@@ -2245,9 +2228,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.
diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index 6dbdba75de6..18a72324c65 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-2018 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,7 +118,7 @@
`(progn
(beginning-of-line 2)
(list ,file ,line)))
- (defmacro cperl-etags-snarf-tag (file line)
+ (defmacro cperl-etags-snarf-tag (_file _line)
`(etags-snarf-tag)))
(if (featurep 'xemacs)
(defmacro cperl-etags-goto-tag-location (elt)
@@ -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")
@@ -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
@@ -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,7 +4454,7 @@ 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 []
+;;; POSIX? [:word:] [:^word:] only inside []
;;; "\\=\\(\\\\.\\|[^][\\\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]")
(while ; look for unescaped ]
(and argument
@@ -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"
"\\|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
@@ -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)
"\\("
@@ -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)
@@ -7372,6 +7266,7 @@ One may build such TAGS files from CPerl mode menu."
"\\$." ; $|
"<<[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,7 +7340,7 @@ 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
@@ -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))
@@ -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)
@@ -8811,61 +8722,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 +8799,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 +8860,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 6cd02da8f52..432be1aaad8 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."
diff --git a/lisp/progmodes/cwarn.el b/lisp/progmodes/cwarn.el
index a578896dbf7..ff79b909563 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/ebnf-abn.el b/lisp/progmodes/ebnf-abn.el
index 1ed07ba17bb..66f1d398df4 100644
--- a/lisp/progmodes/ebnf-abn.el
+++ b/lisp/progmodes/ebnf-abn.el
@@ -2,8 +2,8 @@
;; Copyright (C) 2001-2018 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 7fe61cd626e..7defe9877b2 100644
--- a/lisp/progmodes/ebnf-bnf.el
+++ b/lisp/progmodes/ebnf-bnf.el
@@ -2,8 +2,8 @@
;; Copyright (C) 1999-2018 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 c0dbc9e3308..2dec3f9159b 100644
--- a/lisp/progmodes/ebnf-dtd.el
+++ b/lisp/progmodes/ebnf-dtd.el
@@ -2,8 +2,8 @@
;; Copyright (C) 2001-2018 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 bbaba13e688..0dc82fc3bff 100644
--- a/lisp/progmodes/ebnf-ebx.el
+++ b/lisp/progmodes/ebnf-ebx.el
@@ -2,8 +2,8 @@
;; Copyright (C) 2001-2018 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 c6ebc8d3969..06aaf8a3f55 100644
--- a/lisp/progmodes/ebnf-iso.el
+++ b/lisp/progmodes/ebnf-iso.el
@@ -2,8 +2,8 @@
;; Copyright (C) 1999-2018 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 3affbcc41d7..5857aa306ba 100644
--- a/lisp/progmodes/ebnf-otz.el
+++ b/lisp/progmodes/ebnf-otz.el
@@ -2,8 +2,8 @@
;; Copyright (C) 1999-2018 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 894c9dd9d79..eac0bfc878a 100644
--- a/lisp/progmodes/ebnf-yac.el
+++ b/lisp/progmodes/ebnf-yac.el
@@ -2,8 +2,8 @@
;; Copyright (C) 1999-2018 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
diff --git a/lisp/progmodes/ebnf2ps.el b/lisp/progmodes/ebnf2ps.el
index 40d6af9e654..e29eb74a05b 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-2018 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 c9557900190..07b58b53823 100644
--- a/lisp/progmodes/ebrowse.el
+++ b/lisp/progmodes/ebrowse.el
@@ -1107,7 +1107,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)
@@ -4023,7 +4023,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)
diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el
index 91d05ce6983..f694252c407 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))
@@ -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
@@ -1714,9 +1716,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 a31668e1baa..6844e9b0f7c 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 'multifile)
;;;###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].")
@@ -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 'multifile-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 multifile-initialize and multifile-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))
+ (multifile-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 'multifile-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 'multifile-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)
+ (multifile-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 multifile-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))
+ (multifile-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 multifile operation took place,
+ ;; rather than search for "", we should repeat the last search!
+ (eq multifile--operate-function
+ tags--last-search-operate-function))
+ (multifile-initialize-search
+ regexp
+ (tags--compat-files (or files t))
+ tags-case-fold-search)
+ ;; Store it, so we can detect if some other multifile operation took
+ ;; place since the last search!
+ (setq tags--last-search-operate-function multifile--operate-function))
+ (multifile-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 `multifile-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)))
-
+ (multifile-initialize-replace
+ from to
+ (tags--compat-files (or files t))
+ (if (equal from (downcase from)) nil 'default)
+ delimited)
+ (multifile-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 2105377a165..c3e085dda5b 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
@@ -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..ebcfd7d1f6e
--- /dev/null
+++ b/lisp/progmodes/flymake-cc.el
@@ -0,0 +1,140 @@
+;;; flymake-cc.el --- Flymake support for GNU tools for C/C++ -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018 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
+ "^\\(In file included from \\)?<stdin>:\\([0-9]+\\):\\([0-9]+\\):\n?\\(.*\\): \\(.*\\)$"
+ nil t)
+ for msg = (match-string 5)
+ for (beg . end) = (flymake-diag-region
+ source
+ (string-to-number (match-string 2))
+ (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" "CHK_SOURCES=-x 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 4792a945308..8600be9b97c 100644
--- a/lisp/progmodes/flymake-proc.el
+++ b/lisp/progmodes/flymake-proc.el
@@ -3,8 +3,8 @@
;; Copyright (C) 2003-2018 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)
@@ -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 40eacdd1888..60d1660e5fe 100644
--- a/lisp/progmodes/flymake.el
+++ b/lisp/progmodes/flymake.el
@@ -3,8 +3,8 @@
;; Copyright (C) 2003-2018 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.
@@ -14,10 +14,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 +34,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 +196,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)
@@ -222,18 +292,21 @@ generated it."
(cl-defstruct (flymake--diag
(:constructor flymake--diag-make))
- buffer beg end type text backend)
+ buffer beg end type text backend data overlay)
;;;###autoload
(defun flymake-make-diagnostic (buffer
beg
end
type
- text)
+ text
+ &optional data)
"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."
+ (flymake--diag-make :buffer buffer :beg beg :end end
+ :type type :text text :data data))
;;;###autoload
(defun flymake-diagnostics (&optional beg end)
@@ -257,6 +330,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 +354,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"))
@@ -370,9 +440,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 +470,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 +483,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 +505,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 +586,38 @@ 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 ; 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 +630,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 +678,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 +718,28 @@ 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
+ (dolist (diag (flymake--backend-state-diags state))
+ (let ((diag-beg (flymake--diag-beg diag))
+ (diag-end (flymake--diag-beg diag)))
+ (when (and (< diag-beg (cdr region))
+ (> diag-end (car region)))
+ (delete-overlay (flymake--diag-overlay diag))
+ (setf (flymake--backend-state-diags state)
+ (delq diag (flymake--backend-state-diags state)))))))
+ (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)))
@@ -709,14 +811,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 +830,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 +883,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 +915,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 +933,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
@@ -839,6 +956,7 @@ special *Flymake log* buffer." :group 'flymake :lighter
(add-hook 'kill-buffer-hook 'flymake-kill-buffer-hook nil t)
(setq flymake--backend-state (make-hash-table))
+ (setq flymake--recent-changes nil)
(when flymake-start-on-flymake-mode (flymake-start t)))
@@ -849,7 +967,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)
@@ -891,15 +1009,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 +1042,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 +1058,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 +1087,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 +1101,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))
@@ -1063,12 +1186,10 @@ applied."
(cl-loop
for (type . severity)
in (cl-sort (mapcar (lambda (type)
- (cons type (flymake--lookup-type-property
- type
- 'severity
- (warning-numeric-level :error))))
+ (cons type (flymake--severity type)))
(cl-union (hash-table-keys diags-by-type)
- '(:error :warning)))
+ '(:error :warning)
+ :key #'flymake--severity))
#'>
:key #'cdr)
for diags = (gethash type diags-by-type)
diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el
index 3fddf2392ea..bfbf6c09b27 100644
--- a/lisp/progmodes/fortran.el
+++ b/lisp/progmodes/fortran.el
@@ -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))))
diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el
index 0506386a75d..da979de5400 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).")
@@ -1138,9 +1138,7 @@ Changed values are highlighted with the face `font-lock-warning-face'."
: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")
@@ -2718,10 +2716,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 "}")))
diff --git a/lisp/progmodes/glasses.el b/lisp/progmodes/glasses.el
index de176019a57..f2bf2099469 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 0bfabd5f3fe..0ededb1b155 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,6 +430,28 @@ 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\\)\\)$"
@@ -452,9 +469,18 @@ See `compilation-error-regexp-alist' for format details.")
(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.")
@@ -608,22 +634,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 +658,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
@@ -1048,6 +1074,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 +1197,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 9cf818e99ea..91b4a65edd9 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))))
@@ -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)
@@ -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))
diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el
index 7ac1312d8dc..62e8c453389 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
@@ -1042,16 +1039,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 *))
@@ -1628,7 +1621,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 799536cbf49..84b21473947 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-help.el b/lisp/progmodes/idlw-help.el
index cbdca015e93..54e740be11f 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 1b72eea09eb..46e2ecaa397 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-2018 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 7595db98230..75f55827933 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 1d5dc7c7948..540931c9f2f 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
@@ -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))))
@@ -6223,7 +6223,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 +6520,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]*\\="
@@ -8190,7 +8190,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 +8399,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 +8707,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 +8776,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))
diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el
index 02512ae2de1..3ce5af4c49b 100644
--- a/lisp/progmodes/js.el
+++ b/lisp/progmodes/js.el
@@ -2368,23 +2368,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))
@@ -3870,13 +3869,12 @@ If one hasn't been set, or if it's stale, prompt for a new one."
(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-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
diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el
index a1a66c09c63..f67407f48ee 100644
--- a/lisp/progmodes/make-mode.el
+++ b/lisp/progmodes/make-mode.el
@@ -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/octave.el b/lisp/progmodes/octave.el
index c768d8d6f4d..984bb73c73e 100644
--- a/lisp/progmodes/octave.el
+++ b/lisp/progmodes/octave.el
@@ -639,6 +639,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 +696,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.
@@ -1165,6 +1165,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
diff --git a/lisp/progmodes/pascal.el b/lisp/progmodes/pascal.el
index 737dd9ea8a8..6d13d328c5f 100644
--- a/lisp/progmodes/pascal.el
+++ b/lisp/progmodes/pascal.el
@@ -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 c9bfb1acdfe..b96aad7a6ef 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)
@@ -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 19269766c90..b1a17dfa3cc 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 eab24e1ea60..f3f29cbac94 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -189,6 +189,18 @@ to find the list of ignores for each directory."
(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."
+ ;; This default implementation only works if project-file-completion-table
+ ;; returns a "flat" completion table.
+ ;; FIXME: Maybe we should do the reverse: implement the default
+ ;; `project-file-completion-table' on top of `project-files'.
+ (all-completions
+ "" (project-file-completion-table
+ project (or dirs (project-roots project)))))
+
(defgroup project-vc nil
"Project implementation using the VC package."
:version "25.1"
@@ -389,12 +401,17 @@ 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* (;; (initial-input
+ ;; (let ((common-prefix (try-completion "" collection)))
+ ;; (if (> (length common-prefix) 0)
+ ;; (file-name-directory common-prefix))))
+ (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)))
+ nil ;; initial-input
+ hist default inherit-input-method)))
(if (and (equal res default)
(not (test-completion res collection predicate)))
(completing-read (format "%s: " prompt)
@@ -402,5 +419,30 @@ recognized."
inherit-input-method)
res)))
+(declare-function multifile-continue "multifile" ())
+
+;;;###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 \\[multifile-continue]."
+ (interactive "sSearch (regexp): ")
+ (multifile-initialize-search
+ regexp (project-files (project-current t)) 'default)
+ (multifile-continue))
+
+;;;###autoload
+(defun project-query-replace (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 \\[multifile-continue]."
+ (interactive
+ (pcase-let ((`(,from ,to)
+ (query-replace-read-args "Query replace (regexp)" t t)))
+ (list from to)))
+ (multifile-initialize-replace
+ from to (project-files (project-current t)) 'default)
+ (multifile-continue))
+
(provide 'project)
;;; project.el ends here
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index c7bb2d97c84..c55b69e33ec 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
@@ -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" "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)
(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
@@ -1474,7 +1516,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 +1531,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 +1549,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 +2191,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 +2873,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 +2956,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 +2982,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 +3196,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 +3232,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
@@ -5191,9 +5240,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)
@@ -5286,6 +5336,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 +5356,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)))
@@ -5381,7 +5432,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 5abc29a6645..fad7bc1fb8b 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-"
@@ -255,8 +257,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)
@@ -2311,8 +2312,8 @@ 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."
:version "26.1"
:type 'boolean
:group 'ruby
@@ -2326,7 +2327,7 @@ Only takes effect if Rubocop is installed."
: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"))
@@ -2352,7 +2353,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
diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el
index a4cb4856a84..aaa86b5816f 100644
--- a/lisp/progmodes/sh-script.el
+++ b/lisp/progmodes/sh-script.el
@@ -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)))
diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el
index e7d7494d2ca..1cdae35ac30 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
;;
@@ -344,7 +346,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 +418,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 +709,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 +723,30 @@ 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-is-indent-available ()
+ "Check if sql-indent module is available."
+ (when (locate-library "sql-indent")
+ (fboundp 'sqlind-minor-mode)))
+
+(defun sql-indent-enable ()
+ "Enable `sqlind-minor-mode' if available and requested."
+ (when (sql-is-indent-available)
+ (sqlind-minor-mode (if sql-use-indent-support +1 -1))))
;; misc customization of sql.el behavior
@@ -759,16 +802,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 +835,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 +875,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 +1002,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 +1161,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 +1298,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 +2374,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.
@@ -2712,18 +2847,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
@@ -2760,8 +2929,8 @@ local variable."
(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)
@@ -2952,7 +3121,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 +3146,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 +3165,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))
@@ -3129,7 +3307,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,7 +3329,7 @@ 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
@@ -3198,6 +3376,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 +3419,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.
@@ -3439,15 +3647,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 +3753,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 +3817,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 +3832,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
@@ -4031,15 +4245,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)))))
@@ -4215,31 +4430,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 +4465,37 @@ 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)))
+
+ ;; 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))
@@ -4306,25 +4523,26 @@ the call to \\[sql-product-interactive] with
(<= 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 +4555,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 +4639,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 +5001,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
diff --git a/lisp/progmodes/subword.el b/lisp/progmodes/subword.el
index c09ba37c859..685e171dd64 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
@@ -267,9 +264,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 0d9322359c9..586d8cc0ed0 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 48dee4bef31..66577619028 100644
--- a/lisp/progmodes/verilog-mode.el
+++ b/lisp/progmodes/verilog-mode.el
@@ -3966,7 +3966,9 @@ Key bindings specific to `verilog-mode-map' are:
#'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
)
diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el
index a841f87f3c3..e17b7f504e9 100644
--- a/lisp/progmodes/vhdl-mode.el
+++ b/lisp/progmodes/vhdl-mode.el
@@ -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))
@@ -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)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/lisp/progmodes/which-func.el b/lisp/progmodes/which-func.el
index 152f6d22937..7604be0c25f 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,
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index abb2a93425d..c7ae40eb34e 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -503,8 +503,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 +542,11 @@ 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)
+ (let ((buffer (current-buffer))
+ (xref (or (xref--item-at-point)
(user-error "No reference at point"))))
- (xref--show-location (xref-item-location xref) (if quit 'quit t))))
+ (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."
@@ -876,6 +879,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
diff --git a/lisp/ps-bdf.el b/lisp/ps-bdf.el
index c8f88234a03..f9632f00133 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 9fbb83a74bc..d0cd7625a41 100644
--- a/lisp/ps-def.el
+++ b/lisp/ps-def.el
@@ -2,10 +2,10 @@
;; Copyright (C) 2007-2018 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 a102d974a46..ae2dd19d2fa 100644
--- a/lisp/ps-mule.el
+++ b/lisp/ps-mule.el
@@ -2,10 +2,10 @@
;; Copyright (C) 1998-2018 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
diff --git a/lisp/ps-print.el b/lisp/ps-print.el
index b1a911724f0..7dd1103c2e3 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 9c545ea8537..bd5fff8d8ec 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 b33f22d9598..e318486cded 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 ba13e123580..8ccf051ee18 100644
--- a/lisp/rect.el
+++ b/lisp/rect.el
@@ -604,6 +604,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 fa34e608592..e25f9fd5889 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 95097a4f1b7..4928dd9b202 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)
- (cdr (memq (car entry-key) precious))))
+ (cdr (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 940bf566509..00b2ceee356 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
@@ -1176,9 +1206,34 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]."
(move-to-column col)))))))
+(defun occur--parse-occur-buffer()
+ "Retrieve a list of the form (BEG END ORIG-LINE BUFFER).
+BEG and END define the region.
+ORIG-LINE and BUFFER are the line and the buffer from which
+the user called `occur'."
+ (save-excursion
+ (goto-char (point-min))
+ (let ((buffer (get-text-property (point) 'occur-title))
+ (beg-pos (get-text-property (point) 'region-start))
+ (end-pos (get-text-property (point) 'region-end))
+ (orig-line (get-text-property (point) 'current-line)))
+ (list beg-pos end-pos orig-line buffer))))
+
(defun occur-revert-function (_ignore1 _ignore2)
"Handle `revert-buffer' for Occur mode buffers."
- (apply 'occur-1 (append occur-revert-arguments (list (buffer-name)))))
+ (if (cdr (nth 2 occur-revert-arguments)) ; multi-occur
+ (apply 'occur-1 (append occur-revert-arguments (list (buffer-name))))
+ (pcase-let ((`(,region-start ,region-end ,orig-line ,buffer)
+ (occur--parse-occur-buffer))
+ (regexp (car occur-revert-arguments)))
+ (with-current-buffer buffer
+ (when (wholenump orig-line)
+ (goto-char (point-min))
+ (forward-line (1- orig-line)))
+ (save-excursion
+ (if (or region-start region-end)
+ (occur regexp nil (list (cons region-start region-end)))
+ (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 +1247,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 +1260,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 +1297,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 +1314,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))
@@ -1387,9 +1439,8 @@ invoke `occur'."
;; 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--region-start-line nil)
(defvar occur--orig-line nil)
-(defvar occur--orig-line-str nil)
(defvar occur--final-pos nil)
(defun occur (regexp &optional nlines region)
@@ -1442,17 +1493,15 @@ is not modified."
(or end (setq end (point-max))))
(let ((occur--region-start start)
(occur--region-end end)
- (occur--matches-threshold
+ (occur--region-start-line
(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))))
+ (line-number-at-pos (point))))
(save-excursion ; If no matches `occur-1' doesn't restore the point.
- (and in-region-p (narrow-to-region start end))
+ (and in-region-p (narrow-to-region
+ (save-excursion (goto-char start) (line-beginning-position))
+ (save-excursion (goto-char end) (line-end-position))))
(occur-1 regexp nlines (list (current-buffer)))
(and in-region-p (widen))))))
@@ -1550,7 +1599,7 @@ 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)
@@ -1618,36 +1667,34 @@ See also `multi-occur'."
(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)))
+ (in-region-p (and occur--region-start occur--region-end))
+ (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)
+ (or occur--region-start-line 1))
+ (orig-line (or occur--orig-line 1))
+ (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))
+ ;; 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.
@@ -1677,6 +1724,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 +1762,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 +1784,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,26 +1796,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 (- orig-line (or occur--region-start-line 1)))
+ (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)
- (>= 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
@@ -1765,29 +1831,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))
- (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 (- orig-line (or occur--region-start-line 1)))
+ (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))
@@ -1803,25 +1874,30 @@ See also `multi-occur'."
(if (= lines matches)
"" (format " in %d line%s"
lines
- (if (= lines 1) "" "s")))
+ (if (= lines 1) "" "s")))
;; 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)
- ""))
+ (if in-region-p
+ (format " within region: %d-%d"
+ occur--region-start
+ occur--region-end)
+ ""))
'read-only t))
(setq end (point))
- (add-text-properties beg end `(occur-title ,buf))
+ (add-text-properties beg end `(occur-title ,buf current-line ,orig-line
+ region-start ,occur--region-start
+ region-end ,occur--region-end))
(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))
@@ -1895,7 +1971,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
@@ -1905,13 +1982,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)
@@ -2184,9 +2280,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
@@ -2216,7 +2312,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
@@ -2277,7 +2376,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))))
@@ -2322,8 +2426,17 @@ 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) ")
+ (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.
@@ -2541,13 +2654,13 @@ It must return a string."
(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 " "")
- (if backward "backward " "")
from-string " with "
next-replacement ".\n\n"
(substitute-command-keys
diff --git a/lisp/reveal.el b/lisp/reveal.el
index 2831c0cc010..a3ecfc490e0 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 cf719966605..d6e9a1efae1 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 71ee0a13b90..ee2fca612f5 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-2018 Free Software Foundation, Inc.
@@ -43,9 +43,6 @@
;;; Code:
-(eval-when-compile
- (require 'cl))
-
(defmacro rtree-make-node ()
`(list (list nil) nil))
@@ -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 2e2a589ecf1..366bd150413 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
@@ -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 893590ce809..329929be515 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 b6a71166ffd..f8f15cabcd1 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 dea15d58d85..c32960efba9 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 dd4a8aab0e2..7efbfc77742 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 2ce0f4578bf..123fbb2b37b 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 698be837547..bd7fd0c1ffa 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 270eff55dcd..50684a20aaa 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."
@@ -263,8 +278,10 @@ changed while a server is running."
;; 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))
+ (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.")
@@ -523,13 +540,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
@@ -621,23 +638,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)))
@@ -754,9 +777,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
@@ -1068,9 +1088,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.
@@ -1084,7 +1103,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
@@ -1236,28 +1256,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
@@ -1269,16 +1290,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
@@ -1288,21 +1309,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
@@ -1318,9 +1347,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
@@ -1639,13 +1670,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")))))
diff --git a/lisp/ses.el b/lisp/ses.el
index 9097bf5d819..bcf8bdb6368 100644
--- a/lisp/ses.el
+++ b/lisp/ses.el
@@ -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)))
diff --git a/lisp/shadowfile.el b/lisp/shadowfile.el
index 27d934d9fce..180d5026b6e 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 5c228a5eba9..ac6f11aeb40 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.
@@ -315,6 +315,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.")
@@ -466,6 +468,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)
@@ -496,7 +500,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 +572,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)))
@@ -959,12 +965,8 @@ 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'."
@@ -1167,9 +1169,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 d5674aae9b4..e41630d4ed1 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
@@ -144,6 +122,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 +177,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 +234,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 +263,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 +271,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 +294,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 +307,51 @@ 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)
+ (next-error-found buffer (current-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)))
+ (next-error-found buffer (current-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 +362,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))))
@@ -327,7 +385,11 @@ 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))
+ (let ((display-buffer-overriding-action '(display-buffer-reuse-window)))
+ ;; Override user customization such as display-buffer-same-window
+ ;; and use display-buffer-reuse-window to ensure next-error-last-buffer
+ ;; is displayed somewhere, not necessarily in the same window (bug#32607).
+ (pop-to-buffer next-error-last-buffer)))
(defun previous-error-no-select (&optional n)
"Move point to the previous error in the `next-error' buffer and highlight match.
@@ -343,9 +405,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"
@@ -1103,6 +1163,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
@@ -1353,7 +1414,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'
@@ -1588,13 +1649,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)
@@ -1624,13 +1682,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))))
@@ -1847,11 +1902,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.
@@ -2941,7 +2993,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
@@ -2990,10 +3042,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.
@@ -3006,30 +3058,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
@@ -3142,61 +3202,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.
@@ -3296,6 +3301,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'."
@@ -3376,6 +3403,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.
@@ -3453,12 +3482,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
@@ -3466,24 +3494,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,
@@ -3502,12 +3528,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)
@@ -3539,14 +3564,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)))
@@ -3802,7 +3827,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"
@@ -3825,7 +3851,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)
@@ -3846,7 +3872,7 @@ 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.
@@ -3929,7 +3955,9 @@ 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)
("Command" 0 t)])
(make-local-variable 'process-menu-query-only)
@@ -4363,7 +4391,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)))
@@ -4372,9 +4401,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)))
@@ -4397,20 +4425,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.
@@ -4444,9 +4472,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"))
@@ -5683,22 +5715,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))
@@ -5710,10 +5743,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
@@ -5787,9 +5820,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
@@ -6824,12 +6854,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
@@ -7260,12 +7284,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
@@ -7380,9 +7398,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
@@ -7396,9 +7411,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
@@ -7416,9 +7428,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'
@@ -7426,27 +7435,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.
@@ -7859,7 +7856,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)
@@ -7877,6 +7874,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)))
@@ -8352,20 +8351,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))))
@@ -8520,13 +8517,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))
@@ -8652,9 +8652,6 @@ call `normal-erase-is-backspace-mode' (which see) instead."
(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
@@ -8731,9 +8728,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
@@ -8757,9 +8754,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."
@@ -8951,7 +8945,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)
@@ -8961,7 +8955,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 e3cebba9164..e7ac2ea32b2 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 7915a52df3a..f3ea048cb83 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.
@@ -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.
@@ -1476,9 +1466,10 @@ 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.
@@ -3018,13 +3009,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)))))))
@@ -4077,26 +4068,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 63b831ee38d..4eb71abaacf 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -63,6 +63,9 @@ string or function value that this variable has."
:version "23.1"
:group 'initialization)
+(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.
@@ -71,9 +74,6 @@ 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)
-
(defvar startup-screen-inhibit-startup-screen nil)
;; The mechanism used to ensure that only end users can disable this
@@ -120,18 +120,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 +314,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
@@ -789,7 +797,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 +886,92 @@ If STYLE is nil, display appropriately for the terminal."
(when standard-display-table
(aset standard-display-table char nil)))))))
+(defun 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 init-file-name 'noerror 'nomessage)
+
+ (when (and (eq user-init-file t) alternate-filename-function)
+ (load (funcall alternate-filename-function)
+ '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."
@@ -1029,6 +1123,78 @@ 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.
+ (load-user-init-file
+ (lambda ()
+ (expand-file-name
+ "early-init"
+ (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 +1262,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 +1294,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)))
+ (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 +1361,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
@@ -1890,7 +1903,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 +2519,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 +2537,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 6ffcff73c2f..d5c287c3419 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 59f6949b211..41dc9aa45f5 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)
@@ -223,7 +223,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))
@@ -359,6 +359,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.
@@ -548,13 +576,6 @@ 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))
-
(defun delete-dups (list)
"Destructively remove `equal' duplicates from LIST.
Store the result in LIST and return it. LIST must be a proper list.
@@ -680,20 +701,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.
@@ -705,17 +712,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)
@@ -724,16 +733,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.
@@ -1455,8 +1455,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")
@@ -1468,17 +1477,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.
@@ -1496,15 +1501,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,
@@ -1828,7 +1824,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)))
@@ -1844,27 +1840,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.")
@@ -1893,15 +1887,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'.
@@ -1917,17 +1918,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.
@@ -2177,19 +2212,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))))
@@ -2215,6 +2237,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.
@@ -2298,7 +2324,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
@@ -2324,7 +2350,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 ()
@@ -2339,7 +2365,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
@@ -2590,7 +2616,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.
@@ -2613,8 +2639,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
@@ -3063,6 +3089,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)
@@ -3553,9 +3581,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.
@@ -3612,6 +3662,119 @@ 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 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."
@@ -4253,14 +4416,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)
@@ -4539,25 +4712,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
@@ -4923,32 +5077,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.
+
+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 COUNT [RESULT]) MESSAGE BODY...)"
+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.
diff --git a/lisp/svg.el b/lisp/svg.el
index c0fa26ade03..1178905546a 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 8a816fd4441..3ad719d1932 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 07d902c1bb0..19e5159816a 100644
--- a/lisp/tar-mode.el
+++ b/lisp/tar-mode.el
@@ -265,11 +265,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
@@ -596,7 +595,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 +762,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 +904,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)
@@ -1283,8 +1279,8 @@ for this to be permanent."
;; 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)
+ (ash hibits -2)
+ (logior (ash (logand 3 hibits) 1)
(if (> (logand lobits 32768) 0) 1 0))
(logand 32767 lobits)
)))
diff --git a/lisp/term.el b/lisp/term.el
index ae451e94bd6..9f8f1f703a6 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-2018 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.
;;
;; ----------------------------------------
;;
@@ -396,21 +392,14 @@ 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.
@@ -597,9 +586,6 @@ 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 +743,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
@@ -1084,8 +1064,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 +1076,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)
@@ -2244,6 +2216,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 +2676,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 +2686,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 +2723,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 +2773,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 +2780,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 +2845,220 @@ 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)))
+ (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-hook
+ (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)))
+ (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 ctl-end)))))
(when (>= (term-current-row) term-height)
(term-handle-deferred-scroll))
@@ -3388,86 +3291,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 +3373,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 +3386,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)
@@ -3685,7 +3575,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))
@@ -3863,7 +3753,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))))
diff --git a/lisp/term/common-win.el b/lisp/term/common-win.el
index 5df635a145d..a482067ef39 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 2cf560694c6..0cdf0c1a7c3 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 76b1a414560..8b23cab0100 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 ()
@@ -556,8 +553,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 +573,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)
@@ -739,6 +743,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 +809,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 62734d9cfe4..e0e412e1626 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 b3e70f3107b..34ed492c872 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 a776c830a25..d9b272693b0 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 97687894ec6..0c4b0ae73b6 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 d40c550aff4..b61e557e2f8 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 ed76490751e..dc57160d04f 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 e3196ab84e3..f169b27bc47 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 9209a76fcdc..00747afbdce 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,24 @@ 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 (float-time)))
+ (or (let ((inhibit-redisplay t))
+ (read-event nil nil xterm-query-redisplay-timeout))
+ (read-event nil nil
+ (and xterm-query-timeout
+ (max 0 (+ start-time xterm-query-timeout
+ (- (float-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 +807,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 +870,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 +892,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 +906,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 +1009,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 af7bcc77cdf..940a78ae92d 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 ()
diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el
index 6294b8026ce..57e5ef8017a 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.
diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el
index 62dca463ae3..31ce638b316 100644
--- a/lisp/textmodes/css-mode.el
+++ b/lisp/textmodes/css-mode.el
@@ -32,12 +32,14 @@
;;; Code:
-(require 'eww)
(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
@@ -808,6 +810,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'.")
@@ -898,7 +901,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 "\\)\\|"
@@ -938,11 +941,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)
@@ -952,11 +957,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)
@@ -968,7 +973,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.
@@ -1039,9 +1048,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.
@@ -1203,7 +1218,8 @@ for determining whether point is within a selector."
(pcase (cons kind token)
(`(:elem . basic) css-indent-offset)
(`(:elem . arg) 0)
- (`(:list-intro . ,(or `";" `"")) t) ;"" stands for BOB (bug#15467).
+ ;; "" stands for BOB (bug#15467).
+ (`(:list-intro . ,(or `";" `"" `":-property")) t)
(`(:before . "{")
(when (or (smie-rule-hanging-p) (smie-rule-bolp))
(smie-backward-sexp ";")
@@ -1385,6 +1401,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 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).
@@ -1423,7 +1604,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)
@@ -1520,12 +1707,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 7223d525fa2..87ae35d17be 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)
diff --git a/lisp/textmodes/enriched.el b/lisp/textmodes/enriched.el
index b9d247132dc..f2065cbff90 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 8422f0e1dd2..08e975f2355 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 4d7a18969e6..37f2245eded 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
@@ -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 e77bc7e1128..87bcb5d651a 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)
@@ -814,16 +817,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))
@@ -1180,6 +1173,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.
@@ -1202,9 +1201,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.
@@ -1412,80 +1413,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))
;;; **********************************************************************
@@ -1827,11 +1826,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)
@@ -3705,9 +3702,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/mhtml-mode.el b/lisp/textmodes/mhtml-mode.el
index b99f788156c..552fcd38b04 100644
--- a/lisp/textmodes/mhtml-mode.el
+++ b/lisp/textmodes/mhtml-mode.el
@@ -22,6 +22,7 @@
;;; Code:
(eval-and-compile
+ (require 'cl-lib)
(require 'flyspell)
(require 'sgml-mode))
(require 'js)
@@ -364,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 9c846292f1e..51a9f5820d8 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 61f02190065..92fce4d364b 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-2018 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 3e2784ca953..ee812566b9a 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/refill.el b/lisp/textmodes/refill.el
index 1252afe4172..229d6a24ddd 100644
--- a/lisp/textmodes/refill.el
+++ b/lisp/textmodes/refill.el
@@ -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-ref.el b/lisp/textmodes/reftex-ref.el
index 98fb8f5d700..eb8d98c84be 100644
--- a/lisp/textmodes/reftex-ref.el
+++ b/lisp/textmodes/reftex-ref.el
@@ -314,7 +314,7 @@ also applies `reftex-translate-to-ascii-function' to the string."
(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 11dbb8d5705..e7fe8ffe660 100644
--- a/lisp/textmodes/reftex-vars.el
+++ b/lisp/textmodes/reftex-vars.el
@@ -1030,7 +1030,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 +1042,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 7f4c9b0b24a..83bfc79d6a4 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 b1b4f1073eb..126804fdab2 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)
@@ -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 eb6ebf52807..470f4a348ac 100644
--- a/lisp/textmodes/sgml-mode.el
+++ b/lisp/textmodes/sgml-mode.el
@@ -76,6 +76,8 @@ a DOCTYPE or an XML declaration."
:version "22.1"
:group 'sgml)
+(defvaralias 'sgml-transformation 'sgml-transformation-function)
+
(defcustom sgml-transformation-function 'identity
"Default value for `skeleton-transformation-function' in SGML mode."
:type 'function
@@ -92,7 +94,6 @@ a DOCTYPE or an XML declaration."
(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'.
@@ -618,7 +619,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 `/'.
@@ -940,9 +941,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 +1239,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 +1251,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)
@@ -2232,6 +2242,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,9 +2376,6 @@ 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
diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el
index c65b3b3ea2d..c223af47697 100644
--- a/lisp/textmodes/tex-mode.el
+++ b/lisp/textmodes/tex-mode.el
@@ -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
diff --git a/lisp/textmodes/texinfmt.el b/lisp/textmodes/texinfmt.el
index d6f451a1ab5..e89da6527cb 100644
--- a/lisp/textmodes/texinfmt.el
+++ b/lisp/textmodes/texinfmt.el
@@ -2447,7 +2447,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 c2ceee6e6b7..ff723a4fb94 100644
--- a/lisp/textmodes/texinfo.el
+++ b/lisp/textmodes/texinfo.el
@@ -596,9 +596,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 +610,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.
diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el
index 79f0230a20a..5f9de9abbb2 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
@@ -552,6 +562,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..7974a2603cb
--- /dev/null
+++ b/lisp/thread.el
@@ -0,0 +1,200 @@
+;;; thread.el --- Thread support in Emacs Lisp -*- lexical-binding: t -*-
+
+;; Copyright (C) 2018 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 26c9935429f..067a32ba575 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 9e7bd08b85a..bfecba9f9dd 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,16 @@ 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))))
- (let ((start-time (current-time)))
+ (< 1200 (- (float-time now)
+ display-time-server-down-time))))
+ (let ((start-time (float-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 (float-time)))
+ (and (< 20 (- end-time start-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 +472,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
@@ -585,7 +572,7 @@ For example, the Unix uptime command format is \"%D, %z%2h:%.2m\"."
(let ((str
(format-seconds (or format "%Y, %D, %H, %M, %z%S")
(float-time
- (time-subtract (current-time) before-init-time)))))
+ (time-subtract nil before-init-time)))))
(if (called-interactively-p 'interactive)
(message "%s" str)
str)))
diff --git a/lisp/tool-bar.el b/lisp/tool-bar.el
index 18f54dbac60..e2242cf6f7e 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 ac26f86ac9d..384d3d19db3 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.
@@ -347,7 +356,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/type-break.el b/lisp/type-break.el
index 2c928e9db1e..c7cdc460369 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."
@@ -563,7 +554,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 +615,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 +676,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)
diff --git a/lisp/url/url-auth.el b/lisp/url/url-auth.el
index 4f7b5446743..401baece838 100644
--- a/lisp/url/url-auth.el
+++ b/lisp/url/url-auth.el
@@ -192,9 +192,11 @@ 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))
+ (apply #'format "%016x%08x%08x" (random)
+ (read (format-time-string "(%s %N)")))
+ 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 632a34cdd9d..3765d9dc93d 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."
@@ -206,7 +206,7 @@ If `url-standalone-mode' is non-nil, cached items never expire."
(time-add
cache-time
(seconds-to-time (or expire-time url-cache-expire-time)))
- (current-time))))))
+ nil)))))
(defun url-cache-prune-cache (&optional directory)
"Remove all expired files from the cache.
@@ -226,7 +226,7 @@ considered \"expired\"."
(setq deleted-files (1+ deleted-files))))
((time-less-p
(time-add
- (nth 5 (file-attributes file))
+ (file-attribute-modification-time (file-attributes file))
(seconds-to-time url-cache-expire-time))
now)
(delete-file file)
diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el
index 8b676f037c6..3adca26d76f 100644
--- a/lisp/url/url-cookie.el
+++ b/lisp/url/url-cookie.el
@@ -74,6 +74,55 @@ 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]"
+ (seconds-to-time
+ (let ((s (string-to-number (nth 4 fields))))
+ (if (and (= s 0) long-session)
+ (seconds-to-time (+ (* 365 24 60 60) (float-time)))
+ 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 +139,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 +395,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 +406,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 +421,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 +432,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 +464,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-dired.el b/lisp/url/url-dired.el
index 784f70eb1f3..50d84f71ccd 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 4fac4060237..02542ccbccc 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-2018 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-handlers.el b/lisp/url/url-handlers.el
index 1fe0af65ff2..3802c39b785 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,6 +42,9 @@
(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-decode loads mm-bodies, which loads mm-util.
+(declare-function mm-charset-to-coding-system "mm-util"
+ (charset &optional lbt allow-override silent))
;; Implementation status
;; ---------------------
@@ -98,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
@@ -183,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)
@@ -228,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 aed0efab01a..6b5749e1bce 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)
@@ -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
@@ -623,6 +651,12 @@ 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)
+ (`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
@@ -1258,7 +1292,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 +1328,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,7 +1347,8 @@ 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)
@@ -1375,7 +1412,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 +1602,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-queue.el b/lisp/url/url-queue.el
index cd30d94a72b..cfa8e9affe0 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,11 +148,14 @@ 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)
diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el
index 85bfb65cb68..ffae984941e 100644
--- a/lisp/url/url-util.el
+++ b/lisp/url/url-util.el
@@ -627,6 +627,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 62abcffe393..ef990a75883 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 20c57115426..ea581010178 100644
--- a/lisp/url/url.el
+++ b/lisp/url/url.el
@@ -259,8 +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))
+ (< (float-time (time-subtract nil start-time))
timeout)))
(url-debug 'retrieval
"Spinning in url-retrieve-synchronously: %S (%S)"
diff --git a/lisp/userlock.el b/lisp/userlock.el
index 5ba971ba6c8..73bb0d2aae0 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
diff --git a/lisp/vc/add-log.el b/lisp/vc/add-log.el
index cbfd10affd1..d6e85408608 100644
--- a/lisp/vc/add-log.el
+++ b/lisp/vc/add-log.el
@@ -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/diff-mode.el b/lisp/vc/diff-mode.el
index 7db5ca9b259..6c189c13cd4 100644
--- a/lisp/vc/diff-mode.el
+++ b/lisp/vc/diff-mode.el
@@ -66,14 +66,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,19 +80,26 @@ 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-font-lock-refine t
+ "If non-nil, font-lock highlighting includes hunk refinement."
+ :version "27.1"
+ :type 'boolean)
+
+(defcustom diff-font-lock-prettify nil
+ "If non-nil, font-lock will try and make the format prettier."
+ :version "27.1"
+ :type 'boolean)
(defvar diff-vc-backend nil
"The VC backend that created the current Diff buffer, if any.")
@@ -207,8 +212,7 @@ 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))
@@ -216,9 +220,6 @@ when editing big diffs)."
(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.
Diff Auto Refine mode is a buffer-local minor mode used with
`diff-mode'. When enabled, Emacs automatically highlights
@@ -241,8 +242,7 @@ well."
(((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))
@@ -252,18 +252,15 @@ well."
(((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
@@ -274,8 +271,7 @@ well."
: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
@@ -286,40 +282,34 @@ well."
: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))
"`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))
"`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))
"`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))
@@ -327,13 +317,11 @@ well."
(((class color grayscale) (min-colors 88) (background dark))
:foreground "#dddddd"))
"`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)
@@ -412,7 +400,9 @@ and the face `diff-added' for added lines.")
("^\\(#\\)\\(.*\\)"
(1 font-lock-comment-delimiter-face)
(2 font-lock-comment-face))
- ("^[^-=+*!<>#].*\n" (0 'diff-context))))
+ ("^[^-=+*!<>#].*\n" (0 'diff-context))
+ (,#'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)))
@@ -891,7 +881,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))
@@ -1387,12 +1377,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 +1390,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,7 +1405,7 @@ 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)
@@ -1424,19 +1414,16 @@ a diff with \\[diff-reverse-direction].
;;;###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 +1450,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."
@@ -1693,7 +1680,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))))
@@ -1874,11 +1861,13 @@ then `diff-jump-to-old-file' is also set, for the next invocations."
;; 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)))
+ (rev (not (save-excursion (beginning-of-line) (looking-at "[-<]")))))
(pcase-let ((`(,buf ,line-offset ,pos ,src ,_dst ,switched)
(diff-find-source-location other-file rev)))
(pop-to-buffer buf)
(goto-char (+ (car pos) (cdr src)))
+ (when buffer (next-error-found buffer (current-buffer)))
(diff-hunk-status-msg line-offset (diff-xor rev switched) t))))
@@ -1968,8 +1957,7 @@ 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
@@ -1979,7 +1967,6 @@ For use in `add-log-current-defun-function'."
(((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
@@ -1990,7 +1977,6 @@ For use in `add-log-current-defun-function'."
(((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 +2003,99 @@ 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)
-
- (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)))))))))
+ (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 "^---")))
+ (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--font-lock-refined (max)
+ "Apply hunk refinement from font-lock."
+ (when diff-font-lock-refine
+ (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)))
+ (let* ((min (point))
+ (beg (or (ignore-errors (diff-beginning-of-hunk))
+ (ignore-errors (diff-hunk-next) (point))
+ max)))
+ (while (< beg max)
+ (let ((end
+ (save-excursion (goto-char beg) (diff-end-of-hunk) (point))))
+ (if (< end min) (setq beg min))
+ (unless (or (< end beg)
+ (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 'evaporate t)
+ (overlay-put ol 'modification-hooks
+ '(diff--font-lock-refine--refresh))))
+ (goto-char (max beg end))
+ (setq beg (or (ignore-errors (diff-hunk-next) (point)) max)))))))
+
+(defun diff--font-lock-refine--refresh (ol _after _beg _end &optional _len)
+ (delete-overlay ol))
(defun diff-undo (&optional arg)
"Perform `undo', ignoring the buffer's read-only status."
@@ -2175,6 +2201,83 @@ fixed, visit it in a buffer."
modified-buffers ", "))
(message "No trailing whitespace to delete.")))))
+
+;;; Prettifying from font-lock
+
+(defun diff--font-lock-prettify (limit)
+ ;; Mimicks the output of Magit's diff.
+ ;; FIXME: This has only been tested with Git's diff output.
+ (when diff-font-lock-prettify
+ (while (re-search-forward "^diff " limit t)
+ (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)
+
+;;; 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) (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 b850350cd8a..ac94586cace 100644
--- a/lisp/vc/diff.el
+++ b/lisp/vc/diff.el
@@ -226,8 +226,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-merg.el b/lisp/vc/ediff-merg.el
index ad72d7570c5..b67f520ca07 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-util.el b/lisp/vc/ediff-util.el
index 8670ba4603f..b1652e7efd4 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)
@@ -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 079e195291d..0535aa67253 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 cd2b2c4e628..32a6820fe7d 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 438ef117da6..90860fbdcfe 100644
--- a/lisp/vc/log-edit.el
+++ b/lisp/vc/log-edit.el
@@ -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
;;;
@@ -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/pcvs-info.el b/lisp/vc/pcvs-info.el
index 7e727670554..2947733a24a 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."
@@ -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 8db2fe5e836..dbd25d93a1e 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 5515e0cd608..501666a4997 100644
--- a/lisp/vc/pcvs.el
+++ b/lisp/vc/pcvs.el
@@ -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))
diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el
index ea99d31e898..ff41473435c 100644
--- a/lisp/vc/smerge-mode.el
+++ b/lisp/vc/smerge-mode.el
@@ -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
@@ -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)
diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el
index 630932fe371..8e1a6bec203 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)
@@ -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)
diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el
index 54ece6cc264..ac98d996d2c 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 ")
@@ -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)
@@ -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)
@@ -1174,7 +1177,7 @@ 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))
diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el
index 0cd05b943ec..18da6e33578 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 b0d2221b255..da9d34644cd 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 ad806b38545..4ea7ea53442 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -102,8 +102,7 @@
(eval-when-compile
(require 'cl-lib)
(require 'vc)
- (require 'vc-dir)
- (require 'grep))
+ (require 'vc-dir))
(defgroup vc-git nil
"VC Git backend."
@@ -180,9 +179,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)
@@ -364,8 +375,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
@@ -863,6 +874,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.
@@ -1373,6 +1386,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 +1413,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 +1440,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 +1450,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))
@@ -1462,12 +1480,27 @@ This command shares argument histories with \\[rgrep] and \\[grep]."
(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 (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,16 +1510,22 @@ 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)
@@ -1555,7 +1594,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))
@@ -1582,8 +1628,15 @@ 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 "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 08b1be8f6d3..36965735959 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
@@ -175,6 +175,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 +583,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 +626,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 +833,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 +897,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,7 +914,7 @@ FILENAME must be the file's true absolute name."
(setf ignored (string-match (pop patterns) filename)))
ignored))
-(defun vc-hg--time-to-fixnum (ts)
+(defun vc-hg--time-to-integer (ts)
(+ (* 65536 (car ts)) (cadr ts)))
(defvar vc-hg--cached-ignore-patterns nil
@@ -967,8 +968,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 +1012,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 +1036,9 @@ 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 (vc-hg--time-to-integer
+ (file-attribute-modification-time stat))))
(if (and (eql vc-hg-size fs-size) (eql vc-hg-mtime fs-mtime))
'up-to-date
'edited)))
diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el
index 55c0132bf2b..84e11f2e01d 100644
--- a/lisp/vc/vc-hooks.el
+++ b/lisp/vc/vc-hooks.el
@@ -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)
diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el
index 9fa52bf5dce..51a44439625 100644
--- a/lisp/vc/vc-rcs.el
+++ b/lisp/vc/vc-rcs.el
@@ -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 2cbf34ba43a..4b1a34bd5f8 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 "-".
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index 41a76e0007e..6962664d59f 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -729,13 +729,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]."
@@ -1488,7 +1481,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 +1536,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."
@@ -1565,7 +1558,8 @@ Runs the normal hooks `vc-before-checkin-hook' and `vc-checkin-hook'."
(vc-call-backend backend 'checkin files comment rev)
(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 +1643,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.
@@ -2280,11 +2269,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.
@@ -2295,7 +2284,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)
@@ -2421,11 +2410,13 @@ When called interactively with a prefix argument, prompt for REMOTE-LOCATION."
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)
@@ -2578,7 +2569,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
diff --git a/lisp/vcursor.el b/lisp/vcursor.el
index 89743304526..ce7a895a62c 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 3a38b1d83c8..84919308191 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")
diff --git a/lisp/view.el b/lisp/view.el
index cc328680e2e..56f98a6db23 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 9b9d3ce9adc..91fe5186bc9 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 3531b94f15f..44f9b7670db 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 99465212bc5..3157e887d77 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 e78962201b2..d8249316e4b 100644
--- a/lisp/whitespace.el
+++ b/lisp/whitespace.el
@@ -2,8 +2,8 @@
;; Copyright (C) 2000-2018 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
diff --git a/lisp/wid-browse.el b/lisp/wid-browse.el
index db2be0cc905..d86e9cd2e27 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/windmove.el b/lisp/windmove.el
index db77d810e05..f5650684097 100644
--- a/lisp/windmove.el
+++ b/lisp/windmove.el
@@ -543,16 +543,18 @@ 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 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 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))
(provide 'windmove)
diff --git a/lisp/window.el b/lisp/window.el
index 818bd3dd2bd..0a42dae6ca8 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -3084,11 +3084,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 +3114,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)))
@@ -6642,6 +6644,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
@@ -6655,7 +6658,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.
@@ -7310,12 +7312,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.
@@ -7381,6 +7394,17 @@ below the selected one, use that window."
(window--display-buffer
buffer window 'reuse alist display-buffer-mark-dedicated)))))
+(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.
This either reuses such a window provided it shows BUFFER
@@ -7397,8 +7421,8 @@ 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))
@@ -8770,7 +8794,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)
@@ -8781,15 +8805,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)
@@ -8927,35 +8951,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.
@@ -8963,15 +8969,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.")
diff --git a/lisp/winner.el b/lisp/winner.el
index 72b90b0e43c..5e13a378a71 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 533f14674ab..238a7d389c4 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))
@@ -2071,14 +2071,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
@@ -3663,46 +3663,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 fe2202cfc68..080cd4d13f3 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 96c43dea172..f8183249d5a 100644
--- a/lisp/xdg.el
+++ b/lisp/xdg.el
@@ -34,6 +34,7 @@
;;; Code:
(eval-when-compile
+ (require 'cl-lib)
(require 'subr-x))
@@ -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 3bc8c08cb7b..6ce944ccb82 100644
--- a/lisp/xml.el
+++ b/lisp/xml.el
@@ -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 8fb65d5bfa7..da4af32e5e9 100644
--- a/lisp/xt-mouse.el
+++ b/lisp/xt-mouse.el
@@ -312,9 +312,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 6bd26083816..ed71270a771 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/lwlib/lwlib-Xaw.h b/lwlib/lwlib-Xaw.h
index 363334b575e..644676f320d 100644
--- a/lwlib/lwlib-Xaw.h
+++ b/lwlib/lwlib-Xaw.h
@@ -15,15 +15,13 @@ void
xaw_update_one_widget (widget_instance *, Widget, widget_value *, Boolean);
void
-xaw_update_one_value (widget_instance *, Widget, widget_value *)
- ATTRIBUTE_CONST;
+xaw_update_one_value (widget_instance *, Widget, widget_value *);
void
xaw_destroy_instance (widget_instance *);
void
-xaw_popup_menu (Widget, XEvent *)
- ATTRIBUTE_CONST;
+xaw_popup_menu (Widget, XEvent *);
void
xaw_pop_instance (widget_instance *, Boolean);
diff --git a/lwlib/lwlib-Xlw.h b/lwlib/lwlib-Xlw.h
index 2d38eb7be66..b0790dc3a59 100644
--- a/lwlib/lwlib-Xlw.h
+++ b/lwlib/lwlib-Xlw.h
@@ -15,15 +15,13 @@ xlw_update_one_widget (widget_instance* instance, Widget widget,
void
xlw_update_one_value (widget_instance* instance, Widget widget,
- widget_value* val)
- ATTRIBUTE_CONST;
+ widget_value* val);
void
xlw_destroy_instance (widget_instance* instance);
void
-xlw_pop_instance (widget_instance* instance, Boolean up)
- ATTRIBUTE_CONST;
+xlw_pop_instance (widget_instance* instance, Boolean up);
void
xlw_popup_menu (Widget widget, XEvent * event);
diff --git a/lwlib/lwlib.h b/lwlib/lwlib.h
index 66730fd8d77..41d3e0139d2 100644
--- a/lwlib/lwlib.h
+++ b/lwlib/lwlib.h
@@ -111,15 +111,9 @@ void lw_refigure_widget (Widget w, Boolean doit);
Boolean lw_window_is_in_menubar (Window win, Widget menubar_widget);
/* Manage resizing: TRUE permits resizing widget w; FALSE disallows it. */
-#ifndef USE_MOTIF
-ATTRIBUTE_CONST
-#endif
void lw_allow_resizing (Widget w, Boolean flag);
/* Set up the main window. */
-#ifndef USE_MOTIF
-ATTRIBUTE_CONST
-#endif
void lw_set_main_areas (Widget parent,
Widget menubar,
Widget work_area);
diff --git a/m4/builtin-expect.m4 b/m4/builtin-expect.m4
new file mode 100644
index 00000000000..a1eaf965b45
--- /dev/null
+++ b/m4/builtin-expect.m4
@@ -0,0 +1,49 @@
+dnl Check for __builtin_expect.
+
+dnl Copyright 2016-2018 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
index ccff0e6e8a2..9282cee58e9 100644
--- a/m4/c-strtod.m4
+++ b/m4/c-strtod.m4
@@ -1,4 +1,4 @@
-# c-strtod.m4 serial 15
+# c-strtod.m4 serial 16
# Copyright (C) 2004-2006, 2009-2018 Free Software Foundation, Inc.
# This file is free software; the Free Software Foundation
@@ -37,7 +37,34 @@ dnl Prerequisites of lib/c-strtod.c.
AC_DEFUN([gl_C_STRTOD],
[
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
- AC_CHECK_FUNCS([strtod_l])
+
+ AC_CHECK_HEADERS_ONCE([xlocale.h])
+ dnl We can't use AC_CHECK_FUNC here, because strtod_l() is defined as a
+ dnl static inline function when compiling for Android 7.1 or older.
+ AC_CACHE_CHECK([for strtod_l], [gl_cv_func_strtod_l],
+ [AC_LINK_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <stdlib.h>
+ #include <locale.h>
+ #if HAVE_XLOCALE_H
+ # include <xlocale.h>
+ #endif
+ locale_t loc;
+ ]],
+ [[char *end;
+ return strtod_l("0",&end,loc) < 0.0;
+ ]])
+ ],
+ [gl_cv_func_strtod_l=yes],
+ [gl_cv_func_strtod_l=no])
+ ])
+ if test $gl_cv_func_strtod_l = yes; then
+ HAVE_STRTOD_L=1
+ else
+ HAVE_STRTOD_L=0
+ fi
+ AC_DEFINE_UNQUOTED([HAVE_STRTOD_L], [$HAVE_STRTOD_L],
+ [Define to 1 if the system has the 'strtod_l' function.])
])
dnl Prerequisites of lib/c-strtold.c.
diff --git a/m4/eealloc.m4 b/m4/eealloc.m4
new file mode 100644
index 00000000000..a5a4e267d8e
--- /dev/null
+++ b/m4/eealloc.m4
@@ -0,0 +1,31 @@
+# eealloc.m4 serial 3
+dnl Copyright (C) 2003, 2009-2018 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/extensions.m4 b/m4/extensions.m4
index d1b23215b05..71a854f8bfa 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-2018 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 da8a2cc01c7..3661cbda5ed 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/fsusage.m4 b/m4/fsusage.m4
new file mode 100644
index 00000000000..f9dfbcb7a04
--- /dev/null
+++ b/m4/fsusage.m4
@@ -0,0 +1,336 @@
+# serial 32
+# Obtaining file system usage information.
+
+# Copyright (C) 1997-1998, 2000-2001, 2003-2018 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_MSG_CHECKING([for two-argument statfs with statfs.f_frsize member])
+AC_CACHE_VAL([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])])
+AC_MSG_RESULT([$fu_cv_sys_stat_statfs2_frsize])
+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_MSG_CHECKING([for 3-argument statfs function (DEC OSF/1)])
+ AC_CACHE_VAL([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])])
+ AC_MSG_RESULT([$fu_cv_sys_stat_statfs3_osf1])
+ 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_MSG_CHECKING([for two-argument statfs with statfs.f_bsize dnl
+member (AIX, 4.3BSD)])
+ AC_CACHE_VAL([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])])
+ AC_MSG_RESULT([$fu_cv_sys_stat_statfs2_bsize])
+ 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, AIX PS/2)])
+ fi
+fi
+
+if test $ac_fsusage_space = no; then
+ # SVR3
+ # (Solaris already handled above.)
+ AC_MSG_CHECKING([for four-argument statfs (AIX-3.2.5, SVR3)])
+ AC_CACHE_VAL([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])])
+ AC_MSG_RESULT([$fu_cv_sys_stat_statfs4])
+ 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, Dynix, old Irix, old AIX, Dolphin)])
+ 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_MSG_CHECKING([for two-argument statfs with statfs.f_fsize dnl
+member (4.4BSD and NetBSD)])
+ AC_CACHE_VAL([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])])
+ AC_MSG_RESULT([$fu_cv_sys_stat_statfs2_fsize])
+ 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
+
+if test $ac_fsusage_space = no; then
+ # Ultrix
+ AC_MSG_CHECKING([for two-argument statfs with struct fs_data (Ultrix)])
+ AC_CACHE_VAL([fu_cv_sys_stat_fs_data],
+ [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
+#ifdef HAVE_SYS_FS_TYPES_H
+#include <sys/fs_types.h>
+#endif
+ int
+ main ()
+ {
+ struct fs_data fsd;
+ /* Ultrix's statfs returns 1 for success,
+ 0 for not mounted, -1 for failure. */
+ return statfs (".", &fsd) != 1;
+ }]])],
+ [fu_cv_sys_stat_fs_data=yes],
+ [fu_cv_sys_stat_fs_data=no],
+ [fu_cv_sys_stat_fs_data=no])])
+ AC_MSG_RESULT([$fu_cv_sys_stat_fs_data])
+ if test $fu_cv_sys_stat_fs_data = yes; then
+ ac_fsusage_space=yes
+ AC_DEFINE([STAT_STATFS2_FS_DATA], [1],
+[ Define if statfs takes 2 args and the second argument has
+ type struct fs_data. (Ultrix)])
+ 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_MSG_CHECKING([for statfs that truncates block counts])
+ AC_CACHE_VAL([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
+ AC_MSG_RESULT([$fu_cv_sys_truncating_statfs])
+])
+
+
+# Prerequisites of lib/fsusage.c not done by gl_FILE_SYSTEM_USAGE.
+AC_DEFUN([gl_PREREQ_FSUSAGE_EXTRA],
+[
+ AC_CHECK_HEADERS([dustat.h sys/fs/s5param.h sys/statfs.h])
+ gl_STATFS_TRUNCATES
+])
diff --git a/m4/getloadavg.m4 b/m4/getloadavg.m4
index acc266531ed..c9f5a6da5df 100644
--- a/m4/getloadavg.m4
+++ b/m4/getloadavg.m4
@@ -7,7 +7,7 @@
# 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/glibc21.m4 b/m4/glibc21.m4
new file mode 100644
index 00000000000..126aa1a959e
--- /dev/null
+++ b/m4/glibc21.m4
@@ -0,0 +1,34 @@
+# glibc21.m4 serial 5
+dnl Copyright (C) 2000-2002, 2004, 2008, 2010-2018 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 de65f6b82e8..5f07855acf1 100644
--- a/m4/gnulib-common.m4
+++ b/m4/gnulib-common.m4
@@ -1,4 +1,4 @@
-# gnulib-common.m4 serial 38
+# gnulib-common.m4 serial 39
dnl Copyright (C) 2007-2018 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -72,6 +72,13 @@ 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
])
dnl Preparation for running test programs:
dnl Tell glibc to write diagnostics from -D_FORTIFY_SOURCE=2 to stderr, not
@@ -347,16 +354,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
diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4
index e30ff1f828f..61aabaa3427 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:
@@ -89,6 +90,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,6 +102,7 @@ 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:
@@ -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:
@@ -258,6 +262,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 +298,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 +360,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,6 +432,7 @@ 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
@@ -440,6 +456,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
@@ -643,6 +666,9 @@ AC_DEFUN([gl_INIT],
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 $HAVE_DECL_STRTOIMAX = 0 || test $REPLACE_STRTOIMAX = 1; } && test $ac_cv_type_long_long_int = yes; then
func_gl_gnulib_m4code_strtoll
fi
@@ -651,6 +677,7 @@ 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])
@@ -866,6 +893,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,6 +916,7 @@ 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
@@ -913,6 +943,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
@@ -969,6 +1005,7 @@ AC_DEFUN([gl_FILE_LIST], [
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
@@ -980,6 +1017,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
@@ -998,6 +1036,7 @@ AC_DEFUN([gl_FILE_LIST], [
m4/fpending.m4
m4/fpieee.m4
m4/fstatat.m4
+ m4/fsusage.m4
m4/fsync.m4
m4/getdtablesize.m4
m4/getgroups.m4
@@ -1006,8 +1045,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 +1058,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 +1077,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/ieee754-h.m4 b/m4/ieee754-h.m4
new file mode 100644
index 00000000000..bf7c332e48e
--- /dev/null
+++ b/m4/ieee754-h.m4
@@ -0,0 +1,21 @@
+# Configure ieee754-h module
+
+dnl Copyright 2018 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 8069493cab5..d756f012f6a 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-2018 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 511dcef5e04..3a2cd91ead0 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/lstat.m4 b/m4/lstat.m4
index ac6f143ce7d..3694e4ceaf7 100644
--- a/m4/lstat.m4
+++ b/m4/lstat.m4
@@ -1,4 +1,4 @@
-# serial 31
+# serial 32
# Copyright (C) 1997-2001, 2003-2018 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 dda3d468aef..516c5874765 100644
--- a/m4/manywarnings.m4
+++ b/m4/manywarnings.m4
@@ -1,4 +1,4 @@
-# manywarnings.m4 serial 13
+# manywarnings.m4 serial 16
dnl Copyright (C) 2008-2018 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -106,18 +106,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 +124,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 +160,7 @@ m4_defun([gl_MANYWARN_ALL_GCC(C)],
-Wframe-address \
-Wfree-nonheap-object \
-Whsa \
+ -Wif-not-aligned \
-Wignored-attributes \
-Wignored-qualifiers \
-Wimplicit \
@@ -173,7 +174,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 +181,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 +189,7 @@ m4_defun([gl_MANYWARN_ALL_GCC(C)],
-Wmissing-parameter-type \
-Wmissing-prototypes \
-Wmultichar \
+ -Wmultistatement-macros \
-Wnarrowing \
-Wnested-externs \
-Wnonnull \
@@ -202,6 +204,7 @@ m4_defun([gl_MANYWARN_ALL_GCC(C)],
-Woverride-init \
-Wpacked \
-Wpacked-bitfield-compat \
+ -Wpacked-not-aligned \
-Wparentheses \
-Wpointer-arith \
-Wpointer-compare \
@@ -219,20 +222,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..004aa0d17c8
--- /dev/null
+++ b/m4/mbstate_t.m4
@@ -0,0 +1,41 @@
+# mbstate_t.m4 serial 13
+dnl Copyright (C) 2000-2002, 2008-2018 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/nocrash.m4 b/m4/nocrash.m4
index 87b2d4cbf69..49140074d08 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-2018 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/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 edf4d828209..5cd1e044fc9 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-2018 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 a33b433c0ef..585b80a40ff 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/readlink.m4 b/m4/readlink.m4
index 9d73f5cfa18..4d0ab4836b0 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-2018 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..055d71b5aaa
--- /dev/null
+++ b/m4/regex.m4
@@ -0,0 +1,300 @@
+# serial 67
+
+# Copyright (C) 1996-2001, 2003-2018 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;
+
+#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/stddef_h.m4 b/m4/stddef_h.m4
index ba3d201cf37..07b040abdf1 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-2018 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 b86184c2ea6..38dbbedffec 100644
--- a/m4/stdint.m4
+++ b/m4/stdint.m4
@@ -1,4 +1,4 @@
-# stdint.m4 serial 51
+# stdint.m4 serial 52
dnl Copyright (C) 2001-2018 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -364,8 +364,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])
diff --git a/m4/stdio_h.m4 b/m4/stdio_h.m4
index e06461e6934..0debe69e92d 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-2018 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 eff6f9e685b..49dc5d59cbe 100644
--- a/m4/stdlib_h.m4
+++ b/m4/stdlib_h.m4
@@ -1,4 +1,4 @@
-# stdlib_h.m4 serial 44
+# stdlib_h.m4 serial 45
dnl Copyright (C) 2007-2018 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,6 +14,9 @@ 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
diff --git a/m4/symlink.m4 b/m4/symlink.m4
index a452f7cc3a8..afaa941744e 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-2018 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_rz.m4 b/m4/time_rz.m4
index 43781489786..55557062597 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/unistd_h.m4 b/m4/unistd_h.m4
index b3b71ec2709..3ba64da8a0b 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-2018 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 16798a0ad1e..9a4db07a3da 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/vararrays.m4 b/m4/vararrays.m4
index 329eb490c3c..17563b519b0 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 eb1c795c598..07edda1cca6 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-2018 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 26247b37bca..bafcae35f08 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"
@@ -292,7 +299,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
@@ -331,8 +338,10 @@ if [ $update = yes ]; then
rm -f src/stamp-h.in
echo timestamp > src/stamp-h.in
- 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")
@@ -346,7 +355,7 @@ fi # $update = yes
echo "Creating staging directory: '${tempparent}'"
-mkdir ${tempparent}
+mkdir ${tempparent} || exit
tempdir="${tempparent}/${emacsname}"
### This trap ensures that the staging directory will be cleaned up even
@@ -356,14 +365,16 @@ if [ "${clean_up}" = yes ]; then
fi
echo "Creating top directory: '${tempdir}'"
-mkdir ${tempdir}
+mkdir ${tempdir} || exit
+top_level_ChangeLog=
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
echo "Using existing top-level ChangeLog"
+ top_level_ChangeLog=ChangeLog
else
echo "Making top-level ChangeLog"
make ChangeLog CHANGELOG=${tempdir}/ChangeLog || \
@@ -379,10 +390,13 @@ fi
### 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}
+top_level='
+ INSTALL README BUGS
+ ChangeLog.*[0-9] Makefile.in autogen.sh configure configure.ac
+ config.bat make-dist .dir-locals.el
+ aclocal.m4 CONTRIBUTE
+'
+ln $top_level $top_level_ChangeLog $tempdir || exit
echo "Creating subdirectories"
for subdir in site-lisp \
@@ -412,132 +426,151 @@ do
[ "$subdir" = "site-lisp" ] || [ -d "$subdir" ] || \
echo "WARNING: $subdir not found, making anyway"
[ "$verbose" = "yes" ] && echo " ${tempdir}/${subdir}"
- mkdir ${tempdir}/${subdir}
+ mkdir ${tempdir}/${subdir} || exit
done
echo "Making links to 'lisp' and its subdirectories"
files=`find lisp \( -name '*.el' -o -name '*.elc' -o -name 'ChangeLog*' \
- -o -name 'README' \)`
+ -o -name 'README' \)` || exit
### Don't distribute site-init.el, site-load.el, or default.el.
for file in lisp/Makefile.in $files; do
case $file in
*/site-init*|*/site-load*|*/default*) continue ;;
esac
- ln $file $tempdir/$file
+ ln $file $tempdir/$file || exit
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)
+(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 &&
+:) || exit
## 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)
+(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 &&
+:) || exit
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)
+(cd src &&
+ 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 &&
+:) || exit
echo "Making links to 'src/bitmaps'"
-(cd src/bitmaps
- ln README *.xbm ../../${tempdir}/src/bitmaps)
+(cd src/bitmaps &&
+ ln README *.xbm ../../${tempdir}/src/bitmaps &&
+:) || exit
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"`)
+(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"` &&
+:) || exit
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)
+(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 &&
+:) || exit
echo "Making links to 'm4'"
-(cd m4
- ln *.m4 ../${tempdir}/m4)
+(cd m4 &&
+ ln *.m4 ../${tempdir}/m4 &&
+:) || exit
echo "Making links to 'modules'"
-(cd modules
- ln *.py ../${tempdir}/modules
-)
+(cd modules &&
+ ln *.py ../${tempdir}/modules &&
+:) || exit
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)
+(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 &&
+:) || exit
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
+ ln $f $tempdir/$f || exit
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)
+(cd nt/icons &&
+ ln README [a-z]*.ico ../../${tempdir}/nt/icons &&
+ ln [a-z]*.cur ../../${tempdir}/nt/icons &&
+:) || exit
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)
+(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 &&
+:) || exit
echo "Making links to 'nextstep'"
-(cd nextstep
- ln ChangeLog.*[0-9] README INSTALL Makefile.in ../${tempdir}/nextstep)
+(cd nextstep &&
+ ln ChangeLog.*[0-9] README INSTALL Makefile.in ../${tempdir}/nextstep &&
+:) || exit
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)
+(cd nextstep/templates &&
+ ln Emacs.desktop.in Info-gnustep.plist.in Info.plist.in InfoPlist.strings.in \
+ ../../${tempdir}/nextstep/templates &&
+:) || exit
echo "Making links to 'nextstep/Cocoa/Emacs.base/Contents'"
-(cd nextstep/Cocoa/Emacs.base/Contents
- ln PkgInfo ../../../../${tempdir}/nextstep/Cocoa/Emacs.base/Contents)
+(cd nextstep/Cocoa/Emacs.base/Contents &&
+ ln PkgInfo ../../../../${tempdir}/nextstep/Cocoa/Emacs.base/Contents &&
+:) || exit
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)
+(cd nextstep/Cocoa/Emacs.base/Contents/Resources &&
+ ln Credits.html *.icns \
+ ../../../../../${tempdir}/nextstep/Cocoa/Emacs.base/Contents/Resources &&
+:) || exit
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 )
+(cd nextstep/GNUstep/Emacs.base/Resources &&
+ ln README emacs.tiff \
+ ../../../../${tempdir}/nextstep/GNUstep/Emacs.base/Resources &&
+:) || exit
echo "Making links to 'oldXMenu'"
-(cd oldXMenu
- ln *.[ch] *.in *.mk ../${tempdir}/oldXMenu
- ln README ChangeLog.*[0-9] ../${tempdir}/oldXMenu)
+(cd oldXMenu &&
+ ln *.[ch] *.in *.mk ../${tempdir}/oldXMenu &&
+ ln README ChangeLog.*[0-9] ../${tempdir}/oldXMenu &&
+:) || exit
echo "Making links to 'lwlib'"
-(cd lwlib
- ln *.[ch] *.in *.mk ../${tempdir}/lwlib
- ln README ChangeLog.*[0-9] ../${tempdir}/lwlib)
+(cd lwlib &&
+ ln *.[ch] *.in *.mk ../${tempdir}/lwlib &&
+ ln README ChangeLog.*[0-9] ../${tempdir}/lwlib &&
+:) || exit
## It is important to distribute admin/ because it contains sources
## for generated lisp/international/uni-*.el files.
@@ -546,7 +579,7 @@ for f in `find admin -type f`; do
case $f in
*/Makefile) [ -f $f.in ] && continue ;;
esac
- ln $f $tempdir/$f
+ ln $f $tempdir/$f || exit
done
if [ "$with_tests" = "yes" ]; then
@@ -557,7 +590,7 @@ if [ "$with_tests" = "yes" ]; then
case $f in
*/Makefile) [ -f $f.in ] && continue ;;
esac
- ln $f $tempdir/$f
+ ln $f $tempdir/$f || exit
done
fi
@@ -569,45 +602,52 @@ for f in `find etc -type f`; do
etc/refcards/*.aux|etc/refcards/*.dvi|etc/refcards/*.log|etc/refcards/*.ps)
continue ;;
esac
- ln $f $tempdir/$f
+ ln $f $tempdir/$f || exit
done
-echo "Making links to 'info'"
-ln `find info -type f -print` ${tempdir}/info
+if [ "$with_info" = "yes" ]; then
+ echo "Making links to 'info'"
+ ln `find info -type f -print` ${tempdir}/info || exit
+fi
echo "Making links to 'doc/emacs'"
-(cd doc/emacs
- ln *.texi *.in ChangeLog.*[0-9] ../../${tempdir}/doc/emacs)
+(cd doc/emacs &&
+ ln *.texi *.in ChangeLog.*[0-9] ../../${tempdir}/doc/emacs &&
+:) || exit
echo "Making links to 'doc/misc'"
-(cd doc/misc
+(cd doc/misc &&
ln *.texi *.tex *.in gnus-news.el ChangeLog.*[0-9] \
- ../../${tempdir}/doc/misc)
+ ../../${tempdir}/doc/misc &&
+:) || exit
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)
+(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 &&
+:) || exit
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)
+(cd doc/lispintro &&
+ ln *.texi *.in *.eps *.pdf ../../${tempdir}/doc/lispintro &&
+ ln README ChangeLog.*[0-9] ../../${tempdir}/doc/lispintro &&
+ cd ../../${tempdir}/doc/lispintro &&
+:) || exit
echo "Making links to 'doc/man'"
-(cd doc/man
- ln *.*[0-9] *.in ../../${tempdir}/doc/man
- cd ../../${tempdir}/doc/man
- rm -f emacs.1)
+(cd doc/man &&
+ ln *.*[0-9] *.in ../../${tempdir}/doc/man &&
+ cd ../../${tempdir}/doc/man &&
+ rm -f emacs.1 &&
+:) || exit
### 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}
+ rm -f ${tempdir}/${subdir}/COPYING || exit
+ cp COPYING ${tempdir}/${subdir} || exit
done
if [ "${newer}" ]; then
@@ -615,12 +655,13 @@ if [ "${newer}" ]; then
## 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 ${tempparent} \( -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 {} \;
+find ${tempparent} \( -name '*~' -o -name '#*#' -o -name '.*ignore' -o -name '=*' -o -name 'TAGS' \) -exec rm -f {} \; || exit
if [ "${make_tar}" = yes ]; then
echo "Looking for $default_gzip"
@@ -639,20 +680,32 @@ 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 $tempparent/$emacsname/src/lisp.h 2>/tmp/out &&
+ 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
+ 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
if [ "${clean_up}" != yes ]; then
- (cd ${tempparent}; mv ${emacsname} ..)
+ (cd ${tempparent} && mv ${emacsname} ..) &&
rm -rf ${tempparent}
fi
diff --git a/msdos/sed2v2.inp b/msdos/sed2v2.inp
index 89cb7dcdd04..d6544052d29 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.50"/
+/^#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 0763e63f930..cb698987374 100644
--- a/nextstep/Makefile.in
+++ b/nextstep/Makefile.in
@@ -76,7 +76,7 @@ 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}
diff --git a/nt/INSTALL b/nt/INSTALL
index aa670dfc79b..67069429901 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 6c697151221..c3aa85e8c92 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 1d3064c05d5..f0147b4c68f 100644
--- a/nt/README.W32
+++ b/nt/README.W32
@@ -1,7 +1,7 @@
Copyright (C) 2001-2018 Free Software Foundation, Inc.
See the end of the file for license conditions.
- Emacs version 26.1.50 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 340c407866d..21d42337e84 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/ms-w32.h b/nt/inc/ms-w32.h
index d15b6da1a74..e4dec04fb8b 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 */
diff --git a/oldXMenu/Makefile.in b/oldXMenu/Makefile.in
index d795038797a..211bac97ee4 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 cc06b2e11ce..ae6f13a103b 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
@@ -1270,6 +1246,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 +1288,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 +1303,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 +1330,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 +1341,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 6ed8f3cc916..72f568988a8 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -104,7 +104,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.
@@ -234,7 +234,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 +278,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 +314,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.
@@ -360,10 +369,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,9 +392,9 @@ 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 \
+ cmds.o casetab.o casefiddle.o indent.o search.o regex-emacs.o undo.o \
alloc.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 \
@@ -397,7 +406,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.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 +417,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 +445,10 @@ 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) $(OTHER_FILES)
+.PHONY: all
+
AUTO_DEPEND = @AUTO_DEPEND@
DEPDIR = deps
ifeq ($(AUTO_DEPEND),yes)
@@ -446,9 +459,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
@@ -492,8 +502,9 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \
$(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)
+ $(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 these files
## are up-to-date. Although since charprop depends on bootstrap-emacs,
@@ -634,12 +645,12 @@ ns-app: emacs$(EXEEXT)
.PHONY: versionclean extraclean
mostlyclean:
- rm -f temacs$(EXEEXT) core *.core \#* *.o
+ rm -f temacs$(EXEEXT) core ./*.core \#* ./*.o
rm -f ../etc/DOC
rm -f bootstrap-emacs$(EXEEXT) 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)/*
@@ -663,7 +674,7 @@ 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}
@@ -747,3 +758,8 @@ else
endif
@: Compile some files earlier to speed up further compilation.
$(MAKE) -C ../lisp compile-first EMACS="$(bootstrap_exe)"
+
+### 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 738ed45df81..3b150797c36 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"
@@ -103,7 +105,7 @@ static bool valgrind_p;
#include "w32heap.h" /* for sbrk */
#endif
-#ifdef GNU_LINUX
+#if defined GNU_LINUX && !defined CANNOT_DUMP
/* The address where the heap starts. */
void *
my_heap_start (void)
@@ -171,6 +173,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
@@ -245,8 +248,8 @@ bool gc_in_progress;
/* 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_conses, total_symbols, total_buffers;
+static EMACS_INT total_free_conses, total_free_symbols;
static EMACS_INT total_free_floats, total_floats;
/* Points to memory space allocated as "spare", to be freed if we run
@@ -354,6 +357,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);
@@ -376,7 +380,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
@@ -502,30 +505,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))
-
-/* Extract the pointer hidden within A. */
+/* 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. */
-#define macro_XPNTR(a) \
- ((void *) ((intptr_t) XPNTR_OR_SYMBOL_OFFSET (a) \
- + (SYMBOLP (a) ? (char *) lispsym : NULL)))
+/* Add a pointer P to an integer I without gcc -fsanitize complaining
+ about the result being out of range of the underlying array. */
-/* 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. */
+#define macro_PNTR_ADD(p, i) ((p) + (i))
-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 +542,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
@@ -627,6 +635,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 +678,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] =
@@ -1140,11 +1166,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 unless CANNOT_DUMP. */
-#if ! ADDRESS_SANITIZER && !defined DARWIN_OS
+#if !defined DARWIN_OS || defined CANNOT_DUMP
# if (defined HAVE_ALIGNED_ALLOC \
|| (defined HYBRID_MALLOC \
? defined HAVE_POSIX_MEMALIGN \
@@ -1160,9 +1185,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 +1421,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 +1451,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 +1462,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 +1476,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;
}
@@ -1737,7 +1748,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
@@ -1929,7 +1941,7 @@ 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;
@@ -2044,7 +2056,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
@@ -2130,7 +2142,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 +2150,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;
}
}
@@ -2234,9 +2246,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 +2262,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 +2312,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 +2342,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))
@@ -2403,8 +2418,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);
}
@@ -2878,9 +2893,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 +2918,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 +2931,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 +2947,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 +3000,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 *
@@ -3042,6 +3048,7 @@ static EMACS_INT total_vector_slots, total_free_vector_slots;
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);
@@ -3081,14 +3088,14 @@ init_vectors (void)
/* 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. */
@@ -3173,35 +3180,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. */
@@ -3221,8 +3256,7 @@ sweep_vectors (void)
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)
@@ -3231,31 +3265,26 @@ sweep_vectors (void)
{
VECTOR_UNMARK (vector);
total_vectors++;
- nbytes = vector_nbytes (vector);
+ ptrdiff_t nbytes = vector_nbytes (vector);
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 +3292,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);
}
@@ -3311,15 +3340,14 @@ sweep_vectors (void)
static struct Lisp_Vector *
allocate_vectorlike (ptrdiff_t len)
{
- struct Lisp_Vector *p;
-
- MALLOC_BLOCK_INPUT;
-
if (len == 0)
- p = XVECTOR (zero_vector);
+ return XVECTOR (zero_vector);
else
{
size_t nbytes = header_size + len * word_size;
+ struct Lisp_Vector *p;
+
+ MALLOC_BLOCK_INPUT;
#ifdef DOUG_LEA_MALLOC
if (!mmap_lisp_allowed_p ())
@@ -3349,11 +3377,11 @@ allocate_vectorlike (ptrdiff_t len)
consing_since_gc += nbytes;
vector_cells_consed += len;
- }
- MALLOC_UNBLOCK_INPUT;
+ MALLOC_UNBLOCK_INPUT;
- return p;
+ return ptr_bounds_clip (p, nbytes);
+ }
}
@@ -3431,8 +3459,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 +3488,9 @@ 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_FIXNAT (length);
+ struct Lisp_Vector *p = allocate_vector (XFIXNAT (length));
+ for (ptrdiff_t i = 0; i < XFIXNAT (length); i++)
p->contents[i] = init;
return make_lisp_ptr (p, Lisp_Vectorlike);
}
@@ -3633,205 +3661,27 @@ Its value is void, and its function definition and property list are nil. */)
-/***********************************************************************
- 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_PSEUDOVECTOR (struct Lisp_Misc_Ptr, pointer,
+ 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, next,
+ 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 +3689,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_PSEUDOVECTOR (struct Lisp_Marker, buffer,
+ 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 +3706,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_PSEUDOVECTOR (struct Lisp_Marker, buffer,
+ PVEC_MARKER);
m->buffer = buf;
m->charpos = charpos;
m->bytepos = bytepos;
@@ -3877,7 +3721,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 +3740,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 +3749,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 +3767,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_PSEUDOVECTOR (struct Lisp_User_Ptr,
+ finalizer, PVEC_USER_PTR);
uptr->finalizer = finalizer;
uptr->p = p;
- return obj;
+ return make_lisp_ptr (uptr, Lisp_Vectorlike);
}
#endif
@@ -3973,7 +3814,7 @@ mark_finalizer_list (struct Lisp_Finalizer *head)
finalizer != head;
finalizer = finalizer->next)
{
- finalizer->base.gcmarkbit = true;
+ VECTOR_MARK (finalizer);
mark_object (finalizer->function);
}
}
@@ -3990,7 +3831,7 @@ queue_doomed_finalizers (struct Lisp_Finalizer *dest,
while (finalizer != src)
{
struct Lisp_Finalizer *next = finalizer->next;
- if (!finalizer->base.gcmarkbit && !NILP (finalizer->function))
+ if (!VECTOR_MARKED_P (finalizer) && !NILP (finalizer->function))
{
unchain_finalizer (finalizer);
finalizer_insert (dest, finalizer);
@@ -4026,7 +3867,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 +3886,12 @@ 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, prev, PVEC_FINALIZER);
finalizer->function = function;
finalizer->prev = finalizer->next = NULL;
finalizer_insert (&finalizers, finalizer);
- return val;
+ return make_lisp_ptr (finalizer, Lisp_Vectorlike);
}
@@ -4561,6 +4401,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 +4436,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 +4472,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 +4512,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. */
@@ -4788,7 +4597,7 @@ mark_maybe_object (Lisp_Object obj)
VALGRIND_MAKE_MEM_DEFINED (&obj, sizeof (obj));
#endif
- if (INTEGERP (obj))
+ if (FIXNUMP (obj))
return;
void *po = XPNTR (obj);
@@ -4821,10 +4630,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 +4639,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 *array, ptrdiff_t nelts)
+{
+ for (Lisp_Object *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
@@ -4870,7 +4684,7 @@ 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));
}
m = mem_find (p);
@@ -4897,10 +4711,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;
@@ -5253,15 +5063,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);
@@ -5303,9 +5111,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);
@@ -5341,7 +5146,7 @@ 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
@@ -5354,7 +5159,7 @@ pure_alloc (size_t size, int type)
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
@@ -5439,7 +5244,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;
}
@@ -5522,6 +5327,32 @@ 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));
+
+ pure_limbs = pure_alloc (nbytes, -1);
+ 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 +5425,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 +5494,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");
@@ -5704,7 +5537,7 @@ 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;
}
@@ -5714,7 +5547,7 @@ inhibit_garbage_collection (void)
static Lisp_Object
bounded_number (EMACS_INT number)
{
- return make_number (min (MOST_POSITIVE_FIXNUM, number));
+ return make_fixnum (min (MOST_POSITIVE_FIXNUM, number));
}
/* Calculate total bytes of live objects. */
@@ -5725,7 +5558,6 @@ 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);
@@ -5846,7 +5678,7 @@ compact_undo_list (Lisp_Object list)
{
if (CONSP (XCAR (tail))
&& MARKERP (XCAR (XCAR (tail)))
- && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
+ && !VECTOR_MARKED_P (XMARKER (XCAR (XCAR (tail)))))
*prev = XCDR (tail);
else
prev = xcdr_addr (tail);
@@ -5956,6 +5788,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);
}
}
@@ -6066,37 +5899,34 @@ garbage_collect_1 (void *end)
unbind_to (count, Qnil);
Lisp_Object total[] = {
- list4 (Qconses, make_number (sizeof (struct Lisp_Cons)),
+ list4 (Qconses, make_fixnum (sizeof (struct Lisp_Cons)),
bounded_number (total_conses),
bounded_number (total_free_conses)),
- list4 (Qsymbols, make_number (sizeof (struct Lisp_Symbol)),
+ list4 (Qsymbols, make_fixnum (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)),
+ list4 (Qstrings, make_fixnum (sizeof (struct Lisp_String)),
bounded_number (total_strings),
bounded_number (total_free_strings)),
- list3 (Qstring_bytes, make_number (1),
+ list3 (Qstring_bytes, make_fixnum (1),
bounded_number (total_string_bytes)),
list3 (Qvectors,
- make_number (header_size + sizeof (Lisp_Object)),
+ make_fixnum (header_size + sizeof (Lisp_Object)),
bounded_number (total_vectors)),
- list4 (Qvector_slots, make_number (word_size),
+ list4 (Qvector_slots, make_fixnum (word_size),
bounded_number (total_vector_slots),
bounded_number (total_free_vector_slots)),
- list4 (Qfloats, make_number (sizeof (struct Lisp_Float)),
+ list4 (Qfloats, make_fixnum (sizeof (struct Lisp_Float)),
bounded_number (total_floats),
bounded_number (total_free_floats)),
- list4 (Qintervals, make_number (sizeof (struct interval)),
+ list4 (Qintervals, make_fixnum (sizeof (struct interval)),
bounded_number (total_intervals),
bounded_number (total_free_intervals)),
- list3 (Qbuffers, make_number (sizeof (struct buffer)),
+ list3 (Qbuffers, make_fixnum (sizeof (struct buffer)),
bounded_number (total_buffers)),
#ifdef DOUG_LEA_MALLOC
- list4 (Qheap, make_number (1024),
+ list4 (Qheap, make_fixnum (1024),
bounded_number ((mallinfo ().uordblks + 1023) >> 10),
bounded_number ((mallinfo ().fordblks + 1023) >> 10)),
#endif
@@ -6185,11 +6015,7 @@ mark_glyph_matrix (struct glyph_matrix *matrix)
}
}
-/* 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;
@@ -6235,7 +6061,7 @@ mark_char_table (struct Lisp_Vector *ptr, enum pvec_type pvectype)
{
Lisp_Object val = ptr->contents[i];
- if (INTEGERP (val) || (SYMBOLP (val) && XSYMBOL (val)->u.s.gcmarkbit))
+ if (FIXNUMP (val) || (SYMBOLP (val) && XSYMBOL (val)->u.s.gcmarkbit))
continue;
if (SUB_CHAR_TABLE_P (val))
{
@@ -6265,12 +6091,12 @@ mark_compiled (struct Lisp_Vector *ptr)
static void
mark_overlay (struct Lisp_Overlay *ptr)
{
- for (; ptr && !ptr->gcmarkbit; ptr = ptr->next)
+ for (; ptr && !VECTOR_MARKED_P (ptr); ptr = ptr->next)
{
- ptr->gcmarkbit = 1;
+ VECTOR_MARK (ptr);
/* These two are always markers and can be marked fast. */
- XMARKER (ptr->start)->gcmarkbit = 1;
- XMARKER (ptr->end)->gcmarkbit = 1;
+ VECTOR_MARK (XMARKER (ptr->start));
+ VECTOR_MARK (XMARKER (ptr->end));
mark_object (ptr->plist);
}
}
@@ -6338,30 +6164,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. */
@@ -6415,8 +6217,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
@@ -6596,9 +6397,8 @@ 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_OVERLAY:
+ mark_overlay (XOVERLAY (obj));
break;
case PVEC_SUBR:
@@ -6608,6 +6408,8 @@ mark_object (Lisp_Object arg)
emacs_abort ();
default:
+ /* A regular vector, or a pseudovector needing no special
+ treatment. */
mark_vectorlike (ptr);
}
}
@@ -6656,55 +6458,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);
+ struct Lisp_Cons *ptr = XCONS (obj);
if (CONS_MARKED_P (ptr))
break;
CHECK_ALLOCATED_AND_LIVE (live_cons_p);
CONS_MARK (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;
@@ -6775,10 +6537,6 @@ survives_gc_p (Lisp_Object obj)
survives_p = XSYMBOL (obj)->u.s.gcmarkbit;
break;
- case Lisp_Misc:
- survives_p = XMISCANY (obj)->gcmarkbit;
- break;
-
case Lisp_String:
survives_p = STRING_MARKED_P (XSTRING (obj));
break;
@@ -6845,7 +6603,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 (!CONS_MARKED_P (acons))
{
this_free++;
cblk->conses[pos].u.s.u.chain = cons_free_list;
@@ -6855,7 +6615,7 @@ sweep_conses (void)
else
{
num_used++;
- CONS_UNMARK (&cblk->conses[pos]);
+ CONS_UNMARK (acons);
}
}
}
@@ -6898,17 +6658,20 @@ sweep_floats (void)
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]);
- }
+ {
+ struct Lisp_Float *afloat = ptr_bounds_copy (&fblk->floats[i], fblk);
+ if (!FLOAT_MARKED_P (afloat))
+ {
+ this_free++;
+ fblk->floats[i].u.chain = float_free_list;
+ float_free_list = &fblk->floats[i];
+ }
+ else
+ {
+ num_used++;
+ FLOAT_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
@@ -7050,75 +6813,21 @@ sweep_symbols (void)
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 (VECTOR_MARKED_P (this))
+ prev = &this->next;
+ else
+ {
+ this->buffer = NULL;
+ *prev = this->next;
+ }
}
NO_INLINE /* For better stack traces */
@@ -7139,6 +6848,7 @@ sweep_buffers (void)
VECTOR_UNMARK (buffer);
/* Do not use buffer_(set|get)_intervals here. */
buffer->text->intervals = balance_intervals (buffer->text->intervals);
+ unchain_dead_markers (buffer);
total_buffers++;
bprev = &buffer->next;
}
@@ -7158,7 +6868,6 @@ gc_sweep (void)
sweep_floats ();
sweep_intervals ();
sweep_symbols ();
- sweep_misc ();
sweep_buffers ();
sweep_vectors ();
check_string_bytes (!noninteractive);
@@ -7214,46 +6923,26 @@ 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,
+ return listn (CONSTYPE_HEAP, 7,
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));
}
@@ -7318,8 +7007,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
@@ -7513,11 +7201,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. */);
@@ -7553,7 +7236,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 +7255,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,7 +7276,6 @@ 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);
diff --git a/src/atimer.c b/src/atimer.c
index 97f07362ae1..505f6bcea18 100644
--- a/src/atimer.c
+++ b/src/atimer.c
@@ -113,10 +113,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 +494,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;
}
}
diff --git a/src/bidi.c b/src/bidi.c
index 1f05a1f7d51..a53a2295c09 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-2018 Free Software
- Foundation, Inc.
+
+Copyright (C) 2000-2001, 2004-2005, 2009-2018 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);
diff --git a/src/bignum.c b/src/bignum.c
new file mode 100644
index 00000000000..1e78d981b7d
--- /dev/null
+++ b/src/bignum.c
@@ -0,0 +1,332 @@
+/* Big numbers for Emacs.
+
+Copyright 2018 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,
+ rounding_driver and rounddiv_q need four altogther. */
+
+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_PSEUDOVECTOR (struct Lisp_Bignum, value,
+ 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));
+}
+
+static void mpz_set_uintmax_slow (mpz_t, uintmax_t);
+
+/* Set RESULT to V. */
+static void
+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 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 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);
+}
+static 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);
+}
+
+/* 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)
+{
+ ptrdiff_t bits = mpz_sizeinbase (XBIGNUM (x)->value, 2);
+ bool negative = mpz_sgn (XBIGNUM (x)->value) < 0;
+
+ if (bits < INTMAX_WIDTH)
+ {
+ intmax_t v = 0;
+ int i = 0, shift = 0;
+
+ do
+ {
+ intmax_t limb = mpz_getlimbn (XBIGNUM (x)->value, i++);
+ v += limb << shift;
+ shift += GMP_NUMB_BITS;
+ }
+ while (shift < bits);
+
+ return negative ? -v : v;
+ }
+ return ((bits == INTMAX_WIDTH && INTMAX_MIN < -INTMAX_MAX && negative
+ && mpz_scan1 (XBIGNUM (x)->value, 0) == INTMAX_WIDTH - 1)
+ ? INTMAX_MIN : 0);
+}
+uintmax_t
+bignum_to_uintmax (Lisp_Object x)
+{
+ uintmax_t v = 0;
+ if (0 <= mpz_sgn (XBIGNUM (x)->value))
+ {
+ ptrdiff_t bits = mpz_sizeinbase (XBIGNUM (x)->value, 2);
+ if (bits <= UINTMAX_WIDTH)
+ {
+ int i = 0, shift = 0;
+
+ do
+ {
+ uintmax_t limb = mpz_getlimbn (XBIGNUM (x)->value, i++);
+ v += limb << shift;
+ shift += GMP_NUMB_BITS;
+ }
+ while (shift < bits);
+ }
+ }
+ return v;
+}
+
+/* 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 null. */
+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 null 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_PSEUDOVECTOR (struct Lisp_Bignum, value,
+ 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..e9cd5c07635
--- /dev/null
+++ b/src/bignum.h
@@ -0,0 +1,88 @@
+/* Big numbers for Emacs.
+
+Copyright 2018 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 void mpz_set_intmax_slow (mpz_t, intmax_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);
+}
+
+/* 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 179360c5622..024e64f0d74 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -849,7 +849,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 +939,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 +1102,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));
@@ -1421,7 +1421,7 @@ 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)
{
- return make_number (BUF_MODIFF (decode_buffer (buffer)));
+ return make_fixnum (BUF_MODIFF (decode_buffer (buffer)));
}
DEFUN ("buffer-chars-modified-tick", Fbuffer_chars_modified_tick,
@@ -1436,7 +1436,7 @@ between these calls. No argument or nil as argument means use current
buffer as BUFFER. */)
(register Lisp_Object buffer)
{
- return make_number (BUF_CHARS_MODIFF (decode_buffer (buffer)));
+ return make_fixnum (BUF_CHARS_MODIFF (decode_buffer (buffer)));
}
DEFUN ("rename-buffer", Frename_buffer, Srename_buffer, 1, 2,
@@ -1696,7 +1696,7 @@ 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,
@@ -2203,7 +2203,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 +2233,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);
}
@@ -2409,7 +2409,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 +2417,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 +2547,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 +2628,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 +2789,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 +2796,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 +2842,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 +2917,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 +2925,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 +2970,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 +3085,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 +3195,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 +3273,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 +3320,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 +3354,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 +3444,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 +3452,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 +3479,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 +3504,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 +3536,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 +3594,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 +3603,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 +3612,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 +3657,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 +3704,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 +3757,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 +3782,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 +3848,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;
@@ -3987,10 +3968,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;
@@ -4156,7 +4137,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 +4148,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 +4181,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 +4192,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 +4213,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 +4224,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 +4241,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 +4255,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 +4271,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 +4289,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 +4308,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 +4415,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 +4431,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 +4557,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 +4571,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
@@ -5070,41 +5040,41 @@ init_buffer_once (void)
/* 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 +5085,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;
@@ -5429,7 +5401,7 @@ syms_of_buffer (void)
{
staticpro (&last_overlay_modification_hooks);
last_overlay_modification_hooks
- = Fmake_vector (make_number (10), Qnil);
+ = Fmake_vector (make_fixnum (10), Qnil);
staticpro (&QSFundamental);
staticpro (&Vbuffer_alist);
@@ -5570,17 +5542,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.
@@ -5751,7 +5723,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 +5797,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 +5805,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 +5813,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 +5822,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 +5839,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 +6010,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 +6114,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 b12dad684f2..4ea7fa627e0 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.
@@ -912,7 +890,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
@@ -1349,7 +1327,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 +1365,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 +1374,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 e51f9095b36..17457fc5742 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,30 +362,32 @@ 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;
- 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);
@@ -618,10 +621,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);
}
}
@@ -736,8 +739,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 ??. */
@@ -830,13 +832,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;
}
@@ -970,24 +973,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;
}
@@ -1025,7 +1025,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):
@@ -1061,7 +1063,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):
@@ -1087,7 +1089,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):
@@ -1103,7 +1105,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):
@@ -1167,7 +1169,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)]);
@@ -1256,23 +1258,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;
}
@@ -1413,7 +1408,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))
@@ -1429,9 +1424,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;
}
}
@@ -1466,14 +1461,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
@@ -1498,13 +1493,13 @@ 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 = Fmake_vector (make_fixnum (256), make_fixnum (0));
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)));
+ Fmake_vector (make_fixnum (256), make_fixnum (0)));
}
#endif
}
diff --git a/src/callint.c b/src/callint.c
index e4491e9085a..81efb267bdf 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 (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);
}
@@ -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] = Fmake_vector (make_fixnum (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
@@ -777,7 +715,7 @@ invoke it. If KEYS is omitted or nil, the return value of
{
/* 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);
+ 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);
diff --git a/src/callproc.c b/src/callproc.c
index 973f324139c..e6a81802936 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. */
@@ -324,7 +324,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 */
@@ -403,7 +403,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;
@@ -431,7 +431,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);
@@ -440,7 +440,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]);
}
@@ -471,7 +471,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))
@@ -599,7 +599,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;
@@ -616,7 +615,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;
@@ -672,7 +670,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);
@@ -705,7 +703,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))
@@ -872,7 +870,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;
@@ -885,8 +883,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");
@@ -906,7 +903,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
@@ -1069,7 +1066,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)
@@ -1647,7 +1644,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 8befc5ae7c6..95857d6f361 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 8f806a0647c..0e742de2104 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 62bb7f1a6c6..d6ccde5369b 100644
--- a/src/category.c
+++ b/src/category.c
@@ -103,7 +103,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 +130,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 +148,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 +165,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 +220,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 +271,8 @@ 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),
+ Fmake_vector (make_fixnum (95), Qnil));
return val;
}
@@ -303,7 +303,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 +346,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 +372,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 +423,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 +440,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),
+ Fmake_vector (make_fixnum (95), Qnil));
}
void
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 ed8588d7f8a..31d0a28c5aa 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 = Fmake_vector (make_fixnum (32), Qnil);
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 = Fmake_vector (make_fixnum (16), Qnil);
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 b96161ebfcb..0b14e476c13 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 = Fmake_vector (make_fixnum (16), Qnil);
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 05290e86b4e..c1a237835c7 100644
--- a/src/charset.c
+++ b/src/charset.c
@@ -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 = Fmake_vector (make_fixnum (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);
}
@@ -854,9 +854,9 @@ usage: (define-charset-internal ...) */)
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 = Fmake_vector (make_fixnum (charset_attr_max), Qnil);
CHECK_SYMBOL (args[charset_arg_name]);
ASET (attrs, charset_name, args[charset_arg_name]);
@@ -867,12 +867,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 +890,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 +929,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 +942,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 +970,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 +982,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 +990,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 +1010,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 +1043,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 +1089,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 +1123,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
@@ -1158,7 +1158,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;
@@ -1174,7 +1174,7 @@ usage: (define-charset-internal ...) */)
charset.iso_final) = id;
if (new_definition_p)
Viso_2022_charset_list = nconc2 (Viso_2022_charset_list,
- list1 (make_number (id)));
+ list1 (make_fixnum (id)));
if (ISO_CHARSET_TABLE (1, 0, 'J') == id)
charset_jisx0201_roman = id;
else if (ISO_CHARSET_TABLE (2, 0, '@') == id)
@@ -1194,7 +1194,7 @@ 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)));
+ list1 (make_fixnum (id)));
}
if (new_definition_p)
@@ -1202,29 +1202,29 @@ usage: (define-charset-internal ...) */)
Vcharset_list = Fcons (args[charset_arg_name], Vcharset_list);
if (charset.supplementary_p)
Vcharset_ordered_list = nconc2 (Vcharset_ordered_list,
- list1 (make_number (id)));
+ list1 (make_fixnum (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)));
+ list1 (make_fixnum (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,22 +1254,22 @@ 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;
@@ -1293,7 +1293,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 +1396,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 +1428,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 +1449,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 +1550,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 +1563,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 = Fmake_vector (make_fixnum (charset_table_used), Qnil);
while (1)
{
find_charsets_in_text (BYTE_POS_ADDR (from_byte), stop - from,
@@ -1600,7 +1600,7 @@ only `ascii', `eight-bit-control', and `eight-bit-graphic'. */)
CHECK_STRING (str);
- charsets = Fmake_vector (make_number (charset_table_used), Qnil);
+ charsets = Fmake_vector (make_fixnum (charset_table_used), Qnil);
find_charsets_in_text (SDATA (str), SCHARS (str), SBYTES (str),
charsets, table,
STRING_MULTIBYTE (str));
@@ -1621,8 +1621,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 +1638,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 +1672,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 +1688,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 +1714,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 +1762,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 +1779,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 +1796,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 +1827,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 +1852,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 +1864,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 +1881,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 +1920,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 +1932,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 +1945,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 +1958,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 +1973,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 +1993,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 +2028,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 +2038,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 +2058,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 +2076,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 +2095,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 +2114,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 +2149,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,10 +2175,10 @@ 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;
@@ -2186,7 +2196,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 +2221,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
@@ -2237,7 +2247,7 @@ 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 = XFIXNAT (len), i, j;
int done;
Lisp_Object tail, elt, attrs;
struct charset_sort_data *sort_data;
@@ -2252,7 +2262,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 +2272,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)
diff --git a/src/charset.h b/src/charset.h
index 8832af40d4f..7b85a1a4e31 100644
--- a/src/charset.h
+++ b/src/charset.h
@@ -355,7 +355,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 +416,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 +447,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..3d38b3ce12e 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 = Fmake_vector (make_fixnum (size), init);
XSETPVECTYPE (XVECTOR (vector), PVEC_CHAR_TABLE);
set_char_table_parent (vector, Qnil);
set_char_table_purpose (vector, purpose);
@@ -188,7 +188,7 @@ copy_char_table (Lisp_Object table)
int size = PVSIZE (table);
int i;
- copy = Fmake_vector (make_number (size), Qnil);
+ copy = Fmake_vector (make_fixnum (size), Qnil);
XSETPVECTYPE (XVECTOR (copy), PVEC_CHAR_TABLE);
set_char_table_defalt (copy, XCHAR_TABLE (table)->defalt);
set_char_table_parent (copy, XCHAR_TABLE (table)->parent);
@@ -571,12 +571,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 +586,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 +605,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 +642,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 +742,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 +783,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 +807,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 +817,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 +843,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 +864,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 +878,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 +957,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 +980,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 +991,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 +1041,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 +1052,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 +1125,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 +1150,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 +1174,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 +1192,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 +1227,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 +1240,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);
+ Fmake_vector (make_fixnum (1), value)));
+ return make_fixnum (i);
}
static uniprop_encoder_t uniprop_encoder[] =
@@ -1267,9 +1267,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 +1300,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 +1337,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 +1357,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 db3924e3f6a..1616efbb446 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)
{
@@ -127,8 +127,8 @@ go to its beginning. */)
count = 1;
else
{
- CHECK_NUMBER (n);
- count = XINT (n);
+ CHECK_FIXNUM (n);
+ count = XFIXNUM (n);
}
shortage = scan_newline_from_point (count, &pos, &pos_byte);
@@ -142,7 +142,7 @@ go to its beginning. */)
&& (FETCH_BYTE (PT_BYTE - 1) != '\n'))))
shortage--;
- return make_number (count <= 0 ? - shortage : shortage);
+ return make_fixnum (count <= 0 ? - shortage : shortage);
}
DEFUN ("beginning-of-line", Fbeginning_of_line, Sbeginning_of_line, 0, 1, "^p",
@@ -162,9 +162,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 +187,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 +210,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 +230,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);
@@ -274,12 +274,12 @@ a non-nil value for the inserted character. At the end, it runs
`post-self-insert-hook'. */)
(Lisp_Object n)
{
- CHECK_NUMBER (n);
+ CHECK_FIXNUM (n);
- 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. */
@@ -287,8 +287,8 @@ a non-nil value for the inserted character. At the end, it runs
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 (last_command_event));
+ 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 +360,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 +378,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,8 +408,8 @@ 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;
@@ -439,17 +439,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 867f84de609..966492a322f 100644
--- a/src/coding.c
+++ b/src/coding.c
@@ -324,7 +324,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)))
@@ -620,18 +620,18 @@ inhibit_flag (int encoded_flag, bool var)
} while (0)
static void
-CHECK_NATNUM_CAR (Lisp_Object x)
+CHECK_FIXNAT_CAR (Lisp_Object x)
{
Lisp_Object tmp = XCAR (x);
- CHECK_NATNUM (tmp);
+ CHECK_FIXNAT (tmp);
XSETCAR (x, tmp);
}
static void
-CHECK_NATNUM_CDR (Lisp_Object x)
+CHECK_FIXNAT_CDR (Lisp_Object x)
{
Lisp_Object tmp = XCDR (x);
- CHECK_NATNUM (tmp);
+ CHECK_FIXNAT (tmp);
XSETCDR (x, tmp);
}
@@ -2622,7 +2622,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 +2888,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 +2906,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 +2915,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 +2925,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 +4459,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;
@@ -4612,7 +4612,7 @@ detect_coding_sjis (struct coding_system *coding,
CODING_GET_INFO (coding, attrs, charset_list);
max_first_byte_of_2_byte_code
- = (XINT (Flength (charset_list)) > 3 ? 0xFC : 0xEF);
+ = (XFIXNUM (Flength (charset_list)) > 3 ? 0xFC : 0xEF);
detect_info->checked |= CATEGORY_MASK_SJIS;
/* A coding system of this category is always ASCII compatible. */
@@ -4725,10 +4725,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 +4840,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 +4936,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 +5029,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 +5440,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 +5461,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 +5551,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 +5573,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 +5726,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;
@@ -5749,7 +5749,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 +5852,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 +5908,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 +5934,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 +6356,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
@@ -6693,7 +6714,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 +6740,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 +6924,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 +6936,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 +6951,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 +6962,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 +6981,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 +6997,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 +7048,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 +7081,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 +7239,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 +7263,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 +7534,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 +7546,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 +7591,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 +7709,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);
}
@@ -7984,18 +8005,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 +8163,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 +8293,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 +8459,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);
@@ -8524,7 +8543,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));
}
@@ -8599,7 +8618,7 @@ 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;
@@ -8722,20 +8741,20 @@ detect_coding_system (const unsigned char *src,
{
detect_info.found = CATEGORY_MASK_RAW_TEXT;
id = CODING_SYSTEM_ID (Qno_conversion);
- val = list1 (make_number (id));
+ val = list1 (make_fixnum (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 = list1 (make_fixnum (id));
}
else if (highest)
{
if (detect_info.found)
{
detect_info.found = 1 << category;
- val = list1 (make_number (this->id));
+ val = list1 (make_fixnum (this->id));
}
else
for (i = 0; i < coding_category_raw_text; i++)
@@ -8743,7 +8762,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 = list1 (make_fixnum (id));
break;
}
}
@@ -8760,7 +8779,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 = list1 (make_fixnum (id));
}
}
for (i = coding_category_raw_text - 1; i >= 0; i--)
@@ -8769,7 +8788,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 +8804,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 = list1 (make_fixnum (this->id));
}
}
else if (base_category == coding_category_utf_16_auto)
@@ -8802,13 +8821,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 = list1 (make_fixnum (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 = list1 (make_fixnum (coding.id));
}
/* Then, detect eol-format if necessary. */
@@ -8850,9 +8869,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 +8922,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 +8975,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 +9011,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 +9146,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 +9175,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 +9201,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 +9265,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 +9318,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 +9369,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 +9395,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 +9491,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 +9610,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 +9620,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 +9649,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 +9664,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 +9678,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 +9691,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 +9701,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 +9722,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 +9736,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 +9748,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 +9770,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))));
+ : list1 (make_fixnum (charset_ascii))));
return Qnil;
}
@@ -9864,19 +9883,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 +9917,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 +9967,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. */
@@ -10057,7 +10076,7 @@ usage: (define-coding-system-internal ...) */)
if (nargs < coding_arg_max)
goto short_args;
- attrs = Fmake_vector (make_number (coding_attr_last_index), Qnil);
+ attrs = Fmake_vector (make_fixnum (coding_attr_last_index), Qnil);
name = args[coding_arg_name];
CHECK_SYMBOL (name);
@@ -10089,10 +10108,10 @@ usage: (define-coding-system-internal ...) */)
}
for (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
@@ -10112,7 +10131,7 @@ 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;
}
@@ -10122,7 +10141,7 @@ usage: (define-coding-system-internal ...) */)
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);
+ 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 +10166,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,11 +10194,11 @@ 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 = Fmake_vector (make_fixnum (256), Qnil);
for (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;
@@ -10195,9 +10214,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 +10226,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,31 +10264,31 @@ 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));
+ valids = Fmake_string (make_fixnum (256), make_fixnum (0), Qnil);
for (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)
+ CHECK_FIXNAT_CAR (val);
+ CHECK_FIXNUM_CDR (val);
+ if (XFIXNUM (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))
+ make_fixnum (0), make_fixnum (255));
+ from = XFIXNUM (XCAR (val));
+ if (! (from <= XFIXNUM (XCDR (val)) && XFIXNUM (XCDR (val)) <= 255))
args_out_of_range_3 (XCDR (val),
- XCAR (val), make_number (255));
- to = XINT (XCDR (val));
+ XCAR (val), make_fixnum (255));
+ to = XFIXNUM (XCDR (val));
}
for (i = from; i <= to; i++)
SSET (valids, i, 1);
@@ -10333,18 +10352,18 @@ 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_CAR (reg_usage);
+ CHECK_FIXNUM_CDR (reg_usage);
request = Fcopy_sequence (args[coding_arg_iso2022_request]);
for (tail = request; CONSP (tail); tail = XCDR (tail))
@@ -10356,18 +10375,18 @@ usage: (define-coding-system-internal ...) */)
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_FIXNAT_CDR (val);
+ if (XFIXNUM (XCDR (val)) >= 4)
+ error ("Invalid graphic register number: %"pI"d", XFIXNUM (XCDR (val)));
+ XSETCAR (val, make_fixnum (id));
}
flags = args[coding_arg_iso2022_flags];
- CHECK_NATNUM (flags);
- i = XINT (flags) & INT_MAX;
+ CHECK_FIXNAT (flags);
+ 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 +10403,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)
@@ -10410,11 +10429,11 @@ usage: (define-coding-system-internal ...) */)
struct charset *charset;
- if (XINT (Flength (charset_list)) != 3
- && XINT (Flength (charset_list)) != 4)
+ if (XFIXNUM (Flength (charset_list)) != 3
+ && XFIXNUM (Flength (charset_list)) != 4)
error ("There should be three or four 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))));
@@ -10422,13 +10441,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 +10455,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 +10468,10 @@ usage: (define-coding-system-internal ...) */)
{
struct charset *charset;
- if (XINT (Flength (charset_list)) != 2)
+ if (XFIXNUM (Flength (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 +10479,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))));
@@ -10513,7 +10532,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),
@@ -10580,7 +10599,7 @@ usage: (define-coding-system-internal ...) */)
short_args:
Fsignal (Qwrong_number_of_arguments,
Fcons (intern ("define-coding-system-internal"),
- make_number (nargs)));
+ make_fixnum (nargs)));
}
@@ -10602,7 +10621,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,7 +10766,7 @@ 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 */
@@ -10823,25 +10842,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");
@@ -10855,6 +10874,7 @@ syms_of_coding (void)
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)
@@ -10879,7 +10899,7 @@ syms_of_coding (void)
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
@@ -10896,7 +10916,7 @@ syms_of_coding (void)
DEFSYM (QCascii_compatible_p, ":ascii-compatible-p");
Vcoding_category_table
- = Fmake_vector (make_number (coding_category_max), Qnil);
+ = Fmake_vector (make_fixnum (coding_category_max), Qnil);
staticpro (&Vcoding_category_table);
/* Followings are target of code detection. */
ASET (Vcoding_category_table, coding_category_iso_7,
@@ -11200,7 +11220,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 = Fmake_vector (make_fixnum (256), Qnil);
DEFVAR_LISP ("select-safe-coding-system-function",
Vselect_safe_coding_system_function,
@@ -11289,13 +11309,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,7 +11332,7 @@ 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; */
@@ -11323,8 +11343,8 @@ internal character representation. */);
"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_null_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);
diff --git a/src/coding.h b/src/coding.h
index b803e391280..d2cf4d8a7ba 100644
--- a/src/coding.h
+++ b/src/coding.h
@@ -676,21 +676,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 +702,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,6 +748,18 @@ extern Lisp_Object from_unicode_buffer (const wchar_t *wstr);
} while (false)
+/* 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 Lisp_Object preferred_coding_system (void);
diff --git a/src/composite.c b/src/composite.c
index 746c2959f84..39c54fcfab3 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 = Fmake_vector (make_fixnum (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);
}
@@ -669,12 +669,12 @@ composition_gstring_put_cache (Lisp_Object gstring, ptrdiff_t len)
len = j;
}
- copy = Fmake_vector (make_number (len + 2), Qnil);
+ copy = Fmake_vector (make_fixnum (len + 2), Qnil);
LGSTRING_SET_HEADER (copy, Fcopy_sequence (header));
for (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));
+ LGSTRING_SET_ID (copy, make_fixnum (i));
return copy;
}
@@ -692,7 +692,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 +716,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++)
{
@@ -801,7 +801,7 @@ fill_gstring_header (Lisp_Object header, ptrdiff_t from, ptrdiff_t from_byte,
if (VECTORP (header))
{
if (ASIZE (header) != len + 1)
- args_out_of_range (header, make_number (len + 1));
+ args_out_of_range (header, make_fixnum (len + 1));
}
else
{
@@ -820,7 +820,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 +836,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 +852,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 +881,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 +917,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 +926,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 +941,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 +1030,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 +1081,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 +1221,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 +1262,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 +1391,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 +1559,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 +1739,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
@@ -1759,7 +1759,7 @@ should be ignored. */)
return gstring;
if (LGSTRING_GLYPH_LEN (gstring_work) < topos - frompos)
- gstring_work = Fmake_vector (make_number (topos - frompos + 2), Qnil);
+ gstring_work = Fmake_vector (make_fixnum (topos - frompos + 2), Qnil);
LGSTRING_SET_HEADER (gstring_work, header);
LGSTRING_SET_ID (gstring_work, Qnil);
fill_gstring_body (gstring_work);
@@ -1780,12 +1780,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 +1820,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 +1832,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 +1848,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 +1884,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 +1906,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 +1917,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, Fmake_vector (make_fixnum (i + 2), Qnil));
staticpro (&gstring_work);
- gstring_work = Fmake_vector (make_number (10), Qnil);
+ gstring_work = Fmake_vector (make_fixnum (10), Qnil);
/* Text property `composition' should be nonsticky by default. */
Vtext_property_default_nonsticky
diff --git a/src/composite.h b/src/composite.h
index 19d20fb2b2c..8039113d872 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() Fmake_vector (make_fixnum (LGLYPH_SIZE), Qnil)
+#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 69f686d72df..683a96f9368 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
@@ -67,14 +74,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
@@ -90,11 +90,6 @@ 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
@@ -218,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.
@@ -282,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
@@ -338,12 +334,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 4569f002420..750d494b83a 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"
@@ -74,7 +75,7 @@ XKBOARD_OBJFWD (union Lisp_Fwd *a)
return &a->u_kboard_objfwd;
}
static struct Lisp_Intfwd *
-XINTFWD (union Lisp_Fwd *a)
+XFIXNUMFWD (union Lisp_Fwd *a)
{
eassert (INTFWDP (a));
return &a->u_intfwd;
@@ -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;
@@ -277,6 +268,7 @@ for example, (type-of 1) returns `integer'. */)
case PVEC_MODULE_FUNCTION:
return Qmodule_function;
/* "Impossible" cases. */
+ case PVEC_MISC_PTR:
case PVEC_XWIDGET:
case PVEC_OTHER:
case PVEC_XWIDGET_VIEW:
@@ -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,
@@ -858,10 +850,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,
@@ -992,7 +984,7 @@ do_symval_forwarding (register union Lisp_Fwd *valcontents)
switch (XFWDTYPE (valcontents))
{
case Lisp_Fwd_Int:
- XSETINT (val, *XINTFWD (valcontents)->intvar);
+ XSETINT (val, *XFIXNUMFWD (valcontents)->intvar);
return val;
case Lisp_Fwd_Bool:
@@ -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 = XFIXNUM (Flength (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);
}
@@ -1081,8 +1076,8 @@ store_symval_forwarding (union Lisp_Fwd *valcontents, register Lisp_Object newva
switch (XFWDTYPE (valcontents))
{
case Lisp_Fwd_Int:
- CHECK_NUMBER (newval);
- *XINTFWD (valcontents)->intvar = XINT (newval);
+ CHECK_FIXNUM (newval);
+ *XFIXNUMFWD (valcontents)->intvar = XFIXNUM (newval);
break;
case Lisp_Fwd_Bool:
@@ -1710,11 +1705,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
@@ -1851,7 +1856,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)
{
@@ -1914,8 +1919,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)))
@@ -2154,47 +2158,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. */
@@ -2261,8 +2224,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;
@@ -2271,11 +2234,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))
{
@@ -2312,8 +2275,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);
@@ -2349,7 +2312,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))
{
@@ -2403,39 +2366,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, mp_bitcnt_t 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) };
+
+ mp_bitcnt_t 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
@@ -2445,35 +2482,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;
@@ -2569,48 +2627,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)
@@ -2619,27 +2650,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 = 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);
+ }
}
}
}
@@ -2653,18 +2691,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)
@@ -2673,27 +2711,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 = 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);
+ }
}
}
}
@@ -2712,12 +2757,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);
}
@@ -2732,9 +2780,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);
@@ -2742,18 +2788,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, S2N_IGNORE_TRAILING);
+ return NILP (val) ? make_fixnum (0) : val;
}
enum arithop
@@ -2766,151 +2812,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. */
+
+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;
+ 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 make_float (accum);
+ return (FLOATP (val)
+ ? float_arith_driver (code, nargs, args, argnum, accum, val)
+ : bignum_arith_driver (code, nargs, args, argnum, accum, val));
}
@@ -2919,7 +2992,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,
@@ -2929,7 +3006,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,
@@ -2937,7 +3027,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,
@@ -2948,11 +3042,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,
@@ -2960,16 +3074,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,
@@ -2978,29 +3098,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
@@ -3008,11 +3144,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)))
@@ -3045,7 +3181,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,
@@ -3054,7 +3194,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,
@@ -3063,48 +3207,95 @@ 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);
-
- Lisp_Object val;
+ CHECK_INTEGER (value);
- 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);
+ /* The negative of the minimum value of COUNT that fits into a fixnum,
+ such that mpz_fdiv_q_exp supports -COUNT. */
+ EMACS_INT minus_count_min = min (-MOST_NEGATIVE_FIXNUM,
+ TYPE_MAXIMUM (mp_bitcnt_t));
+ CHECK_INTEGER (value);
+ CHECK_RANGED_INTEGER (count, - minus_count_min, TYPE_MAXIMUM (mp_bitcnt_t));
+
+ 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)
+ 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,
@@ -3112,13 +3303,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,
@@ -3126,22 +3318,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,
@@ -3154,7 +3349,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
@@ -3507,7 +3702,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,
@@ -3526,16 +3721,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
@@ -3556,7 +3751,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
@@ -3583,7 +3778,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);
}
@@ -3626,6 +3821,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");
@@ -3828,10 +4024,6 @@ syms_of_data (void)
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);
@@ -3853,7 +4045,7 @@ syms_of_data (void)
defsubr (&Slogand);
defsubr (&Slogior);
defsubr (&Slogxor);
- defsubr (&Slsh);
+ defsubr (&Slogcount);
defsubr (&Sash);
defsubr (&Sadd1);
defsubr (&Ssub1);
@@ -3877,15 +4069,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 ec3707d18f3..9bc344e9612 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,
diff --git a/src/decompress.c b/src/decompress.c
index 41de6da1dd2..28363382168 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. */
@@ -139,8 +150,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 +169,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;
@@ -196,7 +212,11 @@ This function can be called only in unibyte buffers. */)
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);
}
diff --git a/src/deps.mk b/src/deps.mk
index 7b6ae9cd8e0..f202d0e1041 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 a753b1930e6..7ad401c728b 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,15 @@ 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
+ ;
+
/* Loop reading directory entries. */
for (struct dirent *dp; (dp = read_dirent (d, directory)); )
{
@@ -266,8 +252,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)
{
@@ -360,7 +347,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'.
@@ -684,15 +671,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 +701,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 +729,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 +769,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 +866,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.
@@ -1022,13 +1003,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 +1018,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 +1052,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 29c401c61e5..579665c2ff8 100644
--- a/src/dispextern.h
+++ b/src/dispextern.h
@@ -306,24 +306,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 +1837,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
@@ -2482,7 +2482,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
@@ -3429,11 +3429,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 +3444,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 +3463,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 +3569,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 a81d6f64d1e..798413d091c 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"
@@ -233,9 +234,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
@@ -1281,7 +1280,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);
@@ -2509,8 +2508,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);
}
}
@@ -4652,6 +4650,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);
@@ -4674,8 +4677,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
{
@@ -5714,8 +5716,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)
@@ -5765,9 +5767,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))
@@ -5825,8 +5836,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);
}
@@ -5923,7 +5933,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 = Fmake_vector (make_fixnum (n + 20), Qlambda);
if (! NILP (variable))
Fset (variable, state);
else
@@ -6039,7 +6049,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,
@@ -6055,7 +6065,7 @@ 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 */
@@ -6068,7 +6078,7 @@ init_display (void)
)
{
Vinitial_window_system = Qns;
- Vwindow_system_version = make_number (10);
+ Vwindow_system_version = make_fixnum (10);
return;
}
#endif
@@ -6221,7 +6231,7 @@ syms_of_display (void)
defsubr (&Sdump_redisplay_history);
#endif
- frame_and_buffer_state = Fmake_vector (make_number (20), Qlambda);
+ frame_and_buffer_state = Fmake_vector (make_fixnum (20), Qlambda);
staticpro (&frame_and_buffer_state);
/* This is the "purpose" slot of a display table. */
diff --git a/src/disptab.h b/src/disptab.h
index a86a9130aca..c8de011f7d6 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/doc.c b/src/doc.c
index 3424bffdf9a..343734637fc 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;
@@ -148,7 +148,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 +203,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))
@@ -341,7 +339,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 +351,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 +378,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 +395,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 +437,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 +486,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 +503,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 +533,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;
@@ -609,34 +606,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 +631,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 +657,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 +671,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 cc5ce65105b..f194b43e0a9 100644
--- a/src/doprnt.c
+++ b/src/doprnt.c
@@ -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 c6d4d5b8d82..c159b260142 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 53afdafa2dc..d40aa67f416 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 081ea0b3b7c..47509c23d04 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -47,6 +47,17 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <errno.h>
#include <float.h>
#include <limits.h>
+#include <math.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
#include <c-ctype.h>
#include <intprops.h>
@@ -56,6 +67,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "composite.h"
#include "intervals.h"
+#include "ptr-bounds.h"
#include "character.h"
#include "buffer.h"
#include "coding.h"
@@ -116,14 +128,10 @@ emacs_mktime_z (timezone_t tz, struct tm *tm)
return t;
}
-/* Allocate a timezone, signaling on failure. */
-static timezone_t
-xtzalloc (char const *name)
+static _Noreturn void
+invalid_time_zone_specification (Lisp_Object zone)
{
- timezone_t tz = tzalloc (name);
- if (!tz)
- memory_full (SIZE_MAX);
- return tz;
+ xsignal2 (Qerror, build_string ("Invalid time zone specification"), zone);
}
/* Free a timezone, except do not free the time zone for local time.
@@ -150,30 +158,30 @@ tzlookup (Lisp_Object zone, bool settz)
if (NILP (zone))
return local_tz;
- else if (EQ (zone, Qt))
+ else if (EQ (zone, Qt) || EQ (zone, make_fixnum (0)))
{
zone_string = "UTC0";
new_tz = utc_tz;
}
else
{
- bool plain_integer = INTEGERP (zone);
+ 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) && INTEGERP (XCAR (zone))
+ else if (plain_integer || (CONSP (zone) && FIXNUMP (XCAR (zone))
&& CONSP (XCDR (zone))))
{
- Lisp_Object abbr;
+ Lisp_Object abbr UNINIT;
if (!plain_integer)
{
abbr = XCAR (XCDR (zone));
zone = XCAR (zone);
}
- EMACS_INT abszone = eabs (XINT (zone)), hour = abszone / (60 * 60);
+ 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;
@@ -188,8 +196,8 @@ tzlookup (Lisp_Object zone, bool settz)
prec += 2, numzone = 100 * numzone + sec;
}
sprintf (tzbuf, tzbuf_format, prec,
- XINT (zone) < 0 ? -numzone : numzone,
- &"-"[XINT (zone) < 0], hour, min, sec);
+ XFIXNUM (zone) < 0 ? -numzone : numzone,
+ &"-"[XFIXNUM (zone) < 0], hour, min, sec);
zone_string = tzbuf;
}
else
@@ -197,16 +205,32 @@ tzlookup (Lisp_Object zone, bool settz)
AUTO_STRING (leading, "<");
AUTO_STRING_WITH_LEN (trailing, tzbuf,
sprintf (tzbuf, trailing_tzbuf_format,
- &"-"[XINT (zone) < 0],
+ &"-"[XFIXNUM (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);
+ 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)
@@ -305,7 +329,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 +359,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 +370,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 +421,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 +448,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 +484,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 +505,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 +536,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 +550,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 +603,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 +647,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 +707,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 +719,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 +728,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 +739,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 +792,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 +807,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 +853,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 +869,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
@@ -877,7 +898,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 +907,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,
+ || (find_newline (XFIXNAT (new_pos), -1,
+ XFIXNAT (field_bound), -1,
fwd ? -1 : 1, &shortage, NULL, 1),
shortage != 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 +947,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 +982,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 +1054,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 +1085,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 +1157,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 +1170,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 +1181,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 +1266,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 +1277,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 +1311,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 +1338,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)
{
@@ -1369,38 +1378,38 @@ This ignores the environment variables LOGNAME and USER, so it differs from
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-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 +1417,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 +1460,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 (make_fixnum (pw->pw_uid));
USE_SAFE_ALLOCA;
char *r = SAFE_ALLOCA (strlen (p) + SBYTES (login) + 1);
memcpy (r, p, q - p);
@@ -1476,11 +1485,12 @@ 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);
+ return INT_TO_INTEGER (pid);
}
@@ -1579,13 +1589,21 @@ time_subtract (struct lisp_time ta, struct lisp_time tb)
}
static Lisp_Object
-time_arith (Lisp_Object a, Lisp_Object b,
- struct lisp_time (*op) (struct lisp_time, struct lisp_time))
+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;
+
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);
+ struct lisp_time t = (subtract ? time_subtract : time_add) (ta, tb);
if (FIXNUM_OVERFLOW_P (t.hi))
time_overflow ();
Lisp_Object val = Qnil;
@@ -1593,14 +1611,14 @@ time_arith (Lisp_Object a, Lisp_Object b,
switch (max (alen, blen))
{
default:
- val = Fcons (make_number (t.ps), val);
+ val = Fcons (make_fixnum (t.ps), val);
FALLTHROUGH;
case 3:
- val = Fcons (make_number (t.us), val);
+ val = Fcons (make_fixnum (t.us), val);
FALLTHROUGH;
case 2:
- val = Fcons (make_number (t.lo), val);
- val = Fcons (make_number (t.hi), val);
+ val = Fcons (make_fixnum (t.lo), val);
+ val = Fcons (make_fixnum (t.hi), val);
break;
}
@@ -1613,7 +1631,7 @@ 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);
+ return time_arith (a, b, false);
}
DEFUN ("time-subtract", Ftime_subtract, Stime_subtract, 2, 2, 0,
@@ -1623,7 +1641,30 @@ 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);
+ 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;
+ }
+
+ int alen, blen;
+ struct lisp_time ta = lisp_time_struct (a, &alen);
+ struct lisp_time tb = lisp_time_struct (b, &blen);
+ return (ta.hi != tb.hi ? (ta.hi < tb.hi ? -1 : 1)
+ : ta.lo != tb.lo ? (ta.lo < tb.lo ? -1 : 1)
+ : ta.us != tb.us ? (ta.us < tb.us ? -1 : 1)
+ : ta.ps < tb.ps ? -1 : ta.ps != tb.ps);
}
DEFUN ("time-less-p", Ftime_less_p, Stime_less_p, 2, 2, 0,
@@ -1632,22 +1673,23 @@ 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);
+ return time_cmp (t1, t2) < 0 ? Qt : Qnil;
+}
+
+DEFUN ("time-equal-p", Ftime_equal_p, Stime_equal_p, 2, 2, 0,
+ doc: /* Return non-nil if T1 and T2 are equal time values.
+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)
+{
+ return time_cmp (t1, t2) == 0 ? 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).
+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'. */)
@@ -1702,10 +1744,10 @@ 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 high = make_fixnum (0);
Lisp_Object low = specified_time;
- Lisp_Object usec = make_number (0);
- Lisp_Object psec = make_number (0);
+ Lisp_Object usec = make_fixnum (0);
+ Lisp_Object psec = make_fixnum (0);
int len = 4;
if (CONSP (specified_time))
@@ -1802,9 +1844,10 @@ 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)))
+ EMACS_INT hi, us, ps;
+ intmax_t lo;
+ if (! (FIXNUMP (high)
+ && FIXNUMP (usec) && FIXNUMP (psec)))
return 0;
if (! INTEGERP (low))
{
@@ -1835,16 +1878,18 @@ decode_time_components (Lisp_Object high, Lisp_Object low, Lisp_Object usec,
return 0;
}
- hi = XINT (high);
- lo = XINT (low);
- us = XINT (usec);
- ps = XINT (psec);
+ hi = XFIXNUM (high);
+ if (! integer_to_intmax (low, &lo))
+ return -1;
+ us = XFIXNUM (usec);
+ 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);
lo += us / 1000000 - (us % 1000000 < 0);
- hi += lo >> LO_TIME_BITS;
+ if (INT_ADD_WRAPV (lo >> LO_TIME_BITS, hi, &hi))
+ return -1;
ps = ps % 1000000 + 1000000 * (ps % 1000000 < 0);
us = us % 1000000 + 1000000 * (us % 1000000 < 0);
lo &= (1 << LO_TIME_BITS) - 1;
@@ -1921,8 +1966,8 @@ lisp_seconds_argument (Lisp_Object specified_time)
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);
+ val = decode_time_components (high, low, make_fixnum (0),
+ make_fixnum (0), &t, 0);
if (0 < val
&& ! ((TYPE_SIGNED (time_t)
? TIME_T_MIN >> LO_TIME_BITS <= t.hi
@@ -2152,7 +2197,8 @@ 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
+nil if it is not in effect, and -1 if this 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.)
@@ -2174,18 +2220,19 @@ usage: (decode-time &optional TIME ZONE) */)
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,
+ 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),
+ make_fixnum (local_tm.tm_year + tm_year_base),
+ 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_number (tm_gmtoff (&local_tm))
+ ? make_fixnum (tm_gmtoff (&local_tm))
: gmtime_r (&time_spec, &gmt_tm)
- ? make_number (tm_diff (&local_tm, &gmt_tm))
+ ? make_fixnum (tm_diff (&local_tm, &gmt_tm))
: Qnil));
}
@@ -2194,8 +2241,8 @@ usage: (decode-time &optional TIME ZONE) */)
static int
check_tm_member (Lisp_Object obj, int offset)
{
- CHECK_NUMBER (obj);
- EMACS_INT n = XINT (obj);
+ CHECK_FIXNUM (obj);
+ EMACS_INT n = XFIXNUM (obj);
int result;
if (INT_SUBTRACT_WRAPV (n, offset, &result))
time_overflow ();
@@ -2377,7 +2424,7 @@ the data it can't find. */)
long int offset = (HAVE_TM_GMTOFF
? tm_gmtoff (&local_tm)
: tm_diff (&local_tm, &gmt_tm));
- zone_offset = make_number (offset);
+ zone_offset = make_fixnum (offset);
if (SCHARS (zone_name) == 0)
{
/* No local time zone name is available; use numeric zone instead. */
@@ -2520,7 +2567,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 +2723,18 @@ called interactively, INHERIT is t. */)
CHECK_CHARACTER (character);
if (NILP (count))
XSETFASTINT (count, 1);
- CHECK_NUMBER (count);
- c = XFASTINT (character);
+ 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 +2767,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 +2855,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 +2881,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 +2889,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 +2907,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 +2923,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 +2969,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 +3037,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 +3075,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 +3138,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 +3147,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);
}
@@ -3195,6 +3242,8 @@ differences between the two buffers. */)
return Qnil;
}
+ 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
@@ -3235,8 +3284,7 @@ differences between the two buffers. */)
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 +3333,14 @@ 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)
@@ -3414,8 +3461,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 +3488,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,7 +3538,7 @@ 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))
{
@@ -3558,8 +3605,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 +3661,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)
@@ -3667,9 +3713,9 @@ It returns the number of characters changed. */)
tt = SDATA (table);
}
- pos = XINT (start);
+ pos = XFIXNUM (start);
pos_byte = CHAR_TO_BYTE (pos);
- end_pos = XINT (end);
+ end_pos = XFIXNUM (end);
modify_text (pos, end_pos);
cnt = 0;
@@ -3718,7 +3764,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;
}
@@ -3779,7 +3825,7 @@ It returns the number of characters changed. */)
}
else
{
- string = Fmake_string (make_number (1), val);
+ string = Fmake_string (make_fixnum (1), val, Qnil);
}
replace_range (pos, pos + len, string, 1, 0, 1, 0);
pos_byte += SBYTES (string);
@@ -3793,7 +3839,7 @@ It returns the number of characters changed. */)
pos++;
}
- return make_number (cnt);
+ return make_fixnum (cnt);
}
DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r",
@@ -3803,7 +3849,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 +3859,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, "",
@@ -3844,27 +3890,27 @@ When calling from a program, pass two arguments; 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;
@@ -4110,8 +4156,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;
}
@@ -4171,14 +4217,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
@@ -4228,8 +4274,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 null) 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;
@@ -4273,9 +4337,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);
@@ -4283,6 +4347,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.
@@ -4332,8 +4398,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 == '%')
{
@@ -4453,7 +4525,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)
{
@@ -4569,7 +4641,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'
@@ -4578,43 +4650,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')
@@ -4625,219 +4667,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;
+
+ if (FLOATP (arg))
+ darg = XFLOAT_DATA (arg);
+ else
+ {
+ 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)
{
- /* 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);
+ 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;
}
}
}
@@ -4890,43 +5021,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)
- {
- 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
+ if (bufsize <= buflen_needed)
{
- 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);
+
+ 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;
- format = format0;
- n = n0;
- ispec = ispec0;
+ 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)
@@ -4949,8 +5088,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))
{
@@ -4974,7 +5113,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. */
@@ -4995,10 +5134,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++)
{
@@ -5017,10 +5156,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. */
@@ -5028,17 +5167,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));
}
}
@@ -5061,13 +5200,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
@@ -5170,7 +5309,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.
@@ -5178,7 +5326,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;
@@ -5195,10 +5350,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. */
@@ -5351,8 +5506,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);
@@ -5525,6 +5679,22 @@ 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; 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. */);
+ /* For now, default to true if bignums exist, false in traditional Emacs. */
+#ifdef lisp_h_FIXNUMP
+ binary_as_unsigned = false;
+#else
+ binary_as_unsigned = true;
+#endif
+
defsubr (&Spropertize);
defsubr (&Schar_equal);
defsubr (&Sgoto_char);
@@ -5597,6 +5767,7 @@ functions if all the text being accessed has this property. */);
defsubr (&Scurrent_time);
defsubr (&Stime_add);
defsubr (&Stime_subtract);
+ defsubr (&Stime_equal_p);
defsubr (&Stime_less_p);
defsubr (&Sget_internal_run_time);
defsubr (&Sformat_time_string);
diff --git a/src/emacs-module.c b/src/emacs-module.c
index c20902d0729..0dcd7f0cc5a 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -36,6 +36,16 @@ 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"
+#endif
+
/* We use different strategies for allocating the user-visible objects
(struct emacs_runtime, emacs_env, emacs_value), depending on
whether the user supplied the -module-assertions flag. If
@@ -292,15 +302,15 @@ 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);
@@ -319,9 +329,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);
@@ -337,7 +347,7 @@ module_free_global_ref (emacs_env *env, emacs_value ref)
for (Lisp_Object tail = globals; CONSP (tail);
tail = XCDR (tail))
{
- emacs_value global = XSAVE_POINTER (XCAR (tail), 0);
+ emacs_value global = xmint_pointer (XCAR (tail));
if (global == ref)
{
if (NILP (prev))
@@ -431,7 +441,7 @@ module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity,
? (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;
@@ -465,7 +475,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++)
@@ -508,17 +518,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));
+ return lisp_to_value (env, make_int (n));
}
static double
@@ -572,7 +583,7 @@ module_make_string (emacs_env *env, const char *str, ptrdiff_t length)
{
MODULE_FUNCTION_BEGIN (module_nil);
if (! (0 <= length && length <= STRING_BYTES_BOUND))
- xsignal0 (Qoverflow_error);
+ overflow_error ();
/* FIXME: AUTO_STRING_WITH_LEN requires STR to be null-terminated,
but we shouldn't require that. */
AUTO_STRING_WITH_LEN (lstr, str, length);
@@ -629,8 +640,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
@@ -725,7 +736,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);
@@ -736,11 +747,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);
@@ -753,7 +760,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;
@@ -776,7 +783,6 @@ funcall_module (Lisp_Object function, ptrdiff_t nargs, Lisp_Object *arglist)
}
emacs_value ret = func->subr (env, nargs, args, func->data);
- SAFE_FREE ();
eassert (&priv == env->private_members);
@@ -785,7 +791,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
@@ -793,25 +799,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)
{
@@ -832,7 +826,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;
}
@@ -849,7 +843,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;
}
@@ -915,9 +909,8 @@ static Lisp_Object ltv_mark;
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);
+ return XPL (v);
/* With wide EMACS_INT and when tag bits are the most significant,
reassembling integers differs from reassembling pointers in two
@@ -926,7 +919,8 @@ value_to_lisp_bits (emacs_value v)
integer when restoring, but zero-extend pointers because that
makes TAG_PTR faster. */
- EMACS_UINT tag = i & (GCALIGNMENT - 1);
+ intptr_t i = (intptr_t) v;
+ EMACS_UINT tag = i & ((1 << GCTYPEBITS) - 1);
EMACS_UINT untagged = i - tag;
switch (tag)
{
@@ -961,11 +955,11 @@ value_to_lisp (emacs_value v)
for (Lisp_Object environments = Vmodule_environments;
CONSP (environments); environments = XCDR (environments))
{
- emacs_env *env = XSAVE_POINTER (XCAR (environments), 0);
+ emacs_env *env = xmint_pointer (XCAR (environments));
for (Lisp_Object values = env->private_members->values;
CONSP (values); values = XCDR (values))
{
- Lisp_Object *p = XSAVE_POINTER (XCAR (values), 0);
+ Lisp_Object *p = xmint_pointer (XCAR (values));
if (p == optr)
return *p;
++num_values;
@@ -989,13 +983,22 @@ value_to_lisp (emacs_value v)
static emacs_value
lisp_to_value_bits (Lisp_Object o)
{
- EMACS_UINT u = XLI (o);
+ if (plain_values || USE_LSB_TAG)
+ return XLP (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;
+ /* Compress O into the space of a pointer, possibly losing information. */
+ EMACS_UINT u = XLI (o);
+ if (FIXNUMP (o))
+ {
+ uintptr_t i = (u << VALBITS) + XTYPE (o);
+ return (emacs_value) i;
+ }
+ else
+ {
+ char *p = XLP (o);
+ void *v = p - (u & ~VALMASK) + XTYPE (o);
+ return v;
+ }
}
/* Convert O to an emacs_value. Allocate storage if needed; this can
@@ -1014,7 +1017,7 @@ lisp_to_value (emacs_env *env, Lisp_Object 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);
+ priv->values = Fcons (make_mint_ptr (ret), priv->values);
return ret;
}
@@ -1079,7 +1082,7 @@ 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);
+ Vmodule_environments = Fcons (make_mint_ptr (env), Vmodule_environments);
return env;
}
@@ -1088,7 +1091,7 @@ 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);
+ eassert (xmint_pointer (XCAR (Vmodule_environments)) == env);
Vmodule_environments = XCDR (Vmodule_environments);
if (module_assertions)
/* There is always at least the global environment. */
@@ -1102,10 +1105,10 @@ 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);
}
@@ -1116,7 +1119,7 @@ mark_modules (void)
for (Lisp_Object tail = Vmodule_environments; CONSP (tail);
tail = XCDR (tail))
{
- emacs_env *env = XSAVE_POINTER (XCAR (tail), 0);
+ emacs_env *env = xmint_pointer (XCAR (tail));
struct emacs_env_private *priv = env->private_members;
mark_object (priv->non_local_exit_symbol);
mark_object (priv->non_local_exit_data);
@@ -1160,15 +1163,11 @@ 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);
- }
+ global_env = initialize_environment (NULL, &global_env_private);
}
static _Noreturn void
diff --git a/src/emacs.c b/src/emacs.c
index 483e848f6db..b1c96d18285 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
@@ -372,7 +378,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);
@@ -441,7 +447,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
@@ -841,9 +847,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;
@@ -882,7 +888,7 @@ main (int argc, char **argv)
lim = newlim;
}
}
- /* If the stack is big enough, let regex.c more of it before
+ /* If the stack is big enough, let regex-emacs.c more of it before
falling back to heap allocation. */
emacs_re_safe_alloca = max
(min (lim - extra, SIZE_MAX) * (min_ratio / ratio),
@@ -1250,6 +1256,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)
@@ -1264,6 +1271,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
running_asynch_code = 0;
init_random ();
+#if defined HAVE_JSON && !defined WINDOWSNT
+ init_json ();
+#endif
+
no_loadup
= argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args);
@@ -1544,9 +1555,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 ();
@@ -1565,6 +1574,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
@@ -1612,6 +1625,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
syms_of_threads ();
syms_of_profiler ();
+#ifdef HAVE_JSON
+ syms_of_json ();
+#endif
+
keys_of_casefiddle ();
keys_of_cmds ();
keys_of_buffer ();
@@ -1691,23 +1708,15 @@ 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;
@@ -2012,10 +2021,17 @@ 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;
- run_hook (Qkill_emacs_hook);
+ if (noninteractive)
+ safe_run_hooks (Qkill_emacs_hook);
+ else
+ run_hook (Qkill_emacs_hook);
#ifdef HAVE_X_WINDOWS
/* Transfer any clipboards we own to the clipboard manager. */
@@ -2038,10 +2054,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);
@@ -2402,7 +2418,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
@@ -2469,6 +2485,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;
diff --git a/src/eval.c b/src/eval.c
index f9563a3f80c..5e25caaa847 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -204,6 +204,10 @@ bool
backtrace_p (union specbinding *pdl)
{ return pdl >= specpdl; }
+static bool
+backtrace_thread_p (struct thread_state *tstate, union specbinding *pdl)
+{ return pdl >= tstate->m_specpdl; }
+
union specbinding *
backtrace_top (void)
{
@@ -213,6 +217,15 @@ backtrace_top (void)
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,6 +235,15 @@ backtrace_next (union specbinding *pdl)
return pdl;
}
+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)
{
@@ -264,8 +286,8 @@ init_eval (void)
static void
restore_stack_limits (Lisp_Object data)
{
- max_specpdl_size = XINT (XCAR (data));
- max_lisp_eval_depth = XINT (XCDR (data));
+ max_specpdl_size = XFIXNUM (XCAR (data));
+ max_lisp_eval_depth = XFIXNUM (XCDR (data));
}
static void grow_specpdl (void);
@@ -303,8 +325,8 @@ 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_fixnum (old_max),
+ make_fixnum (old_depth)));
#ifdef HAVE_WINDOW_SYSTEM
if (display_hourglass_p)
@@ -511,7 +533,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 +649,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 +699,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 +775,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))))
@@ -924,7 +960,7 @@ usage: (let VARLIST BODY...) */)
CHECK_LIST (varlist);
/* Make space to hold the values to give the bound variables. */
- EMACS_INT varlist_len = XFASTINT (Flength (varlist));
+ EMACS_INT varlist_len = XFIXNAT (Flength (varlist));
SAFE_ALLOCA_LISP (temps, varlist_len);
ptrdiff_t nvars = varlist_len;
@@ -971,8 +1007,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 +1237,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 +1457,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)
{
@@ -1668,33 +1756,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. */
@@ -1806,7 +1886,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;
}
@@ -1943,12 +2025,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);
@@ -1968,7 +2050,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);
@@ -1993,12 +2075,10 @@ 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. */
@@ -2021,15 +2101,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
{
@@ -2181,9 +2264,9 @@ eval_sub (Lisp_Object form)
check_cons_list ();
- if (XINT (numargs) < XSUBR (fun)->min_args
+ if (XFIXNUM (numargs) < XSUBR (fun)->min_args
|| (XSUBR (fun)->max_args >= 0
- && XSUBR (fun)->max_args < XINT (numargs)))
+ && XSUBR (fun)->max_args < XFIXNUM (numargs)))
xsignal2 (Qwrong_number_of_arguments, original_fun, numargs);
else if (XSUBR (fun)->max_args == UNEVALLED)
@@ -2195,9 +2278,9 @@ eval_sub (Lisp_Object form)
ptrdiff_t argnum = 0;
USE_SAFE_ALLOCA;
- SAFE_ALLOCA_LISP (vals, XINT (numargs));
+ SAFE_ALLOCA_LISP (vals, XFIXNUM (numargs));
- while (CONSP (args_left) && argnum < XINT (numargs))
+ while (CONSP (args_left) && argnum < XFIXNUM (numargs))
{
Lisp_Object arg = XCAR (args_left);
args_left = XCDR (args_left);
@@ -2227,7 +2310,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, XFIXNUM (numargs));
switch (i)
{
@@ -2305,7 +2388,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)
@@ -2340,7 +2423,7 @@ usage: (apply FUNCTION &rest ARGUMENTS) */)
CHECK_LIST (spread_arg);
- numargs = XINT (Flength (spread_arg));
+ numargs = XFIXNUM (Flength (spread_arg));
if (numargs == 0)
return Ffuncall (nargs - 1, args);
@@ -2814,7 +2897,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)
@@ -2895,7 +2978,7 @@ apply_lambda (Lisp_Object fun, Lisp_Object args, ptrdiff_t count)
Lisp_Object tem;
USE_SAFE_ALLOCA;
- numargs = XFASTINT (Flength (args));
+ numargs = XFIXNAT (Flength (args));
SAFE_ALLOCA_LISP (arg_vector, numargs);
args_left = args;
@@ -2957,7 +3040,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.
@@ -2987,7 +3070,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 ();
@@ -2998,17 +3080,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
{
@@ -3021,7 +3101,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;
@@ -3032,14 +3112,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. */
@@ -3146,7 +3225,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
@@ -3161,7 +3240,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
@@ -3175,7 +3254,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,
@@ -3351,6 +3430,15 @@ record_unwind_protect (void (*function) (Lisp_Object), Lisp_Object arg)
}
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 ();
+}
+
+void
record_unwind_protect_ptr (void (*function) (void *), void *arg)
{
specpdl_ptr->unwind_ptr.kind = SPECPDL_UNWIND_PTR;
@@ -3369,6 +3457,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;
@@ -3404,6 +3500,9 @@ do_one_unbind (union specbinding *this_binding, bool unwinding,
case SPECPDL_UNWIND:
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;
@@ -3413,6 +3512,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:
@@ -3578,11 +3681,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;
@@ -3612,7 +3715,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))
@@ -3659,6 +3762,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
@@ -3687,18 +3826,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:
@@ -3779,7 +3922,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);
@@ -3831,8 +3974,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;
@@ -3862,6 +4007,15 @@ mark_specpdl (union specbinding *first, union specbinding *ptr)
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);
@@ -4073,6 +4227,9 @@ alist of active lexical bindings. */);
inhibit_lisp_code = Qnil;
+ DEFSYM (Qcatch_all_memory_full, "catch-all-memory-full");
+ Funintern (Qcatch_all_memory_full, Qnil);
+
defsubr (&Sor);
defsubr (&Sand);
defsubr (&Sif);
@@ -4116,6 +4273,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 e2be7fe2c69..7fb865809f5 100644
--- a/src/fileio.c
+++ b/src/fileio.c
@@ -96,6 +96,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <acl.h>
#include <allocator.h>
#include <careadlinkat.h>
+#include <fsusage.h>
#include <stat-time.h>
#include <tempname.h>
@@ -138,7 +139,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 +232,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 +247,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)
@@ -688,7 +691,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 +732,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);
}
@@ -818,17 +821,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'");
}
{
@@ -1945,9 +1945,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 +2002,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);
}
@@ -2296,6 +2296,21 @@ The arg must be a string. */)
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;
}
@@ -2350,7 +2365,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 +2383,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;
@@ -2461,9 +2476,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,12 +2504,12 @@ 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);
@@ -2518,9 +2533,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;
@@ -2647,7 +2662,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
@@ -2741,19 +2756,47 @@ See `file-symlink-p' to distinguish symlinks. */)
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
}
@@ -2814,7 +2857,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 +2878,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;
}
@@ -3145,7 +3191,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,7 +3208,7 @@ 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. */
@@ -3172,7 +3218,7 @@ symbolic notation, like the `chmod' command from GNU Coreutils. */)
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 +3239,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;
@@ -3244,7 +3290,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);
@@ -3339,21 +3385,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 +3424,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 +3487,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);
}
}
}
@@ -3553,8 +3609,8 @@ by calling `format-decode', which see. */)
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 +3795,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 +4263,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 +4274,7 @@ by calling `format-decode', which see. */)
break;
}
- this = XINT (nbytes);
+ this = XFIXNUM (nbytes);
}
else
{
@@ -4314,7 +4370,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 +4489,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 +4515,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
{
@@ -4482,8 +4538,8 @@ by calling `format-decode', which see. */)
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 +4549,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 +4559,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
@@ -4521,10 +4577,10 @@ by calling `format-decode', which see. */)
EMACS_INT 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 +4592,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 +4608,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 +4646,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);
}
@@ -4932,14 +4988,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 +5242,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 +5281,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. */
@@ -5398,16 +5454,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 +5472,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);
@@ -5494,9 +5548,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
@@ -5663,7 +5717,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 +5732,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 +5749,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 +5778,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 +5791,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 +5892,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 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 +6008,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 +6289,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/floatfns.c b/src/floatfns.c
index ec0349fbf40..900392575c0 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,7 +301,7 @@ 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))
{
@@ -328,27 +318,42 @@ This is the same as the exponent of a float. */)
else
value = MOST_POSITIVE_FIXNUM;
}
+ else if (BIGNUMP (arg))
+ value = mpz_sizeinbase (XBIGNUM (arg)->value, 2) - 1;
else
{
- EMACS_INT i = eabs (XINT (arg));
+ eassert (FIXNUMP (arg));
+ EMACS_INT i = eabs (XFIXNUM (arg));
value = (i == 0
? MOST_NEGATIVE_FIXNUM
: EMACS_UINT_WIDTH - 1 - ecount_leading_zeros (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 +364,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 +406,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 +477,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 +491,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 +500,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 +513,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 +529,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 +587,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 de1dad3736e..c9a6dd6de1e 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,18 +75,18 @@ 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. */
@@ -121,7 +119,7 @@ To get the number of bytes, use `string-bytes'. */)
CHECK_LIST_END (sequence, sequence);
if (MOST_POSITIVE_FIXNUM < i)
error ("List too long");
- val = make_number (i);
+ val = make_fixnum (i);
}
else if (NILP (sequence))
XSETFASTINT (val, 0);
@@ -134,14 +132,37 @@ To get the number of bytes, use `string-bytes'. */)
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.
+Value is a fixnum, if it's small enough, otherwise a bignum. */)
(Lisp_Object list)
{
intptr_t len = 0;
FOR_EACH_TAIL_SAFE (list)
len++;
- return make_fixnum_or_float (len);
+ return INT_TO_INTEGER (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;
+ if (MOST_POSITIVE_FIXNUM < len)
+ xsignal0 (Qoverflow_error);
+ return make_fixnum (len);
}
DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
@@ -150,7 +171,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 +291,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 +319,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 +330,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;
}
@@ -579,7 +666,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 +681,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 +690,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 +730,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 = Fmake_vector (make_fixnum (result_len), Qnil);
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 +761,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 +848,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 +869,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 +1279,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 +1290,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 +1338,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 +1384,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 +1404,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)
{
- CHECK_LIST_END (tail, list);
- return Qnil;
+ 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
+ {
+ 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 +1503,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 +1513,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 +1574,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 +1762,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 +1792,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;
@@ -1780,7 +1963,7 @@ sort_list (Lisp_Object list, Lisp_Object predicate)
front = list;
len = Flength (list);
- length = XINT (len);
+ length = XFIXNUM (len);
if (length < 2)
return list;
@@ -1889,7 +2072,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 ();
}
@@ -2104,11 +2287,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 +2306,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 +2359,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 +2387,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 +2416,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 +2425,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 +2527,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 +2594,7 @@ usage: (nconc &rest LISTS) */)
CHECK_CONS (tem);
- Lisp_Object tail;
+ Lisp_Object tail UNINIT;
FOR_EACH_TAIL (tem)
tail = tem;
@@ -2501,7 +2679,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 +2708,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 +2727,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 +2742,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 +2807,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 +2839,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 +2875,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))
@@ -2949,7 +3127,7 @@ The data read from the system are decoded using `locale-coding-system'. */)
#ifdef DAY_1
else if (EQ (item, Qdays)) /* e.g. for calendar-day-name-array */
{
- Lisp_Object v = Fmake_vector (make_number (7), Qnil);
+ Lisp_Object v = Fmake_vector (make_fixnum (7), Qnil);
const int days[7] = {DAY_1, DAY_2, DAY_3, DAY_4, DAY_5, DAY_6, DAY_7};
int i;
synchronize_system_time_locale ();
@@ -2968,7 +3146,7 @@ The data read from the system are decoded using `locale-coding-system'. */)
#ifdef MON_1
else if (EQ (item, Qmonths)) /* e.g. for calendar-month-name-array */
{
- Lisp_Object v = Fmake_vector (make_number (12), Qnil);
+ Lisp_Object v = Fmake_vector (make_fixnum (12), Qnil);
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;
@@ -3091,9 +3269,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 +3296,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 +3469,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 +3480,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 +3495,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,
@@ -3504,7 +3683,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 +3703,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 +3806,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 +3815,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 +3848,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,
@@ -3706,7 +3886,9 @@ hashfn_equal (struct hash_table_test *ht, Lisp_Object key)
static 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
@@ -3805,10 +3987,10 @@ 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 = Fmake_vector (make_fixnum (2 * size), Qnil);
+ h->hash = Fmake_vector (make_fixnum (size), Qnil);
+ h->next = Fmake_vector (make_fixnum (size), make_fixnum (-1));
+ h->index = Fmake_vector (make_fixnum (index_size), make_fixnum (-1));
h->pure = pure;
/* Set up the free list. */
@@ -3903,8 +4085,8 @@ 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, Fmake_vector (make_fixnum (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 +4115,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);
@@ -3962,7 +4144,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;
@@ -3993,7 +4175,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);
@@ -4019,7 +4201,7 @@ hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key)
{
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 +4245,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;
@@ -4261,18 +4443,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 +4512,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 +4541,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 +4554,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 +4596,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 +4604,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 +4612,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 +4698,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 +4708,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 +4758,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 +4771,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 +4795,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));
}
@@ -4829,8 +5016,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 +5023,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)
@@ -4902,7 +5087,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)
@@ -4936,11 +5121,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);
@@ -5226,7 +5411,9 @@ this variable. */);
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 305bb14576a..799d5db205c 100644
--- a/src/font.c
+++ b/src/font.c
@@ -201,7 +201,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 +270,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 +302,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 +311,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 +353,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 +366,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 = Fmake_vector (make_fixnum (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, Fmake_vector (make_fixnum (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 +421,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 +470,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 +543,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 +559,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 +569,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 +579,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 +875,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,7 +999,7 @@ 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;
@@ -1064,7 +1064,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 +1077,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 +1101,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 +1116,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 +1154,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 +1181,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 +1289,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 +1312,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 +1334,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] = "*";
@@ -1456,19 +1458,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 +1623,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 +1690,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))
@@ -1807,15 +1809,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 +1827,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 +1841,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 +1899,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 +2028,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 = Fmake_vector (make_fixnum (8), Qnil);
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)
@@ -2059,11 +2061,11 @@ 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));
+ val = Fmake_vector (make_fixnum (anchor->AnchorFormat + 1), Qnil);
+ 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 +2136,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,7 +2176,7 @@ 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));
+ EMACS_INT nargs = XFIXNAT (Flength (list));
Lisp_Object *args;
USE_SAFE_ALLOCA;
SAFE_ALLOCA_LISP (args, nargs);
@@ -2244,7 +2246,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 +2448,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 +2494,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 +2506,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 +2561,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 +2584,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 +2700,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 +2749,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
@@ -2824,7 +2826,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 +2875,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 +2912,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 +3135,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 +3181,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 +3243,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 = XFIXNAT (Flength (alters));
SAFE_ALLOCA_LISP (family, alterslen + 2);
for (i = 0; CONSP (alters); i++, alters = XCDR (alters))
family[i] = XCAR (alters);
@@ -3298,9 +3300,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 +3310,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 +3327,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 +3375,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 +3436,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 +3635,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 +3647,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 +3676,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 +3813,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 +3830,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 +4145,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 +4234,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 +4292,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 +4357,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 +4430,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 +4472,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 +4485,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 +4499,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 +4507,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 +4523,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 +4561,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 +4571,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 +4611,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 +4670,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 +4711,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 +4726,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 +4740,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 +4819,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 +4867,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 +4901,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 +4930,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 +4983,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 +5018,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 +5035,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 +5138,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)));
@@ -5173,8 +5177,8 @@ build_style_table (const struct table_entry *entry, int nelement)
for (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));
+ elt = Fmake_vector (make_fixnum (j + 1), Qnil);
+ 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);
@@ -5355,7 +5359,7 @@ syms_of_font (void)
scratch_font_prefer = Ffont_spec (0, NULL);
staticpro (&Vfont_log_deferred);
- Vfont_log_deferred = Fmake_vector (make_number (3), Qnil);
+ Vfont_log_deferred = Fmake_vector (make_fixnum (3), Qnil);
#if 0
#ifdef HAVE_LIBOTF
diff --git a/src/font.h b/src/font.h
index d88c8eb4f66..1741b3f3964 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))
@@ -613,7 +613,7 @@ struct font_driver
(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);
@@ -945,6 +945,22 @@ extern void font_deferred_log (const char *, Lisp_Object, Lisp_Object);
font_deferred_log ((ACTION), (ARG), (RESULT)); \
} while (false)
+/* FIXME: This is for use in functions that can be called while
+ garbage-collecting, but which assume that Lisp data structures are
+ properly-formed. This invalid assumption can lead to core dumps
+ (Bug#20890). */
+INLINE bool
+font_data_structures_may_be_ill_formed (void)
+{
+#ifdef USE_CAIRO
+ /* Although this works around Bug#20890, it is probably not the
+ right thing to do. */
+ return gc_in_progress;
+#else
+ return false;
+#endif
+}
+
INLINE_HEADER_END
#endif /* not EMACS_FONT_H */
diff --git a/src/fontset.c b/src/fontset.c
index e72354078ca..1f877eb606a 100644
--- a/src/fontset.c
+++ b/src/fontset.c
@@ -266,7 +266,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,12 +276,12 @@ 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); \
+ (rfont_def) = Fmake_vector (make_fixnum (4), Qnil); \
ASET ((rfont_def), 1, (font_def)); \
RFONT_DEF_SET_SCORE ((rfont_def), 0); \
} while (0)
@@ -328,10 +328,10 @@ fontset_ref (Lisp_Object fontset, int c)
(NILP (add) \
? (NILP (range) \
? (set_fontset_fallback \
- (fontset, Fmake_vector (make_number (1), (elt)))) \
+ (fontset, Fmake_vector (make_fixnum (1), (elt)))) \
: ((void) \
Fset_char_table_range (fontset, range, \
- Fmake_vector (make_number (1), elt)))) \
+ Fmake_vector (make_fixnum (1), elt)))) \
: fontset_add ((fontset), (range), (elt), (add)))
static void
@@ -340,12 +340,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] = Fmake_vector (make_fixnum (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 +456,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 +496,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 +520,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 +561,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 +577,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 +633,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;
@@ -711,7 +711,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);
+ new_vec = Fmake_vector (make_fixnum (ASIZE (vec) + 1), Qnil);
found_index++;
for (j = 0; j < found_index; j++)
ASET (new_vec, j, AREF (vec, j));
@@ -727,7 +727,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 +756,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 +771,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 +830,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 +892,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 +973,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 +981,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 +990,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 +1003,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 +1040,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 +1048,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 +1083,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 +1306,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 +1399,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 +1412,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 +1424,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 +1547,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 +1559,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 +1632,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 +1765,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 +1800,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 +1988,7 @@ patterns. */)
fontset = check_fontset_name (name, &frame);
CHECK_CHARACTER (ch);
- c = XINT (ch);
+ c = XFIXNUM (ch);
list = Qnil;
while (1)
{
@@ -2003,9 +2003,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;
@@ -2064,7 +2064,7 @@ dump_fontset (Lisp_Object fontset)
{
Lisp_Object vec;
- vec = Fmake_vector (make_number (3), Qnil);
+ vec = Fmake_vector (make_fixnum (3), Qnil);
ASET (vec, 0, FONTSET_ID (fontset));
if (BASE_FONTSET_P (fontset))
@@ -2112,9 +2112,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,12 +2122,12 @@ syms_of_fontset (void)
Vcached_fontset_data = Qnil;
staticpro (&Vcached_fontset_data);
- Vfontset_table = Fmake_vector (make_number (32), Qnil);
+ Vfontset_table = Fmake_vector (make_fixnum (32), Qnil);
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"));
diff --git a/src/frame.c b/src/frame.c
index 0a6ca26f5d7..4371ef7f064 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"
@@ -138,14 +139,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 +153,17 @@ 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))
+ ? list4 (make_fixnum (FRAME_TEXT_WIDTH (f)),
+ make_fixnum (FRAME_TEXT_HEIGHT (f)),
+ make_fixnum (width),
+ make_fixnum (height))
: Qnil),
rest),
XCDR (frame_size_history)));
@@ -188,9 +184,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 +214,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 +312,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 +350,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 +371,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 +595,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
@@ -741,8 +741,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)));
+ list4 (make_fixnum (old_pixel_width), make_fixnum (old_pixel_height),
+ make_fixnum (new_pixel_width), make_fixnum (new_pixel_height)));
/* Assign new sizes. */
FRAME_TEXT_WIDTH (f) = new_text_width;
@@ -846,6 +846,7 @@ make_frame (bool mini_p)
f->no_focus_on_map = false;
f->no_accept_focus = false;
f->z_group = z_group_none;
+ f->tooltip = false;
#if ! defined (USE_GTK) && ! defined (HAVE_NS)
f->last_tool_bar_item = -1;
#endif
@@ -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);
@@ -1453,23 +1454,15 @@ This function returns FRAME, or nil if FRAME has been deleted. */)
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,
@@ -1481,20 +1474,21 @@ DEFUN ("selected-frame", Fselected_frame, Sselected_frame, 0, 0, 0,
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 +1597,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 +1719,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 +1734,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 +1743,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 +1753,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 +1789,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)))
@@ -1891,7 +1886,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 +1935,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;
}
@@ -2161,6 +2160,16 @@ 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);
+
return Qnil;
}
@@ -2310,8 +2319,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 +2429,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 +2470,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 +2807,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);
@@ -2965,7 +2972,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 +2986,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 +3059,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 +3117,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 +3190,7 @@ list, but are otherwise ignored. */)
#endif
{
- EMACS_INT length = XFASTINT (Flength (alist));
+ EMACS_INT length = XFIXNAT (Flength (alist));
ptrdiff_t i;
Lisp_Object *parms;
Lisp_Object *values;
@@ -3231,10 +3238,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 +3257,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 +3274,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 +3300,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 +3318,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 +3425,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 +3450,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 +3473,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 +3494,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,7 +3517,7 @@ 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
}
@@ -3679,10 +3686,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 +3717,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 +3802,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 +3871,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 +3913,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 +3925,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 +3933,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 +3948,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 +3978,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 +3988,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 +4058,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 +4093,31 @@ 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)
+ ? make_fixnum (0)
: FRAME_CONFIG_SCROLL_BAR_WIDTH (f) > 0
- ? make_number (FRAME_CONFIG_SCROLL_BAR_WIDTH (f))
+ ? 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)
+ ? make_fixnum (0)
: FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) > 0
- ? make_number (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f))
+ ? make_fixnum (FRAME_CONFIG_SCROLL_BAR_HEIGHT (f))
/* nil means "use default height"
for non-toolkit scroll bar. */
: Qnil));
@@ -4140,7 +4147,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 +4184,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 +4223,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 +4411,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 +4435,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 +4457,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 +4471,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 +4486,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 +4513,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
@@ -4588,11 +4595,11 @@ x_set_scroll_bar_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
SET_FRAME_GARBAGED (f);
}
- else if (RANGED_INTEGERP (1, arg, INT_MAX)
- && XFASTINT (arg) != FRAME_CONFIG_SCROLL_BAR_WIDTH (f))
+ else if (RANGED_FIXNUMP (1, arg, INT_MAX)
+ && XFIXNAT (arg) != FRAME_CONFIG_SCROLL_BAR_WIDTH (f))
{
- FRAME_CONFIG_SCROLL_BAR_WIDTH (f) = XFASTINT (arg);
- FRAME_CONFIG_SCROLL_BAR_COLS (f) = (XFASTINT (arg) + unit - 1) / unit;
+ 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);
@@ -4618,11 +4625,11 @@ x_set_scroll_bar_height (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
SET_FRAME_GARBAGED (f);
}
- else if (RANGED_INTEGERP (1, arg, INT_MAX)
- && XFASTINT (arg) != FRAME_CONFIG_SCROLL_BAR_HEIGHT (f))
+ else if (RANGED_FIXNUMP (1, arg, INT_MAX)
+ && XFIXNAT (arg) != FRAME_CONFIG_SCROLL_BAR_HEIGHT (f))
{
- FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) = XFASTINT (arg);
- FRAME_CONFIG_SCROLL_BAR_LINES (f) = (XFASTINT (arg) + unit - 1) / unit;
+ 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);
@@ -4661,11 +4668,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 +4840,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 +4920,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 +4970,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 +4984,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 +5219,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 +5232,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;
}
@@ -5288,11 +5299,11 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p, int *x
? tool_bar_button_relief
: DEFAULT_TOOL_BAR_BUTTON_RELIEF);
- 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 +5324,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 +5349,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 +5361,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 +5386,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 +5413,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 +5432,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 +5444,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 +5463,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;
}
@@ -5777,7 +5788,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 +5821,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 +5887,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 +5904,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.
diff --git a/src/frame.h b/src/frame.h
index 402d6c0a7b2..ad7376a6531 100644
--- a/src/frame.h
+++ b/src/frame.h
@@ -342,6 +342,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 +354,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;
@@ -577,7 +578,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. */
@@ -725,7 +726,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. */
@@ -967,6 +968,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 +985,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. */
@@ -1357,17 +1360,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 +1375,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 +1384,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 34bc5db06d1..6a44de1bf24 100644
--- a/src/fringe.c
+++ b/src/fringe.c
@@ -24,6 +24,7 @@ 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"
@@ -487,10 +488,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 +519,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 +587,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;
}
@@ -742,12 +743,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 = XFIXNUM (Flength (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 +757,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 +778,12 @@ get_logical_fringe_bitmap (struct window *w, Lisp_Object bitmap, int right_p, in
{
if (CONSP (bm2))
{
- ln2 = XINT (Flength (bm2));
+ ln2 = XFIXNUM (Flength (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 +795,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;
@@ -1508,8 +1509,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 +1522,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 +1586,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 +1604,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 +1633,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 +1661,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;
diff --git a/src/ftcrfont.c b/src/ftcrfont.c
index 614ef083701..dc1a389c607 100644
--- a/src/ftcrfont.c
+++ b/src/ftcrfont.c
@@ -137,7 +137,7 @@ ftcrfont_open (struct frame *f, Lisp_Object entity, int pixel_size)
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),
@@ -164,6 +164,9 @@ ftcrfont_open (struct frame *f, Lisp_Object entity, int pixel_size)
static void
ftcrfont_close (struct font *font)
{
+ if (font_data_structures_may_be_ill_formed ())
+ return;
+
struct ftcrfont_info *ftcrfont_info = (struct ftcrfont_info *) font;
int i;
diff --git a/src/ftfont.c b/src/ftfont.c
index 8f048d2983b..e83eff3ad08 100644
--- a/src/ftfont.c
+++ b/src/ftfont.c
@@ -196,7 +196,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))
@@ -232,35 +232,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
{
@@ -276,7 +276,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);
}
}
@@ -345,6 +345,7 @@ struct ftfont_cache_data
{
FT_Face ft_face;
FcCharSet *fc_charset;
+ intptr_t face_refcount;
};
static Lisp_Object
@@ -371,17 +372,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)
@@ -391,7 +390,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)
{
@@ -447,7 +446,7 @@ 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;
}
@@ -601,9 +600,9 @@ ftfont_get_open_type_spec (Lisp_Object otf_spec)
continue;
len = Flength (val);
spec->features[i] =
- (min (PTRDIFF_MAX, SIZE_MAX) / sizeof (int) < XINT (len)
+ (min (PTRDIFF_MAX, SIZE_MAX) / sizeof (int) < XFIXNUM (len)
? 0
- : malloc (XINT (len) * sizeof *spec->features[i]));
+ : malloc (XFIXNUM (len) * sizeof *spec->features[i]));
if (! spec->features[i])
{
if (i > 0 && spec->features[0])
@@ -647,10 +646,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);
@@ -687,8 +686,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))
{
@@ -736,7 +735,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;
}
}
@@ -833,8 +832,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))
{
@@ -956,8 +955,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;
@@ -1017,12 +1016,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)
@@ -1118,9 +1117,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)
@@ -1131,22 +1130,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->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;
@@ -1158,8 +1160,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;
@@ -1172,8 +1174,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
@@ -1231,7 +1233,7 @@ 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),
@@ -1242,22 +1244,20 @@ ftfont_open (struct frame *f, Lisp_Object entity, int pixel_size)
void
ftfont_close (struct font *font)
{
- /* FIXME: Although this function can be called while garbage-collecting,
- the function assumes that Lisp data structures are properly-formed.
- This invalid assumption can lead to core dumps (Bug#20890). */
+ if (font_data_structures_may_be_ill_formed ())
+ return;
struct ftfont_info *ftfont_info = (struct ftfont_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)
@@ -2534,7 +2534,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,13 +2603,13 @@ 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
diff --git a/src/gfilenotify.c b/src/gfilenotify.c
index 650df0fcbb5..798f308b315 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))
@@ -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,8 +238,8 @@ 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);
+ 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"),
@@ -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 d013f1f72c6..ebba789f610 100644
--- a/src/gmalloc.c
+++ b/src/gmalloc.c
@@ -40,6 +40,8 @@ License along with this library. If not, see <https://www.gnu.org/licenses/>.
# include "lisp.h"
#endif
+#include "ptr-bounds.h"
+
#ifdef HAVE_MALLOC_H
# if GNUC_PREREQ (4, 2, 0)
# pragma GCC diagnostic ignored "-Wdeprecated-declarations"
@@ -201,7 +203,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 +561,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 +922,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 +1001,7 @@ _free_internal_nolock (void *ptr)
if (ptr == NULL)
return;
+ ptr = ptr_bounds_init (ptr);
PROTECT_MALLOC_STATE (0);
@@ -1308,6 +1313,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 +1436,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.
@@ -1604,6 +1611,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)
diff --git a/src/gnutls.c b/src/gnutls.c
index 9e105b948f0..d36b637044f 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -75,6 +75,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
# ifdef WINDOWSNT
# include <windows.h>
+# include "w32common.h"
# include "w32.h"
# endif
@@ -857,7 +858,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 +908,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 +935,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 +975,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 +1007,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 +1054,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 +1252,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 +1304,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 +1314,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 +1338,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 +1471,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 +1508,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);
+ cert_list = gnutls_certificate_get_peers (state, &cert_list_length);
- gnutls_verify_cert_list
- = gnutls_certificate_get_peers (state, &gnutls_verify_cert_list_size);
-
- 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 +1574,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 +1692,14 @@ one trustfile (usually a CA bundle). */)
state = XPROCESS (proc)->gnutls_state;
- if (TYPE_RANGED_INTEGERP (int, loglevel))
+ if (TYPE_RANGED_FIXNUMP (int, 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);
+ gnutls_global_set_log_level (XFIXNUM (loglevel));
+ max_log_level = XFIXNUM (loglevel);
XPROCESS (proc)->gnutls_log_level = max_log_level;
}
@@ -1685,9 +1732,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 +1893,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 +1943,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);
@@ -1931,19 +1979,19 @@ The alist key is the cipher name. */)
Lisp_Object cp
= listn (CONSTYPE_HEAP, 15, cipher_symbol,
- QCcipher_id, make_number (gca),
+ 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 +2121,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);
@@ -2262,17 +2310,17 @@ name. */)
nonce_size = gnutls_mac_get_nonce_size (gma);
#endif
Lisp_Object mp = listn (CONSTYPE_HEAP, 11, gma_symbol,
- QCmac_algorithm_id, make_number (gma),
+ 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);
}
@@ -2297,11 +2345,11 @@ method name. */)
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),
+ 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 +2400,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 +2490,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,11 +2613,11 @@ 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
@@ -2613,19 +2661,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 6b72671da91..6212e1af4e8 100644
--- a/src/gtkutil.c
+++ b/src/gtkutil.c
@@ -258,8 +258,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
@@ -687,6 +687,7 @@ qttip_cb (GtkWidget *widget,
g_signal_connect (x->ttip_lbl, "hierarchy-changed",
G_CALLBACK (hierarchy_ch_cb), f);
}
+
return FALSE;
}
@@ -713,7 +714,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);
@@ -745,7 +747,7 @@ xg_prepare_tooltip (struct frame *f,
unblock_input ();
- return 1;
+ return TRUE;
#endif /* USE_GTK_TOOLTIP */
}
@@ -762,24 +764,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));
@@ -792,10 +794,10 @@ xg_hide_tooltip (struct frame *f)
}
unblock_input ();
- ret = 1;
+ return TRUE;
}
#endif
- return ret;
+ return FALSE;
}
@@ -961,7 +963,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)));
+ list2 (make_fixnum (gheight), make_fixnum (totalheight)));
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
gwidth, totalheight);
@@ -970,7 +972,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)));
+ list2 (make_fixnum (gwidth), make_fixnum (totalwidth)));
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
totalwidth, gheight);
@@ -979,7 +981,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)));
+ list2 (make_fixnum (totalwidth), make_fixnum (totalheight)));
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
totalwidth, totalheight);
@@ -1064,16 +1066,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;
@@ -1237,9 +1246,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. */
@@ -1856,7 +1867,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);
@@ -4108,8 +4119,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;
@@ -4146,7 +4159,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 ();
}
}
@@ -4264,7 +4279,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);
@@ -4281,7 +4296,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, XFIXNUM (Flength (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);
@@ -4874,18 +4889,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,
diff --git a/src/image.c b/src/image.c
index 767979e63bd..24decbc0997 100644
--- a/src/image.c
+++ b/src/image.c
@@ -77,6 +77,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 +323,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;
@@ -761,23 +762,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 +786,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 +805,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 +884,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");
@@ -1004,9 +1005,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)
@@ -1534,7 +1535,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 +1548,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 +1611,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);
@@ -1761,11 +1762,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
{
@@ -1776,25 +1777,25 @@ lookup_image (struct frame *f, Lisp_Object spec)
int relief_bound;
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);
}
@@ -1973,7 +1974,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;
}
@@ -2306,7 +2307,7 @@ 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);
@@ -2512,8 +2513,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 +2876,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 +3062,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))
{
@@ -4000,7 +4001,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 Fmake_vector (make_fixnum (256), Qnil);
}
static void
@@ -4168,7 +4169,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 +4240,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 +4248,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 +4268,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 +4940,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 +5094,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);
}
@@ -5734,7 +5735,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 */
@@ -7280,9 +7281,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 +7325,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);
@@ -7746,7 +7747,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'",
@@ -8000,7 +8001,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 +8022,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)
@@ -8106,29 +8107,29 @@ compute_image_size (size_t width, size_t height,
scale = XFLOATINT (value);
value = image_spec_value (spec, QCmax_width, NULL);
- if (NATNUMP (value))
- max_width = min (XFASTINT (value), INT_MAX);
+ if (FIXNATP (value))
+ max_width = min (XFIXNAT (value), INT_MAX);
value = image_spec_value (spec, QCmax_height, NULL);
- if (NATNUMP (value))
- max_height = min (XFASTINT (value), INT_MAX);
+ 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 (NATNUMP (value))
+ if (FIXNATP (value))
{
- desired_width = min (XFASTINT (value) * scale, INT_MAX);
+ desired_width = min (XFIXNAT (value) * scale, INT_MAX);
/* :width overrides :max-width. */
max_width = -1;
}
value = image_spec_value (spec, QCheight, NULL);
- if (NATNUMP (value))
+ if (FIXNATP (value))
{
- desired_height = min (XFASTINT (value) * scale, INT_MAX);
+ desired_height = min (XFIXNAT (value) * scale, INT_MAX);
/* :height overrides :max-height. */
max_height = -1;
}
@@ -8272,11 +8273,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 *);
@@ -8573,7 +8583,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 +8593,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 +8638,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 +8688,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);
}
@@ -8814,7 +8824,8 @@ 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);
color_scale /= 256;
@@ -9302,7 +9313,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);
@@ -9551,7 +9562,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 +9572,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 +9600,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 +9654,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 +9779,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 */
@@ -9933,27 +9944,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
@@ -10038,7 +10049,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 9c751bc30b5..18855768d37 100644
--- a/src/indent.c
+++ b/src/indent.c
@@ -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_CAR (frompos);
+ CHECK_FIXNUM_CDR (frompos);
+ CHECK_FIXNUM_COERCE_MARKER (to);
if (!NILP (topos))
{
CHECK_CONS (topos);
- CHECK_NUMBER_CAR (topos);
- CHECK_NUMBER_CDR (topos);
+ CHECK_FIXNUM_CAR (topos);
+ CHECK_FIXNUM_CDR (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_CAR (offsets);
+ CHECK_FIXNUM_CDR (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;
@@ -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 e06cc97c6a7..6e54c185c58 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 173c2438347..70cebc0d2cc 100644
--- a/src/insdel.c
+++ b/src/insdel.c
@@ -930,7 +930,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);
@@ -1936,7 +1936,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 +2046,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 +2103,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 +2210,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);
}
@@ -2287,17 +2287,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 4c624ea79c1..7e7771414fd 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. */
@@ -1557,8 +1557,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 +1793,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 +1806,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 +1926,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 +1937,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 +1954,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 +1969,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 +2026,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 +2055,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 +2065,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 +2096,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 162c4efc62e..f37372a42c8 100644
--- a/src/intervals.h
+++ b/src/intervals.h
@@ -116,7 +116,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..17cc0965b12
--- /dev/null
+++ b/src/json.c
@@ -0,0 +1,1031 @@
+/* JSON parsing and serialization.
+
+Copyright (C) 2017-2018 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 null-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 null characters. */
+
+static void
+check_string_without_embedded_nulls (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
+ null-terminated. */
+ check_string_without_embedded_nulls (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
+ null-terminated. */
+ check_string_without_embedded_nulls (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 null 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;
+};
+
+static Lisp_Object
+json_insert (void *data)
+{
+ struct json_buffer_and_size *buffer_and_size = data;
+ /* FIXME: This should be possible without creating an intermediate
+ string object. */
+ Lisp_Object string
+ = json_make_string (buffer_and_size->buffer, buffer_and_size->size);
+ insert1 (string);
+ return Qnil;
+}
+
+struct json_insert_data
+{
+ /* 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 the UTF-8 string in
+ [BUFFER, BUFFER + SIZE) into the current buffer.
+ If [BUFFER, BUFFER + SIZE) does not contain a valid UTF-8 string,
+ an unspecified string is inserted into the buffer. 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};
+ d->error = internal_catch_all (json_insert, &buffer_and_size, Fidentity);
+ 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);
+
+ struct json_insert_data data;
+ /* If desired, we might want to add the following flags:
+ JSON_DECODE_ANY, JSON_ALLOW_NUL. */
+ int status
+ = 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 ();
+ }
+
+ 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 (FIXNUM_OVERFLOW_P (size))
+ overflow_error ();
+ Lisp_Object result = Fmake_vector (make_fixed_natnum (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_nulls (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 0d56ea3f7ac..35d74f4a795 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
@@ -359,9 +360,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 (sys_jmp_buf);
@@ -376,6 +375,15 @@ static void deliver_user_signal (int);
static char *find_user_signal_name (int);
static void store_user_signal_events (void);
+/* 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 +441,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 +466,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 +535,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 +643,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);
}
@@ -778,35 +786,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 +884,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 +945,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 +1005,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
{
@@ -1250,7 +1219,8 @@ 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);
@@ -1298,11 +1268,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);
@@ -1349,7 +1317,7 @@ command_loop_1 (void)
if (!NILP (Vquit_flag))
{
Vquit_flag = Qnil;
- Vunread_command_events = list1 (make_number (quit_char));
+ Vunread_command_events = list1 (make_fixnum (quit_char));
}
}
@@ -1365,8 +1333,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)))
@@ -1556,7 +1525,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 +1571,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 +1626,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 +1663,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 +1676,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 +1694,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 +1735,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 +1836,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 +1845,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 +1897,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. */
@@ -1991,7 +1962,7 @@ bind_polling_period (int n)
stop_other_atimers (poll_timer);
stop_polling ();
- specbind (Qpolling_period, make_number (new));
+ specbind (Qpolling_period, make_fixnum (new));
/* Start a new alarm with the new period. */
start_polling ();
#endif
@@ -2170,25 +2141,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;
@@ -2236,8 +2207,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);
@@ -2247,7 +2218,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
{
@@ -2255,7 +2226,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;
@@ -2274,7 +2245,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));
}
}
}
@@ -2352,7 +2323,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);
@@ -2382,7 +2353,7 @@ read_char (int commandflag, Lisp_Object map,
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);
@@ -2407,7 +2378,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;
@@ -2432,16 +2403,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_fixnum (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++;
@@ -2545,7 +2516,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))
@@ -2596,7 +2567,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;
@@ -2655,7 +2626,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 ();
}
@@ -2704,23 +2675,23 @@ 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;
save_getcjmp (save_jump);
restore_getcjmp (local_getcjmp);
- tem0 = sit_for (make_number (timeout), 1, 1);
+ tem0 = sit_for (make_fixnum (timeout), 1, 1);
restore_getcjmp (save_jump);
if (EQ (tem0, Qt)
&& ! CONSP (Vunread_command_events))
{
- Fdo_auto_save (Qnil, Qnil);
+ Fdo_auto_save (auto_save_no_message ? Qt : Qnil, Qnil);
redisplay ();
}
}
@@ -2738,7 +2709,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. */
@@ -2789,7 +2760,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 */
}
}
@@ -2807,8 +2778,11 @@ 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);
}
non_reread:
@@ -2847,12 +2821,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
@@ -2866,7 +2844,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
@@ -2874,18 +2852,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))
@@ -2904,18 +2882,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);
@@ -2933,9 +2911,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;
@@ -2960,12 +2938,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;
@@ -3116,7 +3094,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
@@ -3175,6 +3153,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)))
@@ -3249,7 +3231,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;
}
@@ -3278,15 +3263,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
{
@@ -3478,7 +3463,7 @@ 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++)
@@ -3728,7 +3713,7 @@ kbd_buffer_events_waiting (void)
/* Clear input event EVENT. */
static void
-clear_event (union buffered_input_event *event)
+clear_event (struct input_event *event)
{
event->kind = NO_EVENT;
}
@@ -3758,7 +3743,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. */
@@ -3769,7 +3754,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 (;;)
@@ -3865,8 +3850,10 @@ 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,
@@ -3882,202 +3869,61 @@ 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)
+ case MENU_BAR_ACTIVATE_EVENT:
{
kbd_fetch_ptr = event + 1;
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 = event + 1;
+ }
+ 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. */
@@ -4127,10 +3973,11 @@ kbd_buffer_get_event (KBOARD **kbp,
#endif
/* Wipe out this event, to catch bugs. */
- clear_event (event);
+ clear_event (&event->ie);
kbd_fetch_ptr = event + 1;
}
}
+ }
}
/* Try generating a mouse motion event. */
else if (!NILP (do_mouse_tracking) && some_mouse_moved ())
@@ -4320,7 +4167,7 @@ decode_timer (Lisp_Object timer, struct timespec *result)
vec = XVECTOR (timer)->contents;
if (! NILP (vec[0]))
return 0;
- if (! INTEGERP (vec[2]))
+ if (! FIXNUMP (vec[2]))
return false;
struct lisp_time t;
@@ -4531,8 +4378,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.
@@ -5173,7 +5020,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))
@@ -5188,15 +5035,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
@@ -5215,7 +5062,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;
@@ -5234,7 +5081,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);
}
@@ -5316,7 +5163,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;
@@ -5333,10 +5180,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;
@@ -5358,14 +5205,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)));
}
@@ -5374,8 +5221,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
@@ -5394,9 +5241,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))));
}
@@ -5421,7 +5268,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]));
}
@@ -5440,7 +5287,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:
{
@@ -5504,6 +5410,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:
@@ -5566,6 +5477,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])
@@ -5619,7 +5541,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
@@ -5644,8 +5566,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;
@@ -5658,7 +5580,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);
}
@@ -5705,18 +5627,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. */
@@ -5761,10 +5683,10 @@ 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)
@@ -5819,7 +5741,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);
}
@@ -5883,13 +5805,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++;
@@ -5906,8 +5828,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,
@@ -5920,10 +5842,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);
}
@@ -6059,7 +5981,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:
@@ -6068,6 +5990,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:
{
@@ -6075,12 +6004,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,
@@ -6106,7 +6038,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? */
@@ -6131,16 +6063,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.
@@ -6350,15 +6278,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;
@@ -6425,8 +6353,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);
@@ -6494,7 +6422,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));
}
@@ -6581,7 +6509,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 ();
}
@@ -6664,22 +6592,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);
@@ -6687,6 +6615,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. */
@@ -6797,7 +6750,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;
}
@@ -7446,7 +7399,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 = Fmake_vector (make_fixnum (24), Qnil);
menu_bar_items_index = 0;
/* Build our list of keymaps.
@@ -7618,7 +7571,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. */
@@ -7690,7 +7643,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);
+ = Fmake_vector (make_fixnum (ITEM_PROPERTY_ENABLE + 1), Qnil);
/* Initialize optional entries. */
for (i = ITEM_PROPERTY_DEF; i < ITEM_PROPERTY_ENABLE; i++)
@@ -8185,7 +8138,7 @@ parse_tool_bar_item (Lisp_Object key, Lisp_Object item)
}
else
tool_bar_item_properties
- = Fmake_vector (make_number (TOOL_BAR_ITEM_NSLOTS), Qnil);
+ = Fmake_vector (make_fixnum (TOOL_BAR_ITEM_NSLOTS), Qnil);
/* Set defaults. */
set_prop (TOOL_BAR_ITEM_KEY, key);
@@ -8380,7 +8333,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 = Fmake_vector (make_fixnum (64), Qnil);
ntool_bar_items = 0;
}
@@ -8451,7 +8404,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;
@@ -8470,7 +8423,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));
}
@@ -8581,7 +8534,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;
@@ -8592,8 +8545,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);
@@ -8649,8 +8602,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);
@@ -8660,8 +8613,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;
}
@@ -8698,10 +8651,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);
@@ -8721,10 +8674,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));
}
@@ -8786,8 +8748,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.
@@ -8797,7 +8758,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;
@@ -8814,12 +8775,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. */
@@ -8832,7 +8793,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;
@@ -8861,8 +8822,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.
@@ -8902,7 +8868,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)
{
@@ -8917,7 +8883,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. */
@@ -8938,6 +8903,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.
@@ -8972,9 +8940,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;
@@ -9026,17 +8996,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. */
@@ -9104,7 +9077,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)
@@ -9135,6 +9108,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. */
@@ -9148,7 +9122,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'
@@ -9216,7 +9191,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
@@ -9251,8 +9226,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;
@@ -9293,11 +9268,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++;
}
@@ -9344,8 +9322,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;
@@ -9374,7 +9350,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;
@@ -9390,24 +9366,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;
@@ -9451,7 +9427,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.
@@ -9603,8 +9579,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);
@@ -9634,13 +9610,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)
{
@@ -9660,8 +9636,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);
@@ -9681,14 +9657,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))
@@ -9731,11 +9707,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))))
@@ -9744,7 +9720,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;
@@ -9814,8 +9790,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))
@@ -9838,9 +9812,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
@@ -10066,16 +10041,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;
}
@@ -10148,15 +10123,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)
@@ -10295,7 +10273,7 @@ stuff_buffered_input (Lisp_Object stuffstring)
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;
@@ -10698,7 +10676,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
@@ -10707,7 +10685,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);
@@ -10761,7 +10739,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
@@ -10769,7 +10747,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);
}
@@ -10787,12 +10765,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;
@@ -10801,12 +10779,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;
}
@@ -10839,17 +10817,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);
}
@@ -11116,6 +11094,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
@@ -11240,11 +11222,11 @@ syms_of_keyboard (void)
}
}
- button_down_location = Fmake_vector (make_number (5), Qnil);
+ button_down_location = Fmake_vector (make_fixnum (5), Qnil);
staticpro (&button_down_location);
- mouse_syms = Fmake_vector (make_number (5), Qnil);
+ mouse_syms = Fmake_vector (make_fixnum (5), Qnil);
staticpro (&mouse_syms);
- wheel_syms = Fmake_vector (make_number (ARRAYELTS (lispy_wheel_names)),
+ wheel_syms = Fmake_vector (make_fixnum (ARRAYELTS (lispy_wheel_names)),
Qnil);
staticpro (&wheel_syms);
@@ -11252,20 +11234,20 @@ syms_of_keyboard (void)
int i;
int len = ARRAYELTS (modifier_names);
- modifier_symbols = Fmake_vector (make_number (len), Qnil);
+ modifier_symbols = Fmake_vector (make_fixnum (len), Qnil);
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 = Fmake_vector (make_fixnum (NUM_RECENT_KEYS), Qnil);
staticpro (&recent_keys);
- this_command_keys = Fmake_vector (make_number (40), Qnil);
+ this_command_keys = Fmake_vector (make_fixnum (40), Qnil);
staticpro (&this_command_keys);
- raw_keybuf = Fmake_vector (make_number (30), Qnil);
+ raw_keybuf = Fmake_vector (make_fixnum (30), Qnil);
staticpro (&raw_keybuf);
DEFSYM (Qcommand_execute, "command-execute");
@@ -11303,6 +11285,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);
@@ -11428,6 +11411,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.
@@ -11439,7 +11426,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.
@@ -11453,7 +11440,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.
@@ -11803,7 +11790,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.
@@ -11894,6 +11881,14 @@ If nil, Emacs crashes immediately in response to fatal signals. */);
Vwhile_no_input_ignore_events,
doc: /* Ignored events from while-no-input. */);
Vwhile_no_input_ignore_events = Qnil;
+
+ 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. */);
+ inhibit_record_char = false;
}
void
@@ -11954,6 +11949,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. */
diff --git a/src/keyboard.h b/src/keyboard.h
index 9106646ced2..ce4630b8a37 100644
--- a/src/keyboard.h
+++ b/src/keyboard.h
@@ -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 f9c77ea99e6..3a79bf4c5aa 100644
--- a/src/keymap.c
+++ b/src/keymap.c
@@ -159,7 +159,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 +248,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 +379,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 +473,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 +546,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 +604,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 +782,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 +807,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 +833,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 +870,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 +1093,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 = Fmake_vector (make_fixnum (ASIZE (def)), Qnil);
ptrdiff_t i = ASIZE (def);
while (--i >= 0)
{
@@ -1096,7 +1108,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 +1123,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 +1132,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 +1165,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 +1186,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 +1199,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 +1216,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 +1231,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 +1241,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 +1261,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 +1301,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 +1475,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 +1553,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 +1576,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 +1609,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 +1665,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 +1746,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 +1844,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 +1855,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 +1880,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 +1911,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))
{
@@ -1923,7 +1934,7 @@ then the value includes only maps for prefixes that start with PREFIX. */)
int i, i_byte, c;
Lisp_Object copy;
- copy = Fmake_vector (make_number (SCHARS (prefix)), Qnil);
+ copy = Fmake_vector (make_fixnum (SCHARS (prefix)), Qnil);
for (i = 0, i_byte = 0; i < SCHARS (prefix);)
{
int i_before = i;
@@ -1931,7 +1942,7 @@ then the value includes only maps for prefixes that start with PREFIX. */)
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 +1970,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 +1998,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 +2007,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 +2044,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 = XFIXNUM (Flength (list));
else
wrong_type_argument (Qarrayp, list);
@@ -2062,9 +2073,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 +2083,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 +2109,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 +2229,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 +2240,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 +2311,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 +2333,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 +2343,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 +2364,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 +2453,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 +2555,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 +2577,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 +2638,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 +2709,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 +2778,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 +2954,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 +2984,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 +3037,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 +3059,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 +3096,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 +3141,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 = Fmake_vector (make_fixnum (1), Qnil);
definition = Qnil;
map = call1 (Qkeymap_canonicalize, map);
@@ -3192,7 +3169,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 +3253,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 +3299,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 +3378,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 +3390,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 = Fmake_vector (make_fixnum (1), Qnil);
if (partial)
suppress = intern ("suppress-keymap");
@@ -3463,7 +3440,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 +3512,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 +3589,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
@@ -3713,7 +3690,7 @@ be preferred. */);
DEFSYM (Qremap, "remap");
DEFSYM (QCadvertised_binding, ":advertised-binding");
- command_remapping_vector = Fmake_vector (make_number (2), Qremap);
+ command_remapping_vector = Fmake_vector (make_fixnum (2), Qremap);
staticpro (&command_remapping_vector);
where_is_cache_keymaps = Qt;
diff --git a/src/kqueue.c b/src/kqueue.c
index 69d5269d302..bc01ab5062c 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))
@@ -101,7 +101,7 @@ kqueue_generate_event (Lisp_Object watch_object, Lisp_Object actions,
NILP (file1)
? Fcons (file, Qnil)
: 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,7 +395,7 @@ 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)))
+ if ((maxfd - 50) < XFIXNUM (Flength (watch_list)))
xsignal2
(Qfile_notify_error,
build_string ("File watching not possible, no file descriptor left"),
@@ -449,7 +449,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 +473,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 fe8ac85a320..ec5311158e5 100644
--- a/src/lastfile.c
+++ b/src/lastfile.c
@@ -49,9 +49,6 @@ char my_edata[] = "End of Emacs initialized data";
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 3dcb77c8a58..d5cfafa60a6 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 05d1cd8201a..bb190b691b0 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -228,15 +228,11 @@ 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, GCALIGNED_STRUCT_MEMBER, and GCALIGNED_STRUCT. */
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,
@@ -247,10 +243,6 @@ enum Lisp_Bits
FIXNUM_BITS = VALBITS + 1
};
-#if GCALIGNMENT != 1 << GCTYPEBITS
-# error "GCALIGNMENT and GCTYPEBITS are inconsistent"
-#endif
-
/* 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.
This can be used in #if, e.g., '#if USE_LSB_TAG' below expands to an
@@ -277,6 +269,61 @@ 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
+
+/* If a struct is always allocated by the GC and is therefore always
+ GC-aligned, put GCALIGNED_STRUCT after its closing '}'; this can
+ help the compiler generate better code.
+
+ To cause a union to have alignment of at least GCALIGNMENT, put
+ GCALIGNED_UNION_MEMBER in its member list. Similarly for a struct
+ and GCALIGNED_STRUCT_MEMBER, although this may make the struct a
+ bit bigger on non-GCC platforms. Any struct using
+ GCALIGNED_STRUCT_MEMBER should also use GCALIGNED_STRUCT.
+
+ 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_MEMBER
+# define GCALIGNED_STRUCT __attribute__ ((aligned (GCALIGNMENT)))
+#else
+# define GCALIGNED_STRUCT_MEMBER GCALIGNED_UNION_MEMBER
+# 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 +349,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 +400,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 +449,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 +474,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 +495,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 +509,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,
@@ -455,25 +531,6 @@ enum Lisp_Type
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
+ You also need to add the new type to the constant
+ `cl--typeof-types' in lisp/emacs-lisp/cl-preloaded.el. */
-typedef struct Lisp_Object { EMACS_INT i; } Lisp_Object;
-#define LISP_INITIALLY(i) {i}
+/* 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;'.
-#undef CHECK_LISP_OBJECT_TYPE
-enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = true };
-#else /* CHECK_LISP_OBJECT_TYPE */
+ 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. */
-/* If a struct type is not wanted, define Lisp_Object as just a number. */
-
-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);
@@ -591,8 +640,10 @@ 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 +657,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 +682,26 @@ 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. */
-
-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
-}
+/* Extract A's pointer value, assuming A's Lisp type is TYPE and the
+ extracted pointer's type is CTYPE *. */
+#define XUNTAG(a, type, ctype) ((ctype *) \
+ ((char *) XLP (a) - LISP_WORD_TAG (type)))
/* Interned state of a symbol. */
@@ -715,10 +779,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 +809,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. */
@@ -795,7 +871,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 +896,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 +904,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 +925,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 +974,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,
@@ -939,21 +1041,21 @@ enum More_Lisp_Bits
#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 +1069,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 +1088,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 +1099,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 +1115,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 +1131,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. */
@@ -1062,25 +1164,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 +1196,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 +1226,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 +1268,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 +1390,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 +1411,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. */
@@ -1416,7 +1524,7 @@ struct Lisp_Vector
{
union vectorlike_header header;
Lisp_Object contents[FLEXIBLE_ARRAY_MEMBER];
- };
+ } GCALIGNED_STRUCT;
INLINE bool
(VECTORLIKEP) (Lisp_Object x)
@@ -1428,7 +1536,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
@@ -1488,8 +1596,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 +1616,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 +1669,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 +1763,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. */
@@ -1670,7 +1790,8 @@ memclear (void *p, ptrdiff_t nbytes)
ones that the GC needs to trace). */
#define PSEUDOVECSIZE(type, nonlispfield) \
- ((offsetof (type, nonlispfield) - header_size) / word_size)
+ (offsetof (type, nonlispfield) < header_size \
+ ? 0 : (offsetof (type, nonlispfield) - 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 +1856,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 +1868,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 +1890,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 +1902,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 +1968,9 @@ struct Lisp_Subr
const char *symbol_name;
const char *intspec;
EMACS_INT doc;
- };
+ GCALIGNED_STRUCT_MEMBER
+ } GCALIGNED_STRUCT;
+verify (GCALIGNED (struct Lisp_Subr));
INLINE bool
SUBRP (Lisp_Object a)
@@ -1859,7 +1982,7 @@ INLINE struct Lisp_Subr *
XSUBR (Lisp_Object a)
{
eassert (SUBRP (a));
- return XUNTAG (a, Lisp_Vectorlike);
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Subr);
}
enum char_table_specials
@@ -1874,6 +1997,13 @@ enum char_table_specials
SUB_CHAR_TABLE_OFFSET = PSEUDOVECSIZE (struct Lisp_Sub_Char_Table, contents)
};
+/* 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 +2013,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. */
@@ -2099,8 +2224,10 @@ struct Lisp_Hash_Table
/* Next weak hash table if this is a weak hash table. The head
of the list is in weak_hash_tables. */
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 +2239,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) \
@@ -2177,46 +2304,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 +2320,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 +2345,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 +2362,164 @@ 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)
-{
- 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)
+xmint_pointer (Lisp_Object a)
{
- 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;
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,
@@ -2577,7 +2557,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;
};
@@ -2668,7 +2648,7 @@ struct Lisp_Float
double data;
struct Lisp_Float *chain;
} u;
- };
+ } GCALIGNED_STRUCT;
INLINE bool
(FLOATP) (Lisp_Object x)
@@ -2680,7 +2660,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,17 +2671,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)
- };
+
+#define 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. */
@@ -2746,26 +2723,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 +2810,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 +2836,21 @@ 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))) \
+ CHECK_FIXNUM (x); \
+ if (! ((lo) <= XFIXNUM (x) && XFIXNUM (x) <= (hi))) \
args_out_of_range_3 \
(x, \
- make_number ((lo) < 0 && (lo) < MOST_NEGATIVE_FIXNUM \
+ make_fixnum ((lo) < 0 && (lo) < MOST_NEGATIVE_FIXNUM \
? MOST_NEGATIVE_FIXNUM \
: (lo)), \
- make_number (min (hi, MOST_POSITIVE_FIXNUM))); \
+ make_fixnum (min (hi, MOST_POSITIVE_FIXNUM))); \
} while (false)
#define CHECK_TYPE_RANGED_INTEGER(type, x) \
do { \
@@ -2883,27 +2860,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,21 +2896,29 @@ CHECK_NUMBER_OR_FLOAT (Lisp_Object x)
CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x); \
} while (false)
+#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)
+
/* 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)
+CHECK_FIXNUM_CAR (Lisp_Object x)
{
Lisp_Object tmp = XCAR (x);
- CHECK_NUMBER (tmp);
+ CHECK_FIXNUM (tmp);
XSETCAR (x, tmp);
}
INLINE void
-CHECK_NUMBER_CDR (Lisp_Object x)
+CHECK_FIXNUM_CDR (Lisp_Object x)
{
Lisp_Object tmp = XCDR (x);
- CHECK_NUMBER (tmp);
+ CHECK_FIXNUM (tmp);
XSETCDR (x, tmp);
}
@@ -2956,23 +2949,12 @@ 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 }, \
{ .a ## maxargs = fnname }, \
minargs, maxargs, lname, intspec, 0}; \
Lisp_Object fnname
-#endif
/* defsubr (Sname);
is how we define the symbol for function `name' at start-up time. */
@@ -3065,8 +3047,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,6 +3062,8 @@ 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;
@@ -3085,6 +3072,11 @@ union specbinding
} 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 +3087,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 {
@@ -3323,6 +3319,49 @@ 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 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;
+ }
+}
+
/* Defined in data.c. */
extern _Noreturn void wrong_choice (Lisp_Object, Lisp_Object);
extern void notify_variable_watchers (Lisp_Object, Lisp_Object,
@@ -3340,16 +3379,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. */
@@ -3376,7 +3405,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 *);
@@ -3442,8 +3471,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 +3490,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 +3545,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 +3596,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,6 +3607,7 @@ extern void refill_memory_reserve (void);
#endif
extern void alloc_unexec_pre (void);
extern void alloc_unexec_post (void);
+extern void mark_maybe_objects (Lisp_Object *, ptrdiff_t);
extern void mark_stack (char *, char *);
extern void flush_stack_call_func (void (*func) (void *arg), void *arg);
extern const char *pending_malloc_warning;
@@ -3592,20 +3629,20 @@ extern Lisp_Object listn (enum constype, ptrdiff_t, Lisp_Object, ...);
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);
@@ -3712,16 +3749,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,7 +3836,8 @@ 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, int);
extern void map_obarray (Lisp_Object, void (*) (Lisp_Object, Lisp_Object),
Lisp_Object);
extern void dir_warning (const char *, Lisp_Object);
@@ -3859,6 +3887,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 +3909,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);
@@ -3946,7 +3978,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 +3990,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
@@ -3978,9 +4010,9 @@ extern void mark_threads (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);
@@ -4037,7 +4069,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 +4080,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);
@@ -4392,6 +4420,11 @@ 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;
@@ -4417,9 +4450,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
@@ -4500,12 +4533,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 +4542,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 +4550,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 +4563,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 +4575,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 +4628,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 +4638,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 \
@@ -4657,7 +4710,8 @@ enum
Take its unibyte value from the null-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))
@@ -4666,7 +4720,8 @@ enum
Take its unibyte value from the null-terminated string STR with length LEN.
STR may have side effects and may contain null 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 +4731,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 +4746,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) \
diff --git a/src/lread.c b/src/lread.c
index 2e5cba510c5..73e38d89954 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -72,6 +72,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#define file_tell ftell
#endif
+#if IEEE_FLOATING_POINT
+# include <ieee754.h>
+#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));
}
}
@@ -1129,7 +1137,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 +1262,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 +1301,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 +1357,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 +1365,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 +1392,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 +1403,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 +1429,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 +1444,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 +1497,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 +1601,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;
@@ -1945,11 +1988,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 +2000,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 +2149,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 +2234,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 +2245,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 +2320,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,
@@ -2315,18 +2356,18 @@ character_name_to_code (char const *name, ptrdiff_t name_len)
monstrosities like "U+-0000". */
Lisp_Object code
= (name[0] == 'U' && name[1] == '+'
- ? string_to_number (name + 1, 16, false)
+ ? string_to_number (name + 1, 16, 0)
: 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)
+ || 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
@@ -2613,18 +2661,24 @@ read_integer (Lisp_Object readcharfun, EMACS_INT radix)
{
/* Room for sign, leading 0, other digits, trailing null 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 = XFIXNUM (Flength (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;
@@ -3489,6 +3539,13 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
if (! NILP (result))
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;
@@ -3530,7 +3587,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 +3628,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,16 +3700,15 @@ 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 STRING to a number, assuming base BASE. When STRING has
+ floating point syntax and BASE is 10, return a nearest float. When
+ STRING has integer syntax, return a fixnum if the integer fits, or
+ else a bignum. Otherwise, return nil. If FLAGS &
+ S2N_IGNORE_TRAILING is nonzero, consider just the longest prefix of
+ STRING that has valid syntax. */
Lisp_Object
-string_to_number (char const *string, int base, bool ignore_trailing)
+string_to_number (char const *string, int base, int flags)
{
char const *cp = string;
bool float_syntax = 0;
@@ -3662,8 +3718,9 @@ string_to_number (char const *string, int base, bool ignore_trailing)
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 +3741,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 +3770,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 +3783,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,9 +3797,10 @@ 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
+ /* Return nil if the number uses invalid syntax. If FLAGS &
+ S2N_IGNORE_TRAILING, accept any prefix that matches. Otherwise,
+ the entire string must match. */
+ if (! (flags & S2N_IGNORE_TRAILING
? ((state & LEAD_INT) != 0 || float_syntax)
: (!*cp && ((state & ~(INTOVERFLOW | DOT_CHAR)) == LEAD_INT
|| float_syntax))))
@@ -3747,20 +3810,26 @@ string_to_number (char const *string, int base, bool ignore_trailing)
range, use its value, preferably as a fixnum. */
if (leading_digit >= 0 && ! 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))
+ if ((state & INTOVERFLOW) == 0
+ && n <= (negative ? -MOST_NEGATIVE_FIXNUM : MOST_POSITIVE_FIXNUM))
{
EMACS_INT signed_n = n;
- return make_number (negative ? -signed_n : signed_n);
+ return make_fixnum (negative ? -signed_n : signed_n);
}
- else
- value = n;
+
+ /* Trim any leading "+" and trailing nondigits, then convert to
+ 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;
}
/* Either the number uses float syntax, or it does not fit into a fixnum.
@@ -3785,9 +3854,11 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag)
tem = read_list (1, readcharfun);
len = Flength (tem);
+ if (bytecodeflag && XFIXNAT (len) <= COMPILED_STACK_DEPTH)
+ error ("Invalid byte code");
vector = Fmake_vector (len, Qnil);
- size = ASIZE (vector);
+ size = XFIXNAT (len);
ptr = XVECTOR (vector)->contents;
for (i = 0; i < size; i++)
{
@@ -3925,8 +3996,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 +4012,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 +4117,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 +4175,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 +4221,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 +4253,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 +4263,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 +4279,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 +4322,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. */
@@ -4312,7 +4383,7 @@ OBARRAY defaults to the value of `obarray'. */)
void
init_obarray (void)
{
- Vobarray = Fmake_vector (make_number (OBARRAY_SIZE), make_number (0));
+ Vobarray = Fmake_vector (make_fixnum (OBARRAY_SIZE), make_fixnum (0));
initial_obarray = Vobarray;
staticpro (&initial_obarray);
@@ -4898,7 +4969,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 +5059,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 +5083,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 dd7c50f2719..c9a1edaec8b 100644
--- a/src/macfont.m
+++ b/src/macfont.m
@@ -851,7 +851,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 +864,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 +903,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 +944,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 +963,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 +985,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
@@ -1441,8 +1442,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)
@@ -1799,9 +1798,9 @@ macfont_get_open_type_spec (Lisp_Object otf_spec)
continue;
len = Flength (val);
spec->features[i] =
- (min (PTRDIFF_MAX, SIZE_MAX) / sizeof (int) < XINT (len)
+ (min (PTRDIFF_MAX, SIZE_MAX) / sizeof (int) < XFIXNUM (len)
? 0
- : malloc (XINT (len) * sizeof *spec->features[i]));
+ : malloc (XFIXNUM (len) * sizeof *spec->features[i]));
if (! spec->features[i])
{
if (i > 0 && spec->features[0])
@@ -1941,9 +1940,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 +1981,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 +2069,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 +2161,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 +2506,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 +2529,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 +2563,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 +2584,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 +2711,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 +2992,7 @@ macfont_shape (Lisp_Object lgstring)
if (NILP (lglyph))
{
- lglyph = Fmake_vector (make_number (LGLYPH_SIZE), Qnil);
+ lglyph = Fmake_vector (make_fixnum (LGLYPH_SIZE), Qnil);
LGSTRING_SET_GLYPH (lgstring, i, lglyph);
}
@@ -3048,17 +3046,17 @@ macfont_shape (Lisp_Object lgstring)
{
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));
+ vec = Fmake_vector (make_fixnum (3), Qnil);
+ 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. */
diff --git a/src/macros.c b/src/macros.c
index b1fc7a037f4..0677021bfd2 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));
+ executing_kbd_macro_index = XFIXNUM (XCAR (tem));
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_fixnum (executing_kbd_macro_index),
Vreal_this_command));
record_unwind_protect (pop_kbd_macro, tem);
diff --git a/src/marker.c b/src/marker.c
index 432fdd4cbfa..b9ea5c59824 100644
--- a/src/marker.c
+++ b/src/marker.c
@@ -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 d5e1638b7cd..d75a8424a56 100644
--- a/src/menu.c
+++ b/src/menu.c
@@ -86,7 +86,7 @@ init_menu_items (void)
if (NILP (menu_items))
{
menu_items_allocated = 60;
- menu_items = Fmake_vector (make_number (menu_items_allocated), Qnil);
+ menu_items = Fmake_vector (make_fixnum (menu_items_allocated), Qnil);
}
menu_items_inuse = Qt;
@@ -134,11 +134,11 @@ restore_menu_items (Lisp_Object saved)
menu_items_inuse = (! NILP (menu_items) ? Qt : Qnil);
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.
@@ -148,9 +148,9 @@ 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));
+ 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 = Qnil;
@@ -532,7 +532,7 @@ parse_single_submenu (Lisp_Object item_key, Lisp_Object item_name,
USE_SAFE_ALLOCA;
length = Flength (maps);
- len = XINT (length);
+ len = XFIXNUM (length);
/* Convert the list MAPS into a vector MAPVEC. */
SAFE_ALLOCA_LISP (mapvec, len);
@@ -647,7 +647,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 +900,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 +985,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 +1079,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 +1099,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 +1112,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 +1152,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 +1168,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 +1202,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 +1268,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 +1309,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));
+ EMACS_INT nmaps = XFIXNAT (Flength (menu));
Lisp_Object *maps;
ptrdiff_t i;
USE_SAFE_ALLOCA;
@@ -1443,6 +1400,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. */
diff --git a/src/menu.h b/src/menu.h
index 1aa53f74544..fa32a86d1c8 100644
--- a/src/menu.h
+++ b/src/menu.h
@@ -60,4 +60,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..7a1b7ab5de5
--- /dev/null
+++ b/src/mini-gmp-emacs.c
@@ -0,0 +1,32 @@
+/* Tailor mini-gmp.c for GNU Emacs
+
+Copyright 2018 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..c0d5b879a83
--- /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-2018 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..27e0c0671a2
--- /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 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 691fad07b79..751d6bda168 100644
--- a/src/minibuf.c
+++ b/src/minibuf.c
@@ -157,7 +157,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
@@ -198,7 +198,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 +291,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 +299,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 +311,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 +321,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 +393,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
@@ -444,7 +431,7 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt,
&& NILP (Vexecuting_kbd_macro))
{
val = read_minibuf_noninteractive (map, initial, prompt,
- make_number (pos),
+ make_fixnum (pos),
expflag, histvar, histpos, defalt,
allow_props, inherit_input_method);
return unbind_to (count, val);
@@ -491,7 +478,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 +595,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 +610,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 +633,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 +651,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 +702,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 +721,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 +755,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;
@@ -840,12 +788,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 = XFIXNAT (Flength (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 +995,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));
}
@@ -1103,7 +1051,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);
@@ -1246,7 +1195,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;
@@ -1312,7 +1261,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)))
@@ -1325,11 +1274,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;
@@ -1373,11 +1323,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)
{
@@ -1398,13 +1348,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),
@@ -1428,10 +1378,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. */
@@ -1499,7 +1447,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;
@@ -1571,9 +1519,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)))
{
@@ -1585,11 +1533,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;
@@ -1607,10 +1556,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))
@@ -1623,10 +1573,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);
}
@@ -1746,9 +1694,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;
@@ -1891,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;
@@ -1906,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,
@@ -1944,6 +1892,9 @@ syms_of_minibuf (void)
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");
Fset (Qbuffer_name_history, Qnil);
@@ -2127,7 +2078,6 @@ characters. This variable should never be set globally. */);
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/msdos.c b/src/msdos.c
index 94e975eaa21..4031c579df8 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 bd1e2283a0c..659bce8fc57 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>
@@ -54,14 +54,13 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu)
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 +116,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 +178,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 +209,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 +261,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 +285,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 +357,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 +463,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 +524,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 +554,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 +589,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 +598,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 +615,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 +627,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 +686,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 +736,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 +786,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 +822,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 +851,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 +884,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 +939,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 +1041,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 +1086,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 +1127,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 +1170,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 +1184,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 +1213,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 +1226,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 +1275,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 +1291,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 +1326,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 +1422,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 +1497,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 +1738,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 +1762,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 +1831,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 +1850,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 +1867,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 +1882,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 +1907,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 +1917,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 +1977,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 +2094,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 +2135,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 +2147,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 +2162,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 +2178,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 +2194,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 +2248,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 +2290,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 +2300,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 +2325,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 +2343,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 +2357,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 +2426,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 +2476,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 = Fmake_vector (make_fixnum (n_monitors), Qnil);
Lisp_Object frame, rest;
NSArray *screens = [NSScreen screens];
int i;
@@ -2725,35 +2613,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 +2653,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 +2678,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 +2712,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 +2720,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 +2729,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 +2749,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 +2765,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 +2773,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 +2812,44 @@ 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 list4 (make_fixnum (f->left_pos), make_fixnum (f->top_pos),
+ make_fixnum (f->left_pos + outer_width),
+ make_fixnum (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 list4 (make_fixnum (native_left), make_fixnum (native_top),
+ make_fixnum (native_right), make_fixnum (native_bottom));
else if (EQ (attribute, Qinner_edges))
- return list4 (make_number (native_left + internal_border_width),
- make_number (native_top
+ return list4 (make_fixnum (native_left + internal_border_width),
+ make_fixnum (native_top
+ tool_bar_height
+ internal_border_width),
- make_number (native_right - internal_border_width),
- make_number (native_bottom - internal_border_width));
+ make_fixnum (native_right - internal_border_width),
+ make_fixnum (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))),
+ 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 +2930,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 +2947,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 +2968,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 +2976,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 +3028,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 +3040,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
@@ -3289,6 +3159,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 +3188,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);
diff --git a/src/nsfont.m b/src/nsfont.m
index 8b42102a998..b1ebb53c95d 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"
@@ -37,7 +37,7 @@ Author: Adrian Robert (arobert@cogsci.ucsd.edu)
#include "font.h"
#include "termchar.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 +45,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 +61,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 +71,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 +81,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 +103,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 +114,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 +125,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 +156,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 +168,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 +186,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 +220,7 @@ ns_descriptor_to_entity (NSFontDescriptor *desc,
}
-/* Default font entity. */
+/* Default font entity. */
static Lisp_Object
ns_fallback_entity (void)
{
@@ -229,7 +229,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 +292,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 +312,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 +336,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 +347,7 @@ static NSString
}
-/* Convert a font registry, such as */
+/* Convert a font registry. */
static NSString
*ns_registry_to_script (char *reg)
{
@@ -368,14 +368,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 +392,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 +410,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 +425,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 +445,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 +465,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 +497,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 +525,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 +574,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 && XFIXNUM (Flength (list)) > 0)
{
NSFontDescriptor *s1 = [NSFontDescriptor new];
NSFontDescriptor *sDesc
@@ -590,13 +590,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)));
+ XFIXNUM (Flength (list)));
return list;
}
@@ -642,7 +642,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 +651,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 +664,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)));
+ XFIXNUM (Flength (list)));
unblock_input ();
return list;
@@ -705,7 +705,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 +715,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 +757,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 +793,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 +810,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 +823,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 +880,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 +911,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 +920,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 +931,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 +942,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 +985,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 +1019,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 +1049,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 +1082,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 +1099,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 +1119,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 +1258,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 +1288,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 +1303,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 +1319,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 +1337,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 +1387,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
@@ -1508,7 +1508,7 @@ syms_of_nsfont (void)
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. */);
ascii_printable = NULL;
}
diff --git a/src/nsgui.h b/src/nsgui.h
index 92ea6350d62..4e7d7d35daa 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
@@ -75,7 +75,7 @@ typedef unichar XChar2b;
/* 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 +119,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 +160,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 6bce61626ff..0ae1b88edd6 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,21 @@ 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;
+ }
+
+ [eImg setSizeFromSpec:XCDR (img->spec)];
+
size = [eImg size];
img->width = size.width;
img->height = size.height;
@@ -120,7 +135,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;
}
@@ -212,7 +226,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 +251,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 +362,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 +386,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 +457,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 +465,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 +481,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 +495,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 +511,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 +520,106 @@ 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;
}
+- (void)setSizeFromSpec: (Lisp_Object) spec
+{
+ NSSize size = [self size];
+ Lisp_Object value;
+ double scale = 1, aspect = size.width / size.height;
+ double width = -1, height = -1, max_width = -1, max_height = -1;
+
+ value = Fplist_get (spec, QCscale);
+ if (NUMBERP (value))
+ scale = XFLOATINT (value) ;
+
+ value = Fplist_get (spec, QCmax_width);
+ if (NUMBERP (value))
+ max_width = XFLOATINT (value);
+
+ value = Fplist_get (spec, QCmax_height);
+ if (NUMBERP (value))
+ max_height = XFLOATINT (value);
+
+ value = Fplist_get (spec, QCwidth);
+ if (NUMBERP (value))
+ {
+ width = XFLOATINT (value) * scale;
+ /* :width overrides :max-width. */
+ max_width = -1;
+ }
+
+ value = Fplist_get (spec, QCheight);
+ if (NUMBERP (value))
+ {
+ height = XFLOATINT (value) * scale;
+ /* :height overrides :max-height. */
+ max_height = -1;
+ }
+
+ if (width <= 0 && height <= 0)
+ {
+ width = size.width * scale;
+ height = size.height * scale;
+ }
+ else if (width > 0 && height <= 0)
+ height = width / aspect;
+ else if (height > 0 && width <= 0)
+ width = height * aspect;
+
+ if (max_width > 0 && width > max_width)
+ {
+ width = max_width;
+ height = max_width / aspect;
+ }
+
+ if (max_height > 0 && height > max_height)
+ {
+ height = max_height;
+ width = max_height * aspect;
+ }
+
+ [self setSize:NSMakeSize(width, height)];
+}
+
+- (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 604adcf40b5..983e77763b9 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"
@@ -47,7 +47,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 +62,7 @@ static int trackingMenu;
/* NOTE: toolbar implementation is at end,
- following complete menu implementation. */
+ following complete menu implementation. */
/* ==========================================================================
@@ -74,7 +74,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 +123,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 +147,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 +172,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 +214,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 +267,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 +286,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 +302,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 +326,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 +358,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 +369,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 +377,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 +416,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 +461,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 +489,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 +556,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 +664,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 +735,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 +748,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 +756,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 +765,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 +811,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 +828,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 +1009,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 +1021,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 +1042,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 +1070,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 +1119,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 +1252,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 +1267,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 +1275,7 @@ update_frame_tool_bar (struct frame *f)
{
NSTRACE ("[EmacsToolbar toolbarDefaultItemIdentifiers:]");
- /* return entire set.. */
+ /* Return entire set. */
return activeIdentifiers;
}
@@ -1284,7 +1284,7 @@ update_frame_tool_bar (struct frame *f)
{
NSTRACE ("[EmacsToolbar toolbarAllowedItemIdentifiers:]");
- /* return entire set... */
+ /* return entire set... */
return activeIdentifiers;
//return [identifierToItem allKeys];
}
@@ -1313,7 +1313,7 @@ update_frame_tool_bar (struct frame *f)
========================================================================== */
/* Needed because NeXTstep does not provide enough control over tooltip
- display. */
+ display. */
@implementation EmacsTooltip
- (instancetype)init
@@ -1323,7 +1323,7 @@ update_frame_tool_bar (struct frame *f)
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];
@@ -1345,7 +1345,7 @@ update_frame_tool_bar (struct frame *f)
[win setReleasedWhenClosed: NO];
[win setDelegate: self];
[[win contentView] addSubview: textField];
-/* [win setBackgroundColor: col]; */
+ /* [win setBackgroundColor: col]; */
[win setOpaque: NO];
return self;
@@ -1373,6 +1373,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];
@@ -1548,7 +1558,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];
@@ -1559,16 +1569,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;
@@ -1622,24 +1632,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++];
@@ -1716,7 +1726,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)];
@@ -1724,7 +1734,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)
@@ -1736,7 +1746,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++)
@@ -1800,9 +1810,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];
}
@@ -1833,7 +1843,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;
}
}
@@ -1864,7 +1874,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;
diff --git a/src/nsselect.m b/src/nsselect.m
index bee628b7576..35705bfca0e 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 588b9fc6443..23460abc659 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,8 @@ typedef id instancetype;
- (NSColor *)stippleMask;
- (Lisp_Object)getMetadata;
- (BOOL)setFrame: (unsigned int) index;
+- (void)setSizeFromSpec: (Lisp_Object) spec;
+- (instancetype)rotate: (double)rotation;
@end
@@ -718,7 +722,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 +752,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 +766,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 +790,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 +802,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 +823,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 +872,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 +931,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 +969,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 +981,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 +1019,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 +1033,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 +1043,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 +1051,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 +1059,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 +1094,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 +1118,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 +1160,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);
@@ -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 d92d6c32448..68ad64660ca 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>
@@ -66,6 +67,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 +84,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 +93,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 +106,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 +161,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 +185,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 +234,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 +266,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;
@@ -281,8 +283,11 @@ static BOOL gsaved = NO;
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;
@@ -317,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:
@@ -346,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) \
@@ -389,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
@@ -419,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);
@@ -438,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);
@@ -603,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];
@@ -614,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)
@@ -641,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];
@@ -668,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. */
@@ -740,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");
@@ -1276,7 +1330,7 @@ ns_flush_display (struct frame *f)
@interface EmacsBell : NSImageView
{
- // Number of currently active bell:s.
+ // Number of currently active bells.
unsigned int nestCount;
NSView * mView;
bool isAttached;
@@ -1537,7 +1591,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);
@@ -1560,7 +1614,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];
@@ -1572,7 +1626,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);
}
}
@@ -1614,8 +1668,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];
@@ -1626,7 +1680,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();
@@ -1660,10 +1714,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];
@@ -1685,7 +1735,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];
@@ -1707,7 +1757,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");
@@ -1796,6 +1845,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);
@@ -1823,11 +1881,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];
@@ -1869,7 +1927,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)
@@ -1877,7 +1935,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];
@@ -1968,7 +2026,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");
@@ -1987,7 +2045,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");
@@ -2004,7 +2062,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];
@@ -2023,7 +2081,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;
}
@@ -2101,8 +2159,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];
@@ -2169,7 +2226,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;
}
@@ -2181,7 +2238,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];
@@ -2216,8 +2273,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];
@@ -2229,7 +2285,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 */
@@ -2279,7 +2335,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";
@@ -2308,7 +2364,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");
@@ -2353,7 +2409,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;
@@ -2392,8 +2448,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;
@@ -2426,7 +2482,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,
@@ -2447,15 +2503,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)
{
@@ -2479,7 +2535,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;
@@ -2598,7 +2654,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];
@@ -2621,7 +2677,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 */
/* ==========================================================================
@@ -2727,7 +2854,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);
@@ -3067,17 +3194,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;
@@ -3333,7 +3460,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)
@@ -3351,7 +3478,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)
@@ -3363,25 +3490,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;
@@ -3404,7 +3546,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;
@@ -3418,7 +3560,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;
@@ -3525,7 +3667,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;
@@ -3599,7 +3741,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),
@@ -3702,7 +3844,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,
@@ -3728,7 +3870,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
@@ -3754,11 +3896,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
@@ -3766,7 +3908,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 */
@@ -4162,7 +4304,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);
@@ -4207,8 +4349,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)
@@ -4231,7 +4373,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];
@@ -4285,7 +4427,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;
@@ -4381,19 +4523,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]
@@ -4446,7 +4588,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;
@@ -4498,13 +4640,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
@@ -4516,7 +4658,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);
}
@@ -4541,7 +4683,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)
@@ -4553,7 +4695,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;
@@ -4573,11 +4715,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);
}
@@ -4607,7 +4749,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);
@@ -4634,14 +4776,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))
@@ -4662,7 +4804,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
@@ -4689,7 +4831,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;
@@ -4701,7 +4843,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);
@@ -4728,7 +4870,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);
@@ -4741,7 +4883,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
@@ -4760,7 +4902,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);
@@ -4883,7 +5025,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))
@@ -4908,7 +5050,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);
@@ -4949,7 +5091,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;
@@ -4959,11 +5101,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 =
{
@@ -4999,11 +5141,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)
{
@@ -5111,9 +5253,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;
@@ -5185,7 +5327,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
@@ -5217,7 +5359,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);
@@ -5303,7 +5445,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");
@@ -5468,23 +5610,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])
@@ -5513,7 +5638,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];
@@ -5578,7 +5703,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:]");
@@ -5608,7 +5733,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:]");
@@ -5631,7 +5756,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
@@ -5735,7 +5860,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))
@@ -5744,7 +5869,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))
@@ -5753,7 +5878,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))
@@ -5761,7 +5886,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];
@@ -5785,11 +5910,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
@@ -5800,7 +5925,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.
@@ -5810,7 +5935,7 @@ not_in_argv (NSString *arg)
{
NSTRACE ("[EmacsApp applicationDidResignActive:]");
- //ns_app_active=NO;
+ // ns_app_active=NO;
ns_send_appdefined (-1);
}
@@ -5828,7 +5953,7 @@ not_in_argv (NSString *arg)
The timeout specified to ns_select has passed.
-------------------------------------------------------------------------- */
{
- /*NSTRACE ("timeout_handler"); */
+ /* NSTRACE ("timeout_handler"); */
ns_send_appdefined (-2);
}
@@ -5839,7 +5964,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;
@@ -5934,7 +6059,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
@@ -5945,7 +6070,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 ();
@@ -5970,7 +6095,6 @@ not_in_argv (NSString *arg)
@end /* EmacsApp */
-
/* ==========================================================================
EmacsView implementation
@@ -5980,7 +6104,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);
@@ -5999,7 +6123,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];
@@ -6030,7 +6154,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);
}
@@ -6055,13 +6179,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
@@ -6070,12 +6200,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)
@@ -6086,7 +6215,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
@@ -6094,7 +6223,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;
}
@@ -6104,7 +6233,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;
@@ -6112,19 +6241,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);
@@ -6137,14 +6261,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
)
@@ -6153,142 +6276,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);
@@ -6297,23 +6343,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;
@@ -6335,7 +6402,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];
@@ -6344,7 +6411,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];
@@ -6357,7 +6424,7 @@ not_in_argv (NSString *arg)
++i;
}
}
- /* TODO: still need this? */
+ /* TODO: still need this? */
if (code == 0x2DC)
code = '~'; /* 0x7E */
if (code != 32) /* Space */
@@ -6370,7 +6437,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)] ?
@@ -6402,7 +6469,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]");
@@ -6455,7 +6522,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;
@@ -6515,8 +6582,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;
@@ -6561,7 +6628,7 @@ not_in_argv (NSString *arg)
return str;
}
-/* End <NSTextInput> impl. */
+/* End <NSTextInput> implementation. */
/*****************************************************************************/
@@ -6579,8 +6646,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)
@@ -6616,8 +6683,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. */
@@ -6686,7 +6753,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) |
@@ -6699,7 +6766,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];
@@ -6776,7 +6844,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);
@@ -6791,14 +6859,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;
@@ -6833,7 +6901,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);
@@ -6917,7 +6985,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])
@@ -6965,7 +7033,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]]];
@@ -6977,7 +7045,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;
@@ -7019,7 +7087,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)
{
@@ -7053,12 +7121,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];
@@ -7110,8 +7178,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 */
@@ -7182,7 +7250,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);
@@ -7414,7 +7482,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
@@ -7456,7 +7524,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 "]"
@@ -7470,7 +7538,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
{
@@ -7551,7 +7619,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];
@@ -7832,7 +7900,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)]
@@ -7911,7 +7979,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];
@@ -8051,7 +8120,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;
@@ -8062,14 +8131,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);
@@ -8261,13 +8330,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;
}
@@ -8278,7 +8347,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;
}
@@ -8300,10 +8369,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];
@@ -8311,7 +8380,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]])
@@ -8422,7 +8491,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:]",
@@ -8649,7 +8718,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
@@ -8685,7 +8754,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
@@ -8709,7 +8778,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]])
@@ -8717,7 +8786,7 @@ not_in_argv (NSString *arg)
[sview addSubview: self];
}
-/* [self setFrame: r]; */
+ /* [self setFrame: r]; */
return self;
}
@@ -8727,7 +8796,7 @@ not_in_argv (NSString *arg)
{
NSTRACE ("[EmacsScroller setFrame:]");
-/* block_input (); */
+ /* block_input (); */
if (horizontal)
pixel_length = NSWidth (newRect);
else
@@ -8735,7 +8804,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 (); */
}
@@ -8778,7 +8847,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++;
@@ -8805,7 +8874,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
}
@@ -8813,7 +8889,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. */
}
@@ -8852,7 +8928,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;
@@ -8895,7 +8971,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];
@@ -8904,7 +8981,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];
@@ -8930,11 +9007,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;
@@ -9033,9 +9110,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
@@ -9050,7 +9127,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;
@@ -9108,7 +9185,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:]");
@@ -9196,7 +9273,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)
@@ -9237,7 +9314,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;
@@ -9251,7 +9328,7 @@ syms_of_nsterm (void)
ns_antialias_threshold = 10.0;
- /* 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");
@@ -9263,11 +9340,11 @@ 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));
+ 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.");
@@ -9366,11 +9443,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. */);
@@ -9378,60 +9455,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/print.c b/src/print.c
index af1e85f6e7b..c0c90bc7e9a 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);
@@ -1971,7 +2049,8 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
|| c == ';' || c == '#' || c == '(' || c == ')'
|| c == ',' || c == '.' || c == '`'
|| c == '[' || c == ']' || c == '?' || c <= 040
- || confusing)
+ || confusing
+ || (i == 1 && confusable_symbol_character_p (c)))
{
printchar ('\\', printcharfun);
confusing = false;
@@ -1984,8 +2063,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 +2105,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 +2129,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 +2168,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 +2201,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 +2291,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 +2336,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 +2344,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 +2361,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 b0a327229c6..a9638dfc2df 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);
@@ -1013,7 +1025,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 +1064,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 +1083,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 +1151,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 +1165,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 +1261,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 +1384,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 +1585,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 +1658,8 @@ 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.
usage: (make-process &rest ARGS) */)
(ptrdiff_t nargs, Lisp_Object *args)
@@ -1779,7 +1790,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 + XFIXNUM (Flength (command));
Lisp_Object tem2;
SAFE_ALLOCA_LISP (args2, nargs2);
ptrdiff_t i = 0;
@@ -1809,7 +1820,7 @@ usage: (make-process &rest ARGS) */)
{
if (EQ (coding_systems, Qt))
{
- ptrdiff_t nargs2 = 3 + XINT (Flength (command));
+ ptrdiff_t nargs2 = 3 + XFIXNUM (Flength (command));
Lisp_Object tem2;
SAFE_ALLOCA_LISP (args2, nargs2);
ptrdiff_t i = 0;
@@ -1854,7 +1865,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 +1924,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
@@ -2494,9 +2504,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 = Fmake_vector (make_fixnum (len), Qnil);
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 +2516,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 = Fmake_vector (make_fixnum (len), Qnil);
p = XVECTOR (address);
- p->contents[--len] = make_number (ntohs (sin6->sin6_port));
+ p->contents[--len] = make_fixnum (ntohs (sin6->sin6_port));
for (i = 0; i < len; i++)
- p->contents[i] = make_number (ntohs (ip6[i]));
+ p->contents[i] = make_fixnum (ntohs (ip6[i]));
return address;
}
#endif
@@ -2538,8 +2548,8 @@ 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),
+ Fmake_vector (make_fixnum (len), Qnil));
p = XVECTOR (XCDR (address));
cp = (unsigned char *) &sa->sa_family + sizeof (sa->sa_family);
break;
@@ -2547,7 +2557,7 @@ conv_sockaddr_to_lisp (struct sockaddr *sa, ptrdiff_t len)
i = 0;
while (i < len)
- p->contents[i++] = make_number (*cp++);
+ p->contents[i++] = make_fixnum (*cp++);
return address;
}
@@ -2557,8 +2567,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 +2603,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 +2640,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 +2651,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 +2687,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 +2819,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 +2858,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 +3103,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 +3335,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 +3361,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 +3467,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. */
@@ -3773,8 +3783,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 +3860,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 +3927,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 +3951,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");
@@ -3983,7 +3991,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 +4009,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 +4018,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 +4029,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 +4106,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 +4180,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)
@@ -4394,7 +4405,7 @@ network_interface_info (Lisp_Object ifname)
{
if (flags & 1)
{
- elt = Fcons (make_number (fnum), elt);
+ elt = Fcons (make_fixnum (fnum), elt);
}
}
}
@@ -4405,21 +4416,21 @@ 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);
+ Lisp_Object hwaddr = Fmake_vector (make_fixnum (6), Qnil);
register struct Lisp_Vector *p = XVECTOR (hwaddr);
int n;
any = 1;
for (n = 0; n < 6; n++)
- p->contents[n] = make_number (((unsigned char *)
+ 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);
+ Lisp_Object hwaddr = Fmake_vector (make_fixnum (6), Qnil);
register struct Lisp_Vector *p = XVECTOR (hwaddr);
struct ifaddrs *it;
@@ -4436,9 +4447,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;
}
}
@@ -4608,7 +4619,7 @@ is nil, from any process) before the timeout expired. */)
/* 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;
@@ -4624,13 +4635,13 @@ is nil, from any process) before the timeout expired. */)
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));
}
}
@@ -4639,11 +4650,11 @@ is nil, from any process) before the timeout expired. */)
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;
}
}
@@ -4667,7 +4678,7 @@ is nil, from any process) before the timeout expired. */)
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);
}
@@ -4684,16 +4695,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;
@@ -4705,7 +4707,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;
}
@@ -4733,9 +4735,9 @@ server_accept_connection (Lisp_Object server, int channel)
args[nargs++] = procname_format_in;
nargs++;
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]);
args[nargs++] = service;
}
break;
@@ -4746,9 +4748,9 @@ server_accept_connection (Lisp_Object server, int channel)
args[nargs++] = procname_format_in6;
nargs++;
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]);
args[nargs++] = service;
}
break;
@@ -4757,7 +4759,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;
}
@@ -5012,7 +5014,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
@@ -5024,7 +5026,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);
@@ -5051,7 +5053,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)
{
@@ -5476,7 +5478,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
@@ -5641,16 +5643,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
@@ -5689,7 +5681,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
{
@@ -5700,7 +5692,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)
@@ -5752,7 +5744,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))
@@ -5821,7 +5813,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;
}
@@ -6139,7 +6131,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);
@@ -6186,7 +6178,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));
@@ -6214,8 +6206,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;
@@ -6423,7 +6415,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);
@@ -6433,7 +6425,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",
@@ -6469,11 +6461,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);
@@ -6555,7 +6547,7 @@ process group. */)
if (gid == p->pid)
return Qnil;
if (gid != -1)
- return make_number (gid);
+ return make_fixnum (gid);
return Qt;
}
@@ -6860,12 +6852,7 @@ 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;
- }
+ tem = string_to_number (SSDATA (process), 10, 0);
process = tem;
}
else if (!NUMBERP (process))
@@ -6884,10 +6871,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
{
@@ -6901,7 +6888,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,
@@ -7071,13 +7058,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)))
@@ -7141,7 +7126,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;
}
@@ -7536,7 +7521,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);
@@ -7550,7 +7535,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,
@@ -7656,7 +7641,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;
@@ -7949,8 +7934,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)
@@ -7962,7 +7946,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)
@@ -8048,6 +8032,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));
@@ -8240,6 +8236,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 6464a8cc61a..3c6dd7b91f4 100644
--- a/src/process.h
+++ b/src/process.h
@@ -194,7 +194,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 +203,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 +221,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
diff --git a/src/profiler.c b/src/profiler.c
index 312574d7526..7330f8861fc 100644
--- a/src/profiler.c
+++ b/src/profiler.c
@@ -55,7 +55,7 @@ make_log (EMACS_INT heap_size, EMACS_INT max_stack_depth)
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));
+ Fmake_vector (make_fixnum (max_stack_depth), Qnil));
return log;
}
@@ -80,12 +80,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
{
@@ -110,7 +110,7 @@ static void evict_lower_half (log_t *log)
for (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. */
@@ -156,15 +156,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);
@@ -266,14 +266,14 @@ setup_cpu_timer (Lisp_Object sampling_interval)
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);
+ current_sampling_interval = XFIXNUM (sampling_interval);
interval = make_timespec (current_sampling_interval / billion,
current_sampling_interval % billion);
emacs_sigaction_init (&action, deliver_profiler_signal);
@@ -422,8 +422,8 @@ Before returning, a new log is allocated for future samples. */)
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),
+ Fputhash (Fmake_vector (make_fixnum (1), QAutomatic_GC),
+ make_fixnum (cpu_gc_count),
result);
cpu_gc_count = 0;
return result;
diff --git a/src/ptr-bounds.h b/src/ptr-bounds.h
new file mode 100644
index 00000000000..8cbd58d72b0
--- /dev/null
+++ b/src/ptr-bounds.h
@@ -0,0 +1,79 @@
+/* Pointer bounds checking for GNU Emacs
+
+Copyright 2017-2018 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 e6319ff2d21..b37ab977ac3 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/regex.c b/src/regex-emacs.c
index 4f9df68a9fe..d19838a876e 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-2018 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,108 @@
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 */
+#define ISSPACE(c) (SYNTAX (c) == Swhitespace)
-/* 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 ISUPPER(c) uppercasep (c)
- 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;
-}
-
-# endif /* not SYNTAX_TABLE */
-
-# define SYNTAX(c) re_syntax_table[(c)]
-
-#endif /* not emacs */
+#define ISWORD(c) (SYNTAX (c) == Sword)
#define SIGN_EXTEND_CHAR(c) ((signed char) (c))
-/* 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 TALLOC(n, t) ((t *) xmalloc ((n) * sizeof (t)))
+#define RETALLOC(addr, n, t) ((addr) = (t *) xrealloc (addr, (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,
+static void re_compile_fastmap (struct re_pattern_buffer *);
+static ptrdiff_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,
+ 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 +245,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 +259,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 +276,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 +324,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 +337,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 +347,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 +357,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. */
@@ -736,7 +396,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 +406,7 @@ extract_number_and_incr (re_char **source)
(destination) = ((source)[0] \
| ((source)[1] << 8) \
| ((source)[2] << 16)); \
- } while (0)
+ } while (false)
/* Macros for charset. */
@@ -760,47 +420,39 @@ extract_number_and_incr (re_char **source)
/* 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. */
@@ -1089,7 +741,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 ("%zu bytes used/%zu bytes allocated.\n",
bufp->used, bufp->allocated);
if (bufp->fastmap_accurate && bufp->fastmap)
@@ -1101,9 +753,6 @@ print_compiled_pattern (struct re_pattern_buffer *bufp)
printf ("re_nsub: %zu\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
@@ -1135,141 +784,105 @@ print_double_string (re_char *where, re_char *string1, ssize_t size1,
}
}
-#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
union fail_stack_elt
{
re_char *pointer;
- /* This should be the biggest `int' that's no bigger than a pointer. */
+ /* This should be the biggest 'int' that's no bigger than a pointer. */
long integer;
};
@@ -1286,45 +899,28 @@ typedef struct
#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 +930,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,8 +972,8 @@ 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: %zu\n", (fail_stack).size);\
+ DEBUG_PRINT (" slots available: %zu\n", REMAINING_AVAIL_SLOTS);\
}
/* Push register NUM onto the stack. */
@@ -1394,7 +987,7 @@ do { \
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,7 +1002,7 @@ 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() \
@@ -1418,7 +1011,7 @@ do { \
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); \
@@ -1431,19 +1024,19 @@ 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; \
@@ -1453,47 +1046,44 @@ do { \
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: %zu\n", (fail_stack).avail); \
+ DEBUG_PRINT (" size: %zu\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: %zu\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 +1095,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: %zu\n", fail_stack.avail); \
+ DEBUG_PRINT (" size: %zu\n", fail_stack.size); \
\
/* Pop the saved registers. */ \
while (fail_stack.frame < fail_stack.avail) \
@@ -1541,13 +1131,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 */
@@ -1557,12 +1147,8 @@ do { \
/* Subroutine declarations and macros for regex_compile. */
static reg_errcode_t regex_compile (re_char *pattern, size_t size,
-#ifdef emacs
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,10 +1156,8 @@ 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);
@@ -1586,35 +1170,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 ()
-/* 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 +1200,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 +1212,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,7 +1224,7 @@ 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
reset the pointers that pointed into the old block to point to the
@@ -1671,15 +1248,13 @@ static int analyze_first (re_char *p, re_char *pend,
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; \
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,7 +1262,7 @@ 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;
@@ -1696,7 +1271,6 @@ typedef int regnum_t;
/* 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;
typedef struct
@@ -1723,12 +1297,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,8 +1307,6 @@ 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.
@@ -1754,7 +1320,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 +1331,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 +1366,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 +1380,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 +1392,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 +1401,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 +1432,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 +1440,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 +1454,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 +1467,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 +1482,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.
@@ -2025,7 +1584,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 +1637,6 @@ re_wctype_to_bit (re_wctype_t cc)
abort ();
}
}
-#endif
/* Filling in the work area of a range. */
@@ -2088,357 +1646,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);
+ work_area->table = xrealloc (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;
-}
-
-#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. */
-
-static fail_stack_type fail_stack;
-
-/* 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.
+/* regex_compile and helpers. */
- 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.
+static bool group_in_compile_stack (compile_stack_type, regnum_t);
- 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 zero;
+ '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, size_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,7 +1730,7 @@ 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;
@@ -2462,9 +1738,8 @@ regex_compile (const_re_char *pattern, size_t size,
struct range_table_work_area range_table_work;
/* If the object matched can contain multibyte characters. */
- const boolean multibyte = RE_MULTIBYTE_P (bufp);
+ bool multibyte = RE_MULTIBYTE_P (bufp);
-#ifdef emacs
/* Nonzero if we have pushed down into a subpattern. */
int in_subpattern = 0;
@@ -2473,26 +1748,22 @@ 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;
+ size_t debug_count;
for (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.size = INIT_COMPILE_STACK_SIZE;
compile_stack.avail = 0;
@@ -2500,26 +1771,16 @@ 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;
- /* 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)
@@ -2532,8 +1793,6 @@ regex_compile (const_re_char *pattern, size_t size,
{ /* 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);
-
bufp->allocated = INIT_BUF_SIZE;
}
@@ -2544,7 +1803,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 +1813,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 +1821,6 @@ regex_compile (const_re_char *pattern, size_t size,
switch (c)
{
-#ifdef emacs
case ' ':
{
re_char *p1 = p;
@@ -2597,95 +1853,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 +1911,25 @@ regex_compile (const_re_char *pattern, size_t size,
{
if (many_times_ok)
{
- boolean simple = skip_one_char (laststart) == b;
+ bool simple = skip_one_char (laststart) == b;
size_t startoffset = 0;
re_opcode_t ofj =
/* Check if the loop can match the empty string. */
(simple || !analyze_first (laststart, b, NULL, 0))
? 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 +1950,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 +1962,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, 0);
/* The non-greedy multiple match looks like
a repeat..until: we only need a conditional jump
@@ -2802,8 +2014,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 +2029,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 +2048,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,7 +2074,7 @@ 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
@@ -2896,60 +2092,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 (c <= c1)
{
- if (syntax & RE_NO_EMPTY_RANGES)
- FREE_STACK_RETURN (REG_ERANGEX);
- /* Else, repeat the loop. */
- }
- else
- {
-#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 +2127,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 +2162,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 +2175,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 +2186,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;
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)
@@ -3121,8 +2242,6 @@ regex_compile (const_re_char *pattern, size_t size,
{
RETALLOC (compile_stack.stack, compile_stack.size << 1,
compile_stack_elt_t);
- if (compile_stack.stack == NULL) return REG_ESPACE;
-
compile_stack.size <<= 1;
}
@@ -3154,35 +2273,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 +2312,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 +2329,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 +2351,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 +2362,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,8 +2395,8 @@ 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. */
@@ -3340,21 +2416,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 +2445,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 +2481,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 +2516,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 +2551,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 +2581,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 +2591,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 +2599,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 +2630,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 +2658,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 +2687,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 +2714,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 +2731,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 +2806,39 @@ 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,
+analyze_first (re_char *p, re_char *pend, char *fastmap,
const int 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 +2860,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 +2907,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 +2934,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 +2952,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 +2982,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 +3003,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 +3018,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 +3042,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 +3051,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 +3085,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,18 +3097,16 @@ 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.
-
- Returns 0 if we succeed, -2 if an internal error. */
+ Set the 'fastmap', 'fastmap_accurate', and 'can_be_null' fields in
+ the pattern buffer. */
-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. */
bufp->fastmap_accurate = 1; /* It will be when we're done. */
@@ -4134,14 +3114,13 @@ re_compile_fastmap (struct re_pattern_buffer *bufp)
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 +3130,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,
+ unsigned int num_regs, ptrdiff_t *starts, ptrdiff_t *ends)
{
if (num_regs)
{
@@ -4167,21 +3147,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
+ptrdiff_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 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 +3186,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
+ptrdiff_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)
+ const char *str2, size_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;
+ char *fastmap = bufp->fastmap;
+ Lisp_Object translate = bufp->translate;
size_t total_size = size1 + size2;
- ssize_t endpos = startpos + range;
- boolean anchored_start;
+ 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 +3229,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 +3237,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 +3245,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 +3273,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 +3305,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 +3350,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 +3422,16 @@ 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,
+ ptrdiff_t len,
+ Lisp_Object translate,
const int multibyte);
-/* 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 +3455,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 +3464,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 +3495,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 +3527,8 @@ skip_one_char (const_re_char *p)
case syntaxspec:
case notsyntaxspec:
-#ifdef emacs
case categoryspec:
case notcategoryspec:
-#endif /* emacs */
p++;
break;
@@ -4596,7 +3541,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 +3562,7 @@ skip_noops (const_re_char *p, const_re_char *pend)
return p;
}
}
- assert (p == pend);
+ eassert (p == pend);
return p;
}
@@ -4627,7 +3572,7 @@ 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, unsigned c, unsigned corig, bool unibyte)
{
re_char *p = *pp, *rtp = NULL;
bool not = (re_opcode_t) *p == charset_not;
@@ -4644,17 +3589,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 +3629,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)
+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 +3654,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;
@@ -4730,7 +3674,7 @@ mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1,
case endline:
case exactn:
{
- register re_wchar_t c
+ int c
= (re_opcode_t) *p2 == endline ? '\n'
: RE_STRING_CHAR (p2 + 2, multibyte);
@@ -4746,7 +3690,7 @@ mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1,
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;
@@ -4773,10 +3717,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
@@ -4860,12 +3804,10 @@ 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:
;
@@ -4878,61 +3820,43 @@ mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1,
/* 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
+ptrdiff_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)
+ size_t size1, const char *string2, size_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,
+ size_t size1, re_char *string2, size_t size2,
+ ptrdiff_t pos, struct re_registers *regs, ptrdiff_t stop)
{
/* General temporaries. */
int mcnt;
@@ -4959,13 +3883,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,19 +3898,11 @@ 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;
-#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. */
@@ -4999,24 +3915,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
+ 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. */
@@ -5033,7 +3945,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,29 +3952,16 @@ 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;
- }
+ regstart = SAFE_ALLOCA (num_regs * 4 * sizeof *regstart);
+ regend = regstart + num_regs;
+ best_regstart = regend + num_regs;
+ best_regend = best_regstart + num_regs;
}
- 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;
- }
-#endif /* MATCH_MAY_ALLOCATE */
/* The starting position is bogus. */
if (pos < 0 || pos > size1 + size2)
{
- FREE_VARIABLES ();
+ SAFE_FREE ();
return -1;
}
@@ -5073,8 +3971,8 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
for (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 +3983,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 +4005,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 +4013,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;
@@ -5192,10 +4090,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");
@@ -5215,21 +4113,16 @@ 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
+ 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;
- }
+ regs->start = TALLOC (regs->num_regs, ptrdiff_t);
+ regs->end = TALLOC (regs->num_regs, ptrdiff_t);
bufp->regs_allocated = REGS_REALLOCATE;
}
else if (bufp->regs_allocated == REGS_REALLOCATE)
@@ -5239,23 +4132,14 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
if (regs->num_regs < num_regs + 1)
{
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;
- }
+ RETALLOC (regs->start, regs->num_regs, ptrdiff_t);
+ RETALLOC (regs->end, regs->num_regs, ptrdiff_t);
}
}
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,7 +4148,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)'
+ /* 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++)
{
@@ -5284,7 +4168,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
-1 at the end. */
for (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",
nfailure_points_pushed, nfailure_points_popped,
@@ -5295,7 +4179,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
DEBUG_PRINT ("Returning %td from re_match_2.\n", dcnt);
- FREE_VARIABLES ();
+ SAFE_FREE ();
return dcnt;
}
@@ -5322,34 +4206,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 +4270,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 +4286,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);
@@ -5454,7 +4302,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
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" : "");
@@ -5524,10 +4372,10 @@ 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]));
+ eassert (REG_UNSET (regend[*p]));
PUSH_FAILURE_REGSTOP ((unsigned int)*p);
But the only info to be pushed is regend[*p] and it is known to
@@ -5547,11 +4395,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 +4452,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 +4465,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 +4479,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 +4487,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 +4510,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,7 +4553,7 @@ 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;
CHECK_INFINITE_LOOP (p - 4, d);
@@ -5738,7 +4578,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
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 +4613,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 +4622,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 +4633,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 +4665,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 +4674,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 +4693,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 +4710,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 +4722,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 +4734,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 - 1);
+ ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset);
+ 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 +4772,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 +4790,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 +4813,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) - 1;
+ ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset);
+ UPDATE_SYNTAX_TABLE (charpos);
GET_CHAR_BEFORE_2 (c1, d, string1, end1, string2, end2);
s1 = SYNTAX (c1);
@@ -6001,9 +4831,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);
s2 = SYNTAX (c2);
/* ... and S2 is Sword, and WORD_BOUNDARY_P (C1, C2)
@@ -6026,13 +4854,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 +4871,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 +4893,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) - 1;
+ ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset);
+ UPDATE_SYNTAX_TABLE (charpos);
GET_CHAR_BEFORE_2 (c1, d, string1, end1, string2, end2);
s1 = SYNTAX (c1);
@@ -6088,9 +4910,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 +4923,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 +4945,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 +4954,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 +4962,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 +4971,6 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
}
break;
-#endif /* emacs */
-
default:
abort ();
}
@@ -6174,11 +4989,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 +5013,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,9 +5025,9 @@ 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. */
@@ -6221,19 +5036,19 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1,
bytes; nonzero otherwise. */
static int
-bcmp_translate (const_re_char *s1, const_re_char *s2, register ssize_t len,
- RE_TRANSLATE_TYPE translate, const int target_multibyte)
+bcmp_translate (re_char *s1, re_char *s2, ptrdiff_t len,
+ Lisp_Object translate, int 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);
@@ -6257,16 +5072,14 @@ 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
bool posix_backtracking, const char *whitespace_regexp,
-#endif
struct re_pattern_buffer *bufp)
{
reg_errcode_t ret;
@@ -6275,335 +5088,12 @@ re_compile_pattern (const char *pattern, size_t length,
(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
posix_backtracking,
whitespace_regexp,
-#else
- re_syntax_options,
-#endif
bufp);
if (!ret)
return NULL;
- return gettext (re_error_msgid[(int) 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;
+ return re_error_msgid[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..a849cbea054
--- /dev/null
+++ b/src/regex-emacs.h
@@ -0,0 +1,197 @@
+/* Emacs regular expression API
+
+ Copyright (C) 1985, 1989-1993, 1995, 2000-2018 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
+{
+ unsigned 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 size_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. */
+ size_t allocated;
+
+ /* Number of bytes actually used in 'buffer'. */
+ size_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. */
+ size_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'. */
+ 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. */
+ 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. */
+ unsigned 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. */
+ unsigned used_syntax : 1;
+
+ /* 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;
+};
+
+/* 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, size_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, size_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, size_t length1,
+ const char *string2, size_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, size_t length1,
+ const char *string2, size_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,
+ unsigned 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,
+ unsigned limit);
+
+#endif /* EMACS_REGEX_H */
diff --git a/src/regex.h b/src/regex.h
deleted file mode 100644
index b4aad6daac9..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-2018 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 8a53f9614f7..a29f2d37f54 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
@@ -120,8 +114,8 @@ calculate_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->insertcount = 0;
matrix->deletecount = 0;
@@ -132,8 +126,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 +138,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;
}
@@ -465,8 +459,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 +472,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 +483,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 6d010466dcd..f5c771963ea 100644
--- a/src/search.c
+++ b/src/search.c
@@ -30,7 +30,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "blockinput.h"
#include "intervals.h"
-#include "regex.h"
+#include "regex-emacs.h"
#define REGEXP_CACHE_SIZE 20
@@ -48,6 +48,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. */
@@ -57,8 +59,8 @@ static struct regexp_cache searchbufs[REGEXP_CACHE_SIZE];
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
+/* 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).
@@ -93,6 +95,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 +114,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 +130,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 +141,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 +151,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 +167,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 +188,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,7 +218,7 @@ 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)
{
@@ -229,9 +235,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)))
@@ -244,7 +251,10 @@ compile_pattern (Lisp_Object pattern, struct re_registers *regp,
string value. */
if (cp->next == 0)
{
+ if (cp->busy)
+ error ("Too much matching reentrancy");
compile_it:
+ eassert (!cp->busy);
compile_pattern_1 (cp, pattern, translate, posix);
break;
}
@@ -265,8 +275,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 +286,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 +330,20 @@ 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 ();
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 +357,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 +402,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 +411,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 +448,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 +490,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 +512,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 +531,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 +545,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 +570,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;
}
@@ -1026,8 +1038,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 +1052,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 +1064,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 +1099,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 +1154,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 +1171,372 @@ 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)
+ {
+ 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)
+ {
+ 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;
+}
+
+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 ();
- 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;
+ /* 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 +2189,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 +2423,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 +2434,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 +2528,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 +2593,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;
}
@@ -2753,12 +2783,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 +2812,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 +2911,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,7 +2992,7 @@ 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;
+ EMACS_INT length = XFIXNAT (Flength (list)) / 2;
if (length > search_regs.num_regs)
{
@@ -2971,9 +3001,9 @@ If optional arg RESEAT is non-nil, make markers on LIST point nowhere. */)
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 +3040,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 +3057,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
{
@@ -3322,11 +3349,11 @@ the buffer. If the buffer doesn't have a cache, the value is nil. */)
NULL, true);
if (shortage != 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. */
@@ -3344,10 +3371,10 @@ the buffer. If the buffer doesn't have a cache, the value is nil. */)
NULL, true);
if (shortage != 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,6 +3387,7 @@ the buffer. If the buffer doesn't have a cache, the value is nil. */)
return val;
}
+
void
syms_of_search (void)
{
@@ -3372,6 +3400,7 @@ syms_of_search (void)
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;
staticpro (&searchbufs[i].regexp);
staticpro (&searchbufs[i].f_whitespace_regexp);
@@ -3412,6 +3441,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.
diff --git a/src/sound.c b/src/sound.c
index ce1a11e3863..6f15f5dab6d 100644
--- a/src/sound.c
+++ b/src/sound.c
@@ -2,6 +2,8 @@
Copyright (C) 1998-1999, 2001-2018 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 e54325589f3..432d82cdf0f 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"
@@ -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,
@@ -490,7 +491,7 @@ parse_sexp_propertize (ptrdiff_t charpos)
{
EMACS_INT 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 +606,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))
+ {
+ EMACS_INT 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 +895,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 +953,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 +1119,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 +1131,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 +1166,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 +1213,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 +1278,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 +1320,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 +1349,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 +1414,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 +1481,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 +1530,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 +1587,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 +1677,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 +1722,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 +1818,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 +1937,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 +2095,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 +2116,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 +2173,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 +2206,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 +2257,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 +2276,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 +2443,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 +2794,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 +2950,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 +3030,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 +3054,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 +3074,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 +3217,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 +3463,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;
@@ -3469,7 +3491,7 @@ internalize_parse_state (Lisp_Object external, struct lisp_parse_state *state)
{
tem = Fcar (external);
if (!NILP (tem))
- state->depth = XINT (tem);
+ state->depth = XFIXNUM (tem);
else
state->depth = 0;
@@ -3479,13 +3501,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 +3521,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 +3584,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 +3601,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 +3642,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 +3678,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 +3717,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,7 +3730,7 @@ syms_of_syntax (void)
staticpro (&gl_state.current_syntax_table);
staticpro (&gl_state.old_prop);
- /* Defined in regex.c. */
+ /* Defined in regex-emacs.c. */
staticpro (&re_match_object);
DEFSYM (Qscan_error, "scan-error");
diff --git a/src/syntax.h b/src/syntax.h
index 2171cbbba45..d971c747539 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 34bff23386d..722d8138ded 100644
--- a/src/sysdep.c
+++ b/src/sysdep.c
@@ -1671,7 +1671,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
@@ -2554,6 +2554,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 +2578,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)
@@ -2833,8 +2850,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 +2862,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 +2916,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 +3045,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
}
@@ -3061,16 +3078,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 +3111,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 +3237,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 +3259,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 +3267,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 +3275,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 +3333,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 +3365,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);
@@ -3478,7 +3489,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 +3497,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 +3505,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 +3527,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 +3557,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,8 +3583,7 @@ 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__
@@ -3614,14 +3621,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 +3636,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 +3675,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 +3685,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 +3711,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 +3733,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 +3743,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;
@@ -3794,7 +3802,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 +3810,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 +3819,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 +3859,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 +3869,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 +3890,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 ();
diff --git a/src/syssignal.h b/src/syssignal.h
index 4f6da845ad1..0887eacb05d 100644
--- a/src/syssignal.h
+++ b/src/syssignal.h
@@ -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 c4dcc4e9069..d53b5c207b6 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 4745d220654..3805cb261f1 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 b2f893714b3..ad5ab857308 100644
--- a/src/systime.h
+++ b/src/systime.h
@@ -23,12 +23,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
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,23 +56,14 @@ 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;
@@ -82,10 +71,6 @@ 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 };
@@ -103,7 +88,6 @@ 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 struct timespec lisp_time_argument (Lisp_Object);
-#endif
INLINE_HEADER_END
diff --git a/src/term.c b/src/term.c
index 8493cc02c4d..852dc23bd60 100644
--- a/src/term.c
+++ b/src/term.c
@@ -1359,7 +1359,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),
+ Fmake_vector (make_fixnum (1),
intern (keys[i].name)));
}
@@ -1379,13 +1379,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")));
+ Fmake_vector (make_fixnum (1), intern ("f0")));
Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k_semi),
- Fmake_vector (make_number (1), intern ("f10")));
+ Fmake_vector (make_fixnum (1), intern ("f10")));
}
else if (k0)
Fdefine_key (KVAR (kboard, Vinput_decode_map), build_string (k0),
- Fmake_vector (make_number (1), intern (k0_name)));
+ Fmake_vector (make_fixnum (1), intern (k0_name)));
}
/* Set up cookies for numbered function keys above f10. */
@@ -1408,7 +1408,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),
+ Fmake_vector (make_fixnum (1),
intern (fkey)));
}
}
@@ -1425,7 +1425,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), \
+ Fmake_vector (make_fixnum (1), \
intern (sym))); \
}
@@ -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)
{
@@ -2721,7 +2721,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 +2805,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 +3132,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 +3403,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 +3477,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 +3488,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 +3702,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 +3754,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 +3776,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 +4149,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 +4161,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/termhooks.h b/src/termhooks.h
index 543809b9e40..4e341055100 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. */
@@ -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 043ee67e0c1..e4803592575 100644
--- a/src/terminal.c
+++ b/src/terminal.c
@@ -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 904e2265bdb..8e8baf43d9f 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);
@@ -137,15 +137,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 +157,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 +166,24 @@ 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));
+ XSETFASTINT (*begin, XFIXNAT (*begin));
if (begin != end)
- XSETFASTINT (*end, XFASTINT (*end));
+ XSETFASTINT (*end, XFIXNAT (*end));
i = string_intervals (object);
if (len == 0)
return NULL;
- searchpos = XINT (*begin);
+ searchpos = XFIXNUM (*begin);
}
if (!i)
@@ -544,7 +544,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 +572,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 +604,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 +621,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 +714,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 +740,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 +774,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 +796,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 +826,7 @@ last valid position in OBJECT. */)
break;
}
- unbind_to (count, Qnil);
+ position = unbind_to (count, position);
}
return position;
@@ -859,10 +859,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 +880,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 +911,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 +920,7 @@ first valid position in OBJECT. */)
}
}
- unbind_to (count, Qnil);
+ position = unbind_to (count, position);
}
return position;
@@ -948,7 +948,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 +976,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 +1015,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 +1025,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 +1062,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 +1112,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 +1128,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 +1164,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 +1221,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 +1232,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 +1243,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;
}
@@ -1363,8 +1363,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;
@@ -1413,8 +1413,8 @@ 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;
}
@@ -1431,15 +1431,15 @@ set_text_properties_1 (Lisp_Object start, Lisp_Object end, Lisp_Object propertie
register ptrdiff_t s, len;
INTERVAL unchanged;
- if (XINT (start) < XINT (end))
+ if (XFIXNUM (start) < XFIXNUM (end))
{
- s = XINT (start);
- len = XINT (end) - s;
+ s = XFIXNUM (start);
+ len = XFIXNUM (end) - s;
}
- else if (XINT (end) < XINT (start))
+ else if (XFIXNUM (end) < XFIXNUM (start))
{
- s = XINT (end);
- len = XINT (start) - s;
+ s = XFIXNUM (end);
+ len = XFIXNUM (start) - s;
}
else
return;
@@ -1531,8 +1531,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 +1589,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 +1598,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 +1609,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 +1643,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 +1687,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 +1701,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 +1714,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 +1733,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 +1762,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 +1771,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 +1798,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 +1809,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 +1827,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 +1835,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;
@@ -1907,11 +1907,11 @@ copy_text_properties (Lisp_Object start, Lisp_Object end, Lisp_Object src,
if (!i)
return Qnil;
- CHECK_NUMBER_COERCE_MARKER (pos);
+ CHECK_FIXNUM_COERCE_MARKER (pos);
{
Lisp_Object dest_start, dest_end;
- e = XINT (pos) + (XINT (end) - XINT (start));
+ e = XFIXNUM (pos) + (XFIXNUM (end) - XFIXNUM (start));
if (MOST_POSITIVE_FIXNUM < e)
args_out_of_range (pos, end);
dest_start = pos;
@@ -1921,9 +1921,9 @@ copy_text_properties (Lisp_Object start, Lisp_Object end, Lisp_Object src,
validate_interval_range (dest, &dest_start, &dest_end, soft);
}
- s = XINT (start);
- e = XINT (end);
- p = XINT (pos);
+ s = XFIXNUM (start);
+ e = XFIXNUM (end);
+ p = XFIXNUM (pos);
stuff = Qnil;
@@ -1948,7 +1948,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);
@@ -1991,8 +1991,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 +2015,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 +2043,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 +2062,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 +2071,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 +2082,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 +2285,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);
}
}
diff --git a/src/thread.c b/src/thread.c
index 9b450ee0a45..fc933440fcc 100644
--- a/src/thread.c
+++ b/src/thread.c
@@ -25,6 +25,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "process.h"
#include "coding.h"
#include "syssignal.h"
+#include "keyboard.h"
static struct thread_state main_thread;
@@ -34,7 +35,6 @@ static struct thread_state *all_threads = &main_thread;
static sys_mutex_t global_lock;
-extern int poll_suppress_count;
extern volatile int interrupt_input_blocked;
@@ -681,7 +681,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);
}
@@ -789,6 +789,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 +863,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 +875,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 +953,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 +967,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 +1000,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;
}
@@ -1011,6 +1044,7 @@ init_main_thread (void)
main_thread.m_saved_last_thing_searched = Qnil;
main_thread.name = Qnil;
main_thread.function = Qnil;
+ main_thread.result = Qnil;
main_thread.error_symbol = Qnil;
main_thread.error_data = Qnil;
main_thread.event_object = Qnil;
@@ -1022,6 +1056,14 @@ main_thread_p (void *ptr)
return ptr == &main_thread;
}
+bool
+in_current_thread (void)
+{
+ if (current_thread == NULL)
+ return false;
+ return sys_thread_equal (sys_thread_self (), current_thread->thread_id);
+}
+
void
init_threads_once (void)
{
@@ -1078,4 +1120,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);
+#else
+ Vmain_thread = Qnil;
+#endif
}
diff --git a/src/thread.h b/src/thread.h
index 5746512b799..464506d2632 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;
@@ -109,8 +111,8 @@ struct thread_state
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_match_2, etc., must pass &search_regs as the regs
+ argument unless you can show it is unnecessary (i.e., if re_match_2
is certainly going to be called again before region-around-match
can be called).
@@ -137,15 +139,6 @@ struct thread_state
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 +183,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 +201,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 +230,7 @@ struct Lisp_Mutex
/* The lower-level mutex object. */
lisp_mutex_t mutex;
-};
+} GCALIGNED_STRUCT;
INLINE bool
MUTEXP (Lisp_Object a)
@@ -255,7 +248,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 +264,7 @@ struct Lisp_CondVar
/* The lower-level condition variable object. */
sys_cond_t cond;
-};
+} GCALIGNED_STRUCT;
INLINE bool
CONDVARP (Lisp_Object a)
@@ -289,7 +282,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;
@@ -303,6 +296,7 @@ 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 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/tparam.h b/src/tparam.h
index f8fb9e08690..79c55b94d2a 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 c34faa42720..1975e387e3f 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)));
}
}
@@ -352,14 +348,14 @@ 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)
+ if (FIXNUMP (Vundo_outer_limit)
+ && size_so_far > XFIXNUM (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_fixnum (size_so_far));
if (! NILP (tem))
{
/* The function is responsible for making
@@ -472,7 +468,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/unexcw.c b/src/unexcw.c
index 762b996e4b6..dea9f6a7462 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/w16select.c b/src/w16select.c
index ed3d041f2df..a5f07578671 100644
--- a/src/w16select.c
+++ b/src/w16select.c
@@ -2,6 +2,8 @@
Copyright (C) 1996-1997, 2001-2018 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
@@ -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 5ac66181403..4b57d916416 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
@@ -570,8 +576,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 +608,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 +644,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 +677,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 +701,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 +731,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 +766,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 +787,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 +823,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 +843,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 +882,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 +903,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 +934,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 +962,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 +991,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 +1017,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 +1040,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 +1063,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 +1086,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 +1111,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 +1135,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 +1165,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 +1200,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 +1245,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 +1279,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 +1324,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 +1363,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
@@ -2728,7 +2795,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)
{
@@ -6560,8 +6628,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 +6647,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 +6666,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 +6693,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 +6723,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 +6746,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 +6773,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 +6798,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 +6821,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 +6844,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 +6873,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 +7031,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 +7061,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 +7214,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)),
@@ -7181,12 +7249,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);
}
@@ -7196,9 +7264,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);
}
@@ -7207,7 +7275,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);
}
@@ -7349,8 +7417,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");
@@ -7359,7 +7427,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);
@@ -7394,8 +7462,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)
@@ -8390,13 +8458,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;
@@ -9134,7 +9203,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;
@@ -9163,11 +9232,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;
@@ -9229,9 +9298,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,
@@ -9269,6 +9338,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 null 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 null 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 null 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
@@ -9603,10 +9881,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;
}
@@ -9657,7 +9935,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");
@@ -9699,6 +9977,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;
@@ -9814,8 +10095,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. */
@@ -9824,12 +10105,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. */
@@ -9868,14 +10149,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 1e416ceead7..9c219cdda62 100644
--- a/src/w32.h
+++ b/src/w32.h
@@ -227,6 +227,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 +241,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 af548dd8ea1..e860dbce032 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 36a6ced2983..9f9db68f0ef 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..bc401239787
--- /dev/null
+++ b/src/w32cygwinx.c
@@ -0,0 +1,135 @@
+/* Common functions for the Microsoft Windows and Cygwin builds.
+
+Copyright (C) 2018 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 = listn (CONSTYPE_HEAP, 8,
+ 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 b673cd31618..9a9789d8af3 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -457,12 +457,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 +748,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 +828,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 +1182,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 +1198,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 +1208,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 +1220,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 +1343,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 +1352,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 +1362,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 +1373,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 +1383,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 +1404,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
@@ -1689,7 +1689,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 +1725,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 +1757,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 +1780,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 +1805,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 +2027,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 +2334,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 +2350,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 +2640,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 +2655,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 +3116,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 +3140,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 +3157,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 +4199,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 +4215,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 +5413,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 +5529,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 +5675,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 +5728,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 +5809,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 +5845,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 +5861,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 +5921,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 +5938,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 +6094,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 +6109,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 +6126,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 +6139,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 +6152,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 +6194,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 +6241,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 +6257,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 +6270,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 +6279,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 +6290,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 +6301,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 +6330,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 +6426,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 +6555,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 +6637,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 +6655,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 +6668,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 +6684,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 +6710,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 +6731,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 +6786,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;
-Lisp_Object last_show_tip_args;
+/* Normalized FRAME argument of last `x-show-tip' call. */
+Lisp_Object tip_last_frame;
+
+/* PARMS argument of last `x-show-tip' call. */
+Lisp_Object tip_last_parms;
static void
@@ -7007,6 +6877,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 +6912,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 +6928,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 +7064,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 +7104,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 +7172,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 +7196,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 +7209,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 +7274,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 +7291,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 +7299,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 +7330,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 +7344,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 +7370,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 +7386,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 +7420,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 +7475,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 +7621,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 */
@@ -8187,10 +8033,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 +8143,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 +8209,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
@@ -8455,7 +8301,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 +8336,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 +8412,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 +8430,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 +8534,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 +8547,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 +8562,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 +8594,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 +8602,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 +8642,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;
}
@@ -8941,32 +8787,32 @@ and width values are in pixels.
return listn (CONSTYPE_HEAP, 10,
Fcons (Qouter_position,
- Fcons (make_number (left), make_number (top))),
+ 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 +8849,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 +8891,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 +9048,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 +9071,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 +9079,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 +9087,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 +9096,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 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 +9117,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 +9431,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 +9694,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)
{
@@ -10315,7 +10059,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 +10070,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 +10079,72 @@ 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.
+
+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
***********************************************************************/
@@ -10427,12 +10237,21 @@ 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));
@@ -10625,9 +10444,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 +10452,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 +10595,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 +10602,7 @@ tip frame. */);
#endif
#ifdef WINDOWSNT
+ defsubr (&Sw32_read_registry);
defsubr (&Sfile_system_info);
defsubr (&Sdefault_printer_name);
#endif
@@ -10813,9 +10614,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 +10656,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 +10731,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 +10865,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;
diff --git a/src/w32font.c b/src/w32font.c
index 9cbc3ee14bb..798869b5caf 100644
--- a/src/w32font.c
+++ b/src/w32font.c
@@ -29,6 +29,7 @@ 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
@@ -153,7 +154,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 +171,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 +189,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 +207,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 +719,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 +921,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 +1097,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 +1110,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 +1230,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 +1823,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 +1956,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 +1967,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 +1978,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 +2037,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;
diff --git a/src/w32heap.c b/src/w32heap.c
index df79f8c2cef..8c946825067 100644
--- a/src/w32heap.c
+++ b/src/w32heap.c
@@ -250,7 +250,9 @@ init_heap (void)
#ifndef MINGW_W64
/* 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,
@@ -281,7 +283,7 @@ init_heap (void)
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));
diff --git a/src/w32inevt.c b/src/w32inevt.c
index 907cc476a91..f5558bb3d54 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 0cd7284c9b0..a2d39c5edfe 100644
--- a/src/w32menu.c
+++ b/src/w32menu.c
@@ -1407,7 +1407,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 +1572,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;
@@ -1606,9 +1607,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 c16a8d11b65..67385b80a81 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-2018 Free Software Foundation, Inc.
+
+Copyright (C) 2012-2018 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 28d7b6611f6..cb02ba63412 100644
--- a/src/w32proc.c
+++ b/src/w32proc.c
@@ -548,9 +548,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. */
@@ -1766,7 +1765,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;
@@ -1889,8 +1888,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 +2690,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 +3016,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;
@@ -3186,14 +3185,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,16 +3200,16 @@ 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
character, when the returned information is a string, whereas
@@ -3231,7 +3230,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 +3259,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 +3288,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 +3298,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 +3323,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 +3346,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 +3357,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 +3374,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 +3385,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 +3411,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 +3443,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 +3461,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 +3476,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_CAR (layout);
+ CHECK_FIXNUM_CDR (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 +3607,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 +3762,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 df61847887a..4ddbaa3f268 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-2018 Free Software Foundation,
- Inc.
+
+Copyright (C) 1990, 1993-1994, 2001-2018 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 c451b7ff933..dc568d47f27 100644
--- a/src/w32select.c
+++ b/src/w32select.c
@@ -2,6 +2,9 @@
Copyright (C) 1993-1994, 2001-2018 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;
}
@@ -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 611b7c66e7a..8d189ae32c8 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;
@@ -1476,7 +1476,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;
}
@@ -1979,14 +1979,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;
@@ -2475,31 +2475,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 +2886,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 +3573,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);
@@ -4762,7 +4769,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 +4794,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 +4872,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 +4996,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 +5576,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 +6053,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 +6142,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 +6432,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,
@@ -7258,7 +7265,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));
@@ -7329,14 +7336,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",
@@ -7390,30 +7390,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 e500b730ead..ebdab040fbc 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 884b4cf8bcc..29c9c7a0bd1 100644
--- a/src/w32uniscribe.c
+++ b/src/w32uniscribe.c
@@ -36,6 +36,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "composite.h"
#include "font.h"
#include "w32font.h"
+#include "w32common.h"
struct uniscribe_font_info
{
@@ -460,21 +461,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
@@ -502,7 +503,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.
@@ -879,7 +880,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. */
@@ -1194,11 +1195,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 2d66c093ebd..2e9295f1cd6 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)));
+ list2 (make_fixnum (ew->core.width), make_fixnum (ew->core.height)));
}
static void
@@ -421,10 +421,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 409b01f302e..6cdc52f90e6 100644
--- a/src/window.c
+++ b/src/window.c
@@ -695,7 +695,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 +708,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,7 +720,7 @@ 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",
@@ -734,7 +734,7 @@ The return value is the pixel width of WINDOW at the last time
after that. */)
(Lisp_Object window)
{
- return (make_number
+ return (make_fixnum
(decode_valid_window (window)->pixel_width_before_size_change));
}
@@ -749,7 +749,7 @@ The return value is the pixel height of WINDOW at the last time
after that. */)
(Lisp_Object window)
{
- return (make_number
+ return (make_fixnum
(decode_valid_window (window)->pixel_height_before_size_change));
}
@@ -778,12 +778,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 +815,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 +898,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 +906,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 +918,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 +930,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
@@ -997,7 +997,7 @@ 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)));
}
@@ -1017,7 +1017,7 @@ Note that the returned value includes the column reserved for the
continuation glyph. */)
(Lisp_Object window, Lisp_Object pixelwise)
{
- return make_number (window_body_width (decode_live_window (window),
+ return make_fixnum (window_body_width (decode_live_window (window),
!NILP (pixelwise)));
}
@@ -1027,7 +1027,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 +1036,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 +1045,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 +1054,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 +1063,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 +1072,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 +1080,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 +1104,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 +1117,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 +1383,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);
@@ -1533,9 +1533,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 +1560,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 +1651,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 +1682,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);
@@ -1763,8 +1762,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;
@@ -1789,8 +1788,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;
@@ -1869,8 +1868,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);
@@ -1972,10 +1971,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");
@@ -1985,10 +1984,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");
@@ -2001,19 +2000,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++;
}
@@ -2492,7 +2491,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
@@ -2551,7 +2550,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))
;
@@ -2834,7 +2833,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;
@@ -3443,7 +3442,11 @@ run_window_size_change_functions (Lisp_Object frame)
{
struct frame *f = XFRAME (frame);
struct window *r = XWINDOW (FRAME_ROOT_WINDOW (f));
- Lisp_Object functions = Vwindow_size_change_functions;
+
+ if (NILP (Vrun_hooks)
+ || !(f->can_x_set_window_size)
+ || !(f->after_make_frame))
+ return;
if (FRAME_WINDOW_CONFIGURATION_CHANGED (f)
/* Here we implicitly exclude the possibility that the height of
@@ -3451,11 +3454,44 @@ run_window_size_change_functions (Lisp_Object frame)
of FRAME's root window alone. */
|| window_size_changed (r))
{
- while (CONSP (functions))
+ Lisp_Object globals = Fdefault_value (Qwindow_size_change_functions);
+ Lisp_Object windows = Fwindow_list (frame, Qlambda, Qnil);
+ /* The buffers for which the local hook was already run. */
+ Lisp_Object buffers = Qnil;
+
+ for (; CONSP (windows); windows = XCDR (windows))
{
- if (!EQ (XCAR (functions), Qt))
- safe_call1 (XCAR (functions), frame);
- functions = XCDR (functions);
+ Lisp_Object window = XCAR (windows);
+ Lisp_Object buffer = Fwindow_buffer (window);
+
+ /* Run a buffer-local value only once for that buffer and
+ only if at least one window showing that buffer on FRAME
+ actually changed its size. Note that the function is run
+ with FRAME as its argument and as such oblivious to the
+ window checked below. */
+ if (window_size_changed (XWINDOW (window))
+ && !NILP (Flocal_variable_p (Qwindow_size_change_functions, buffer))
+ && NILP (Fmemq (buffer, buffers)))
+ {
+ Lisp_Object locals
+ = Fbuffer_local_value (Qwindow_size_change_functions, buffer);
+
+ while (CONSP (locals))
+ {
+ if (!EQ (XCAR (locals), Qt))
+ safe_call1 (XCAR (locals), frame);
+ locals = XCDR (locals);
+ }
+
+ buffers = Fcons (buffer, buffers);
+ }
+ }
+
+ while (CONSP (globals))
+ {
+ if (!EQ (XCAR (globals), Qt))
+ safe_call1 (XCAR (globals), frame);
+ globals = XCDR (globals);
}
window_set_before_size_change_sizes (r);
@@ -3494,8 +3530,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;
@@ -3513,7 +3549,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;
@@ -3769,9 +3805,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 ());
@@ -3820,14 +3856,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;
}
@@ -3849,11 +3885,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;
}
@@ -3895,7 +3931,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;
@@ -3908,14 +3944,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);
@@ -3932,14 +3968,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);
@@ -3952,7 +3988,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;
@@ -3966,7 +4002,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)));
}
@@ -3992,7 +4028,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);
@@ -4001,7 +4037,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);
@@ -4076,12 +4112,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;
}
@@ -4149,7 +4185,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;
@@ -4193,10 +4229,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 ();
@@ -4286,7 +4322,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);
@@ -4297,7 +4333,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);
@@ -4369,9 +4405,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));
@@ -4406,19 +4442,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");
}
@@ -4440,9 +4476,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
@@ -4511,10 +4547,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));
@@ -4596,7 +4632,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. */
{
@@ -4727,20 +4763,20 @@ grow_mini_window (struct window *w, int delta, bool pixelwise)
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))
+ root, make_fixnum (- delta), pixelwise ? Qt : Qnil);
+ if (FIXNUMP (height) && window_resize_check (r, false))
{
block_input ();
window_resize_apply (r, false);
if (pixelwise)
{
- pixel_height = min (-XINT (height), INT_MAX - w->pixel_height);
+ pixel_height = min (-XFIXNUM (height), INT_MAX - w->pixel_height);
line_height = pixel_height / FRAME_LINE_HEIGHT (f);
}
else
{
- line_height = min (-XINT (height),
+ line_height = min (-XFIXNUM (height),
((INT_MAX - w->pixel_height)
/ FRAME_LINE_HEIGHT (f)));
pixel_height = line_height * FRAME_LINE_HEIGHT (f);
@@ -4784,9 +4820,9 @@ shrink_mini_window (struct window *w, bool pixelwise)
root = FRAME_ROOT_WINDOW (f);
r = XWINDOW (root);
delta = call3 (Qwindow__resize_root_window_vertically,
- root, make_number (height - unit),
+ root, make_fixnum (height - unit),
pixelwise ? Qt : Qnil);
- if (INTEGERP (delta) && window_resize_check (r, false))
+ if (FIXNUMP (delta) && window_resize_check (r, false))
{
block_input ();
window_resize_apply (r, false);
@@ -4831,13 +4867,13 @@ DEFUN ("resize-mini-window-internal", Fresize_mini_window_internal, Sresize_mini
r = XWINDOW (FRAME_ROOT_WINDOW (f));
height = r->pixel_height + 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
+ && height == XFIXNUM (r->new_pixel) + XFIXNUM (w->new_pixel))
{
block_input ();
window_resize_apply (r, false);
- w->pixel_height = XFASTINT (w->new_pixel);
+ w->pixel_height = XFIXNAT (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;
@@ -5105,7 +5141,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;
}
}
@@ -5115,7 +5151,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;
}
@@ -5124,14 +5160,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);
@@ -5143,7 +5179,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 ();
@@ -5448,7 +5484,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);
}
@@ -5497,8 +5533,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);
@@ -5506,14 +5542,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 ();
@@ -5555,7 +5591,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
@@ -5574,8 +5610,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);
@@ -5587,9 +5623,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;
@@ -5609,11 +5645,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);
}
}
}
@@ -5628,41 +5664,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 (save_excursion_restore, save_excursion_save ());
- Fset_buffer (XWINDOW (selected_window)->contents);
+ record_unwind_protect_excursion ();
+ if (XBUFFER (w->contents) != current_buffer)
+ Fset_buffer (w->contents);
+ }
+
+ if (other_window)
+ {
+ 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);
@@ -5677,7 +5737,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;
}
@@ -5690,17 +5750,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;
@@ -5709,8 +5770,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);
@@ -5725,11 +5785,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);
@@ -5743,49 +5800,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",
@@ -5802,7 +5840,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))
@@ -5827,7 +5865,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))
@@ -5899,22 +5937,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);
@@ -5934,7 +5973,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))))
{
@@ -5957,8 +5997,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
@@ -6135,10 +6175,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,
@@ -6156,10 +6196,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,
@@ -6192,7 +6232,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;
@@ -6206,7 +6246,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;
@@ -6224,12 +6264,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);
}
@@ -6265,7 +6305,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
@@ -6467,14 +6507,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
@@ -6482,7 +6522,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);
}
@@ -6490,32 +6530,32 @@ 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_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->pixel_width_before_size_change
- = XFASTINT (p->pixel_width_before_size_change);
+ = XFIXNAT (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);
+ = XFIXNAT (p->pixel_height_before_size_change);
+ 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);
@@ -6607,7 +6647,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
@@ -6711,7 +6751,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;
@@ -6846,21 +6886,21 @@ 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_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->pixel_width_before_size_change
- = make_number (w->pixel_width_before_size_change);
+ = make_fixnum (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);
+ = make_fixnum (w->pixel_height_before_size_change);
+ 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);
@@ -6868,13 +6908,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;
@@ -7009,7 +7049,7 @@ saved by this function. */)
data->saved_windows = tem;
for (i = 0; i < n_windows; i++)
ASET (tem, i,
- Fmake_vector (make_number (VECSIZE (struct saved_window)), Qnil));
+ Fmake_vector (make_fixnum (VECSIZE (struct saved_window)), Qnil));
save_window_save (FRAME_ROOT_WINDOW (f), XVECTOR (tem), 0);
XSETWINDOW_CONFIGURATION (tem, data);
return (tem);
@@ -7038,7 +7078,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 *
@@ -7101,9 +7141,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);
}
@@ -7182,8 +7222,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);
}
@@ -7305,14 +7345,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));
}
@@ -7334,9 +7374,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;
}
@@ -7356,7 +7396,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))
{
@@ -7553,6 +7593,7 @@ syms_of_window (void)
Fput (Qscroll_down, Qscroll_command, Qt);
DEFSYM (Qwindow_configuration_change_hook, "window-configuration-change-hook");
+ DEFSYM (Qwindow_size_change_functions, "window-size-change-functions");
DEFSYM (Qwindowp, "windowp");
DEFSYM (Qwindow_configuration_p, "window-configuration-p");
DEFSYM (Qwindow_live_p, "window-live-p");
@@ -7849,6 +7890,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 629283ac40c..cc0b6b6667d 100644
--- a/src/window.h
+++ b/src/window.h
@@ -178,6 +178,9 @@ struct window
/* An alist with parameters. */
Lisp_Object window_parameters;
+ /* The help echo text for this window. Qnil if there's none. */
+ Lisp_Object mode_line_help_echo;
+
/* 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. */
@@ -397,7 +400,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)
@@ -415,7 +418,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
@@ -445,6 +448,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;
diff --git a/src/xdisp.c b/src/xdisp.c
index eccefa41cf3..d61d421f08a 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;
@@ -2639,8 +2637,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;
@@ -2811,7 +2808,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. */
@@ -2845,8 +2842,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));
@@ -2871,9 +2868,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));
@@ -2892,9 +2889,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);
@@ -2906,9 +2903,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))
@@ -3191,11 +3188,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);
}
@@ -3580,12 +3577,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)
{
@@ -3602,7 +3599,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)
@@ -3619,10 +3616,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);
@@ -3737,7 +3734,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
@@ -3745,7 +3742,7 @@ 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,
@@ -3758,10 +3755,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;
@@ -3794,7 +3791,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;
@@ -3822,7 +3819,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);
}
@@ -3852,7 +3849,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. */
@@ -4062,7 +4059,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);
}
@@ -4352,7 +4349,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);
@@ -4376,10 +4373,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)
@@ -4455,7 +4452,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);
@@ -4493,7 +4490,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);
}
@@ -4748,7 +4745,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;
@@ -4864,13 +4861,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;
}
@@ -4937,10 +4934,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))
@@ -4965,10 +4962,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);
@@ -4990,9 +4987,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)
{
@@ -5003,7 +5000,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);
@@ -5177,12 +5174,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;
@@ -5491,11 +5488,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);
@@ -5508,7 +5505,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);
@@ -5520,7 +5517,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.
@@ -5822,11 +5819,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;
@@ -5855,19 +5848,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;
@@ -5878,17 +5872,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))
@@ -5902,12 +5897,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;
@@ -5918,16 +5914,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))
@@ -5953,12 +5950,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);
@@ -6388,9 +6384,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))
{
@@ -6466,7 +6462,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;
@@ -6499,7 +6495,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)))
@@ -6987,7 +6983,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;
@@ -7012,7 +7008,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;
@@ -7186,7 +7182,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);
@@ -7201,7 +7197,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;
@@ -7214,7 +7210,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;
@@ -7234,7 +7230,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: */
@@ -7862,7 +7858,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);
}
@@ -7891,7 +7887,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);
}
}
@@ -8191,7 +8187,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
@@ -8387,7 +8383,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
@@ -8573,7 +8569,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);
@@ -10146,8 +10142,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))
@@ -10163,17 +10159,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));
@@ -10253,7 +10249,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));
}
/***********************************************************************
@@ -10421,6 +10417,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);
@@ -10460,12 +10463,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);
@@ -10966,22 +10971,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 = Fmake_vector (make_fixnum (11), Qnil);
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
{
@@ -11003,7 +11008,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)))
{
@@ -11015,14 +11020,14 @@ unwind_with_echo_area_buffer (Lisp_Object vector)
wset_buffer (w, buffer);
set_marker_both (w->pointm, buffer,
- XFASTINT (AREF (vector, 5)),
- XFASTINT (AREF (vector, 6)));
+ XFIXNAT (AREF (vector, 5)),
+ XFIXNAT (AREF (vector, 6)));
set_marker_both (w->old_pointm, buffer,
- XFASTINT (AREF (vector, 7)),
- XFASTINT (AREF (vector, 8)));
+ XFIXNAT (AREF (vector, 7)),
+ XFIXNAT (AREF (vector, 8)));
set_marker_both (w->start, buffer,
- XFASTINT (AREF (vector, 9)),
- XFASTINT (AREF (vector, 10)));
+ XFIXNAT (AREF (vector, 9)),
+ XFIXNAT (AREF (vector, 10)));
}
Vwith_echo_area_save_vector = vector;
@@ -11064,10 +11069,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)
@@ -11143,7 +11156,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. */
@@ -11204,8 +11217,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)
@@ -11274,8 +11287,8 @@ 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;
+ else if (FIXNUMP (Vmax_mini_window_height))
+ max_height = XFIXNUM (Vmax_mini_window_height) * unit;
else
max_height = total_height / 4;
@@ -11513,10 +11526,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)))
@@ -11824,10 +11844,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 = Fmake_vector (make_fixnum (10), Qnil);
- 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);
@@ -11859,8 +11879,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);
@@ -11970,7 +11990,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;
@@ -11987,8 +12007,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;
}
@@ -12057,13 +12077,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))
{
@@ -12104,7 +12117,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
@@ -12142,7 +12155,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
@@ -12427,11 +12440,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);
}
@@ -12480,21 +12493,21 @@ build_desired_tool_bar_string (struct frame *f)
: 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)
@@ -12503,7 +12516,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;
}
@@ -12515,8 +12528,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;
}
@@ -12525,11 +12538,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
@@ -12544,7 +12557,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
@@ -12553,7 +12566,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
}
@@ -12759,7 +12772,7 @@ PIXELWISE non-nil means return the height of the tool bar in pixels. */)
}
#endif
- return make_number (height);
+ return make_fixnum (height);
}
@@ -12830,8 +12843,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))
@@ -12949,11 +12962,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;
}
@@ -13198,9 +13211,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;
}
@@ -13299,7 +13312,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);
@@ -13556,8 +13569,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;
@@ -13759,10 +13772,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);
}
@@ -13928,7 +13941,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. */
@@ -14129,9 +14150,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);
@@ -14325,7 +14346,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;
@@ -14734,6 +14755,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
}
@@ -15094,7 +15121,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))
{
@@ -15115,9 +15142,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
@@ -15178,7 +15205,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))
{
@@ -15189,9 +15216,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. */
@@ -15365,7 +15392,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))
@@ -15496,7 +15523,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
@@ -15579,7 +15606,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));
@@ -15601,19 +15628,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. */
@@ -15975,7 +16029,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. */
@@ -16340,7 +16394,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
@@ -16358,7 +16412,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;
@@ -16914,18 +16968,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,
@@ -16937,7 +16991,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. */
@@ -17032,7 +17086,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;
@@ -17179,7 +17234,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;
@@ -17446,18 +17501,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);
@@ -17475,7 +17530,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)
@@ -19041,9 +19096,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);
@@ -19566,7 +19622,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;
}
@@ -19610,14 +19666,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;
}
@@ -19642,12 +19698,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;
}
@@ -19663,7 +19719,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;
@@ -19729,7 +19785,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);
@@ -20065,7 +20121,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);
@@ -20129,8 +20185,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,
@@ -20141,9 +20197,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);
}
@@ -20212,8 +20268,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
@@ -20467,11 +20523,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)
@@ -20516,7 +20573,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;
@@ -20578,7 +20635,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)
@@ -20594,7 +20651,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;
@@ -20733,10 +20790,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
@@ -21088,9 +21145,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)
@@ -21109,8 +21166,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. */
@@ -21273,13 +21330,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
@@ -21287,7 +21338,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,
@@ -21550,7 +21601,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;
}
@@ -22175,15 +22227,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);
@@ -22439,8 +22491,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;
@@ -22482,7 +22534,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,
@@ -22508,8 +22560,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
@@ -22542,7 +22594,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))
{
@@ -22567,7 +22619,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))
{
@@ -22583,7 +22635,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))
@@ -22604,7 +22656,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];
@@ -22632,7 +22684,7 @@ Value is the new character position of point. */)
else
continue;
w->cursor.vpos = -1;
- return make_number (PT);
+ return make_fixnum (PT);
}
}
}
@@ -22642,7 +22694,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;
@@ -22670,7 +22722,7 @@ Value is the new character position of point. */)
else
continue;
w->cursor.vpos = -1;
- return make_number (PT);
+ return make_fixnum (PT);
}
}
}
@@ -22930,7 +22982,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
}
@@ -22979,8 +23031,8 @@ Emacs UBA implementation, in particular with the test suite. */)
}
else
{
- CHECK_NUMBER_COERCE_MARKER (vpos);
- nrow = XINT (vpos);
+ CHECK_FIXNUM_COERCE_MARKER (vpos);
+ nrow = XFIXNUM (vpos);
}
/* We require up-to-date glyph matrix for this window. */
@@ -23019,7 +23071,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. */
{
@@ -23034,7 +23086,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;
}
@@ -23136,7 +23188,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)
@@ -23343,6 +23395,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. */
@@ -23357,7 +23426,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. */
@@ -23490,6 +23558,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.
@@ -23539,7 +23618,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
@@ -23584,15 +23663,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);
@@ -23663,8 +23751,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);
}
@@ -23727,7 +23815,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);
@@ -23884,9 +23972,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)
{
@@ -24001,23 +24089,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 = XFIXNAT (Flength (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;
@@ -24028,7 +24116,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);
}
@@ -24041,9 +24129,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;
@@ -24080,7 +24169,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;
@@ -24156,8 +24245,7 @@ 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
@@ -24336,7 +24424,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)
@@ -24365,7 +24453,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
@@ -24571,8 +24659,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;
@@ -24777,7 +24865,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 "-";
@@ -24860,7 +24948,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)
{
@@ -25259,13 +25347,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
@@ -25539,7 +25627,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;
@@ -27164,23 +27252,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;
@@ -27814,7 +27902,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;
@@ -27836,10 +27924,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;
@@ -27857,12 +27945,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);
+ else
+ {
+ intmax_t v;
+ if (integer_to_intmax (val, &v))
+ height *= v;
+ }
- return make_number (height);
+ return make_fixnum (height);
}
@@ -28350,8 +28443,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,
@@ -28362,9 +28455,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);
}
@@ -28581,7 +28674,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
@@ -28632,7 +28725,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)
@@ -29068,9 +29161,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;
}
@@ -29082,9 +29175,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;
}
@@ -30707,13 +30800,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;
}
@@ -30725,12 +30818,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);
}
}
@@ -30755,17 +30848,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)
@@ -30817,12 +30910,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 */
@@ -30881,9 +30974,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;
@@ -30973,11 +31063,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
@@ -30994,19 +31085,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;
}
}
@@ -31018,7 +31103,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;
@@ -31028,25 +31112,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);
@@ -31065,18 +31152,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
@@ -31474,7 +31561,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;
@@ -31545,15 +31632,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
@@ -31579,7 +31666,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;
}
@@ -31610,7 +31697,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;
@@ -31618,9 +31705,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
@@ -31638,10 +31725,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;
@@ -31680,7 +31767,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))
{
@@ -31692,7 +31779,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))
{
@@ -31705,7 +31792,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))
@@ -31736,7 +31823,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))
{
@@ -31747,14 +31834,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);
}
}
@@ -32071,7 +32158,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. */
@@ -32731,7 +32818,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.
@@ -32785,7 +32872,7 @@ and is used only on frames for which no explicit name has been set
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.
@@ -32845,9 +32932,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.
@@ -32863,7 +32956,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. */);
@@ -32971,7 +33064,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.
@@ -33110,6 +33203,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.
@@ -33119,7 +33213,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;
@@ -33144,7 +33238,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.
@@ -33167,7 +33261,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,
@@ -33235,7 +33329,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 ('.');
}
{
@@ -33294,9 +33388,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 f1fc6bb632f..50593f6804c 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);
@@ -1389,12 +1390,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;
@@ -1456,7 +1457,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));
+ ndrivers = XFIXNUM (Flength (list));
SAFE_ALLOCA_LISP (drivers, ndrivers);
for (i = 0; i < ndrivers; i++, list = XCDR (list))
drivers[i] = XCAR (list);
@@ -1476,9 +1477,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 +1526,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 +1552,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 +1566,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 +1575,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 +1585,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,
@@ -1683,7 +1684,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 +1908,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 +1943,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 +2007,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 +2043,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 +2066,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 +2076,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 +2098,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 +2113,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 +2159,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 +2174,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 +2186,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 +2320,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 +2476,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 +2545,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 +2569,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,7 +2615,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),
+ global_lface = Fmake_vector (make_fixnum (LFACE_VECTOR_SIZE),
Qunspecified);
ASET (global_lface, 0, Qface);
Vface_new_frame_defaults = Fcons (Fcons (face, global_lface),
@@ -2486,7 +2631,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,7 +2643,7 @@ Value is a vector of face attributes. */)
{
if (NILP (lface))
{
- lface = Fmake_vector (make_number (LFACE_VECTOR_SIZE),
+ lface = Fmake_vector (make_fixnum (LFACE_VECTOR_SIZE),
Qunspecified);
ASET (lface, 0, Qface);
fset_face_alist (f, Fcons (Fcons (face, lface), f->face_alist));
@@ -2647,7 +2792,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 +2862,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 +2871,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 +2971,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 +2985,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 +3001,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 +3029,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 +3504,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 +3537,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 +3698,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 +3846,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 +3919,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 +3928,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 +4256,15 @@ 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)));
+ list3 (make_fixnum (cdef1.red),
+ make_fixnum (cdef1.green),
+ make_fixnum (cdef1.blue)),
+ list3 (make_fixnum (cdef2.red),
+ make_fixnum (cdef2.green),
+ make_fixnum (cdef2.blue)));
}
@@ -4432,10 +4577,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 +4595,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 +4609,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 +4634,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 +4652,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 +4685,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 +4696,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 +4736,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 +4750,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);
}
@@ -4627,9 +4776,10 @@ DEFUN ("face-attributes-as-vector", Fface_attributes_as_vector,
(Lisp_Object plist)
{
Lisp_Object lface;
- lface = Fmake_vector (make_number (LFACE_VECTOR_SIZE),
+ lface = Fmake_vector (make_fixnum (LFACE_VECTOR_SIZE),
Qunspecified);
- merge_face_ref (XFRAME (selected_frame), plist, XVECTOR (lface)->contents,
+ merge_face_ref (NULL, XFRAME (selected_frame),
+ plist, XVECTOR (lface)->contents,
true, 0);
return lface;
}
@@ -4713,7 +4863,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 +4886,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 +5134,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 +5391,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 +5503,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 +5675,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 +5708,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 +5875,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 +6018,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 +6074,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;
@@ -5947,7 +6097,7 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos,
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);
}
@@ -5965,7 +6115,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);
@@ -5985,7 +6135,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]);
@@ -6003,7 +6153,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);
@@ -6053,8 +6203,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;
@@ -6064,12 +6214,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;
@@ -6126,8 +6276,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;
@@ -6148,7 +6298,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. */
@@ -6158,7 +6308,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.
@@ -6172,9 +6322,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;
@@ -6189,7 +6340,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);
}
@@ -6198,7 +6349,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
@@ -6209,7 +6360,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,
@@ -6255,7 +6406,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);
}
}
@@ -6320,13 +6471,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);
@@ -6420,6 +6571,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. */
@@ -6495,6 +6651,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;
@@ -6525,7 +6687,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.
@@ -6538,7 +6705,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
@@ -6558,13 +6725,32 @@ 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. */);
diff --git a/src/xfns.c b/src/xfns.c
index 1381fee57ee..c4cf59d9b27 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 = Fmake_vector (make_fixnum (n_monitors), Qnil);
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 = Fmake_vector (make_fixnum (n_monitors), Qnil);
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));
@@ -5078,8 +5099,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;
@@ -5164,43 +5185,43 @@ 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 list4 (make_fixnum (outer_left), make_fixnum (outer_top),
+ make_fixnum (outer_right), make_fixnum (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 list4 (make_fixnum (native_left), make_fixnum (native_top),
+ make_fixnum (native_right), make_fixnum (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 list4 (make_fixnum (inner_left), make_fixnum (inner_top),
+ make_fixnum (inner_right), make_fixnum (inner_bottom));
else
return
listn (CONSTYPE_HEAP, 11,
Fcons (Qouter_position,
- Fcons (make_number (outer_left),
- make_number (outer_top))),
+ 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 +5421,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 +5450,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 +5470,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 +5673,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 +5716,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 +5768,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 +5947,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 +6066,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 +6080,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 +6174,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 +6251,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 +6268,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 +6439,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 +6457,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 +6478,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 +6504,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 +6560,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 +6585,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;
+
+ 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);
- was_open = 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 +6726,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 +6738,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 +6747,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 +6780,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 +6812,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 +6829,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 +6837,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 +6869,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 +6879,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 +6900,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 +6916,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 +6950,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 +7058,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 +7227,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 ();
@@ -7708,7 +7791,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 +7805,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 +7921,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 +7928,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 c2e416bc058..73caa705890 100644
--- a/src/xfont.c
+++ b/src/xfont.c
@@ -190,7 +190,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 +213,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 +376,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 +672,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 +811,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
@@ -1101,6 +1101,6 @@ 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 = Fmake_vector (make_fixnum (8), Qnil);
register_font_driver (&xfont_driver, NULL);
}
diff --git a/src/xftfont.c b/src/xftfont.c
index 5ef90a014ea..85df0d857a2 100644
--- a/src/xftfont.c
+++ b/src/xftfont.c
@@ -219,24 +219,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);
@@ -271,7 +271,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 ();
@@ -289,16 +289,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). */
@@ -307,7 +307,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 ();
@@ -352,8 +352,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])
@@ -412,7 +412,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;
diff --git a/src/xmenu.c b/src/xmenu.c
index d285e568b03..10e882af439 100644
--- a/src/xmenu.c
+++ b/src/xmenu.c
@@ -3,6 +3,10 @@
Copyright (C) 1986, 1988, 1993-1994, 1996, 1999-2018 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
@@ -278,12 +279,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 +1173,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 +1487,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 +1656,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 +2043,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 +2305,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 +2375,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,7 +2394,8 @@ 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;
diff --git a/src/xml.c b/src/xml.c
index 8bf5a3d122b..e85891d2a29 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 836c147947a..4abf1ad84ed 100644
--- a/src/xrdb.c
+++ b/src/xrdb.c
@@ -474,13 +474,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 ecf59df2943..a87784fb4b1 100644
--- a/src/xselect.c
+++ b/src/xselect.c
@@ -321,7 +321,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 +387,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
@@ -1536,17 +1536,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 +1574,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 +1604,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 +1613,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 +1638,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 +1646,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 +1661,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 +1669,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 +1686,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 +1741,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 +1749,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 +1804,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 +1825,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 +1841,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 +2087,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 +2117,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 +2299,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 +2474,11 @@ x_handle_dnd_message (struct frame *f, const XClientMessageEvent *event,
data = (unsigned char *) idata;
}
- vec = Fmake_vector (make_number (4), Qnil);
+ vec = Fmake_vector (make_fixnum (4), Qnil);
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 +2489,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 +2547,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))
{
diff --git a/src/xsettings.c b/src/xsettings.c
index 81c8f9b2919..0b67db30746 100644
--- a/src/xsettings.c
+++ b/src/xsettings.c
@@ -393,7 +393,7 @@ parse_settings (unsigned char *prop,
struct xsettings *settings)
{
Lisp_Object byteorder = Fbyteorder ();
- int my_bo = XFASTINT (byteorder) == 'B' ? MSBFirst : LSBFirst;
+ int my_bo = XFIXNAT (byteorder) == 'B' ? MSBFirst : LSBFirst;
int that_bo = prop[0];
CARD32 n_settings;
int bytes_parsed = 0;
diff --git a/src/xterm.c b/src/xterm.c
index b2d1b5c1980..f8ea787e8df 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -544,10 +544,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 ();
@@ -606,7 +604,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)
{
@@ -919,8 +917,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;
@@ -991,12 +989,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))
@@ -1978,7 +1971,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)
@@ -3107,14 +3106,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;
@@ -3699,33 +3698,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. */
@@ -4245,6 +4264,7 @@ 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);
@@ -4255,8 +4275,8 @@ x_scroll_run (struct window *w, struct run *run)
cr = FRAME_CR_CONTEXT (f);
cairo_save (cr);
- cairo_set_source_surface (cr, s, 0, to_y);
- cairo_rectangle (cr, x, to_y, width, height);
+ cairo_set_source_surface (cr, s, wx, to_y);
+ cairo_rectangle (cr, wx, to_y, width, height);
cairo_fill (cr);
cairo_restore (cr);
cairo_surface_destroy (s);
@@ -4365,16 +4385,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);
}
@@ -4814,15 +4824,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)
@@ -4844,15 +4854,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)
@@ -5501,8 +5511,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;
}
@@ -5536,8 +5546,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;
}
@@ -8099,7 +8109,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);
}
@@ -8191,7 +8201,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))
@@ -8348,15 +8358,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;
}
@@ -8741,7 +8751,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)
@@ -9812,7 +9822,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);
@@ -9843,7 +9853,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 */
}
@@ -9925,7 +9935,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. */
@@ -9979,11 +9988,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,
@@ -10248,8 +10253,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)
@@ -10290,8 +10295,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)
@@ -10495,16 +10500,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))));
}
@@ -10632,7 +10637,7 @@ 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;
@@ -11133,8 +11138,8 @@ 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))));
+ list2 (make_fixnum (old_height),
+ make_fixnum (pixelheight + FRAME_MENUBAR_HEIGHT (f))));
XResizeWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
old_width, pixelheight + FRAME_MENUBAR_HEIGHT (f));
@@ -11143,7 +11148,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)));
+ list2 (make_fixnum (old_width), make_fixnum (pixelwidth)));
XResizeWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
pixelwidth, old_height);
@@ -11153,10 +11158,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)
+ list3 (make_fixnum (pixelwidth + FRAME_TOOLBAR_WIDTH (f)),
+ make_fixnum (pixelheight + FRAME_TOOLBAR_HEIGHT (f)
+ FRAME_MENUBAR_HEIGHT (f)),
- make_number (FRAME_MENUBAR_HEIGHT (f))));
+ make_fixnum (FRAME_MENUBAR_HEIGHT (f))));
XResizeWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
pixelwidth, pixelheight + FRAME_MENUBAR_HEIGHT (f));
@@ -11221,7 +11226,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;
@@ -11340,9 +11345,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));
}
}
@@ -13268,11 +13273,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,
@@ -13283,6 +13289,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,
@@ -13316,15 +13323,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 f73dd0e25ab..2ea8a93f8c1 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. */
@@ -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 530d1af707a..4739993e729 100644
--- a/src/xwidget.c
+++ b/src/xwidget.c
@@ -79,16 +79,16 @@ Returns the newly constructed xwidget, or nil if construction fails. */)
Lisp_Object arguments, Lisp_Object buffer)
{
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);
@@ -294,7 +294,7 @@ 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))
@@ -362,7 +362,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;
@@ -370,6 +370,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);
@@ -381,19 +386,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);
}
@@ -585,22 +590,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;
@@ -680,6 +683,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;
}
@@ -687,8 +691,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 ();
@@ -703,12 +706,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 = Fmake_vector (make_fixnum (32), Qnil);
+
+ /* 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)
{
@@ -717,36 +741,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;
@@ -789,8 +811,8 @@ 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 list2 (make_fixnum (requisition.width),
+ make_fixnum (requisition.height));
}
DEFUN ("xwidgetp",
@@ -821,7 +843,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",
@@ -833,9 +855,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",
@@ -1077,7 +1099,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 *
@@ -1200,6 +1222,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 8267012d5d6..c203d4f60cd 100644
--- a/src/xwidget.h
+++ b/src/xwidget.h
@@ -47,6 +47,9 @@ struct xwidget
/* A title used for button labels, for instance. */
Lisp_Object title;
+ /* Vector of currently executing scripts with callbacks. */
+ Lisp_Object script_callbacks;
+
/* Here ends the Lisp part. "height" is the marker field. */
int height;
@@ -58,7 +61,7 @@ struct xwidget
/* Kill silently if Emacs is exited. */
bool_bf kill_without_query : 1;
-};
+} GCALIGNED_STRUCT;
struct xwidget_view
{
@@ -85,13 +88,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 +102,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 c0a073338ef..adb316c3d9c 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,18 @@ else
maybe_exclude_module_tests := -name emacs-module-tests.el -prune -o
endif
+## 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})))
+
## .log files may be in a different directory for out of source builds
LOGFILES := $(patsubst %.el,%.log, \
$(patsubst $(srcdir)/%,%,$(ELFILES)))
@@ -239,6 +254,7 @@ MODULE_CFLAGS = -I../src $(FPIC_CFLAGS) $(PROFILING_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
+ $(AM_V_at)${MKDIR_P} $(dir $@)
$(AM_V_CCLD)$(CC) -shared $(CPPFLAGS) $(MODULE_CFLAGS) $(LDFLAGS) \
-o $@ $<
endif
@@ -283,14 +299,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 +321,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 e473248c9e0..83ee2614004 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
diff --git a/test/data/emacs-module/mod-test.c b/test/data/emacs-module/mod-test.c
index 4c783faeeae..a9b459b4cc4 100644
--- a/test/data/emacs-module/mod-test.c
+++ b/test/data/emacs-module/mod-test.c
@@ -317,11 +317,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. */
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 1187700b84d..facf097815e 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"))
@@ -230,6 +236,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/auth-source-pass-tests.el b/test/lisp/auth-source-pass-tests.el
index 0e441ac01b1..b30419f44b0 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 90caac8e4a2..ca8a3eb78f0 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 8f375b63a69..9710600f169 100644
--- a/test/lisp/autorevert-tests.el
+++ b/test/lisp/autorevert-tests.el
@@ -161,12 +161,13 @@ This expects `auto-revert--messages' to be bound by
:tags '(:expensive-test)
(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 +175,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 +197,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 +208,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/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el
index 2fecabcd75b..617e8869897 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 3a956a56621..ca71ff71b7a 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 159294f8162..015fbaccf4d 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 eb8dec74d65..364975317f2 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 64898888ba8..eab2709cea9 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-tests.el b/test/lisp/custom-tests.el
new file mode 100644
index 00000000000..96887f8f5fe
--- /dev/null
+++ b/test/lisp/custom-tests.el
@@ -0,0 +1,87 @@
+;;; custom-tests.el --- tests for custom.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2018 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)))))
+
+;;; custom-tests.el ends here
diff --git a/test/lisp/dired-aux-tests.el b/test/lisp/dired-aux-tests.el
index f7935cd38b9..daf60f760e0 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 bb0e1bc3880..49ae4bc0400 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 8a13c8c7b2c..7e94dfa496c 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
@@ -375,6 +391,16 @@ baz\"\""
:bindings '((electric-pair-skip-whitespace . chomp))
:test-in-comments nil)
+
+;; A test failure introduced by some changes in CC mode. Hopefully CC
+;; mode will sort this out eventually, using some new e-p-m machinery.
+;; 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
@@ -617,6 +643,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 +670,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 +691,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 +712,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 +733,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 +754,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
diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el
new file mode 100644
index 00000000000..edd45c770c5
--- /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 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 8de7818bdbf..26bd3ff08a8 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 f93c3bdc40f..ba625490960 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..d14847ce45e
--- /dev/null
+++ b/test/lisp/emacs-lisp/cconv-tests.el
@@ -0,0 +1,40 @@
+;;; cconv-tests.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2018 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 26bc6188738..f100e8c6c5f 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."))
@@ -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 f0bde7af397..6e9fb44b4b0 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..9d5feee396a
--- /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-2018 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 404d323d0c1..a469b5526c0 100644
--- a/test/lisp/emacs-lisp/cl-print-tests.el
+++ b/test/lisp/emacs-lisp/cl-print-tests.el
@@ -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 e86c2f1c1e7..97dead057a9 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 85f6bd47db2..7880aaf95bc 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 c6da9e15fa3..52014aea01e 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 eae69c89eb2..f5c25e64912 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 5ba094c0072..74c76609b87 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 e92b4342748..1fe5b79ef36 100644
--- a/test/lisp/emacs-lisp/ert-tests.el
+++ b/test/lisp/emacs-lisp/ert-tests.el
@@ -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 ()
@@ -496,48 +496,6 @@ This macro is used to test if macroexpansion in `should' works."
;;; 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..7d1a128694c
--- /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-2018 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..0558bd12e5f
--- /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-2018 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..f910a1d732a
--- /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-2018 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..8df38bcc8a9
--- /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-2018 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 9bf8413e159..bca3efa550b 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/package-tests.el b/test/lisp/emacs-lisp/package-tests.el
index 62fba58919f..f08bc92ff2a 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.
@@ -414,7 +415,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,7 +429,7 @@ 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)))
@@ -467,15 +468,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 +493,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 +515,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/['’]."
diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el
index c9618f3c37f..81467bab2d4 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 cacdef9cb42..69ef5b596be 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 be48aa443b6..6c76421d38b 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..5ea6b5372e1
--- /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 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 4cc19f90d6c..b24e8d1fdb7 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 65e5dc9bde9..c5971ee7687 100644
--- a/test/lisp/emacs-lisp/timer-tests.el
+++ b/test/lisp/emacs-lisp/timer-tests.el
@@ -39,4 +39,9 @@
(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))))
+
;;; timer-tests.el ends here
diff --git a/test/lisp/epg-tests.el b/test/lisp/epg-tests.el
index 0fe15017dd0..c1e98a6935e 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,12 +71,14 @@
(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
@@ -85,7 +107,6 @@
(delete-directory epg-tests-home-directory t)))))
(ert-deftest epg-decrypt-1 ()
- (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase))
(with-epg-tests (:require-passphrase t)
(should (equal "test"
(epg-decrypt-string epg-tests-context "\
@@ -97,14 +118,12 @@ jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA==
-----END PGP MESSAGE-----")))))
(ert-deftest epg-roundtrip-1 ()
- (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase))
(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)
@@ -115,7 +134,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)
@@ -129,7 +147,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)
@@ -145,7 +162,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)
@@ -160,7 +176,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 1ce832f1dcc..c5c9eac3249 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 ."
diff --git a/test/lisp/eshell/esh-opt-tests.el b/test/lisp/eshell/esh-opt-tests.el
new file mode 100644
index 00000000000..13b522b389e
--- /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 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/filenotify-tests.el b/test/lisp/filenotify-tests.el
index feb1f19cb5c..612ea8cd7f4 100644
--- a/test/lisp/filenotify-tests.el
+++ b/test/lisp/filenotify-tests.el
@@ -57,9 +57,10 @@
'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.")
@@ -566,35 +567,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,163 +627,191 @@ 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))
- (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 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))
- (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))
-
- ;; 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))
- (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))
-
- ;; 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 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))
+ (t '(created changed 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)
+ (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 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))
+ (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)
+
+ ;; 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))
+ (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))
@@ -849,15 +885,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)
@@ -867,7 +903,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))
@@ -1013,7 +1052,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))
@@ -1033,7 +1072,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)))
@@ -1090,14 +1129,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))
diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el
index d51f8bb9f80..3b192ee8727 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,766 @@ 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--insert-directory-wildcard-in-dir-p ()
(let ((alist (list (cons "/home/user/*/.txt" (cons "/home/user/" "*/.txt"))
(cons "/home/user/.txt" nil)
@@ -373,7 +1157,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/gnus/gnus-tests.el b/test/lisp/gnus/gnus-tests.el
index e149dccc258..fe1fc184147 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 ec1f2470204..7fa0fe9b0e9 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 5fd788c03fc..7e726eb7e8b 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 40d76ee9de5..4c639b03dca 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 908c888af54..002415cadfe 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 7532befae0a..1fcbb385791 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..7dd7224726b
--- /dev/null
+++ b/test/lisp/international/ccl-tests.el
@@ -0,0 +1,229 @@
+;; Copyright (C) 2018 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/json-tests.el b/test/lisp/json-tests.el
index ea562e8b134..84039c09cee 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..1a84c30e33d
--- /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 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 d16ffa3acdb..91e8b0b7011 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/mouse-tests.el b/test/lisp/mouse-tests.el
index 639ccf78a9f..909ba64a724 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 c5bfe439d17..326e2416495 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/secrets-tests.el b/test/lisp/net/secrets-tests.el
new file mode 100644
index 00000000000..de3ce731bec
--- /dev/null
+++ b/test/lisp/net/secrets-tests.el
@@ -0,0 +1,275 @@
+;;; secrets-tests.el --- Tests of Secret Service API
+
+;; Copyright (C) 2018 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))
+
+ ;; There must be at least the collections "Login" and "session".
+ (should (or (member "Login" (secrets-list-collections))
+ (member "login" (secrets-list-collections))))
+ (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"))
+ ;; There shall be items in the "Login" collection.
+ (should (or (secrets-list-items "Login")
+ (secrets-list-items "login")))
+
+ ;; 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..e7597864c6e
--- /dev/null
+++ b/test/lisp/net/tramp-archive-tests.el
@@ -0,0 +1,948 @@
+;;; tramp-archive-tests.el --- Tests of file archive access -*- lexical-binding:t -*-
+
+;; Copyright (C) 2017-2018 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)
+
+(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))))))))
+
+ ;; Cleanup.
+ (tramp-archive-cleanup-hash))))
+
+(ert-deftest tramp-archive-test18-file-attributes ()
+ "Check `file-attributes'.
+This tests also `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))
+ attr)
+ (unwind-protect
+ (progn
+ (should (file-exists-p tmp-name1))
+ (should (file-readable-p tmp-name1))
+ (should (file-regular-p tmp-name1))
+
+ ;; 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)))
+
+ ;; 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-test38-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-test41-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-test44-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-test44-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 8f810818af1..523c7afada8 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-test42-asynchronous-requests'
;; might be too heavy. Setting $REMOTE_PARALLEL_PROCESSES to a proper
;; value less than 10 could help.
@@ -52,14 +52,23 @@
(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-copy-size-limit)
(defvar tramp-persistency-file-name)
(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 +93,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 +105,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,6 +132,13 @@ 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.
@@ -179,6 +191,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)
@@ -229,6 +251,9 @@ 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:"))
@@ -242,6 +267,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))
@@ -365,7 +396,10 @@ 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)
;; Expand `tramp-default-user' and `tramp-default-host'.
(should (string-equal
(file-remote-p "/method::")
@@ -715,7 +749,55 @@ 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:"
+ "-" "user1" "host1"
+ "-" "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:"
+ "method1" "host1"
+ "method2" "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:"
+ "method1" "user1"
+ "method2" "user2"
+ "method3" "user3" "host3")))))
(ert-deftest tramp-test02-file-name-dissect-simplified ()
"Check simplified file name components."
@@ -723,6 +805,8 @@ 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
(syntax tramp-syntax))
(unwind-protect
(progn
@@ -970,7 +1054,39 @@ 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:"
+ "host1"
+ "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:"
+ "user1"
+ "user2"
+ "user3" "host3"))))
;; Exit.
(tramp-change-syntax syntax))))
@@ -981,6 +1097,9 @@ 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
(syntax tramp-syntax))
(unwind-protect
(progn
@@ -1538,7 +1657,55 @@ 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]"
+ "user1" "host1"
+ "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]"
+ "method1" "host1"
+ "method2" "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]"
+ "method1" "user1"
+ "method2" "user2"
+ "method3" "user3" "host3"))))
;; Exit.
(tramp-change-syntax syntax))))
@@ -1567,41 +1734,103 @@ handled properly. BODY shall not contain a timeout."
;; 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
+ (if (tramp-method-out-of-band-p vec 0) 'file-error 'user-error)))))
+
+(ert-deftest tramp-test03-file-name-method-rules ()
+ "Check file name rules for some methods."
+ (skip-unless (tramp--test-enabled))
+
+ ;; 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"))
(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"))
(let (process-environment)
(should
@@ -1661,6 +1890,7 @@ handled properly. BODY shall not contain a timeout."
;; 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)
(tramp-smb-file-name-p tramp-test-temporary-file-directory))
@@ -1709,6 +1939,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/") ""))
@@ -1743,7 +1981,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 +1993,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 +2025,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 +2053,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 +2143,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 +2168,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 +2180,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 +2203,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 +2228,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 +2255,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 +2283,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 +2302,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 +2318,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 +2342,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 +2369,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 +2392,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 +2412,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 +2478,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 +2511,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 +2575,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))
@@ -2383,7 +2636,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
@@ -2500,7 +2753,7 @@ This tests also `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.
@@ -2607,7 +2860,7 @@ This tests also `file-readable-p', `file-regular-p' and
"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,16 +2882,17 @@ 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)))))
(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)))))
(setq attr (directory-files-and-attributes tmp-name2 nil "^b"))
@@ -2653,7 +2907,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'."
(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 ((tmp-name (tramp--test-make-temp-name nil quoted)))
(unwind-protect
(progn
@@ -2673,15 +2927,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.
@@ -2705,14 +2971,16 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(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
@@ -2747,9 +3015,10 @@ 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
@@ -2771,38 +3040,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
@@ -2882,12 +3153,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 +3173,41 @@ 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)))
- (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 +3216,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 +3241,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 +3250,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 (equal (visited-file-modtime) '(0 1 0 0)))))
+ (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 (= 1 (float-time (visited-file-modtime))))))
;; Cleanup.
(ignore-errors (delete-file tmp-name))))))
@@ -2982,7 +3272,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 +3350,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))
@@ -3208,7 +3498,7 @@ 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)
(let ;; This is needed for the `simplified' syntax.
@@ -3259,7 +3549,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)))
@@ -3321,7 +3611,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 +3636,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)
@@ -3392,7 +3682,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(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-name (tramp--test-make-temp-name nil quoted))
kill-buffer-query-functions proc)
@@ -3484,7 +3774,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(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 ((tmp-name (tramp--test-make-temp-name nil quoted))
(default-directory tramp-test-temporary-file-directory)
;; Suppress nasty messages.
@@ -3740,13 +4030,55 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(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-test34-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)))))
+
+(ert-deftest tramp-test35-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 +4142,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-test36-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)))
@@ -3901,11 +4233,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-test37-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.
@@ -4012,7 +4344,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-test38-make-nearby-temp-file ()
"Check `make-nearby-temp-file' and `temporary-file-directory'."
(skip-unless (tramp--test-enabled))
;; Since Emacs 26.1.
@@ -4104,6 +4436,11 @@ 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-rsync-p ()
"Check, whether the rsync method is used.
This does not support special file names."
@@ -4142,7 +4479,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
@@ -4275,9 +4612,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 +4637,55 @@ 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-test39-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-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}")))
+ ;; 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-test39-special-characters ()
"Check special characters in file names."
(skip-unless (tramp--test-enabled))
(skip-unless (not (tramp--test-rsync-p)))
@@ -4350,7 +4693,7 @@ This requires restrictions of file name syntax."
(tramp--test-special-characters))
-(ert-deftest tramp-test38-special-characters-with-stat ()
+(ert-deftest tramp-test39-special-characters-with-stat ()
"Check special characters in file names.
Use the `stat' command."
:tags '(:expensive-test)
@@ -4368,7 +4711,7 @@ Use the `stat' command."
tramp-connection-properties)))
(tramp--test-special-characters)))
-(ert-deftest tramp-test38-special-characters-with-perl ()
+(ert-deftest tramp-test39-special-characters-with-perl ()
"Check special characters in file names.
Use the `perl' command."
:tags '(:expensive-test)
@@ -4389,7 +4732,7 @@ Use the `perl' command."
tramp-connection-properties)))
(tramp--test-special-characters)))
-(ert-deftest tramp-test38-special-characters-with-ls ()
+(ert-deftest tramp-test39-special-characters-with-ls ()
"Check special characters in file names.
Use the `ls' command."
:tags '(:expensive-test)
@@ -4412,7 +4755,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-test40-utf8*'."
(let* ((utf8 (if (and (eq system-type 'darwin)
(memq 'utf-8-hfs (coding-system-list)))
'utf-8-hfs 'utf-8))
@@ -4420,14 +4763,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-test40-utf8 ()
"Check UTF8 encoding in file names and file contents."
(skip-unless (tramp--test-enabled))
(skip-unless (not (tramp--test-docker-p)))
@@ -4437,7 +4800,7 @@ Use the `ls' command."
(tramp--test-utf8))
-(ert-deftest tramp-test39-utf8-with-stat ()
+(ert-deftest tramp-test40-utf8-with-stat ()
"Check UTF8 encoding in file names and file contents.
Use the `stat' command."
:tags '(:expensive-test)
@@ -4457,7 +4820,7 @@ Use the `stat' command."
tramp-connection-properties)))
(tramp--test-utf8)))
-(ert-deftest tramp-test39-utf8-with-perl ()
+(ert-deftest tramp-test40-utf8-with-perl ()
"Check UTF8 encoding in file names and file contents.
Use the `perl' command."
:tags '(:expensive-test)
@@ -4480,7 +4843,7 @@ Use the `perl' command."
tramp-connection-properties)))
(tramp--test-utf8)))
-(ert-deftest tramp-test39-utf8-with-ls ()
+(ert-deftest tramp-test40-utf8-with-ls ()
"Check UTF8 encoding in file names and file contents.
Use the `ls' command."
:tags '(:expensive-test)
@@ -4503,7 +4866,7 @@ Use the `ls' command."
tramp-connection-properties)))
(tramp--test-utf8)))
-(ert-deftest tramp-test40-file-system-info ()
+(ert-deftest tramp-test41-file-system-info ()
"Check that `file-system-info' returns proper values."
(skip-unless (tramp--test-enabled))
;; Since Emacs 27.1.
@@ -4525,18 +4888,21 @@ Use the `ls' command."
(ert-fail (format "`%s' timed out" (ert-test-name (ert-running-test)))))
;; This test is inspired by Bug#16928.
-(ert-deftest tramp-test41-asynchronous-requests ()
+(ert-deftest tramp-test42-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)
+ :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.
+ ;; This clearly doesn't work though, because the test not
+ ;; infrequently hangs for hours until killed by the infrastructure.
(with-timeout (300 (tramp--test-timeout-handler))
(define-key special-event-map [sigusr1] 'tramp--test-timeout-handler)
+ (tramp--test-instrument-test-case (if (getenv "EMACS_HYDRA_CI") 10 0)
(let* (;; For the watchdog.
(default-directory (expand-file-name temporary-file-directory))
(watchdog
@@ -4555,10 +4921,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
@@ -4588,11 +4955,16 @@ process sentinels. They shall not disturb each other."
(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.
(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))
+ (tramp--test-message
+ "Stop timer %s %s" file (current-time-string)))))))
;; Create temporary buffers. The number of buffers
;; corresponds to the number of processes; it could be
@@ -4619,6 +4991,8 @@ 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))
@@ -4628,6 +5002,8 @@ process sentinels. They shall not disturb each other."
(set-process-sentinel
proc
(lambda (proc _state)
+ (tramp--test-message
+ "Process sentinel %s %s" proc (current-time-string))
(dired-uncache (process-get proc 'foo))
(should-not (file-attributes (process-get proc 'foo)))))))
@@ -4641,6 +5017,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)
@@ -4651,11 +5029,15 @@ process sentinels. They shall not disturb each other."
(accept-process-output proc 0.1 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,6 +5045,7 @@ 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)))))
@@ -4677,11 +5060,13 @@ process sentinels. They shall not disturb each other."
(ignore-errors (delete-process (get-buffer-process buf)))
(ignore-errors (kill-buffer buf)))
(ignore-errors (cancel-timer timer))
- (ignore-errors (delete-directory tmp-name 'recursive))))))
+ (ignore-errors (delete-directory tmp-name 'recursive)))))))
;; This test is inspired by Bug#29163.
-(ert-deftest tramp-test42-auto-load ()
+(ert-deftest tramp-test43-auto-load ()
"Check that Tramp autoloads properly."
+ (skip-unless (tramp--test-enabled))
+
(let ((default-directory (expand-file-name temporary-file-directory))
(code
(format
@@ -4698,7 +5083,7 @@ process sentinels. They shall not disturb each other."
(mapconcat 'shell-quote-argument load-path " -L ")
(shell-quote-argument code)))))))
-(ert-deftest tramp-test42-delay-load ()
+(ert-deftest tramp-test43-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.
@@ -4731,7 +5116,7 @@ process sentinels. They shall not disturb each other."
(mapconcat 'shell-quote-argument load-path " -L ")
(shell-quote-argument (format code tm)))))))))
-(ert-deftest tramp-test42-recursive-load ()
+(ert-deftest tramp-test43-recursive-load ()
"Check that Tramp does not fail due to recursive load."
(skip-unless (tramp--test-enabled))
@@ -4755,7 +5140,7 @@ process sentinels. They shall not disturb each other."
(mapconcat 'shell-quote-argument load-path " -L ")
(shell-quote-argument code))))))))
-(ert-deftest tramp-test42-remote-load-path ()
+(ert-deftest tramp-test43-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.
@@ -4783,7 +5168,7 @@ process sentinels. They shall not disturb each other."
(mapconcat 'shell-quote-argument load-path " -L ")
(shell-quote-argument code)))))))
-(ert-deftest tramp-test43-unload ()
+(ert-deftest tramp-test44-unload ()
"Check that Tramp and its subpackages unload completely.
Since it unloads Tramp, it shall be the last test to run."
:tags '(:expensive-test)
@@ -4792,42 +5177,52 @@ 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]."
@@ -4844,11 +5239,14 @@ Since it unloads Tramp, it shall be the last test to run."
;; * file-name-case-insensitive-p
;; * 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'.
+;; * Investigate, why `tramp-test11-copy-file' and `tramp-test12-rename-file'
+;; do not work properly for `nextcloud'.
;; * 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'.
+;; * Fix Bug#16928 in `tramp-test42-asynchronous-requests'.
(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 4fa8de10c6b..5b824841d41 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/flymake-tests.el b/test/lisp/progmodes/flymake-tests.el
index 5118e302405..bba1f12e691 100644
--- a/test/lisp/progmodes/flymake-tests.el
+++ b/test/lisp/progmodes/flymake-tests.el
@@ -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,11 +130,14 @@ 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 ()
diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el
index 4955da02a25..0b9f8484c10 100644
--- a/test/lisp/progmodes/python-tests.el
+++ b/test/lisp/progmodes/python-tests.el
@@ -2004,6 +2004,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
"
@@ -5352,6 +5358,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 b16698fba11..72d83affaef 100644
--- a/test/lisp/progmodes/ruby-mode-tests.el
+++ b/test/lisp/progmodes/ruby-mode-tests.el
@@ -705,13 +705,15 @@ 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)))))
diff --git a/test/lisp/progmodes/tcl-tests.el b/test/lisp/progmodes/tcl-tests.el
new file mode 100644
index 00000000000..061488636d0
--- /dev/null
+++ b/test/lisp/progmodes/tcl-tests.el
@@ -0,0 +1,77 @@
+;;; tcl-tests.el --- Test suite for tcl-mode
+
+;; Copyright (C) 2018 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/ses-tests.el b/test/lisp/ses-tests.el
index c9966e237fa..c773c9b396f 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/simple-tests.el b/test/lisp/simple-tests.el
index d13b8599c65..417aa648edf 100644
--- a/test/lisp/simple-tests.el
+++ b/test/lisp/simple-tests.el
@@ -448,6 +448,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 +500,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 +521,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 430d719037f..f218a7663e0 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,43 @@ 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--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")))))
+
+(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."
diff --git a/test/lisp/term-tests.el b/test/lisp/term-tests.el
index 7fd8d1293dc..ebf48d50a84 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/css-mode-tests.el b/test/lisp/textmodes/css-mode-tests.el
index d4fb348326a..bfae1bf2f75 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..a2bcde44b99
--- /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-2018 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 7ca6e676c64..6c0070ccb1e 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 1d80519fe74..aa29924ac1a 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..0d57d38779f
--- /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 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..5822e16a88a
--- /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 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 ee97d97dd34..2e2875a196b 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 1e35f9f7cd3..7900e41b257 100644
--- a/test/lisp/vc/diff-mode-tests.el
+++ b/test/lisp/vc/diff-mode-tests.el
@@ -182,7 +182,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))
diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el
index 7fdf0626cd7..cd774d301df 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/xdg-tests.el b/test/lisp/xdg-tests.el
index 40f5802854d..ad5e4a48a26 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/cedet/semantic-ia-utest.el b/test/manual/cedet/semantic-ia-utest.el
index 7aae701cc01..938d152925e 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 c2bc0e1e307..d4be9301be5 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/src/buffer-tests.el b/test/src/buffer-tests.el
index 8479bbdda0b..0e4fd3655ae 100644
--- a/test/src/buffer-tests.el
+++ b/test/src/buffer-tests.el
@@ -69,4 +69,14 @@ 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))))
+
;;; 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..feee9b692b7
--- /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 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/data-tests.el b/test/src/data-tests.el
index b444dc70f17..3cd4802a981 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))
@@ -508,4 +525,144 @@ 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 (= (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)))
+
;;; data-tests.el ends here
diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el
index c2ec99d8032..4a840c8d7d1 100644
--- a/test/src/editfns-tests.el
+++ b/test/src/editfns-tests.el
@@ -150,6 +150,60 @@
(ert-deftest format-c-float ()
(should-error (format "%c" 0.5)))
+;;; 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))
+ (let ((binary-as-unsigned nil))
+ (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")))
+
;;; 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.
@@ -199,6 +253,16 @@
(format-time-string "%Y-%m-%d %H:%M:%S.%3N %z" nil
(concat (make-string 2048 ?X) "0")))))
+(defun editfns-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")
+ (editfns-tests--have-leap-seconds))))
+
(ert-deftest format-with-field ()
(should (equal (format "First argument %2$s, then %3$s, then %1$s" 1 2 3)
"First argument 2, then 3, then 1"))
@@ -323,4 +387,27 @@
(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 "))))
+
;;; editfns-tests.el ends here
diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el
index 9f598c68275..c67190be5cb 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))))
@@ -254,4 +267,26 @@ during garbage collection."
(rx "Module function called during garbage collection\n")
(mod-test-invalid-finalizer)))
+(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))))
+
;;; emacs-module-tests.el ends here
diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el
index e68fd136113..281d959b530 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,4 +114,29 @@ 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)))))
+
;;; eval-tests.el ends here
diff --git a/test/src/fileio-tests.el b/test/src/fileio-tests.el
index 5b4db5423fe..5d12685fa19 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))
diff --git a/test/src/floatfns-tests.el b/test/src/floatfns-tests.el
index cb173eea76d..61b1c25743d 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 641947d66a0..b180f30f285 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))
@@ -575,4 +586,63 @@
: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))))))))
+
(provide 'fns-tests)
diff --git a/test/src/json-tests.el b/test/src/json-tests.el
new file mode 100644
index 00000000000..911bc49730d
--- /dev/null
+++ b/test/src/json-tests.el
@@ -0,0 +1,290 @@
+;;; json-tests.el --- unit tests for json.c -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2018 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-error
+ (catch 'test-tag
+ (json-insert '((a . "b") (c . 123) (d . [1 2 t :false]))))
+ :type 'no-catch)
+ (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/keyboard-tests.el b/test/src/keyboard-tests.el
new file mode 100644
index 00000000000..125dbd09391
--- /dev/null
+++ b/test/src/keyboard-tests.el
@@ -0,0 +1,36 @@
+;;; keyboard-tests.el --- Tests for keyboard.c -*- lexical-binding: t -*-
+
+;; Copyright (C) 2017-2018 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 keyboard-unread-command-events ()
+ "Test `unread-command-events'."
+ (should (equal (progn (push ?\C-a unread-command-events)
+ (read-event nil nil 1))
+ ?\C-a))
+ (should (equal (progn (run-with-timer
+ 1 nil
+ (lambda () (push '(t . ?\C-b) unread-command-events)))
+ (read-event nil nil 2))
+ ?\C-b)))
+
+(provide 'keyboard-tests)
+;;; keyboard-tests.el ends here
diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el
index eb212f3c957..f19d98320ab 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 46368c69ada..091f1aa1afb 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,15 @@
(buffer-string))
"--------\n"))))
+(ert-deftest print-read-roundtrip ()
+ (let ((sym '\’bar))
+ (should (eq (read (prin1-to-string sym)) sym))))
+
+(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 7d355602297..551b34ff371 100644
--- a/test/src/process-tests.el
+++ b/test/src/process-tests.el
@@ -181,5 +181,39 @@
(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 (process-live-p process)
+ (accept-process-output 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"))))))
+
(provide 'process-tests)
;; process-tests.el ends here.
diff --git a/test/src/regex-tests.el b/test/src/regex-emacs-tests.el
index 86aa7d26350..7a075908a6b 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-2018 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).
@@ -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 e721e0f9621..109e71128ab 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 ()