[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/etags-regen 7ee6e8f: Merge branch 'master' into scratch/etags-re
|
From: |
Dmitry Gutov |
|
Subject: |
scratch/etags-regen 7ee6e8f: Merge branch 'master' into scratch/etags-regen |
|
Date: |
Thu, 29 Apr 2021 14:21:46 -0400 (EDT) |
branch: scratch/etags-regen
commit 7ee6e8f3502c59b950437a733337476204af2f1d
Merge: 1db074f a8aa217
Author: Dmitry Gutov <dgutov@yandex.ru>
Commit: Dmitry Gutov <dgutov@yandex.ru>
Merge branch 'master' into scratch/etags-regen
---
.gitignore | 9 +
GNUmakefile | 2 +
Makefile.in | 54 +-
admin/MAINTAINERS | 7 +
admin/charsets/Makefile.in | 12 +-
admin/charsets/eucjp-ms.awk | 2 +-
admin/charsets/mule-charsets.el | 2 +-
admin/emake | 2 +
admin/grammars/Makefile.in | 46 +-
admin/make-tarball.txt | 14 +-
admin/unidata/Makefile.in | 16 +-
admin/unidata/unidata-gen.el | 6 +-
admin/update_autogen | 12 +-
configure.ac | 163 +-
doc/emacs/buffers.texi | 9 +
doc/emacs/emacs.texi | 2 +-
doc/emacs/maintaining.texi | 8 +-
doc/emacs/mini.texi | 11 +-
doc/emacs/search.texi | 8 +
doc/emacs/text.texi | 38 +-
doc/lispintro/emacs-lisp-intro.texi | 96 +-
doc/lispref/control.texi | 9 +-
doc/lispref/display.texi | 44 +-
doc/lispref/edebug.texi | 10 +-
doc/lispref/elisp.texi | 1 +
doc/lispref/files.texi | 2 +-
doc/lispref/frames.texi | 5 +-
doc/lispref/keymaps.texi | 4 +-
doc/lispref/macros.texi | 26 +-
doc/lispref/minibuf.texi | 144 +-
doc/lispref/modes.texi | 64 +-
doc/lispref/nonascii.texi | 10 +-
doc/lispref/objects.texi | 2 +-
doc/lispref/processes.texi | 7 +-
doc/lispref/variables.texi | 3 +
doc/lispref/windows.texi | 10 +-
doc/misc/Makefile.in | 15 +-
doc/misc/cl.texi | 15 +-
doc/misc/erc.texi | 73 +-
doc/misc/eshell.texi | 4 +-
doc/misc/eww.texi | 19 +-
doc/misc/gnus.texi | 2 +-
doc/misc/message.texi | 163 +-
doc/misc/modus-themes.org | 499 +-
doc/misc/reftex.texi | 85 +-
doc/misc/sem-user.texi | 2 +-
doc/misc/tramp.texi | 53 +-
doc/misc/woman.texi | 8 +-
etc/NEWS | 181 +-
etc/TODO | 7 +
etc/images/README | 27 +
etc/images/checkbox-mixed.svg | 6 +
etc/images/checked.svg | 6 +
etc/images/down.svg | 40 +
etc/images/left.svg | 40 +
etc/images/radio-checked.svg | 6 +
etc/images/radio-mixed.svg | 6 +
etc/images/radio.svg | 3 +
etc/images/right.svg | 40 +
etc/images/unchecked.svg | 3 +
etc/images/up.svg | 40 +
etc/themes/manoj-dark-theme.el | 2 +-
etc/themes/modus-operandi-theme.el | 5 +-
etc/themes/modus-themes.el | 2333 +++++----
etc/themes/modus-vivendi-theme.el | 5 +-
leim/Makefile.in | 14 +-
leim/leim-ext.el | 2 +-
lib-src/Makefile.in | 39 +
lib-src/seccomp-filter.c | 370 ++
lib/Makefile.in | 6 +
lib/af_alg.h | 115 +
lisp/Makefile.in | 45 +-
lisp/align.el | 2 -
lisp/allout-widgets.el | 5 +-
lisp/allout.el | 1 -
lisp/array.el | 54 +-
lisp/autoarg.el | 4 +-
lisp/autorevert.el | 5 +-
lisp/avoid.el | 17 +-
lisp/bs.el | 3 -
lisp/calc/calc-alg.el | 12 +-
lisp/calc/calc-ext.el | 22 +-
lisp/calc/calc-menu.el | 2 +
lisp/calc/calc-nlfit.el | 2 +
lisp/calc/calc-prog.el | 12 +-
lisp/calc/calc.el | 14 +-
lisp/calculator.el | 9 +-
lisp/calendar/icalendar.el | 35 +-
lisp/calendar/parse-time.el | 62 +-
lisp/calendar/timeclock.el | 2 -
lisp/cedet/mode-local.el | 40 +-
lisp/cedet/semantic.el | 18 +-
lisp/cedet/semantic/bovine/c.el | 4 +-
lisp/cedet/semantic/bovine/el.el | 2 +-
lisp/cedet/semantic/bovine/grammar.el | 5 +-
lisp/cedet/semantic/db-ebrowse.el | 4 +-
lisp/cedet/semantic/db-global.el | 2 +-
lisp/cedet/semantic/decorate/mode.el | 2 +-
lisp/cedet/semantic/edit.el | 4 +-
lisp/cedet/semantic/fw.el | 10 +-
lisp/cedet/semantic/grammar.el | 53 +-
.../semantic/{grammar-wy.el => grm-wy-boot.el} | 0
lisp/cedet/semantic/idle.el | 15 +-
lisp/cedet/semantic/imenu.el | 12 +-
lisp/cedet/semantic/java.el | 50 +-
lisp/cedet/semantic/lex-spp.el | 20 +-
lisp/cedet/semantic/lex.el | 10 +-
lisp/cedet/semantic/util-modes.el | 2 +-
lisp/cedet/semantic/wisent.el | 5 +-
lisp/cedet/semantic/wisent/comp.el | 41 +-
lisp/cedet/semantic/wisent/grammar.el | 24 +-
lisp/cedet/semantic/wisent/java-tags.el | 3 -
lisp/cedet/semantic/wisent/wisent.el | 3 -
lisp/chistory.el | 21 +-
lisp/cmuscheme.el | 103 +-
lisp/comint.el | 25 +-
lisp/cus-dep.el | 7 +-
lisp/cus-edit.el | 2 -
lisp/cus-face.el | 2 -
lisp/cus-theme.el | 6 +-
lisp/custom.el | 13 +-
lisp/dframe.el | 4 +-
lisp/dired-aux.el | 2 +-
lisp/dirtrack.el | 14 +-
lisp/doc-view.el | 13 +-
lisp/dos-w32.el | 2 +-
lisp/double.el | 4 +-
lisp/dynamic-setting.el | 11 +-
lisp/ebuff-menu.el | 90 +-
lisp/echistory.el | 77 +-
lisp/edmacro.el | 36 +-
lisp/emacs-lisp/advice.el | 5 +
lisp/emacs-lisp/autoload.el | 4 +-
lisp/emacs-lisp/avl-tree.el | 61 +-
lisp/emacs-lisp/bindat.el | 33 +-
lisp/emacs-lisp/byte-opt.el | 15 +-
lisp/emacs-lisp/byte-run.el | 10 +
lisp/emacs-lisp/bytecomp.el | 241 +-
lisp/emacs-lisp/cconv.el | 4 +-
lisp/emacs-lisp/check-declare.el | 2 +-
lisp/emacs-lisp/checkdoc.el | 11 +-
lisp/emacs-lisp/cl-generic.el | 2 +-
lisp/emacs-lisp/cl-indent.el | 2 +-
lisp/emacs-lisp/cl-macs.el | 43 +
lisp/emacs-lisp/comp-cstr.el | 1192 +++++
lisp/emacs-lisp/comp.el | 4210 +++++++++++++++
lisp/emacs-lisp/debug.el | 2 +-
lisp/emacs-lisp/disass.el | 29 +-
lisp/emacs-lisp/easy-mmode.el | 232 +-
lisp/emacs-lisp/easymenu.el | 8 +-
lisp/emacs-lisp/edebug.el | 25 +-
lisp/emacs-lisp/eieio-base.el | 3 +-
lisp/emacs-lisp/eieio-core.el | 12 +-
lisp/emacs-lisp/eieio-custom.el | 2 +-
lisp/emacs-lisp/eieio-opt.el | 2 +-
lisp/emacs-lisp/eieio-speedbar.el | 2 +-
lisp/emacs-lisp/eieio.el | 2 +-
lisp/emacs-lisp/eldoc.el | 16 +-
lisp/emacs-lisp/faceup.el | 5 -
lisp/emacs-lisp/find-func.el | 11 +-
lisp/emacs-lisp/float-sup.el | 1 +
lisp/emacs-lisp/lisp-mnt.el | 5 -
lisp/emacs-lisp/macroexp.el | 3 +-
lisp/emacs-lisp/map-ynp.el | 86 +-
lisp/emacs-lisp/memory-report.el | 18 +-
lisp/emacs-lisp/nadvice.el | 18 +
lisp/emacs-lisp/package.el | 81 +-
lisp/emacs-lisp/ring.el | 2 -
lisp/emacs-lisp/rx.el | 2 +-
lisp/emacs-lisp/seq.el | 3 +
lisp/emacs-lisp/shortdoc.el | 14 +-
lisp/emacs-lisp/smie.el | 34 +-
lisp/emacs-lisp/tabulated-list.el | 19 +-
lisp/emacs-lisp/tcover-ses.el | 4 +-
lisp/emacs-lisp/testcover.el | 4 +-
lisp/emacs-lisp/text-property-search.el | 2 +
lisp/emacs-lisp/unsafep.el | 2 +-
lisp/emulation/edt-mapper.el | 2 +-
lisp/emulation/edt.el | 6 +-
lisp/epa-file.el | 4 +-
lisp/epa-mail.el | 2 +-
lisp/epg-config.el | 6 +-
lisp/erc/erc-backend.el | 30 +-
lisp/erc/erc-button.el | 2 +-
lisp/erc/erc-dcc.el | 24 +-
lisp/erc/erc-desktop-notifications.el | 2 +-
lisp/erc/erc-fill.el | 1 -
lisp/erc/erc-goodies.el | 2 +-
lisp/erc/erc-imenu.el | 2 +-
lisp/erc/erc-menu.el | 2 +-
lisp/erc/erc-page.el | 2 +-
lisp/erc/erc-replace.el | 2 +-
lisp/erc/erc-ring.el | 2 +-
lisp/erc/erc-track.el | 9 +-
lisp/erc/erc.el | 129 +-
lisp/eshell/em-dirs.el | 8 +-
lisp/eshell/em-hist.el | 2 +-
lisp/eshell/em-pred.el | 58 +-
lisp/eshell/em-script.el | 11 +-
lisp/eshell/em-xtra.el | 44 +-
lisp/eshell/esh-proc.el | 38 +-
lisp/eshell/esh-util.el | 204 +-
lisp/eshell/eshell.el | 6 +-
lisp/expand.el | 1 -
lisp/facemenu.el | 1 +
lisp/faces.el | 3 +-
lisp/filecache.el | 4 -
lisp/filenotify.el | 1 -
lisp/files-x.el | 4 +-
lisp/files.el | 50 +-
lisp/find-file.el | 300 +-
lisp/foldout.el | 71 +-
lisp/follow.el | 43 +-
lisp/font-core.el | 1 -
lisp/forms.el | 82 +-
lisp/frame.el | 246 +-
lisp/generic-x.el | 335 +-
lisp/gnus/gnus-art.el | 5 +-
lisp/gnus/gnus-cite.el | 8 +-
lisp/gnus/gnus-cus.el | 2 -
lisp/gnus/gnus-diary.el | 5 -
lisp/gnus/gnus-group.el | 41 +-
lisp/gnus/gnus-msg.el | 11 +-
lisp/gnus/gnus-notifications.el | 2 +-
lisp/gnus/gnus-range.el | 17 +-
lisp/gnus/gnus-registry.el | 15 +-
lisp/gnus/gnus-score.el | 4 +-
lisp/gnus/gnus-sum.el | 13 +-
lisp/gnus/gnus-uu.el | 4 +-
lisp/gnus/gnus.el | 5 +-
lisp/gnus/legacy-gnus-agent.el | 2 +-
lisp/gnus/message.el | 204 +-
lisp/gnus/mm-archive.el | 2 +-
lisp/gnus/mm-partial.el | 16 +-
lisp/gnus/nnagent.el | 1 -
lisp/gnus/nndiary.el | 2 +-
lisp/gnus/nnimap.el | 10 +-
lisp/gnus/nnselect.el | 69 +-
lisp/gnus/nnvirtual.el | 6 +-
lisp/gnus/spam-report.el | 2 +-
lisp/gnus/spam-stat.el | 2 +-
lisp/gnus/spam.el | 14 +-
lisp/help-fns.el | 2 +
lisp/help-macro.el | 31 +-
lisp/help.el | 172 +-
lisp/hilit-chg.el | 117 +-
lisp/hippie-exp.el | 53 +-
lisp/htmlfontify.el | 29 +-
lisp/ibuf-ext.el | 152 +-
lisp/ibuf-macs.el | 32 +-
lisp/icomplete.el | 43 +-
lisp/image-mode.el | 8 +-
lisp/image.el | 8 +-
lisp/info.el | 5 +-
lisp/informat.el | 4 +-
lisp/international/characters.el | 60 +-
lisp/international/fontset.el | 48 +-
lisp/international/ja-dic-cnv.el | 6 +-
lisp/international/latin1-disp.el | 4 +-
lisp/international/mule-cmds.el | 50 +-
lisp/international/mule-diag.el | 16 +-
lisp/international/mule.el | 33 +-
lisp/international/quail.el | 32 +-
lisp/international/titdic-cnv.el | 26 +-
lisp/isearch.el | 138 +-
lisp/isearchb.el | 8 +-
lisp/jka-compr.el | 27 +-
lisp/language/burmese.el | 2 +
lisp/language/cham.el | 2 +
lisp/language/khmer.el | 2 +-
lisp/language/sinhala.el | 2 +-
lisp/language/tai-viet.el | 2 +
lisp/language/thai-word.el | 4 +-
lisp/language/tv-util.el | 3 +-
lisp/ldefs-boot.el | 301 +-
lisp/leim/quail/croatian.el | 2 +-
lisp/leim/quail/hebrew.el | 2 +-
lisp/leim/quail/persian.el | 2 +-
lisp/linum.el | 6 +-
lisp/loadhist.el | 17 +-
lisp/loadup.el | 64 +-
lisp/lpr.el | 39 +-
lisp/ls-lisp.el | 2 +-
lisp/mail/emacsbug.el | 2 +-
lisp/mail/mail-extr.el | 4 +-
lisp/mail/rmail-spam-filter.el | 2 +-
lisp/mail/rmail.el | 6 +-
lisp/mail/rmailmm.el | 8 +-
lisp/mail/smtpmail.el | 18 +-
lisp/mail/uudecode.el | 2 +-
lisp/man.el | 4 +-
lisp/mh-e/mh-acros.el | 2 -
lisp/mh-e/mh-alias.el | 2 -
lisp/mh-e/mh-buffers.el | 2 -
lisp/mh-e/mh-comp.el | 2 -
lisp/mh-e/mh-compat.el | 2 -
lisp/mh-e/mh-folder.el | 2 -
lisp/mh-e/mh-funcs.el | 2 -
lisp/mh-e/mh-gnus.el | 2 -
lisp/mh-e/mh-identity.el | 2 -
lisp/mh-e/mh-inc.el | 2 -
lisp/mh-e/mh-junk.el | 2 -
lisp/mh-e/mh-letter.el | 2 -
lisp/mh-e/mh-limit.el | 2 -
lisp/mh-e/mh-mime.el | 2 -
lisp/mh-e/mh-print.el | 2 -
lisp/mh-e/mh-scan.el | 2 -
lisp/mh-e/mh-search.el | 46 +-
lisp/mh-e/mh-seq.el | 2 -
lisp/mh-e/mh-show.el | 4 +-
lisp/mh-e/mh-speed.el | 2 -
lisp/mh-e/mh-thread.el | 38 +-
lisp/mh-e/mh-tool-bar.el | 2 -
lisp/mh-e/mh-utils.el | 6 +-
lisp/mh-e/mh-xface.el | 2 -
lisp/minibuffer.el | 155 +-
lisp/misearch.el | 30 +-
lisp/mpc.el | 172 +-
lisp/msb.el | 79 +-
lisp/net/ange-ftp.el | 4 -
lisp/net/eww.el | 10 +
lisp/net/gnutls.el | 4 +-
lisp/net/goto-addr.el | 8 +-
lisp/net/imap.el | 6 +-
lisp/net/net-utils.el | 12 +-
lisp/net/newst-backend.el | 1 +
lisp/net/newst-ticker.el | 2 +-
lisp/net/newst-treeview.el | 4 -
lisp/net/pop3.el | 6 +-
lisp/net/rcirc.el | 12 +-
lisp/net/secrets.el | 2 +
lisp/net/shr.el | 12 +-
lisp/net/sieve-manage.el | 2 +-
lisp/net/sieve-mode.el | 2 +-
lisp/net/sieve.el | 2 +-
lisp/net/tramp-archive.el | 6 +-
lisp/net/tramp-cmds.el | 43 +
lisp/net/tramp-sh.el | 247 +-
lisp/net/tramp.el | 120 +-
lisp/notifications.el | 2 +
lisp/nxml/rng-cmpct.el | 2 +-
lisp/nxml/rng-loc.el | 2 +-
lisp/nxml/rng-match.el | 2 +-
lisp/nxml/rng-nxml.el | 2 +-
lisp/nxml/rng-util.el | 28 +-
lisp/nxml/xmltok.el | 45 +-
lisp/obsolete/fast-lock.el | 2 -
lisp/obsolete/info-edit.el | 2 +-
lisp/obsolete/iswitchb.el | 2 +-
lisp/obsolete/lazy-lock.el | 2 -
lisp/obsolete/nnir.el | 1 -
lisp/obsolete/old-emacs-lock.el | 4 +-
lisp/obsolete/otodo-mode.el | 4 +-
lisp/obsolete/pc-select.el | 2 -
lisp/obsolete/sb-image.el | 2 +-
lisp/obsolete/sregex.el | 4 +-
lisp/obsolete/tpu-mapper.el | 2 +-
lisp/org/ob-hledger.el | 2 +-
lisp/org/ob-mscgen.el | 4 +-
lisp/org/ol-eshell.el | 2 +-
lisp/org/org-capture.el | 2 +-
lisp/org/org-ctags.el | 4 +-
lisp/org/org-indent.el | 2 +-
lisp/org/org-list.el | 2 +-
lisp/org/org-src.el | 2 +-
lisp/org/org-table.el | 6 +-
lisp/org/org.el | 2 +-
lisp/org/ox-beamer.el | 8 +-
lisp/org/ox-man.el | 2 +-
lisp/outline.el | 44 +-
lisp/pcomplete.el | 27 +-
lisp/pixel-scroll.el | 8 +-
lisp/play/bubbles.el | 8 +-
lisp/printing.el | 227 +-
lisp/progmodes/bug-reference.el | 8 +-
lisp/progmodes/cc-align.el | 5 +-
lisp/progmodes/cc-awk.el | 4 +-
lisp/progmodes/cc-bytecomp.el | 29 +-
lisp/progmodes/cc-cmds.el | 79 +-
lisp/progmodes/cc-defs.el | 201 +-
lisp/progmodes/cc-engine.el | 58 +-
lisp/progmodes/cc-fonts.el | 37 +-
lisp/progmodes/cc-guess.el | 6 +-
lisp/progmodes/cc-langs.el | 36 +-
lisp/progmodes/cc-menus.el | 2 +-
lisp/progmodes/cc-mode.el | 4 +-
lisp/progmodes/cc-styles.el | 10 +-
lisp/progmodes/cc-vars.el | 5 +-
lisp/progmodes/cfengine.el | 4 +-
lisp/progmodes/cmacexp.el | 37 +-
lisp/progmodes/cperl-mode.el | 34 +-
lisp/progmodes/cwarn.el | 2 +-
lisp/progmodes/dcl-mode.el | 59 +-
lisp/progmodes/ebnf-yac.el | 8 +-
lisp/progmodes/ebnf2ps.el | 8 +-
lisp/progmodes/ebrowse.el | 2 +-
lisp/progmodes/elisp-mode.el | 28 +-
lisp/progmodes/executable.el | 2 +-
lisp/progmodes/flymake.el | 5 +-
lisp/progmodes/glasses.el | 4 -
lisp/progmodes/grep.el | 28 +-
lisp/progmodes/gud.el | 15 +
lisp/progmodes/hideif.el | 2 +-
lisp/progmodes/idlw-shell.el | 2 +-
lisp/progmodes/idlwave.el | 14 +-
lisp/progmodes/inf-lisp.el | 114 +-
lisp/progmodes/js.el | 7 +-
lisp/progmodes/meta-mode.el | 3 -
lisp/progmodes/octave.el | 4 +-
lisp/progmodes/project.el | 108 +-
lisp/progmodes/ps-mode.el | 38 +-
lisp/progmodes/python.el | 13 +-
lisp/progmodes/ruby-mode.el | 16 +-
lisp/progmodes/sh-script.el | 2 +-
lisp/progmodes/simula.el | 99 +-
lisp/progmodes/sql.el | 8 +-
lisp/progmodes/verilog-mode.el | 51 +-
lisp/progmodes/vhdl-mode.el | 981 ++--
lisp/progmodes/which-func.el | 19 +-
lisp/progmodes/xref.el | 20 +-
lisp/ps-bdf.el | 4 +-
lisp/ps-mule.el | 46 +-
lisp/recentf.el | 107 +-
lisp/rect.el | 2 +-
lisp/repeat.el | 131 +-
lisp/replace.el | 36 +-
lisp/rot13.el | 29 +-
lisp/ruler-mode.el | 5 -
lisp/scroll-all.el | 23 +-
lisp/ses.el | 78 +-
lisp/shadowfile.el | 118 +-
lisp/shell.el | 2 +-
lisp/simple.el | 8 +-
lisp/so-long.el | 2 +-
lisp/speedbar.el | 5 +-
lisp/startup.el | 34 +-
lisp/strokes.el | 179 +-
lisp/subr.el | 41 +-
lisp/svg.el | 48 +-
lisp/tab-bar.el | 22 +
lisp/tar-mode.el | 40 +-
lisp/term/konsole.el | 2 +-
lisp/term/linux.el | 4 +-
lisp/term/lk201.el | 2 +-
lisp/term/screen.el | 2 +-
lisp/term/st.el | 2 +-
lisp/term/tmux.el | 2 +-
lisp/term/w32-win.el | 3 +-
lisp/term/w32console.el | 2 +-
lisp/textmodes/artist.el | 23 +-
lisp/textmodes/bibtex-style.el | 1 -
lisp/textmodes/bibtex.el | 3 -
lisp/textmodes/fill.el | 22 +-
lisp/textmodes/flyspell.el | 2 +-
lisp/textmodes/ispell.el | 8 +-
lisp/textmodes/makeinfo.el | 1 -
lisp/textmodes/page.el | 2 -
lisp/textmodes/paragraphs.el | 8 +-
lisp/textmodes/refer.el | 16 +-
lisp/textmodes/reftex-auc.el | 14 +-
lisp/textmodes/reftex-vars.el | 98 +-
lisp/textmodes/remember.el | 15 +-
lisp/textmodes/rst.el | 344 +-
lisp/textmodes/sgml-mode.el | 5 +-
lisp/textmodes/table.el | 2 +-
lisp/textmodes/tex-mode.el | 1 -
lisp/textmodes/texinfmt.el | 6 +-
lisp/textmodes/texnfo-upd.el | 2 -
lisp/textmodes/tildify.el | 4 +-
lisp/textmodes/two-column.el | 11 +-
lisp/thingatpt.el | 6 +-
lisp/thumbs.el | 3 -
lisp/time.el | 11 +-
lisp/transient.el | 3615 +++++++++++++
lisp/tree-widget.el | 4 +-
lisp/uniquify.el | 2 -
lisp/url/url-cookie.el | 8 +-
lisp/url/url-dav.el | 17 +-
lisp/url/url-history.el | 16 +-
lisp/url/url-mailto.el | 6 +-
lisp/url/url-proxy.el | 10 +-
lisp/url/url-vars.el | 9 +-
lisp/vc/add-log.el | 2 +-
lisp/vc/ediff-mult.el | 6 +-
lisp/vc/ediff-util.el | 7 +-
lisp/vc/log-edit.el | 7 +-
lisp/vc/pcvs.el | 2 +-
lisp/vc/vc-dispatcher.el | 2 +-
lisp/vc/vc-filewise.el | 2 +
lisp/vc/vc-git.el | 8 -
lisp/vc/vc-hg.el | 9 -
lisp/vcursor.el | 298 +-
lisp/vt-control.el | 16 +-
lisp/wdired.el | 43 +-
lisp/wid-edit.el | 25 +-
lisp/widget.el | 2 -
lisp/window.el | 91 +-
lisp/winner.el | 32 +-
lisp/woman.el | 8 +-
lwlib/Makefile.in | 4 +-
nt/epaths.nt | 5 +
nt/mingw-cfg.site | 4 +
src/Makefile.in | 18 +-
src/alloc.c | 39 +-
src/callproc.c | 2 +-
src/character.c | 56 +-
src/character.h | 6 +-
src/charset.c | 2 +-
src/comp.c | 5410 ++++++++++++++++++++
src/comp.h | 114 +
src/data.c | 95 +-
src/decompress.c | 102 +
src/dispextern.h | 9 +-
src/dispnew.c | 120 +-
src/doc.c | 12 +-
src/dynlib.c | 4 -
src/editfns.c | 11 +-
src/emacs.c | 381 +-
src/epaths.in | 4 +
src/eval.c | 155 +-
src/fns.c | 43 +-
src/frame.c | 760 +--
src/frame.h | 220 +-
src/gtkutil.c | 158 +-
src/image.c | 171 +-
src/keyboard.c | 9 +-
src/keymap.c | 6 -
src/lisp.h | 76 +-
src/lread.c | 229 +-
src/minibuf.c | 125 +-
src/nsfns.m | 26 +-
src/nsterm.m | 43 +-
src/pdumper.c | 339 +-
src/pdumper.h | 15 +-
src/print.c | 13 +-
src/process.c | 2 +-
src/sound.c | 5 +-
src/term.c | 4 +-
src/termhooks.h | 2 +-
src/verbose.mk.in | 8 +
src/w32.c | 28 +-
src/w32.h | 3 +
src/w32common.h | 8 +
src/w32fns.c | 102 +-
src/w32inevt.c | 12 +-
src/w32proc.c | 13 +-
src/w32term.c | 176 +-
src/widget.c | 75 +-
src/window.c | 97 +-
src/window.h | 1 +
src/xdisp.c | 101 +-
src/xfns.c | 137 +-
src/xmenu.c | 32 +-
src/xselect.c | 21 +-
src/xterm.c | 276 +-
src/xterm.h | 2 +-
test/Makefile.in | 12 +
test/infra/Dockerfile.emba | 2 +-
test/infra/gitlab-ci.yml | 38 +
test/lisp/auth-source-tests.el | 4 +-
test/lisp/autorevert-tests.el | 2 +-
test/lisp/calc/calc-tests.el | 27 +
test/lisp/calculator-tests.el | 51 +
test/lisp/calendar/icalendar-tests.el | 2 +-
test/lisp/calendar/parse-time-tests.el | 2 +-
test/lisp/cedet/srecode-utest-template.el | 2 +-
test/lisp/custom-resources/custom--test-theme.el | 2 +-
test/lisp/descr-text-tests.el | 2 +-
test/lisp/electric-tests.el | 90 +-
test/lisp/emacs-lisp/bytecomp-tests.el | 357 +-
test/lisp/emacs-lisp/cl-macs-tests.el | 15 +-
test/lisp/emacs-lisp/comp-cstr-tests.el | 233 +
test/lisp/emacs-lisp/edebug-tests.el | 25 +
.../eieio-tests/eieio-test-methodinvoke.el | 2 +-
test/lisp/emacs-lisp/eieio-tests/eieio-tests.el | 2 +-
test/lisp/epg-config-tests.el | 47 +
test/lisp/eshell/em-hist-tests.el | 2 +-
test/lisp/eshell/em-ls-tests.el | 2 +-
test/lisp/eshell/esh-opt-tests.el | 2 +-
test/lisp/eshell/eshell-tests.el | 2 +-
test/lisp/filenotify-tests.el | 3 +-
test/lisp/gnus/message-tests.el | 2 +-
test/lisp/help-fns-tests.el | 8 +-
test/lisp/info-xref-tests.el | 2 +-
test/lisp/international/ucs-normalize-tests.el | 2 +-
test/lisp/loadhist-tests.el | 57 +
test/lisp/{play/cookie1-tests.el => lpr-tests.el} | 35 +-
test/lisp/minibuffer-tests.el | 59 +-
test/lisp/net/nsm-tests.el | 2 +-
test/lisp/net/shr-tests.el | 2 +-
test/lisp/net/tramp-tests.el | 40 +-
test/lisp/play/cookie1-tests.el | 2 +-
test/lisp/progmodes/cperl-mode-tests.el | 31 +-
test/lisp/progmodes/executable-tests.el | 51 +
test/lisp/progmodes/perl-mode-tests.el | 2 +-
test/lisp/progmodes/project-tests.el | 85 +
test/lisp/progmodes/ruby-mode-tests.el | 31 +
test/lisp/progmodes/xref-tests.el | 4 +-
test/lisp/shadowfile-tests.el | 2 +-
test/lisp/simple-tests.el | 2 +-
test/lisp/subr-tests.el | 2 +-
test/lisp/textmodes/fill-tests.el | 2 +-
test/lisp/textmodes/tildify-tests.el | 2 +-
test/lisp/thingatpt-tests.el | 2 +-
test/lisp/vc/vc-bzr-tests.el | 2 +-
test/lisp/xml-tests.el | 2 +-
test/manual/cedet/semantic-tests.el | 2 +-
test/manual/cedet/tests/test.el | 3 -
test/manual/image-size-tests.el | 2 +-
test/manual/image-transforms-tests.el | 2 +-
test/manual/indent/scheme.scm | 23 +
test/manual/scroll-tests.el | 2 +-
test/misc/test-custom-noloads.el | 4 +-
test/src/character-tests.el | 45 +
test/src/coding-tests.el | 2 +-
test/src/comp-resources/comp-test-45603.el | 28 +
.../comp-resources/comp-test-funcs-dyn.el} | 37 +-
test/src/comp-resources/comp-test-funcs.el | 710 +++
.../comp-resources/comp-test-pure.el} | 27 +-
test/src/comp-tests.el | 1443 ++++++
test/src/editfns-tests.el | 2 +-
test/src/emacs-module-tests.el | 2 +-
test/src/emacs-resources/seccomp-filter-exec.bpf | 1 +
test/src/emacs-resources/seccomp-filter.bpf | 1 +
test/src/emacs-tests.el | 257 +
test/src/fileio-tests.el | 2 +-
test/src/thread-tests.el | 8 +-
test/src/timefns-tests.el | 2 +-
628 files changed, 30665 insertions(+), 9235 deletions(-)
diff --git a/.gitignore b/.gitignore
index b653ef2..fcbc9cd 100644
--- a/.gitignore
+++ b/.gitignore
@@ -88,6 +88,7 @@ lisp/cedet/semantic/wisent/javat-wy.el
lisp/cedet/semantic/wisent/js-wy.el
lisp/cedet/semantic/wisent/python-wy.el
lisp/cedet/srecode/srt-wy.el
+lisp/cedet/semantic/grammar-wy.el
lisp/eshell/esh-groups.el
lisp/finder-inf.el
lisp/leim/ja-dic/
@@ -134,6 +135,7 @@ src/gl-stamp
*.dll
*.core
*.elc
+*.eln
*.o
*.res
*.so
@@ -188,6 +190,7 @@ lib-src/make-docfile
lib-src/make-fingerprint
lib-src/movemail
lib-src/profile
+lib-src/seccomp-filter
lib-src/test-distrib
lib-src/update-game-score
nextstep/Cocoa/Emacs.base/Contents/Info.plist
@@ -301,3 +304,9 @@ nt/emacs.rc
nt/emacsclient.rc
src/gdb.ini
/var/
+
+# Seccomp filter files.
+lib-src/seccomp-filter.bpf
+lib-src/seccomp-filter.pfc
+lib-src/seccomp-filter-exec.bpf
+lib-src/seccomp-filter-exec.pfc
diff --git a/GNUmakefile b/GNUmakefile
index f271638..5155487 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -50,6 +50,8 @@ help:
@echo "make distclean -- delete all build and configuration
files,"
@echo " leave only files included in source
distribution"
@echo "make maintainer-clean -- delete almost everything that can be
regenerated"
+ @echo "make extraclean -- like maintainer-clean, and also delete"
+ @echo " backup and autosave files"
@echo "make bootstrap -- delete all compiled files to force a
new bootstrap"
@echo " from a clean slate, then build in the
normal way"
@echo "make uninstall -- remove files installed by 'make
install'"
diff --git a/Makefile.in b/Makefile.in
index 4fa7c9e..8d52cb5 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -48,8 +48,6 @@
#
# make extraclean
# Still more severe - delete backup and autosave files, too.
-# Also generated files that do not normally change and can be slow
-# to rebuild (eg leim/ja-dic).
#
# make bootstrap
# Removes all the compiled files to force a new bootstrap from a
@@ -98,6 +96,8 @@ NTDIR=@NTDIR@
top_builddir = @top_builddir@
-include ${top_builddir}/src/verbose.mk
+HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@
+
# ==================== Where To Install Things ====================
# Location to install Emacs.app under GNUstep / macOS.
@@ -208,6 +208,10 @@ iconsrcdir=$(srcdir)/etc/images/icons
# These variables hold the values Emacs will actually use. They are
# based on the values of the standard Make variables above.
+# Where lisp files are installed in a distributed with Emacs (relative
+# path to the installation directory).
+lispdirrel=@lispdirrel@
+
# Where to install the lisp files distributed with Emacs.
# This includes the Emacs version, so that the lisp files for different
# versions of Emacs will install themselves in separate directories.
@@ -317,6 +321,14 @@ CONFIG_STATUS_FILES_IN = \
COPYDIR = ${srcdir}/etc ${srcdir}/lisp
COPYDESTS = "$(DESTDIR)${etcdir}" "$(DESTDIR)${lispdir}"
+ifeq (${ns_self_contained},no)
+BIN_DESTDIR='$(DESTDIR)${bindir}/'
+ELN_DESTDIR = $(DESTDIR)${libdir}/emacs/${version}/
+else
+BIN_DESTDIR='${ns_appbindir}/'
+ELN_DESTDIR = ${ns_appresdir}/
+endif
+
all: ${SUBDIR} info
.PHONY: all ${SUBDIR} blessmail epaths-force epaths-force-w32 etc-emacsver
@@ -351,6 +363,7 @@ epaths-force:
@(gamedir='${gamedir}'; \
sed < ${srcdir}/src/epaths.in > epaths.h.$$$$ \
-e 's;\(#.*PATH_LOADSEARCH\).*$$;\1 "${standardlisppath}";' \
+ -e 's;\(#.*PATH_REL_LOADSEARCH\).*$$;\1 "${lispdirrel}";' \
-e 's;\(#.*PATH_SITELOADSEARCH\).*$$;\1 "${locallisppath}";' \
-e 's;\(#.*PATH_DUMPLOADSEARCH\).*$$;\1 "${buildlisppath}";' \
-e '/^#define PATH_[^ ]*SEARCH /s/\([":]\):*/\1/g' \
@@ -381,6 +394,7 @@ epaths-force-w32:
w32locallisppath=$${w32locallisppath//$${w32prefix}/"%emacs_dir%"} ; \
sed < ${srcdir}/nt/epaths.nt > epaths.h.$$$$ \
-e 's;\(#.*PATH_SITELOADSEARCH\).*$$;\1
"'"$${w32locallisppath//;/\\;}"'";' \
+ -e 's;\(#.*PATH_REL_LOADSEARCH\).*$$;\1 "${lispdirrel}";' \
-e '/^.*#/s/@VER@/${version}/g' \
-e '/^.*#/s/@CFG@/${configuration}/g' \
-e "/^.*#/s|@SRC@|$${w32srcdir}|g") && \
@@ -408,7 +422,8 @@ lib lib-src lisp nt: Makefile
dirstate = .git/logs/HEAD
VCSWITNESS = $(if $(wildcard $(srcdir)/$(dirstate)),$$(srcdir)/../$(dirstate))
src: Makefile
- $(MAKE) -C $@ VCSWITNESS='$(VCSWITNESS)' all
+ $(MAKE) -C $@ VCSWITNESS='$(VCSWITNESS)' BIN_DESTDIR='$(BIN_DESTDIR)' \
+ ELN_DESTDIR='$(ELN_DESTDIR)' all
blessmail: Makefile src
$(MAKE) -C lib-src maybe-blessmail
@@ -448,14 +463,14 @@ $(srcdir)/configure: $(srcdir)/configure.ac
$(srcdir)/m4/*.m4
# ==================== Installation ====================
.PHONY: install install-arch-dep install-arch-indep install-etcdoc install-info
-.PHONY: install-man install-etc install-strip install-$(NTDIR)
+.PHONY: install-man install-etc install-strip install-$(NTDIR) install-eln
.PHONY: uninstall uninstall-$(NTDIR)
## If we let lib-src do its own installation, that means we
## don't have to duplicate the list of utilities to install in
## this Makefile as well.
-install: all install-arch-indep install-etcdoc install-arch-dep
install-$(NTDIR) blessmail
+install: all install-arch-indep install-etcdoc install-arch-dep
install-$(NTDIR) blessmail install-eln
@true
## Ensure that $subdir contains a subdirs.el file.
@@ -735,6 +750,13 @@ install-etc:
done ; \
done
+### Install native compiled Lisp files.
+install-eln:
+ifeq ($(HAVE_NATIVE_COMP),yes)
+ find native-lisp -type d -exec $(MKDIR_P) "$(ELN_DESTDIR){}" \; ; \
+ find native-lisp -type f -exec ${INSTALL_DATA} "{}" "$(ELN_DESTDIR){}"
\;
+endif
+
### Build Emacs and install it, stripping binaries while installing them.
install-strip:
$(MAKE) INSTALL_STRIP=-s install
@@ -836,15 +858,15 @@ mostlyclean: $(mostlyclean_dirs:=_mostlyclean)
### with them.
###
### Delete '.dvi' files here if they are not part of the distribution.
-clean_dirs = $(mostlyclean_dirs) nextstep
+clean_dirs = $(mostlyclean_dirs) nextstep admin/charsets admin/unidata
$(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 -rf info-dir.*
+ -rm -rf native-lisp
### 'bootclean'
### Delete all files that need to be remade for a clean bootstrap.
@@ -862,16 +884,11 @@ top_distclean=\
rm -f config.status config.log~ \
Makefile makefile lib/gnulib.mk ${SUBDIR_MAKEFILES}
-distclean_dirs = $(clean_dirs) leim lisp
+distclean_dirs = $(clean_dirs) leim lisp admin/grammars
$(foreach dir,$(distclean_dirs),$(eval $(call
submake_template,$(dir),distclean)))
-maybeclean_dirs = test admin/grammars admin/unidata admin/charsets
-
distclean: $(distclean_dirs:=_distclean)
- for dir in $(filter-out test,$(maybeclean_dirs)); do \
- $(MAKE) -C $$dir $@ || exit; \
- done
[ ! -d test ] || $(MAKE) -C test $@
${top_distclean}
@@ -881,9 +898,6 @@ distclean: $(distclean_dirs:=_distclean)
$(foreach dir,$(distclean_dirs),$(eval $(call
submake_template,$(dir),bootstrap-clean)))
bootstrap-clean: $(distclean_dirs:=_bootstrap-clean)
- for dir in $(filter-out test,$(maybeclean_dirs)); do \
- $(MAKE) -C $$dir $@ || exit; \
- done
[ ! -d test ] || $(MAKE) -C test $@
[ ! -f config.log ] || mv -f config.log config.log~
rm -rf ${srcdir}/info
@@ -905,14 +919,12 @@ top_maintainer_clean=\
${top_distclean}; \
rm -fr autom4te.cache
-maintainer_clean_dirs = src leim lisp
+maintainer_clean_dirs = src leim lisp admin/charsets admin/grammars \
+ admin/unidata
$(foreach dir,$(maintainer_clean_dirs),$(eval $(call
submake_template,$(dir),maintainer-clean)))
maintainer-clean: bootstrap-clean $(maintainer_clean_dirs:=_maintainer-clean)
- for dir in $(filter-out test,$(maybeclean_dirs)); do \
- $(MAKE) -C $$dir $@ || exit; \
- done
[ ! -d test ] || $(MAKE) -C test $@
${top_maintainer_clean}
@@ -923,7 +935,7 @@ maintainer-clean: bootstrap-clean
$(maintainer_clean_dirs:=_maintainer-clean)
### Note that we abuse this in some subdirectories (eg leim),
### to delete some generated files that are slow to rebuild.
extraclean_dirs = ${NTDIR} lib-src src leim \
- admin/charsets admin/grammars admin/unidata lisp lib
+ admin/charsets admin/grammars admin/unidata lisp lib lwlib
$(foreach dir,$(extraclean_dirs),$(eval $(call
submake_template,$(dir),extraclean)))
diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS
index 53afe87..02b8cf3 100644
--- a/admin/MAINTAINERS
+++ b/admin/MAINTAINERS
@@ -131,6 +131,13 @@ Amin Bandali
lisp/erc/*
doc/misc/erc.texi
+Andrea Corallo
+ Lisp native compiler
+ src/comp.c
+ lisp/emacs-lisp/comp.el
+ lisp/emacs-lisp/comp-cstr.el
+ test/src/comp-*.el
+
==============================================================================
2. Areas that someone is willing to maintain, although he would not
necessarily mind if someone else was the official maintainer.
diff --git a/admin/charsets/Makefile.in b/admin/charsets/Makefile.in
index 1fe0299..0042484 100644
--- a/admin/charsets/Makefile.in
+++ b/admin/charsets/Makefile.in
@@ -297,17 +297,19 @@ ${charsetdir}/%.map: ${GLIBC_CHARMAPS}/%.gz ${mapconv}
${compact}
${AM_V_GEN}${run_mapconv} $< '/^<.*[ ]\/x/' GLIBC-1 ${compact} > $@
-.PHONY: clean bootstrap-clean distclean maintainer-clean extraclean
+.PHONY: clean bootstrap-clean distclean maintainer-clean extraclean gen-clean
clean:
+## IMO this should also run gen-clean.
bootstrap-clean: clean
distclean: clean
rm -f Makefile
-maintainer-clean: distclean
-
-## Do not remove these files, even in a bootstrap. They rarely change.
-extraclean:
+gen-clean:
rm -f ${CHARSETS} ${SED_SCRIPT} ${TRANS_TABLE} ${srcdir}/charsets.stamp
+
+maintainer-clean: gen-clean distclean
+
+extraclean: maintainer-clean
diff --git a/admin/charsets/eucjp-ms.awk b/admin/charsets/eucjp-ms.awk
index ca9a317..033b37f 100644
--- a/admin/charsets/eucjp-ms.awk
+++ b/admin/charsets/eucjp-ms.awk
@@ -38,7 +38,7 @@ BEGIN {
JISX0208_FROM2 = "/xf5/xa1";
JISX0212_FROM = "/x8f/xf3/xf3";
- print ";;; eucjp-ms.el -- translation table for eucJP-ms -*-
lexical-binding:t -*-";
+ print ";;; eucjp-ms.el --- translation table for eucJP-ms -*-
lexical-binding:t -*-";
print ";;; Automatically generated from
/usr/share/i18n/charmaps/EUC-JP-MS.gz";
print "(let ((map";
print " '(;JISEXT<->UNICODE";
diff --git a/admin/charsets/mule-charsets.el b/admin/charsets/mule-charsets.el
index 99a8c60..7bcceb3 100644
--- a/admin/charsets/mule-charsets.el
+++ b/admin/charsets/mule-charsets.el
@@ -1,4 +1,4 @@
-;; mule-charsets.el -- Generate Mule-original charset maps. -*-
lexical-binding: t -*-
+;;; mule-charsets.el --- Generate Mule-original charset maps. -*-
lexical-binding: t -*-
;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
;; Registration Number H13PRO009
diff --git a/admin/emake b/admin/emake
index e95b17d..834a184 100755
--- a/admin/emake
+++ b/admin/emake
@@ -68,6 +68,8 @@ GEN.*loaddefs|\
^\"configure\" file built.|\
^There seems to be no|\
^config.status:|\
+ELN_DESTDIR|\
+--bin-dest |\
^ *$|\
^Makefile built|\
The GNU allocators don't work|\
diff --git a/admin/grammars/Makefile.in b/admin/grammars/Makefile.in
index aa09d9e..4172411 100644
--- a/admin/grammars/Makefile.in
+++ b/admin/grammars/Makefile.in
@@ -34,7 +34,7 @@ top_builddir = @top_builddir@
unexport EMACSDATA EMACSDOC EMACSPATH
EMACS = ${top_builddir}/src/emacs
-emacs = EMACSLOADPATH= "${EMACS}" -batch --no-site-file --no-site-lisp
+emacs = EMACSLOADPATH= "${EMACS}" -batch --no-site-file --no-site-lisp --eval
'(setq load-prefer-newer t)'
make_bovine = ${emacs} -l semantic/bovine/grammar -f bovine-batch-make-parser
make_wisent = ${emacs} -l semantic/wisent/grammar -f wisent-batch-make-parser
@@ -43,19 +43,19 @@ cedetdir = ${top_srcdir}/lisp/cedet
bovinedir = ${cedetdir}/semantic/bovine
wisentdir = ${cedetdir}/semantic/wisent
+grammar_bovine = ${bovinedir}/grammar.el
+grammar_wisent = ${wisentdir}/grammar.el
+
BOVINE = \
${bovinedir}/c-by.el \
${bovinedir}/make-by.el \
${bovinedir}/scm-by.el
-## FIXME Should include this one too:
-## ${cedetdir}/semantic/grammar-wy.el
-## but semantic/grammar.el (which is what we use to generate grammar-wy.el)
-## requires it!
-WISENT = \
- ${wisentdir}/javat-wy.el \
- ${wisentdir}/js-wy.el \
- ${wisentdir}/python-wy.el \
+WISENT = \
+ ${cedetdir}/semantic/grammar-wy.el \
+ ${wisentdir}/javat-wy.el \
+ ${wisentdir}/js-wy.el \
+ ${wisentdir}/python-wy.el \
${cedetdir}/srecode/srt-wy.el
ALL = ${BOVINE} ${WISENT}
@@ -69,46 +69,46 @@ bovine: ${BOVINE}
wisent: ${WISENT}
## c-by.el, make-by.el.
-${bovinedir}/%-by.el: ${srcdir}/%.by
+${bovinedir}/%-by.el: ${srcdir}/%.by ${grammar_bovine}
$(AM_V_GEN)[ ! -f "$@" ] || chmod +w "$@"
$(AM_V_at)${make_bovine} -o "$@" $<
-${bovinedir}/scm-by.el: ${srcdir}/scheme.by
+${bovinedir}/scm-by.el: ${srcdir}/scheme.by ${grammar_bovine}
$(AM_V_GEN)[ ! -f "$@" ] || chmod +w "$@"
$(AM_V_at)${make_bovine} -o "$@" $<
## grammar-wy.el
-${cedetdir}/semantic/%-wy.el: ${srcdir}/%.wy
+${cedetdir}/semantic/%-wy.el: ${srcdir}/%.wy ${grammar_wisent}
$(AM_V_GEN)[ ! -f "$@" ] || chmod +w "$@"
$(AM_V_at)${make_wisent} -o "$@" $<
## js-wy.el, python-wy.el
-${wisentdir}/%-wy.el: ${srcdir}/%.wy
+${wisentdir}/%-wy.el: ${srcdir}/%.wy ${grammar_wisent}
$(AM_V_GEN)[ ! -f "$@" ] || chmod +w "$@"
$(AM_V_at)${make_wisent} -o "$@" $<
-${wisentdir}/javat-wy.el: ${srcdir}/java-tags.wy
+${wisentdir}/javat-wy.el: ${srcdir}/java-tags.wy ${grammar_wisent}
$(AM_V_GEN)[ ! -f "$@" ] || chmod +w "$@"
$(AM_V_at)${make_wisent} -o "$@" $<
-${cedetdir}/srecode/srt-wy.el: ${srcdir}/srecode-template.wy
+${cedetdir}/srecode/srt-wy.el: ${srcdir}/srecode-template.wy ${grammar_wisent}
$(AM_V_GEN)[ ! -f "$@" ] || chmod +w "$@"
$(AM_V_at)${make_wisent} -o "$@" $<
-
-.PHONY: distclean bootstrap-clean maintainer-clean extraclean
+.PHONY: distclean bootstrap-clean maintainer-clean extraclean gen-clean
distclean:
rm -f Makefile
-## Perhaps this should do what extraclean (qv) does.
+## IMO this should run gen-clean.
bootstrap-clean:
-maintainer-clean: distclean
-
-## We do not normally delete the generated files, even in bootstrap.
-## Creating them does not take long, so we could easily change this.
-extraclean:
+gen-clean:
rm -f ${ALL}
+maintainer-clean: gen-clean distclean
+
+extraclean: maintainer-clean
+
+
# Makefile.in ends here
diff --git a/admin/make-tarball.txt b/admin/make-tarball.txt
index c207895..2f763a5 100644
--- a/admin/make-tarball.txt
+++ b/admin/make-tarball.txt
@@ -259,8 +259,9 @@ General steps (for each step, check for possible errors):
UPDATING THE EMACS WEB PAGES AFTER A RELEASE
-As soon as possible after a release, the Emacs web pages should be updated.
-(See admin/notes/www for general information.)
+As soon as possible after a release, the Emacs web pages at
+https://www.gnu.org/software/emacs/ should be updated. (See
+admin/notes/www for general information.)
The pages to update are:
@@ -270,7 +271,14 @@ add the new NEWS file as news/NEWS.xx.y
For every new release, a banner is displayed on top of the emacs.html
page. Uncomment and the release banner in emacs.html. Keep it on the
-page for about a month, then comment it again.
+page for about a month, then comment it again. The new release banner
+looks like this:
+
+ <div class="release-banner">
+ <div class="container">
+ <h2><em>Emacs 27.1 is out</em>, download it <a
href="download.html">here</a>!</h2>
+ </div>
+ </div>
Regenerate the various manuals in manual/.
The scripts admin/make-manuals and admin/upload-manuals summarize the process.
diff --git a/admin/unidata/Makefile.in b/admin/unidata/Makefile.in
index 183569f..b7a927d 100644
--- a/admin/unidata/Makefile.in
+++ b/admin/unidata/Makefile.in
@@ -85,26 +85,26 @@ ${unidir}/charscript.el: ${srcdir}/Blocks.txt ${blocks}
$(AM_V_GEN)$(AWK) -f ${blocks} < $< > $@
-.PHONY: clean bootstrap-clean distclean maintainer-clean extraclean
+.PHONY: clean bootstrap-clean distclean maintainer-clean extraclean gen-clean
clean:
rm -f ${srcdir}/*.elc unidata.txt
+## IMO this should also run gen-clean.
bootstrap-clean: clean
distclean: clean
rm -f Makefile
-maintainer-clean: distclean
-
-## Do not remove these files, even in a bootstrap, because they rarely
-## change and it slows down bootstrap (a tiny bit).
-## Cf leim/ja-dic (which is much slower).
-
## macuvs.h is a generated file, but it's also checked in because
## macOS builds would need to do a headless bootstrap without it,
## which is currently awkward. To avoid changing checked-in files
## from a make target, we don't delete it here.
-extraclean: distclean
+gen-clean:
rm -f ${unidir}/charscript.el*
rm -f ${unifiles} ${unidir}/charprop.el
+## ref: https://lists.gnu.org/r/emacs-devel/2013-11/msg01029.html
+
+maintainer-clean: gen-clean distclean
+
+extraclean: maintainer-clean
diff --git a/admin/unidata/unidata-gen.el b/admin/unidata/unidata-gen.el
index 221c9b1..abd41e3 100644
--- a/admin/unidata/unidata-gen.el
+++ b/admin/unidata/unidata-gen.el
@@ -1,4 +1,4 @@
-;; unidata-gen.el -- Create files containing character property data -*-
lexical-binding:t -*-
+;;; unidata-gen.el --- Create files containing character property data -*-
lexical-binding:t -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -1446,7 +1446,7 @@ Property value is a symbol `o' (Open), `c' (Close), or
`n' (None)."
";; no-byte-compile: t\n"
";; no-update-autoloads: t\n"
";; End:\n\n"
- (format ";; %s ends here\n" basename)))))
+ (format ";;; %s ends here\n" basename)))))
(or noninteractive (message "Generating %s...done" file)))
(defun unidata-gen-charprop (&optional charprop-file)
@@ -1470,7 +1470,7 @@ Property value is a symbol `o' (Open), `c' (Close), or
`n' (None)."
";; no-byte-compile: t\n"
";; no-update-autoloads: t\n"
";; End:\n\n"
- (format ";; %s ends here\n"
+ (format ";;; %s ends here\n"
(file-name-nondirectory charprop-file)))))
diff --git a/admin/update_autogen b/admin/update_autogen
index 35c391d..11c4313 100755
--- a/admin/update_autogen
+++ b/admin/update_autogen
@@ -317,7 +317,7 @@ EOF
echo "Finding loaddef targets..."
find lisp -name '*.el' -exec grep '^;.*generated-autoload-file:' {} + | \
- sed -e '/loaddefs\|esh-groups/d' -e 's|/[^/]*: "|/|' -e 's/"//g' \
+ sed -e '/loaddefs\|esh-groups/d' -e 's|/[^/]*: "|/|' -e 's/"//g' \
>| $tempfile || die "Error finding targets"
genfiles=
@@ -363,17 +363,23 @@ make -C lisp "$@" autoloads EMACS=../src/bootstrap-emacs
|| die "make src error"
## Ignore comment differences.
-[ ! "$lboot_flag" ] || \
+[ ! "$lboot_flag" ] || \
diff -q -I '^;' $ldefs_in $ldefs_out || \
cp $ldefs_in $ldefs_out || die "cp ldefs_boot error"
+# Refresh the prebuilt grammar-wy.el
+grammar_in=lisp/cedet/semantic/grammar-wy.el
+grammar_out=lisp/cedet/semantic/grm-wy-boot.el
+make -C admin/grammars/ ../../$grammar_in
+cp $grammar_in $grammar_out || die "cp grm_wy_boot error"
+
echo "Checking status of loaddef files..."
## It probably would be fine to just check+commit lisp/, since
## making autoloads should not effect any other files. But better
## safe than sorry.
-modified=$(status $genfiles $ldefs_out) || die
+modified=$(status $genfiles $ldefs_out $grammar_out) || die
commit "loaddefs" $modified || die "commit error"
diff --git a/configure.ac b/configure.ac
index 2c62a9f..3df4359 100644
--- a/configure.ac
+++ b/configure.ac
@@ -187,7 +187,8 @@ dnl It is important that variables on the RHS not be
expanded here,
dnl hence the single quotes. This is per the GNU coding standards, see
dnl (autoconf) Installation Directory Variables
dnl See also epaths.h below.
-lispdir='${datadir}/emacs/${version}/lisp'
+lispdirrel='${version}/lisp'
+lispdir='${datadir}/emacs/'${lispdirrel}
standardlisppath='${lispdir}'
locallisppath='${datadir}/emacs/${version}/site-lisp:'\
'${datadir}/emacs/site-lisp'
@@ -483,6 +484,7 @@ OPTION_DEFAULT_ON([gnutls],[don't use -lgnutls for SSL/TLS
support])
OPTION_DEFAULT_ON([zlib],[don't compile with zlib decompression support])
OPTION_DEFAULT_ON([modules],[don't compile with dynamic modules support])
OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support])
+OPTION_DEFAULT_OFF([native-compilation],[compile with Emacs Lisp native
compiler support])
AC_ARG_WITH([file-notification],[AS_HELP_STRING([--with-file-notification=LIB],
[use a file notification library (LIB one of: yes, inotify, kqueue, gfile,
w32, no)])],
@@ -1889,6 +1891,7 @@ if test "${with_ns}" != no; then
# so avoid NS_IMPL_COCOA if macuvs.h is absent.
# Even a headless Emacs can build macuvs.h, so this should let you bootstrap.
if test "${opsys}" = darwin && test -f "$srcdir/src/macuvs.h"; then
+ lispdirrel=Contents/Resources/lisp
NS_IMPL_COCOA=yes
ns_appdir=`pwd`/nextstep/Emacs.app
ns_appbindir=${ns_appdir}/Contents/MacOS
@@ -3660,6 +3663,7 @@ AC_SUBST(LIBZ)
LIBMODULES=
HAVE_MODULES=no
MODULES_OBJ=
+NEED_DYNLIB=no
case $opsys in
cygwin|mingw32) MODULES_SUFFIX=".dll" ;;
darwin) MODULES_SUFFIX=".dylib" ;;
@@ -3695,7 +3699,8 @@ if test "${with_modules}" != "no"; then
fi
if test "${HAVE_MODULES}" = yes; then
- MODULES_OBJ="dynlib.o emacs-module.o"
+ MODULES_OBJ="emacs-module.o"
+ NEED_DYNLIB=yes
AC_DEFINE(HAVE_MODULES, 1, [Define to 1 if dynamic modules are enabled])
AC_DEFINE_UNQUOTED(MODULES_SUFFIX, "$MODULES_SUFFIX",
[System extension for dynamic libraries])
@@ -3722,6 +3727,124 @@ module_env_snippet_28="$srcdir/src/module-env-28.h"
emacs_major_version="${PACKAGE_VERSION%%.*}"
AC_SUBST(emacs_major_version)
+### Emacs Lisp native compiler support
+
+AC_DEFUN([libgccjit_smoke_test], [
+ AC_LANG_SOURCE(
+ [[#include <libgccjit.h>
+ #include <stdlib.h>
+ #include <stdio.h>
+ int
+ main (int argc, char **argv)
+ {
+ gcc_jit_context *ctxt;
+ gcc_jit_result *result;
+ ctxt = gcc_jit_context_acquire ();
+ if (!ctxt)
+ exit (1);
+ gcc_jit_type *int_type =
+ gcc_jit_context_get_type (ctxt, GCC_JIT_TYPE_INT);
+ gcc_jit_function *func =
+ gcc_jit_context_new_function (ctxt, NULL,
+ GCC_JIT_FUNCTION_EXPORTED,
+ int_type, "foo", 0, NULL, 0);
+ gcc_jit_block *block = gcc_jit_function_new_block (func, "foo");
+ gcc_jit_block_end_with_return (
+ block,
+ NULL,
+ gcc_jit_context_new_rvalue_from_int (ctxt, int_type, 1));
+ result = gcc_jit_context_compile (ctxt);
+ if (!result)
+ exit (1);
+ typedef int (*fn_type) (void);
+ fn_type foo =
+ (fn_type)gcc_jit_result_get_code (result, "foo");
+ if (!foo)
+ exit (1);
+ if (foo () != 1)
+ exit (1);
+ gcc_jit_context_release (ctxt);
+ gcc_jit_result_release (result);
+ return 0;
+ }]])])
+
+AC_DEFUN([libgccjit_not_found], [
+ AC_MSG_ERROR([elisp native compiler requested but libgccjit not found.
+Please try installing libgccjit or similar package.
+If you are sure you want Emacs compiled without elisp native compiler, pass
+ --without-native-compilation
+to configure.])])
+
+AC_DEFUN([libgccjit_dev_not_found], [
+ AC_MSG_ERROR([elisp native compiler requested but libgccjit header files were
+not found.
+Please try installing libgccjit-dev or similar package.
+If you are sure you want Emacs compiled without elisp native compiler, pass
+--without-nativecomp
+to configure.])])
+
+AC_DEFUN([libgccjit_broken], [
+ AC_MSG_ERROR([Installed libgccjit has failed passing the smoke test.
+You can verify it yourself compiling:
+<https://gcc.gnu.org/onlinedocs/jit/intro/tutorial01.html>.
+Please report the issue to your distribution if libgccjit was installed through
+that.
+Here instructions on how to compile and install libgccjit from source:
+<https://gcc.gnu.org/wiki/JIT>.])])
+
+HAVE_NATIVE_COMP=no
+LIBGCCJIT_LIB=
+if test "${with_native_compilation}" != "no"; then
+ if test "${HAVE_PDUMPER}" = no; then
+ AC_MSG_ERROR(['--with-nativecomp' requires '--with-dumping=pdumper'])
+ fi
+ if test "${HAVE_ZLIB}" = no; then
+ AC_MSG_ERROR(['--with-nativecomp' requires zlib])
+ fi
+
+ # Ensure libgccjit installed by Homebrew can be found.
+ if test -n "$BREW"; then
+ BREW_LIBGCCJIT_PREFIX=`$BREW --prefix --installed libgccjit 2>/dev/null`
+ if test "$BREW_LIBGCCJIT_PREFIX"; then
+ brew_libdir=`find ${BREW_LIBGCCJIT_PREFIX}/ -name \*.so \
+ | sed -e '1!d;s|/[[^/]]*\.so$||'`
+ CFLAGS="$CFLAGS -I${BREW_LIBGCCJIT_PREFIX}/include"
+ LDFLAGS="$LDFLAGS -L${brew_libdir} -I${BREW_LIBGCCJIT_PREFIX}/include"
+ fi
+ fi
+
+ # Check if libgccjit is available.
+ AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, [], [libgccjit_not_found])
+ AC_CHECK_HEADERS(libgccjit.h, [], [libgccjit_dev_not_found])
+ emacs_save_LIBS=$LIBS
+ LIBS="-lgccjit"
+ # Check if libgccjit really works.
+ AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken])
+ LIBS=$emacs_save_LIBS
+ HAVE_NATIVE_COMP=yes
+ case "${opsys}" in
+ # mingw32 loads the library dynamically.
+ mingw32) ;;
+ # OpenBSD doesn't have libdl, all the functions are in libc
+ netbsd|openbsd)
+ LIBGCCJIT_LIB="-lgccjit" ;;
+ *)
+ LIBGCCJIT_LIB="-lgccjit -ldl" ;;
+ esac
+ NEED_DYNLIB=yes
+ AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if native compiler is
available.])
+fi
+AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln",
+ [System extension for native compiled elisp])
+AC_SUBST(HAVE_NATIVE_COMP)
+AC_SUBST(LIBGCCJIT_LIB)
+
+DYNLIB_OBJ=
+if test "${NEED_DYNLIB}" = yes; then
+ DYNLIB_OBJ="dynlib.o"
+fi
+AC_SUBST(DYNLIB_OBJ)
+
### Use -lpng if available, unless '--with-png=no'.
HAVE_PNG=no
LIBPNG=
@@ -4179,6 +4302,22 @@ fi
AC_SUBST([BLESSMAIL_TARGET])
AC_SUBST([LIBS_MAIL])
+HAVE_SECCOMP=no
+AC_CHECK_HEADERS(
+ [linux/seccomp.h linux/filter.h],
+ [AC_CHECK_DECLS(
+ [SECCOMP_SET_MODE_FILTER, SECCOMP_FILTER_FLAG_TSYNC],
+ [HAVE_SECCOMP=yes], [],
+ [[
+ #include <linux/seccomp.h>
+ ]])])
+AC_SUBST([HAVE_SECCOMP])
+
+EMACS_CHECK_MODULES([LIBSECCOMP], [libseccomp >= 2.4.0])
+AC_SUBST([HAVE_LIBSECCOMP])
+AC_SUBST([LIBSECCOMP_LIBS])
+AC_SUBST([LIBSECCOMP_CFLAGS])
+
OLD_LIBS=$LIBS
LIBS="$LIB_PTHREAD $LIB_MATH $LIBS"
AC_CHECK_FUNCS(accept4 fchdir gethostname \
@@ -4186,7 +4325,7 @@ getrusage get_current_dir_name \
lrand48 random rint trunc \
select getpagesize setlocale newlocale \
getrlimit setrlimit shutdown \
-pthread_sigmask strsignal setitimer timer_getoverrun \
+pthread_sigmask strsignal setitimer \
sendto recvfrom getsockname getifaddrs freeifaddrs \
gai_strerror sync \
getpwent endpwent getgrent endgrent \
@@ -5242,6 +5381,7 @@ AC_SUBST(sharedstatedir)
AC_SUBST(libexecdir)
AC_SUBST(mandir)
AC_SUBST(infodir)
+AC_SUBST(lispdirrel)
AC_SUBST(lispdir)
AC_SUBST(standardlisppath)
AC_SUBST(locallisppath)
@@ -5483,6 +5623,12 @@ gl_INIT
CFLAGS=$SAVE_CFLAGS
LIBS=$SAVE_LIBS
+# timer_getoverrun needs the same libarary as timer_settime
+OLD_LIBS=$LIBS
+LIBS="$LIB_TIMER_TIME $LIBS"
+AC_CHECK_FUNCS(timer_getoverrun)
+LIBS=$OLD_LIBS
+
if test "${opsys}" = "mingw32"; then
CPPFLAGS="$CPPFLAGS -DUSE_CRT_DLL=1 -I \${abs_top_srcdir}/nt/inc"
# Remove unneeded switches from the value of CC that goes to Makefiles
@@ -5538,6 +5684,13 @@ case "$opsys" in
x86_64-*-*) LD_SWITCH_SYSTEM_TEMACS="-Wl,-stack,0x00800000
-Wl,-heap,0x00100000 -Wl,-image-base,0x400000000 -Wl,-entry,__start
-Wl,-Map,./temacs.map" ;;
*) LD_SWITCH_SYSTEM_TEMACS="-Wl,-stack,0x00800000 -Wl,-heap,0x00100000
-Wl,-image-base,0x01000000 -Wl,-entry,__start -Wl,-Map,./temacs.map" ;;
esac
+ ## If they want unexec, disable Windows ASLR for the Emacs binary
+ if test "$with_dumping" = "unexec"; then
+ case "$canonical" in
+ x86_64-*-*) LD_SWITCH_SYSTEM_TEMACS="$LD_SWITCH_SYSTEM_TEMACS
-Wl,-disable-dynamicbase -Wl,-disable-high-entropy-va
-Wl,-default-image-base-low" ;;
+ *) LD_SWITCH_SYSTEM_TEMACS="$LD_SWITCH_SYSTEM_TEMACS
-Wl,-disable-dynamicbase" ;;
+ esac
+ fi
;;
*) LD_SWITCH_SYSTEM_TEMACS= ;;
@@ -5672,7 +5825,8 @@ optsep=
emacs_config_features=
for opt in ACL CAIRO DBUS FREETYPE GCONF GIF GLIB GMP GNUTLS GPM GSETTINGS \
HARFBUZZ IMAGEMAGICK JPEG JSON LCMS2 LIBOTF LIBSELINUX LIBSYSTEMD LIBXML2 \
- M17N_FLT MODULES NOTIFY NS OLDXMENU PDUMPER PNG RSVG SOUND THREADS TIFF \
+ M17N_FLT MODULES NATIVE_COMP NOTIFY NS OLDXMENU PDUMPER PNG RSVG SECCOMP \
+ SOUND THREADS TIFF \
TOOLKIT_SCROLL_BARS UNEXEC X11 XAW3D XDBE XFT XIM XPM XWIDGETS X_TOOLKIT \
ZLIB; do
@@ -5748,6 +5902,7 @@ AS_ECHO([" Does Emacs use -lXaw3d?
${HAVE_XAW3D
Does Emacs support the portable dumper? ${with_pdumper}
Does Emacs support legacy unexec dumping? ${with_unexec}
Which dumping strategy does Emacs use? ${with_dumping}
+ Does Emacs have native lisp compiler? ${HAVE_NATIVE_COMP}
"])
if test -n "${EMACSDATA}"; then
diff --git a/doc/emacs/buffers.texi b/doc/emacs/buffers.texi
index 3a166e4..bec7f37 100644
--- a/doc/emacs/buffers.texi
+++ b/doc/emacs/buffers.texi
@@ -765,6 +765,15 @@ your initialization file (@pxref{Init File}):
the variable @code{fido-mode} to @code{t} (@pxref{Easy
Customization}).
+@findex icomplete-vertical-mode
+@cindex Icomplete vertical mode
+
+ Icomplete mode and Fido mode display the possible completions on the
+same line as the prompt by default. To display the completion candidates
+vertically under the prompt, type @kbd{M-x icomplete-vertical-mode}, or
+customize the variable @code{icomplete-vertical-mode} to @code{t}
+(@pxref{Easy Customization}).
+
@node Buffer Menus
@subsection Customizing Buffer Menus
diff --git a/doc/emacs/emacs.texi b/doc/emacs/emacs.texi
index 925c701..590dc42 100644
--- a/doc/emacs/emacs.texi
+++ b/doc/emacs/emacs.texi
@@ -159,7 +159,7 @@ Fundamental Editing Commands
Important Text-Changing Commands
* Mark:: The mark: how to delimit a region of text.
-* Killing:: Killing (cutting) and yanking (copying) text.
+* Killing:: Killing (cutting) and yanking (pasting) text.
* Registers:: Saving a text string or a location in the buffer.
* Display:: Controlling what text is displayed.
* Search:: Finding or replacing occurrences of a string.
diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi
index dfe4eb0..880829a 100644
--- a/doc/emacs/maintaining.texi
+++ b/doc/emacs/maintaining.texi
@@ -2213,7 +2213,8 @@ the special XREF mode:
@table @kbd
@item @key{RET}
@itemx mouse-2
-Display the reference on the current line.
+Display the reference on the current line (@code{xref-goto-xref}).
+With prefix argument, also bury the @file{*xref*} buffer.
@item n
@itemx .
@@ -2242,11 +2243,6 @@ display it in the other window (@code{xref-prev-group}).
Display the reference on the current line in the other window
(@code{xref-show-location-at-point}).
-@item @key{TAB}
-@findex xref-quit-and-goto-xref
-Display the reference on the current line and bury the @file{*xref*}
-buffer (@code{xref-quit-and-goto-xref}).
-
@item r @var{pattern} @key{RET} @var{replacement} @key{RET}
Perform interactive query-replace on references that match
@var{pattern} (@code{xref-query-replace-in-results}), replacing
diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi
index d0865c5..03db669 100644
--- a/doc/emacs/mini.texi
+++ b/doc/emacs/mini.texi
@@ -64,10 +64,10 @@ minibuffer-electric-default-mode}.
Since the minibuffer appears in the echo area, it can conflict with
other uses of the echo area. If an error message or an informative
-message is emitted while the minibuffer is active, the message hides
-the minibuffer for a few seconds, or until you type something; then
-the minibuffer comes back. While the minibuffer is in use, Emacs does
-not echo keystrokes.
+message is emitted while the minibuffer is active, the message is
+displayed in brackets after the minibuffer text for a few seconds, or
+until you type something; then the message disappears. While the
+minibuffer is in use, Emacs does not echo keystrokes.
@vindex minibuffer-follows-selected-frame
While using the minibuffer, you can switch to a different frame,
@@ -247,6 +247,9 @@ You might need also to enable
@code{minibuffer-depth-indicate-mode}
to show the current recursion depth in the minibuffer prompt
on recursive use of the minibuffer.
+ When active, the minibuffer is usually in @code{minibuffer-mode}.
+This is an internal Emacs mode without any special features.
+
@findex minibuffer-inactive-mode
When not active, the minibuffer is in @code{minibuffer-inactive-mode},
and clicking @kbd{mouse-1} there shows the @file{*Messages*} buffer.
diff --git a/doc/emacs/search.texi b/doc/emacs/search.texi
index f3c42bc..38430a2 100644
--- a/doc/emacs/search.texi
+++ b/doc/emacs/search.texi
@@ -201,6 +201,14 @@ something before the starting point, type @kbd{C-r} to
switch to a
backward search, leaving the search string unchanged. Similarly,
@kbd{C-s} in a backward search switches to a forward search.
+@cindex search, changing direction
+@vindex isearch-repeat-on-direction-change
+ When you change the direction of a search, the first command you
+type will, by default, remain on the same match, and the cursor will
+move to the other end of the match. To move to another match
+immediately, customize the variable
+@code{isearch-repeat-on-direction-change} to @code{t}.
+
@cindex search, wrapping around
@cindex search, overwrapped
@cindex wrapped search
diff --git a/doc/emacs/text.texi b/doc/emacs/text.texi
index 54e1669..2c9d486 100644
--- a/doc/emacs/text.texi
+++ b/doc/emacs/text.texi
@@ -502,8 +502,8 @@ text.
@cindex mode, Auto Fill
@dfn{Auto Fill} mode is a buffer-local minor mode (@pxref{Minor
-Modes}) in which lines are broken automatically at spaces when the
-line becomes too wide.
+Modes}) in which lines are broken automatically when the line becomes
+too wide and you type @kbd{@key{SPC}} or @kbd{@key{RET}}.
@table @kbd
@item M-x auto-fill-mode
@@ -522,12 +522,21 @@ certain major modes, add @code{auto-fill-mode} to the
mode hooks
(@pxref{Major Modes}). When Auto Fill mode is enabled, the mode
indicator @samp{Fill} appears in the mode line (@pxref{Mode Line}).
- Auto Fill mode breaks lines automatically at spaces whenever they
-get longer than the desired width. This line breaking occurs only
-when you type @key{SPC} or @key{RET}. If you wish to insert a space
-or newline without permitting line-breaking, type @kbd{C-q @key{SPC}}
-or @kbd{C-q C-j} respectively. Also, @kbd{C-o} inserts a newline
-without line breaking.
+ Auto Fill mode breaks lines automatically at the appropriate places
+whenever lines get longer than the desired width. This line breaking
+occurs only when you type @kbd{@key{SPC}} or @kbd{@key{RET}}. If you
+wish to insert a space or newline without permitting line-breaking,
+type @kbd{C-q @key{SPC}} or @kbd{C-q C-j} respectively. Also,
+@kbd{C-o} inserts a newline without line breaking.
+
+@cindex kinsoku line-breaking rules
+ The place where Auto Fill breaks a line depends on the line's
+characters. For characters from @acronym{ASCII}, Latin, and most
+other scripts Emacs breaks a line on space characters, to keep the
+words intact. But for CJK scripts, a line can be broken between any
+two characters. (If you load the @file{kinsoku} library, Emacs will
+avoid breaking a line between certain pairs of CJK characters, where
+special rules prohibit that.)
When Auto Fill mode breaks a line, it tries to obey the
@dfn{adaptive fill prefix}: if a fill prefix can be deduced from the
@@ -549,6 +558,9 @@ described in the next section.
(@pxref{Fill Commands}).
@end ifnottex
+ A similar feature that wraps long lines automatically at display
+time is Visual Line Mode (@pxref{Visual Line Mode}).
+
@node Fill Commands
@subsection Explicit Fill Commands
@@ -571,7 +583,11 @@ Center a line.
current paragraph. It redistributes the line breaks within the
paragraph, and deletes any excess space and tab characters occurring
within the paragraph, in such a way that the lines end up fitting
-within a certain maximum width.
+within a certain maximum width. Like Auto Fill mode, this and other
+filling commands usually break lines at space characters, but for CJK
+characters these commands can break a line between almost any two
+characters, and they can also obey the kinsoku rules. @xref{Auto
+Fill}.
@findex fill-region
Normally, @kbd{M-q} acts on the paragraph where point is, but if
@@ -645,8 +661,8 @@ or before @samp{)}, @samp{:} or @samp{?}); and
even if preceded by a non-whitespace character).
Emacs can display an indicator in the @code{fill-column} position
-using the Display fill column indicator mode
-(@pxref{Displaying Boundaries, display-fill-column-indicator}).
+using the Display fill column indicator mode (@pxref{Displaying
+Boundaries, display-fill-column-indicator}).
@node Fill Prefix
@subsection The Fill Prefix
diff --git a/doc/lispintro/emacs-lisp-intro.texi
b/doc/lispintro/emacs-lisp-intro.texi
index 5b15a45..fade409 100644
--- a/doc/lispintro/emacs-lisp-intro.texi
+++ b/doc/lispintro/emacs-lisp-intro.texi
@@ -1364,19 +1364,6 @@ C-e}:
(this is an unquoted list)
@end smallexample
-@ignore
-@noindent
-What you see depends on which version of Emacs you are running. GNU
-Emacs version 22 provides more information than version 20 and before.
-First, the more recent result of generating an error; then the
-earlier, version 20 result.
-
-@need 1250
-@noindent
-In GNU Emacs version 22, a @file{*Backtrace*} window will open up and
-you will see the following in it:
-@end ignore
-
A @file{*Backtrace*} window will open up and you should see the
following in it:
@@ -1838,19 +1825,6 @@ Debugger entered--Lisp error: (void-function fill-column)
(Remember, to quit the debugger and make the debugger window go away,
type @kbd{q} in the @file{*Backtrace*} buffer.)
-@ignore
-@need 800
-In GNU Emacs 20 and before, you will produce an error message that says:
-
-@smallexample
-Symbol's function definition is void:@: fill-column
-@end smallexample
-
-@noindent
-(The message will go away as soon as you move the cursor or type
-another key.)
-@end ignore
-
@node Void Variable
@subsection Error Message for a Symbol Without a Value
@cindex Symbol without value error
@@ -1907,18 +1881,6 @@ Since @code{+} does not have a value bound to it, just
the function
definition, the error message reported that the symbol's value as a
variable was void.
-@ignore
-@need 800
-In GNU Emacs version 20 and before, your error message will say:
-
-@example
-Symbol's value as variable is void:@: +
-@end example
-
-@noindent
-The meaning is the same as in GNU Emacs 22.
-@end ignore
-
@node Arguments
@section Arguments
@cindex Arguments
@@ -2197,19 +2159,6 @@ addition had been passed the correct type of object, the
value passed
would have been a number, such as 37, rather than a symbol like
@code{hello}. But then you would not have got the error message.
-@ignore
-@need 1250
-In GNU Emacs version 20 and before, the echo area displays an error
-message that says:
-
-@smallexample
-Wrong type argument:@: number-or-marker-p, hello
-@end smallexample
-
-This says, in different words, the same as the top line of the
-@file{*Backtrace*} buffer.
-@end ignore
-
@node message
@subsection The @code{message} Function
@findex message
@@ -6663,9 +6612,9 @@ original text of the function:
@end group
@end smallexample
-(In recent versions of GNU Emacs, the @code{what-line} function has
+(In modern versions of GNU Emacs, the @code{what-line} function has
been expanded to tell you your line number in a narrowed buffer as
-well as your line number in a widened buffer. The recent version is
+well as your line number in a widened buffer. The modern version is
more complex than the version shown here. If you feel adventurous,
you might want to look at it after figuring out how this version
works. You will probably need to use @kbd{C-h f}
@@ -10392,9 +10341,8 @@ echo area:
@code{^Jgazelle^J^Jgiraffe^J^Jlion^J^Jtiger^Jnil}, in which
each @samp{^J} stands for a newline.)
@need 1500
-In a recent instance of GNU Emacs, you can evaluate these expressions
-directly in the Info buffer, and the echo area will grow to show the
-results.
+You can evaluate these expressions directly in the Info buffer, and
+the echo area will grow to show the results.
@smallexample
@group
@@ -18104,8 +18052,7 @@ argument of 4:
@end smallexample
@noindent
-In a recent GNU Emacs, you will create and enter a @file{*Backtrace*}
-buffer that says:
+This will create and enter a @file{*Backtrace*} buffer that says:
@noindent
@smallexample
@@ -18139,25 +18086,12 @@ In practice, for a bug as simple as this, the Lisp
error line will
tell you what you need to know to correct the definition. The
function @code{1=} is void.
-@ignore
-@need 800
-In GNU Emacs 20 and before, you will see:
-
-@smallexample
-Symbol's function definition is void:@: 1=
-@end smallexample
-
-@noindent
-which has the same meaning as the @file{*Backtrace*} buffer line in
-version 21.
-@end ignore
-
However, suppose you are not quite certain what is going on?
You can read the complete backtrace.
-In this case, you need to run a recent GNU Emacs, which automatically
-starts the debugger that puts you in the @file{*Backtrace*} buffer; or
-else, you need to start the debugger manually as described below.
+Emacs automatically starts the debugger that puts you in the
+@file{*Backtrace*} buffer. You can also start the debugger manually
+as described below.
Read the @file{*Backtrace*} buffer from the bottom up; it tells you
what Emacs did that led to the error. Emacs made an interactive call
@@ -18197,14 +18131,8 @@ then run your test again.
@section @code{debug-on-entry}
@findex debug-on-entry
-A recent GNU Emacs starts the debugger automatically when your
-function has an error.
-
-@ignore
-GNU Emacs version 20 and before did not; it simply
-presented you with an error message. You had to start the debugger
-manually.
-@end ignore
+Emacs starts the debugger automatically when your function has an
+error.
Incidentally, you can start the debugger manually for all versions of
Emacs; the advantage is that the debugger runs even if you do not have
@@ -20079,8 +20007,8 @@ the tic marks themselves and their spacing:
@code{defvar}. The @code{boundp} predicate checks whether it has
already been set; @code{boundp} returns @code{nil} if it has not. If
@code{graph-blank} were unbound and we did not use this conditional
-construction, in a recent GNU Emacs, we would enter the debugger and
-see an error message saying @samp{@w{Debugger entered--Lisp error:}
+construction, we would enter the debugger and see an error message
+saying @samp{@w{Debugger entered--Lisp error:}
@w{(void-variable graph-blank)}}.)
@need 1200
diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index 3388102..22b665b 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -2012,7 +2012,8 @@ that can be handled).
This special form establishes the error handlers @var{handlers} around
the execution of @var{protected-form}. If @var{protected-form} executes
without error, the value it returns becomes the value of the
-@code{condition-case} form; in this case, the @code{condition-case} has
+@code{condition-case} form (in the absence of a success handler; see below).
+In this case, the @code{condition-case} has
no effect. The @code{condition-case} form makes a difference when an
error occurs during @var{protected-form}.
@@ -2062,6 +2063,12 @@ error description.
If @var{var} is @code{nil}, that means no variable is bound. Then the
error symbol and associated data are not available to the handler.
+@cindex success handler
+As a special case, one of the @var{handlers} can be a list of the
+form @code{(:success @var{body}@dots{})}, where @var{body} is executed
+with @var{var} (if non-@code{nil}) bound to the return value of
+@var{protected-form} when that expression terminates without error.
+
@cindex rethrow a signal
Sometimes it is necessary to re-throw a signal caught by
@code{condition-case}, for some outer-level handler to catch. Here's
diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index 2e1b4a6..228c940 100644
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -1965,9 +1965,18 @@ Tables}). The width of a tab character is usually
@code{tab-width}
(@pxref{Usual Display}).
@end defun
-@defun string-width string
+@defun string-width string &optional from to
This function returns the width in columns of the string @var{string},
if it were displayed in the current buffer and the selected window.
+Optional arguments @var{from} and @var{to} specify the substring of
+@var{string} to consider, and are interpreted as in @code{substring}
+(@pxref{Creating Strings}).
+
+The return value is an approximation: it only considers the values
+returned by @code{char-width} for the constituent characters, always
+takes a tab character as taking @code{tab-width} columns, ignores
+display properties and fonts, etc. For these reasons, we recommend
+using @code{window-text-pixel-size}, described below, instead.
@end defun
@defun truncate-string-to-width string width &optional start-column padding
ellipsis ellipsis-text-property
@@ -4752,6 +4761,7 @@ window on a minibuffer-less frame.
@node Display Property
@section The @code{display} Property
@cindex display specification
+@cindex display property
@kindex display @r{(text property)}
The @code{display} text property (or overlay property) is used to
@@ -5289,6 +5299,16 @@ where @var{props} is a property list of alternating
keyword symbols
and values, including at least the pair @code{:type @var{type}} that
specifies the image type.
+ Image descriptors which define image dimensions, @code{:width},
+@code{:height}, @code{:max-width} and @code{:max-height}, may take
+either an integer, which represents the dimension in pixels, or a pair
+@code{(@var{value} . em)}, where @var{value} is the dimension's
+length in @dfn{ems}@footnote{In typography an em is a distance
+equivalent to the height of the type. For example when using 12 point
+type 1 em is equal to 12 points. Its use ensures distances and type
+remain proportional.}. One em is equivalent to the height of the font
+and @var{value} may be an integer or a float.
+
The following is a list of properties that are meaningful for all
image types (there are also properties which are meaningful only for
certain image types, as documented in the following subsections):
@@ -5751,6 +5771,28 @@ Cropping is performed after scaling but before rotation.
@cindex SVG images
SVG (Scalable Vector Graphics) is an XML format for specifying images.
+SVG images support the following additional image descriptor
+properties:
+
+@table @code
+@item :foreground @var{foreground}
+@var{foreground}, if non-@code{nil}, should be a string specifying a
+color, which is used as the image's foreground color. If the value is
+@code{nil}, it defaults to the current face's foreground color.
+
+@item :background @var{background}
+@var{background}, if non-@code{nil}, should be a string specifying a
+color, which is used as the image's background color if the image
+supports transparency. If the value is @code{nil}, it defaults to the
+current face's background color.
+
+@item :css @var{css}
+@var{css}, if non-@code{nil}, should be a string specifying the CSS to
+override the default CSS used when generating the image.
+@end table
+
+@subsubheading SVG library
+
If your Emacs build has SVG support, you can create and manipulate
these images with the following functions from the @file{svg.el}
library.
diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi
index 8942f55..323130f 100644
--- a/doc/lispref/edebug.texi
+++ b/doc/lispref/edebug.texi
@@ -1510,11 +1510,11 @@ form specifications (that is, @code{form}, @code{body},
@code{def-form}, and
must be in the form itself rather than at a higher level.
Backtracking is also disabled after successfully matching a quoted
-symbol or string specification, since this usually indicates a
-recognized construct. But if you have a set of alternative constructs that
-all begin with the same symbol, you can usually work around this
-constraint by factoring the symbol out of the alternatives, e.g.,
-@code{["foo" &or [first case] [second case] ...]}.
+symbol, string specification, or @code{&define} keyword, since this
+usually indicates a recognized construct. But if you have a set of
+alternative constructs that all begin with the same symbol, you can
+usually work around this constraint by factoring the symbol out of the
+alternatives, e.g., @code{["foo" &or [first case] [second case] ...]}.
Most needs are satisfied by these two ways that backtracking is
automatically disabled, but occasionally it is useful to explicitly
diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi
index dade855..be0c835 100644
--- a/doc/lispref/elisp.texi
+++ b/doc/lispref/elisp.texi
@@ -531,6 +531,7 @@ Scoping Rules for Variable Bindings
* Dynamic Binding Tips:: Avoiding problems with dynamic binding.
* Lexical Binding:: A different type of local variable binding.
* Using Lexical Binding:: How to enable lexical binding.
+* Converting to Lexical Binding:: Convert existing code to lexical binding.
Buffer-Local Variables
diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi
index a8b921e..2033177 100644
--- a/doc/lispref/files.texi
+++ b/doc/lispref/files.texi
@@ -2244,7 +2244,7 @@ form.
A @dfn{directory name} is a string that must name a directory if it
names any file at all. A directory is actually a kind of file, and it
-has a file name (called the @dfn{directory file name}, which is
+has a file name (called the @dfn{directory file name}), which is
related to the directory name but is typically not identical. (This
is not quite the same as the usual POSIX terminology.) These two
names for the same entity are related by a syntactic transformation.
diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi
index cd2ff8f..a9d20c5 100644
--- a/doc/lispref/frames.texi
+++ b/doc/lispref/frames.texi
@@ -2628,7 +2628,7 @@ When Emacs gets one of these commands, it generates a
@code{delete-frame} event, whose normal definition is a command that
calls the function @code{delete-frame}. @xref{Misc Events}.
-@deffn Command delete-other-frames &optional frame
+@deffn Command delete-other-frames &optional frame iconify
This command deletes all frames on @var{frame}'s terminal, except
@var{frame}. If @var{frame} uses another frame's minibuffer, that
minibuffer frame is left untouched. The argument @var{frame} must
@@ -2639,6 +2639,9 @@ this command works by calling @code{delete-frame} with
@var{force}
This function does not delete any of @var{frame}'s child frames
(@pxref{Child Frames}). If @var{frame} is a child frame, it deletes
@var{frame}'s siblings only.
+
+With the prefix argument @var{iconify}, the frames are iconified rather
+than deleted.
@end deffn
diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi
index dabf985..4097c86 100644
--- a/doc/lispref/keymaps.texi
+++ b/doc/lispref/keymaps.texi
@@ -1686,7 +1686,7 @@ presence of such a binding can still prevent translation
from taking place.
For example, let us return to our VT100 example above and add a binding for
@kbd{C-c @key{ESC}} to the global map; now when the user hits @kbd{C-c
@key{PF1}} Emacs will fail to decode @kbd{C-c @key{ESC} O P} into @kbd{C-c
-@key{PF1}} because it will stop reading keys right after @kbd{C-x @key{ESC}},
+@key{PF1}} because it will stop reading keys right after @kbd{C-c @key{ESC}},
leaving @kbd{O P} for later. This is in case the user really hit @kbd{C-c
@key{ESC}}, in which case Emacs should not sit there waiting for the next key
to decide whether the user really pressed @kbd{@key{ESC}} or @kbd{@key{PF1}}.
@@ -2920,7 +2920,7 @@ menu item.
@item :active @var{enable}
@var{enable} is an expression; if it evaluates to @code{nil}, the item
-is make unselectable.. @code{:enable} is an alias for @code{:active}.
+is made unselectable. @code{:enable} is an alias for @code{:active}.
@item :visible @var{include}
@var{include} is an expression; if it evaluates to @code{nil}, the
diff --git a/doc/lispref/macros.texi b/doc/lispref/macros.texi
index e56a85c..b8df363 100644
--- a/doc/lispref/macros.texi
+++ b/doc/lispref/macros.texi
@@ -480,12 +480,16 @@ in expressions ordinarily.
Another problem can happen if the macro definition itself
evaluates any of the macro argument expressions, such as by calling
-@code{eval} (@pxref{Eval}). If the argument is supposed to refer to the
-user's variables, you may have trouble if the user happens to use a
-variable with the same name as one of the macro arguments. Inside the
-macro body, the macro argument binding is the most local binding of this
-variable, so any references inside the form being evaluated do refer to
-it. Here is an example:
+@code{eval} (@pxref{Eval}). You have to take into account that macro
+expansion may take place long before the code is executed, when the
+context of the caller (where the macro expansion will be evaluated) is
+not yet accessible.
+
+ Also, if your macro definition does not use @code{lexical-binding}, its
+formal arguments may hide the user's variables of the same name. Inside
+the macro body, the macro argument binding is the most local binding of
+such variable, so any references inside the form being evaluated do refer
+to it. Here is an example:
@example
@group
@@ -508,12 +512,10 @@ it. Here is an example:
@code{x}, because @code{a} conflicts with the macro argument variable
@code{a}.
- Another problem with calling @code{eval} in a macro definition is that
-it probably won't do what you intend in a compiled program. The
-byte compiler runs macro definitions while compiling the program, when
-the program's own computations (which you might have wished to access
-with @code{eval}) don't occur and its local variable bindings don't
-exist.
+ Also, the expansion of @code{(foo x)} above will return something
+different or signal an error when the code is compiled, since in that case
+@code{(foo x)} is expanded during compilation, whereas the execution of
+@code{(setq x 'b)} will only take place later when the code is executed.
To avoid these problems, @strong{don't evaluate an argument expression
while computing the macro expansion}. Instead, substitute the
diff --git a/doc/lispref/minibuf.texi b/doc/lispref/minibuf.texi
index d16409d..bc8868b 100644
--- a/doc/lispref/minibuf.texi
+++ b/doc/lispref/minibuf.texi
@@ -97,6 +97,14 @@ to be done. @xref{Text from Minibuffer}, for the
non-completion
minibuffer local maps. @xref{Completion Commands}, for the minibuffer
local maps for completion.
+@cindex active minibuffer
+ An active minibuffer usually has major mode @code{minibuffer-mode}.
+This is an Emacs internal mode without any special features. To
+customize the setup of minibuffers, we suggest you use
+@code{minibuffer-setup-hook} (@pxref{Minibuffer Misc}) rather than
+@code{minibuffer-mode-hook}, since the former is run later, after the
+minibuffer has been fully initialized.
+
@cindex inactive minibuffer
When a minibuffer is inactive, its major mode is
@code{minibuffer-inactive-mode}, with keymap
@@ -167,8 +175,10 @@ various applications such as completion.
The argument @var{history} specifies a history list variable to use
for saving the input and for history commands used in the minibuffer.
-It defaults to @code{minibuffer-history}. You can optionally specify
-a starting position in the history list as well. @xref{Minibuffer History}.
+It defaults to @code{minibuffer-history}. If @var{history} is the
+symbol @code{t}, history is not recorded. You can optionally specify
+a starting position in the history list as well. @xref{Minibuffer
+History}.
If the variable @code{minibuffer-allow-text-properties} is
non-@code{nil}, then the string that is returned includes whatever text
@@ -970,16 +980,19 @@ and @var{suffix} holds the text after point.
Normally completion operates on the whole string, so for all normal
collections, this will always return @code{(0 . (length
-@var{suffix}))}. But more complex completion such as completion on
-files is done one field at a time. For example, completion of
+@var{suffix}))}. But more complex completion, such as completion on
+files, is done one field at a time. For example, completion of
@code{"/usr/sh"} will include @code{"/usr/share/"} but not
@code{"/usr/share/doc"} even if @code{"/usr/share/doc"} exists.
Also @code{all-completions} on @code{"/usr/sh"} will not include
@code{"/usr/share/"} but only @code{"share/"}. So if @var{string} is
@code{"/usr/sh"} and @var{suffix} is @code{"e/doc"},
-@code{completion-boundaries} will return @code{(5 . 1)} which tells us
+@code{completion-boundaries} will return @w{@code{(5 . 1)}} which tells us
that the @var{collection} will only return completion information that
pertains to the area after @code{"/usr/"} and before @code{"/doc"}.
+@code{try-completion} is not affected by nontrivial boundaries; e.g.,
+@code{try-completion} on @code{"/usr/sh"} might still return
+@code{"/usr/share/"}, not @code{"share/"}.
@end defun
If you store a completion alist in a variable, you should mark the
@@ -1107,9 +1120,10 @@ The function @code{completing-read} uses
@code{minibuffer-local-must-match-map} if @var{require-match} is
non-@code{nil}. @xref{Completion Commands}.
-The argument @var{history} specifies which history list variable to use for
-saving the input and for minibuffer history commands. It defaults to
-@code{minibuffer-history}. @xref{Minibuffer History}.
+The argument @var{history} specifies which history list variable to
+use for saving the input and for minibuffer history commands. It
+defaults to @code{minibuffer-history}. If @var{history} is the symbol
+@code{t}, history is not recorded. @xref{Minibuffer History}.
The argument @var{initial} is mostly deprecated; we recommend using a
non-@code{nil} value only in conjunction with specifying a cons cell
@@ -1805,12 +1819,10 @@ default to that string.
@item :affixation-function
The value should be a function to add prefixes and suffixes to
completions. This function must accept one argument, a list of
-completions, and should return such a list of completions where
-each element contains a list of three elements: a completion,
-a prefix string, and a suffix string. When this function
-returns a list of two elements, it is interpreted as a list
-of a completion and a suffix string like in @code{:annotation-function}.
-This function takes priority over @code{:annotation-function}.
+completions, and should return a list of annotated completions. Each
+element of the returned list must be a three-element list, the
+completion, a prefix string, and a suffix string. This function takes
+priority over @code{:annotation-function}.
@item :exit-function
The value should be a function to run after performing completion.
@@ -1883,6 +1895,13 @@ should return @code{(boundaries @var{start} .
@var{end})}, where
string, and @var{end} is the position of the end boundary in
@var{suffix}.
+If a Lisp program returns nontrivial boundaries, it should make sure that the
+@code{all-completions} operation is consistent with them. The
+completions returned by @code{all-completions} should only pertain to
+the piece of the prefix and suffix covered by the completion
+boundaries. @xref{Basic Completion}, for the precise expected semantics
+of completion boundaries.
+
@item metadata
This specifies a request for information about the state of the
current completion. The return value should have the form
@@ -1921,10 +1940,8 @@ completions. The function should take one argument,
return such a list of @var{completions} where each element contains a list
of three elements: a completion, a prefix which is displayed before
the completion string in the @file{*Completions*} buffer, and
-a suffix displayed after the completion string. When this function
-returns a list of two elements, it is interpreted as a list of
-a completion and a suffix string like in @code{annotation-function}.
-This function takes priority over @code{annotation-function}.
+a suffix displayed after the completion string. This function
+takes priority over @code{annotation-function}.
@item display-sort-function
The value should be a function for sorting completions. The function
@@ -1961,7 +1978,7 @@ was entered.
The return value of @code{completion-table-dynamic} is a function that
can be used as the 2nd argument to @code{try-completion} and
@code{all-completions}. Note that this function will always return
-empty metadata and trivial boundaries (@pxref{Programmed Completion}).
+empty metadata and trivial boundaries.
@end defun
@defun completion-table-with-cache function &optional ignore-case
@@ -2218,9 +2235,10 @@ This function asks the user a series of questions,
reading a
single-character answer in the echo area for each one.
The value of @var{list} specifies the objects to ask questions about.
-It should be either a list of objects or a generator function. If it is
-a function, it should expect no arguments, and should return either the
-next object to ask about, or @code{nil}, meaning to stop asking questions.
+It should be either a list of objects or a generator function. If it
+is a function, it will be called with no arguments, and should return
+either the next object to ask about, or @code{nil}, meaning to stop
+asking questions.
The argument @var{prompter} specifies how to ask each question. If
@var{prompter} is a string, the question text is computed like this:
@@ -2231,19 +2249,20 @@ The argument @var{prompter} specifies how to ask each
question. If
@noindent
where @var{object} is the next object to ask about (as obtained from
-@var{list}).
+@var{list}). @xref{Formatting Strings}, for more information about
+@code{format}.
-If not a string, @var{prompter} should be a function of one argument
-(the next object to ask about) and should return the question text. If
-the value is a string, that is the question to ask the user. The
-function can also return @code{t}, meaning do act on this object (and
-don't ask the user), or @code{nil}, meaning ignore this object (and don't
-ask the user).
+If @var{prompter} is not a string, it should be a function of one
+argument (the object to ask about) and should return the question text
+for that object. If the value @var{prompter} returns is a string,
+that is the question to ask the user. The function can also return
+@code{t}, meaning to act on this object without asking the user, or
+@code{nil}, which means to silently ignore this object.
-The argument @var{actor} says how to act on the answers that the user
-gives. It should be a function of one argument, and it is called with
-each object that the user says yes for. Its argument is always an
-object obtained from @var{list}.
+The argument @var{actor} says how to act on the objects for which the
+user answers yes. It should be a function of one argument, and will
+be called with each object from @var{list} for which the user answers
+yes.
If the argument @var{help} is given, it should be a list of this form:
@@ -2253,34 +2272,49 @@ If the argument @var{help} is given, it should be a
list of this form:
@noindent
where @var{singular} is a string containing a singular noun that
-describes the objects conceptually being acted on, @var{plural} is the
+describes a single object to be acted on, @var{plural} is the
corresponding plural noun, and @var{action} is a transitive verb
-describing what @var{actor} does.
+describing what @var{actor} does with the objects.
+
+If you don't specify @var{help}, it defaults to the list
+@w{@code{("object" "objects" "act on")}}.
+
+Each time a question is asked, the user can answer as follows:
-If you don't specify @var{help}, the default is @code{("object"
-"objects" "act on")}.
+@table @asis
+@item @kbd{y}, @kbd{Y}, or @kbd{@key{SPC}}
+act on the object
+@item @kbd{n}, @kbd{N}, or @kbd{@key{DEL}}
+skip the object
+@item @kbd{!}
+act on all the following objects
+@item @kbd{@key{ESC}} or @kbd{q}
+exit (skip all following objects)
+@item @kbd{.} (period)
+act on the object and then exit
+@item @kbd{C-h}
+get help
+@end table
-Each time a question is asked, the user may enter @kbd{y}, @kbd{Y}, or
-@key{SPC} to act on that object; @kbd{n}, @kbd{N}, or @key{DEL} to skip
-that object; @kbd{!} to act on all following objects; @key{ESC} or
-@kbd{q} to exit (skip all following objects); @kbd{.} (period) to act on
-the current object and then exit; or @kbd{C-h} to get help. These are
-the same answers that @code{query-replace} accepts. The keymap
-@code{query-replace-map} defines their meaning for @code{map-y-or-n-p}
-as well as for @code{query-replace}; see @ref{Search and Replace}.
+@noindent
+These are the same answers that @code{query-replace} accepts. The
+keymap @code{query-replace-map} defines their meaning for
+@code{map-y-or-n-p} as well as for @code{query-replace}; see
+@ref{Search and Replace}.
You can use @var{action-alist} to specify additional possible answers
-and what they mean. It is an alist of elements of the form
-@code{(@var{char} @var{function} @var{help})}, each of which defines one
-additional answer. In this element, @var{char} is a character (the
+and what they mean. If provided, @var{action-alist} should be an
+alist whose elements are of the form @w{@code{(@var{char}
+@var{function} @var{help})}}. Each of the alist elements defines one
+additional answer. In each element, @var{char} is a character (the
answer); @var{function} is a function of one argument (an object from
-@var{list}); @var{help} is a string.
-
-When the user responds with @var{char}, @code{map-y-or-n-p} calls
-@var{function}. If it returns non-@code{nil}, the object is considered
-acted upon, and @code{map-y-or-n-p} advances to the next object in
-@var{list}. If it returns @code{nil}, the prompt is repeated for the
-same object.
+@var{list}); and @var{help} is a string. When the user responds with
+@var{char}, @code{map-y-or-n-p} calls @var{function}. If it returns
+non-@code{nil}, the object is considered to have been acted upon, and
+@code{map-y-or-n-p} advances to the next object in @var{list}. If it
+returns @code{nil}, the prompt is repeated for the same object. If
+the user requests help, the text in @var{help} is used to describe
+these additional answers.
Normally, @code{map-y-or-n-p} binds @code{cursor-in-echo-area} while
prompting. But if @var{no-cursor-in-echo-area} is non-@code{nil}, it
diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi
index 6cf4dd2..88f2f14 100644
--- a/doc/lispref/modes.texi
+++ b/doc/lispref/modes.texi
@@ -1660,7 +1660,7 @@ reserved for users. @xref{Key Binding Conventions}.
The macro @code{define-minor-mode} offers a convenient way of
implementing a mode in one self-contained definition.
-@defmac define-minor-mode mode doc [init-value [lighter [keymap]]]
keyword-args@dots{} body@dots{}
+@defmac define-minor-mode mode doc keyword-args@dots{} body@dots{}
This macro defines a new minor mode whose name is @var{mode} (a
symbol). It defines a command named @var{mode} to toggle the minor
mode, with @var{doc} as its documentation string.
@@ -1675,41 +1675,12 @@ If @var{doc} is @code{nil}, the macro supplies a
default documentation string
explaining the above.
By default, it also defines a variable named @var{mode}, which is set to
-@code{t} or @code{nil} by enabling or disabling the mode. The variable
-is initialized to @var{init-value}. Except in unusual circumstances
-(see below), this value must be @code{nil}.
+@code{t} or @code{nil} by enabling or disabling the mode.
-The string @var{lighter} says what to display in the mode line
-when the mode is enabled; if it is @code{nil}, the mode is not displayed
-in the mode line.
-
-The optional argument @var{keymap} specifies the keymap for the minor
-mode. If non-@code{nil}, it should be a variable name (whose value is
-a keymap), a keymap, or an alist of the form
-
-@example
-(@var{key-sequence} . @var{definition})
-@end example
-
-@noindent
-where each @var{key-sequence} and @var{definition} are arguments
-suitable for passing to @code{define-key} (@pxref{Changing Key
-Bindings}). If @var{keymap} is a keymap or an alist, this also
-defines the variable @code{@var{mode}-map}.
-
-The above three arguments @var{init-value}, @var{lighter}, and
-@var{keymap} can be (partially) omitted when @var{keyword-args} are
-used. The @var{keyword-args} consist of keywords followed by
+The @var{keyword-args} consist of keywords followed by
corresponding values. A few keywords have special meanings:
@table @code
-@item :group @var{group}
-Custom group name to use in all generated @code{defcustom} forms.
-Defaults to @var{mode} without the possible trailing @samp{-mode}.
-@strong{Warning:} don't use this default group name unless you have
-written a @code{defgroup} to define that group properly. @xref{Group
-Definitions}.
-
@item :global @var{global}
If non-@code{nil}, this specifies that the minor mode should be global
rather than buffer-local. It defaults to @code{nil}.
@@ -1719,19 +1690,34 @@ One of the effects of making a minor mode global is
that the
through the Customize interface turns the mode on and off, and its
value can be saved for future Emacs sessions (@pxref{Saving
Customizations,,, emacs, The GNU Emacs Manual}. For the saved
-variable to work, you should ensure that the @code{define-minor-mode}
-form is evaluated each time Emacs starts; for packages that are not
-part of Emacs, the easiest way to do this is to specify a
-@code{:require} keyword.
+variable to work, you should ensure that the minor mode function
+is available each time Emacs starts; usually this is done by
+marking the @code{define-minor-mode} form as autoloaded.
@item :init-value @var{init-value}
-This is equivalent to specifying @var{init-value} positionally.
+This is the value to which the @var{mode} variable is initialized.
+Except in unusual circumstances (see below), this value must be
+@code{nil}.
@item :lighter @var{lighter}
-This is equivalent to specifying @var{lighter} positionally.
+The string @var{lighter} says what to display in the mode line
+when the mode is enabled; if it is @code{nil}, the mode is not displayed
+in the mode line.
@item :keymap @var{keymap}
-This is equivalent to specifying @var{keymap} positionally.
+The optional argument @var{keymap} specifies the keymap for the minor
+mode. If non-@code{nil}, it should be a variable name (whose value is
+a keymap), a keymap, or an alist of the form
+
+@example
+(@var{key-sequence} . @var{definition})
+@end example
+
+@noindent
+where each @var{key-sequence} and @var{definition} are arguments
+suitable for passing to @code{define-key} (@pxref{Changing Key
+Bindings}). If @var{keymap} is a keymap or an alist, this also
+defines the variable @code{@var{mode}-map}.
@item :variable @var{place}
This replaces the default variable @var{mode}, used to store the state
diff --git a/doc/lispref/nonascii.texi b/doc/lispref/nonascii.texi
index 84f5d2f..c22930d 100644
--- a/doc/lispref/nonascii.texi
+++ b/doc/lispref/nonascii.texi
@@ -301,7 +301,7 @@ character, and returns that character. If @var{char} is
neither
@end defun
@defun unibyte-char-to-multibyte char
-This convert the unibyte character @var{char} to a multibyte
+This converts the unibyte character @var{char} to a multibyte
character, assuming @var{char} is either @acronym{ASCII} or raw 8-bit
byte.
@end defun
@@ -676,7 +676,7 @@ This function returns the value of @var{char}'s
@var{propname} property.
@end group
@group
(get-char-code-property ?\( 'paired-bracket)
- @result{} 41 ;; closing parenthesis
+ @result{} 41 ; closing parenthesis
@end group
@group
(get-char-code-property ?\) 'bracket-type)
@@ -955,13 +955,13 @@ translating the result.
@defvar standard-translation-table-for-decode
This is the default translation table for decoding. If a coding
-systems specifies its own translation tables, the table that is the
+system specifies its own translation tables, the table that is the
value of this variable, if non-@code{nil}, is applied after them.
@end defvar
@defvar standard-translation-table-for-encode
This is the default translation table for encoding. If a coding
-systems specifies its own translation tables, the table that is the
+system specifies its own translation tables, the table that is the
value of this variable, if non-@code{nil}, is applied after them.
@end defvar
@@ -1258,7 +1258,7 @@ name or @code{nil}.
@defun check-coding-system coding-system
This function checks the validity of @var{coding-system}. If that is
valid, it returns @var{coding-system}. If @var{coding-system} is
-@code{nil}, the function return @code{nil}. For any other values, it
+@code{nil}, the function returns @code{nil}. For any other values, it
signals an error whose @code{error-symbol} is @code{coding-system-error}
(@pxref{Signaling Errors, signal}).
@end defun
diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi
index 0d0caeb..d8091f1 100644
--- a/doc/lispref/objects.texi
+++ b/doc/lispref/objects.texi
@@ -2411,7 +2411,7 @@ that is evaluated. For example:
@noindent
Although the list @code{(0.5)} was mutable when it was created, it should not
-have been changed via @code{setcar} because it given to @code{eval}. The
+have been changed via @code{setcar} because it was given to @code{eval}. The
reverse does not occur: an object that should not be changed never
becomes mutable afterwards.
diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi
index b324649..0dfdac7 100644
--- a/doc/lispref/processes.texi
+++ b/doc/lispref/processes.texi
@@ -1325,7 +1325,7 @@ the numeric ID of the foreground process group of
@var{process}; it
returns @code{nil} if Emacs can be certain that this is not so. The
value is @code{t} if Emacs cannot tell whether this is true. This
function signals an error if @var{process} is a network, serial, or
-pipe connection, or is the subprocess is not active.
+pipe connection, or if the subprocess is not active.
@end defun
@node Signals to Processes
@@ -3410,8 +3410,9 @@ Unsigned integer in little endian order, with
@var{bitlen} bits.
@item str @var{len}
String of bytes of length @var{len}.
-@item strz @var{len}
-Zero-terminated string of bytes, in a fixed-size field with length @var{len}.
+@item strz &optional @var{len}
+Zero-terminated string of bytes, can be of arbitrary length or in a fixed-size
+field with length @var{len}.
@item vec @var{len} [@var{type}]
Vector of @var{len} elements. The type of the elements is given by
diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi
index 0ddf3e4..b25eea1 100644
--- a/doc/lispref/variables.texi
+++ b/doc/lispref/variables.texi
@@ -1010,6 +1010,9 @@ a dynamic local binding, Emacs records the contents of
the value cell
value cell. When the binding construct finishes executing, Emacs pops
the old value off the stack, and puts it in the value cell.
+ Note that when code using Dynamic Binding is native compiled the
+native compiler will not perform any Lisp specific optimization.
+
@node Dynamic Binding Tips
@subsection Proper Use of Dynamic Binding
diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi
index c32d711..82d2ce4 100644
--- a/doc/lispref/windows.texi
+++ b/doc/lispref/windows.texi
@@ -5877,7 +5877,7 @@ which window parameters (if any) are saved by this
function.
@xref{Window Parameters}.
@end defun
-@defun set-window-configuration configuration &optional dont-set-frame
+@defun set-window-configuration configuration &optional dont-set-frame
dont-set-miniwindow
This function restores the configuration of windows and buffers as
specified by @var{configuration}, for the frame that
@var{configuration} was created for, regardless of whether that frame
@@ -5885,8 +5885,12 @@ is selected or not. The argument @var{configuration}
must be a value
that was previously returned by @code{current-window-configuration}
for that frame. Normally the function also selects the frame which is
recorded in the configuration, but if @var{dont-set-frame} is
-non-@code{nil}, it leaves selected the frame which was current at the
-start of the function.
+non-@code{nil}, it leaves selected the frame which was already
+selected at the start of the function.
+
+Normally the function restores the saved minibuffer (if any), but if
+@var{dont-set-miniwindow} is non-@code{nil}, the minibuffer current
+at the start of the function (if any) remains in the mini-window.
If the frame from which @var{configuration} was saved is dead, all
this function does is to restore the value of the variable
diff --git a/doc/misc/Makefile.in b/doc/misc/Makefile.in
index 63d4bf0..7982c0d 100644
--- a/doc/misc/Makefile.in
+++ b/doc/misc/Makefile.in
@@ -22,7 +22,7 @@ SHELL = @SHELL@
# Where to find the source code. $(srcdir) will be the doc/misc subdirectory
# of the source tree. This is set by configure's '--srcdir' option.
srcdir=@srcdir@
-
+top_srcdir = @top_srcdir@
top_builddir = @top_builddir@
## Where the output files go.
@@ -100,10 +100,6 @@ texi_sources = $(addsuffix .texi,${TARGETS})
texi_notgen = $(filter-out $(notdir ${TEXI_FROM_ORG}),${texi_sources})
texi_and_org = $(notdir ${ORG_SRC}) ${texi_notgen}
SOURCES = $(sort ${texi_and_org})
-.PHONY: echo-sources
-## Used by the top-level Makefile.
-echo-sources:
- @echo ${SOURCES}
DVI_TARGETS = $(TARGETS:=.dvi)
HTML_TARGETS = $(TARGETS:=.html)
@@ -122,7 +118,7 @@ ENVADD =
$(AM_V_GEN)TEXINPUTS="$(srcdir):$(emacsdir):$(TEXINPUTS)" \
gfdl = ${srcdir}/doclicense.texi
style = ${emacsdir}/docstyle.texi
-.PHONY: info dvi html pdf ps echo-info $(INFO_TARGETS)
+.PHONY: info dvi html pdf ps echo-info echo-sources $(INFO_TARGETS)
## Prevent implicit rule triggering for foo.info.
.SUFFIXES:
@@ -138,6 +134,9 @@ echo-info:
@echo "$(INFO_INSTALL) " | \
sed -e 's|[^ ]*/||g' -e 's/\.info//g' -e "s/ */.info /g"
+echo-sources:
+ @echo ${SOURCES}
+
dvi: $(DVI_TARGETS)
html: $(HTML_TARGETS)
@@ -235,14 +234,14 @@ ${buildinfodir}/tramp.info tramp.html:
${srcdir}/trampver.texi
abs_top_builddir = @abs_top_builddir@
EMACS = ${abs_top_builddir}/src/emacs
-emacs = "${EMACS}" -batch --no-site-file --no-site-lisp
+emacs = "${EMACS}" -batch --no-site-file --no-site-lisp --eval '(setq
load-prefer-newer t)'
# Generated .texi files go in srcdir so they can be included in the
# release tarfile along with the others.
# Work in srcdir (and use abs_top_builddir) so that +setupfile and
# things like org-setup's "version" macro work. Sigh.
define org_template
- $(1:.org=.texi): $(1)
+ $(1:.org=.texi): $(1) ${top_srcdir}/lisp/org/ox-texinfo.el
$${AM_V_GEN}cd "$${srcdir}" && $${emacs} -l ox-texinfo \
-f org-texinfo-export-to-texinfo-batch $$(notdir $$<) $$(notdir $$@)
endef
diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi
index 7464ba2..c89e0e7 100644
--- a/doc/misc/cl.texi
+++ b/doc/misc/cl.texi
@@ -2084,14 +2084,15 @@ This clause also accepts optional @samp{from @var{pos}}
and
@samp{to @var{pos}} terms, limiting the clause to overlays which
overlap the specified region.
-@item for @var{var} being the intervals [of @var{buffer}] @dots{}
-This clause iterates over all intervals of a buffer with constant
-text properties. The variable @var{var} will be bound to conses
-of start and end positions, where one start position is always equal
-to the previous end position. The clause allows @code{of},
+@item for @var{var} being the intervals [of @var{object}] @dots{}
+This clause iterates over all intervals of a buffer or string with
+constant text properties. The variable @var{var} will be bound to
+conses of start and end positions, where one start position is always
+equal to the previous end position. The clause allows @code{of},
@code{from}, @code{to}, and @code{property} terms, where the latter
term restricts the search to just the specified property. The
-@code{of} term may specify either a buffer or a string.
+@code{of} term may specify either a buffer or a string. @xref{Text
+Properties,,,elisp}.
@item for @var{var} being the frames
This clause iterates over all Emacs frames. The clause @code{screens} is
@@ -2238,7 +2239,7 @@ were non-@code{nil}, the loop returns @code{t}:
@item never @var{condition}
This clause is like @code{always}, except that the loop returns
-@code{t} if any conditions were false, or @code{nil} otherwise.
+@code{t} if all conditions were false, or @code{nil} otherwise.
@item thereis @var{condition}
This clause stops the loop when the specified form is non-@code{nil};
diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi
index d635cac..45a753d 100644
--- a/doc/misc/erc.texi
+++ b/doc/misc/erc.texi
@@ -514,15 +514,82 @@ Non-interactively, it takes the following keyword
arguments.
That is, if called with the following arguments, @var{server} and
@var{full-name} will be set to those values, whereas
-@code{erc-compute-port}, @code{erc-compute-nick} and
-@code{erc-compute-full-name} will be invoked for the values of the other
-parameters.
+@code{erc-compute-port} and @code{erc-compute-nick} will be invoked
+for the values of the other parameters.
@example
(erc :server "chat.freenode.net" :full-name "Harry S Truman")
@end example
@end defun
+To connect securely over an encrypted TLS connection, use @kbd{M-x
+erc-tls}.
+
+@defun erc-tls
+Select connection parameters and run ERC over TLS@.
+Non-interactively, it takes the following keyword arguments.
+
+@itemize @bullet
+@item @var{server}
+@item @var{port}
+@item @var{nick}
+@item @var{password}
+@item @var{full-name}
+@item @var{client-certificate}
+@end itemize
+
+That is, if called with the following arguments, @var{server} and
+@var{full-name} will be set to those values, whereas
+@code{erc-compute-port} and @code{erc-compute-nick} will be invoked
+for the values of the other parameters, and @code{client-certificate}
+will be @code{nil}.
+
+@example
+(erc-tls :server "chat.freenode.net" :full-name "Harry S Truman")
+@end example
+
+To use a certificate with @code{erc-tls}, specify the optional
+@var{client-certificate} keyword argument, whose value should be as
+described in the documentation of @code{open-network-stream}: if
+non-@code{nil}, it should either be a list where the first element is
+the file name of the private key corresponding to a client certificate
+and the second element is the file name of the client certificate
+itself to use when connecting over TLS, or @code{t}, which means that
+@code{auth-source} will be queried for the private key and the
+certificate. Authenticating using a TLS client certificate is also
+refered to as ``CertFP'' (Certificate Fingerprint) authentication by
+various IRC networks.
+
+Examples of use:
+
+@example
+(erc-tls :server "chat.freenode.net" :port 6697
+ :client-certificate
+ '("/home/bandali/my-cert.key"
+ "/home/bandali/my-cert.crt"))
+@end example
+
+@example
+(erc-tls :server "chat.freenode.net" :port 6697
+ :client-certificate
+ `(,(expand-file-name "~/cert-freenode.key")
+ ,(expand-file-name "~/cert-freenode.crt")))
+@end example
+
+@example
+(erc-tls :server "chat.freenode.net" :port 6697
+ :client-certificate t)
+@end example
+
+In the case of @code{:client-certificate t}, you will need to add a
+line like the following to your authinfo file
+(e.g. @file{~/.authinfo.gpg}):
+
+@example
+machine chat.freenode.net key /home/bandali/my-cert.key cert
/home/bandali/my-cert.crt
+@end example
+@end defun
+
@subheading Server
@defun erc-compute-server &optional server
diff --git a/doc/misc/eshell.texi b/doc/misc/eshell.texi
index e106f39..fc2e3f3 100644
--- a/doc/misc/eshell.texi
+++ b/doc/misc/eshell.texi
@@ -515,8 +515,8 @@ below the @code{completion-cycle-threshold}), press
@kbd{M-?}.
@subsection pcomplete
Pcomplete, short for programmable completion, is the completion
library originally written for Eshell, but usable for command
-completion@footnote{Command completion as opposed to code completion,
-which is a beyond the scope of pcomplete.} in other modes.
+completion@footnote{Command completion, as opposed to code completion,
+which is beyond the scope of pcomplete.} in other modes.
Completions are defined as functions (with @code{defun}) named
@code{pcomplete/COMMAND}, where @code{COMMAND} is the name of the
diff --git a/doc/misc/eww.texi b/doc/misc/eww.texi
index 6e82a97..cc546a9 100644
--- a/doc/misc/eww.texi
+++ b/doc/misc/eww.texi
@@ -124,17 +124,25 @@ which part of the document contains the ``readable''
text, and will
only display this part. This usually gets rid of menus and the like.
@findex eww-toggle-fonts
-@findex shr-use-fonts
+@vindex shr-use-fonts
@kindex F
The @kbd{F} command (@code{eww-toggle-fonts}) toggles whether to use
variable-pitch fonts or not. This sets the @code{shr-use-fonts} variable.
@findex eww-toggle-colors
-@findex shr-use-colors
-@kindex F
+@vindex shr-use-colors
+@kindex M-C
The @kbd{M-C} command (@code{eww-toggle-colors}) toggles whether to use
HTML-specified colors or not. This sets the @code{shr-use-colors} variable.
+@findex eww-toggle-images
+@vindex shr-inhibit-images
+@kindex M-I
+@cindex Image Display
+ The @kbd{M-I} command (@code{eww-toggle-images}, capital letter i)
+toggles whether to display images or not. This also sets the
+@code{shr-inhibit-images} variable.
+
@findex eww-download
@vindex eww-download-directory
@kindex d
@@ -305,6 +313,11 @@ of the width and height. If Emacs supports image scaling
(ImageMagick
support required) then larger images are scaled down. You can block
specific images completely by customizing @code{shr-blocked-images}.
+@vindex shr-inhibit-images
+ You can control image display by customizing
+@code{shr-inhibit-images}. If this variable is @code{nil}, display
+the ``ALT'' text of images instead.
+
@vindex shr-color-visible-distance-min
@vindex shr-color-visible-luminance-min
@cindex Contrast
diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi
index b6553c8..869bb27 100644
--- a/doc/misc/gnus.texi
+++ b/doc/misc/gnus.texi
@@ -17966,7 +17966,7 @@ This creates a group including all flagged messages
from all groups on
two IMAP servers, "home" and "work".
And one last example. Here is a function that runs a search query to
-find all message that have been received recently from certain groups:
+find all messages that have been received recently from certain groups:
@lisp
(defun my-recent-email (args)
diff --git a/doc/misc/message.texi b/doc/misc/message.texi
index 1497c71..d2353e6 100644
--- a/doc/misc/message.texi
+++ b/doc/misc/message.texi
@@ -1792,8 +1792,89 @@ 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.
+@item message-syntax-checks
+@vindex message-syntax-checks
+Controls what syntax checks should not be performed on outgoing posts.
+To disable checking of long signatures, for instance, add
+
+@lisp
+(signature . disabled)
+@end lisp
+
+to this list.
+
+Valid checks are:
+
+@table @code
+@item approved
+@cindex approved
+Check whether the article has an @code{Approved} header, which is
+something only moderators should include.
+@item continuation-headers
+Check whether there are continuation header lines that don't begin with
+whitespace.
+@item control-chars
+Check for invalid characters.
+@item empty
+Check whether the article is empty.
+@item existing-newsgroups
+Check whether the newsgroups mentioned in the @code{Newsgroups} and
+@code{Followup-To} headers exist.
+@item from
+Check whether the @code{From} header seems nice.
+@item illegible-text
+Check whether there is any non-printable character in the body.
+@item invisible-text
+Check whether there is any invisible text in the buffer.
+@item long-header-lines
+Check for too long header lines.
+@item long-lines
+@cindex long lines
+Check for too long lines in the body.
+@item message-id
+Check whether the @code{Message-ID} looks syntactically ok.
+@item multiple-headers
+Check for the existence of multiple equal headers.
+@item new-text
+Check whether there is any new text in the messages.
+@item newsgroups
+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
+contains repeated group names.
+@item reply-to
+Check whether the @code{Reply-To} header looks ok.
+@item sender
+@cindex Sender
+Insert a new @code{Sender} header if the @code{From} header looks odd.
+@item sendsys
+@cindex sendsys
+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
+of groups to post to.
+@item signature
+Check the length of the signature.
+@item size
+Check for excessive size.
+@item subject
+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
+are valid syntactically.
@end table
+All these conditions are checked by default, except for @code{sender}
+for which the check is disabled by default if
+@code{message-insert-canlock} is non-@code{nil} (@pxref{Canceling News}).
+
+@end table
@node Mail Headers
@section Mail Headers
@@ -2072,88 +2153,6 @@ Other variables for customizing outgoing news articles:
@table @code
-@item message-syntax-checks
-@vindex message-syntax-checks
-Controls what syntax checks should not be performed on outgoing posts.
-To disable checking of long signatures, for instance, add
-
-@lisp
-(signature . disabled)
-@end lisp
-
-to this list.
-
-Valid checks are:
-
-@table @code
-@item approved
-@cindex approved
-Check whether the article has an @code{Approved} header, which is
-something only moderators should include.
-@item continuation-headers
-Check whether there are continuation header lines that don't begin with
-whitespace.
-@item control-chars
-Check for invalid characters.
-@item empty
-Check whether the article is empty.
-@item existing-newsgroups
-Check whether the newsgroups mentioned in the @code{Newsgroups} and
-@code{Followup-To} headers exist.
-@item from
-Check whether the @code{From} header seems nice.
-@item illegible-text
-Check whether there is any non-printable character in the body.
-@item invisible-text
-Check whether there is any invisible text in the buffer.
-@item long-header-lines
-Check for too long header lines.
-@item long-lines
-@cindex long lines
-Check for too long lines in the body.
-@item message-id
-Check whether the @code{Message-ID} looks syntactically ok.
-@item multiple-headers
-Check for the existence of multiple equal headers.
-@item new-text
-Check whether there is any new text in the messages.
-@item newsgroups
-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
-contains repeated group names.
-@item reply-to
-Check whether the @code{Reply-To} header looks ok.
-@item sender
-@cindex Sender
-Insert a new @code{Sender} header if the @code{From} header looks odd.
-@item sendsys
-@cindex sendsys
-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
-of groups to post to.
-@item signature
-Check the length of the signature.
-@item size
-Check for excessive size.
-@item subject
-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
-are valid syntactically.
-@end table
-
-All these conditions are checked by default, except for @code{sender}
-for which the check is disabled by default if
-@code{message-insert-canlock} is non-@code{nil} (@pxref{Canceling News}).
-
@item message-ignored-news-headers
@vindex message-ignored-news-headers
Regexp of headers to be removed before posting. The default is@*
diff --git a/doc/misc/modus-themes.org b/doc/misc/modus-themes.org
index 9764a34..001ed57 100644
--- a/doc/misc/modus-themes.org
+++ b/doc/misc/modus-themes.org
@@ -4,9 +4,9 @@
#+language: en
#+options: ':t toc:nil author:t email:t
-#+macro: stable-version 1.2.3
-#+macro: release-date 2021-03-05
-#+macro: development-version 1.3.0-dev
+#+macro: stable-version 1.3.2
+#+macro: release-date 2021-04-18
+#+macro: development-version 1.4.0-dev
#+macro: export-date (eval (format-time-string "%F %R %z" (current-time)))
#+macro: file @@texinfo:@file{@@$1@@texinfo:}@@
#+macro: space @@texinfo:@: @@
@@ -46,11 +46,15 @@ built on {{{export-date}}}.
Copyright (C) 2020-2021 Free Software Foundation, Inc.
#+begin_quote
-Permission is granted to copy, distribute and/or modify this
-document under the terms of the GNU Free Documentation License,
-Version 1.3 or any later version published by the Free Software
-Foundation; with no Invariant Sections, with no Front-Cover Texts,
-and with no Back-Cover Texts.
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the GNU Free Documentation License, Version 1.3 or
+any later version published by the Free Software Foundation; with no
+Invariant Sections, with the Front-Cover Texts being “A GNU Manual,” and
+with the Back-Cover Texts as in (a) below. A copy of the license is
+included in the section entitled “GNU Free Documentation License.”
+
+(a) The FSF’s Back-Cover Text is: “You have the freedom to copy and
+modify this GNU manual.”
#+end_quote
* Overview
@@ -141,7 +145,7 @@ The themes are now ready to be used:
[[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][
:custom_id: h:c4b10085-149f-43e2-bd4d-347f33aee054
:end:
-The =modus-themes= package is available from the GNU ELPA archive, which
+The ~modus-themes~ package is available from the GNU ELPA archive, which
is configured by default.
Prior to querying any package archive, make sure to have updated the
@@ -287,7 +291,8 @@ package configurations in their setup. We use this as an
example:
:init
;; Add all your customizations prior to loading the themes
(setq modus-themes-slanted-constructs t
- modus-themes-bold-constructs nil)
+ modus-themes-bold-constructs nil
+ modus-themes-region 'no-extend)
;; Load the theme files before enabling a theme (else you get an error).
(modus-themes-load-themes)
@@ -374,13 +379,13 @@ Symbol: ~modus-themes-bold-constructs~
Possible values:
-1. =nil= (default)
-2. =t=
+1. ~nil~ (default)
+2. ~t~
The default is to use a bold typographic weight only when it is
required.
-With a non-nil value (=t=) display several syntactic constructs in bold
+With a non-nil value (~t~) display several syntactic constructs in bold
weight. This concerns keywords and other important aspects of code
syntax. It also affects certain mode line indicators and command-line
prompts.
@@ -397,13 +402,13 @@ Symbol: ~modus-themes-slanted-constructs~
Possible values:
-1. =nil= (default)
-2. =t=
+1. ~nil~ (default)
+2. ~t~
The default is to not use slanted text (italics) unless it is absolutely
necessary.
-With a non-nil value (=t=) choose to render more faces in slanted text.
+With a non-nil value (~t~) choose to render more faces in slanted text.
This typically affects documentation strings and code comments.
** Option for syntax highlighting
@@ -418,7 +423,7 @@ Symbol: ~modus-themes-syntax~
Possible values:
-1. =nil= (default)
+1. ~nil~ (default)
2. ~faint~
3. ~yellow-comments~
4. ~green-strings~
@@ -467,8 +472,8 @@ Symbol: ~modus-themes-no-mixed-fonts~
Possible values:
-1. =nil= (default)
-2. =t=
+1. ~nil~ (default)
+2. ~t~
By default, the themes configure some spacing-sensitive faces like Org
tables and code blocks to always inherit from the ~fixed-pitch~ face.
@@ -476,14 +481,14 @@ This is to ensure that those constructs remain monospaced
even when
users opt for a mode that remaps typeface families, such as the built-in
{{{kbd(M-x variable-pitch-mode)}}}. Otherwise the layout would appear
broken, due to how spacing is done. To disable this behaviour, set the
-option to =t=.
+option to ~t~.
Users may prefer to use another package for handling mixed typeface
configurations, rather than letting the theme do it, perhaps because a
purpose-specific package has extra functionality. Two possible options
are ~org-variable-pitch~ and ~mixed-pitch~.
-[[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org (and
others)]].
+[[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org and
others]].
** Option for links
:properties:
@@ -497,7 +502,7 @@ Symbol: ~modus-themes-links~
Possible values:
-1. =nil= (default)
+1. ~nil~ (default)
2. ~faint~
3. ~neutral-underline~
4. ~faint-neutral-underline~
@@ -545,7 +550,7 @@ Symbol: ~modus-themes-prompts~
Possible values:
-1. =nil= (default)
+1. ~nil~ (default)
2. ~subtle-accented~ (~subtle~ exists for backward compatibility)
3. ~intense-accented~ (~intense~ exists for backward compatibility)
4. ~subtle-gray~
@@ -577,12 +582,15 @@ Symbol: ~modus-themes-mode-line~
Possible values:
-1. =nil= (default)
+1. ~nil~ (default)
2. ~3d~
3. ~moody~
4. ~borderless~
5. ~borderless-3d~
6. ~borderless-moody~
+7. ~accented~
+8. ~accented-3d~
+9. ~accented-moody~
The default produces a two-dimensional effect both for the active and
inactive modelines. The differences between the two are limited to
@@ -612,6 +620,11 @@ that the inactive modelines remain visible, they apply a
slightly more
prominent background to them than what their counterparts do (same
inactive background as with the default).
+Similarly, ~accented~, ~accented-3d~, and ~accented-moody~ correspond to the
+default (~nil~), ~3d~, and ~moody~ styles respectively, except that the active
+mode line uses a colored background instead of the standard shade of
+gray.
+
Note that Moody does not expose any faces that the themes could style
directly. Instead it re-purposes existing ones to render its tabs and
ribbons. As such, there may be cases where the contrast ratio falls
@@ -624,10 +637,11 @@ is activated when Emacs determines that the background
and foreground of
the given construct are too close to each other in terms of color
distance. In effect, users would need to experiment with the variable
~face-near-same-color-threshold~ to trigger the effect. We find that a
-value of =45000= will suffice, contrary to the default =30000=. Do not set
-the value too high, because that would have the adverse effect of always
-overriding the default color (which has been carefully designed to be
-highly accessible).
+value of =45000= will suffice, contrary to the default =30000=. Though for
+the ~accented-moody~ value mentioned above, that should be raised up to
+=70000=. Do not set it too high, because it has the adverse effect of
+always overriding the default colors (which have been carefully designed
+to be highly accessible).
Furthermore, because Moody expects an underline and overline instead of
a box style, it is advised you include this in your setup:
@@ -648,7 +662,7 @@ Symbol: ~modus-themes-completions~
Possible values:
-1. =nil= (default)
+1. ~nil~ (default)
2. ~moderate~
3. ~opinionated~
@@ -661,7 +675,7 @@ The former category encompasses Icomplete, Ido, Selectrum
as well as
pattern matching styles like Orderless and Flx. The latter covers Helm,
Ivy, and similar.
-A value of =nil= will respect the metaphors of each completion framework.
+A value of ~nil~ will respect the metaphors of each completion framework.
Option ~moderate~ applies a combination of background and foreground that
is fairly subtle. For Icomplete and friends this constitutes a
@@ -677,7 +691,7 @@ packages will revert to an even more nuanced aesthetic with
some
additional changes to the choice of hues.
To appreciate the scope of this customization option, you should spend
-some time with every one of the =nil= (default), ~moderate~, and ~opinionated~
+some time with every one of the ~nil~ (default), ~moderate~, and ~opinionated~
possibilities.
** Option for fringe visibility
@@ -692,7 +706,7 @@ Symbol: ~modus-themes-fringes~
Possible values:
-1. =nil= (default)
+1. ~nil~ (default)
2. ~subtle~
3. ~intense~
@@ -716,7 +730,7 @@ Symbol: ~modus-themes-lang-checkers~
Possible values:
-1. =nil= (default)
+1. ~nil~ (default)
2. ~subtle-foreground~
3. ~intense-foreground~
4. ~straight-underline~
@@ -755,25 +769,50 @@ refer to their documentation strings.
** Option for line highlighting (hl-line-mode)
:properties:
:alt_title: Line highlighting
-:description: Toggle intense style for current line highlighting
+:description: Choose style of current line (hl-line-mode)
:custom_id: h:1dba1cfe-d079-4c13-a810-f768e8789177
:end:
-#+vindex: modus-themes-intense-hl-line
+#+vindex: modus-themes-hl-line
-Symbol: ~modus-themes-intense-hl-line~
+Symbol: ~modus-themes-hl-line~
Possible values:
-1. =nil= (default)
-2. =t=
+1. ~nil~ (default)
+2. ~intense-background~
+3. ~accented-background~
+4. ~underline-neutral~
+5. ~underline-accented~
+6. ~underline-only-neutral~
+7. ~underline-only-accented~
+
+The default is to use a subtle gray background for the current line when
+~hl-line-mode~ is enabled.
+
+The ~intense-background~ applies a more prominent gray to the background
+of the current line.
+
+With ~accented-background~ the default's subtle aesthetic is retained, but
+the background has a more colored hint.
+
+The ~underline-neutral~ combines the default subtle neutral background
+with a gray underline.
-The default is to use a subtle gray background for ~hl-line-mode~ and its
-global equivalent.
+Similarly, the ~underline-accented~ renders the background of the current
+line in a subtle colored background, while it also draws an accented
+underline.
-With a non-nil value (=t=) use a more prominent background color instead.
+Option ~underline-only-neutral~ produces a neutral underline, but does not
+use any background.
-This affects several packages that enable ~hl-line-mode~, such as =elfeed=
-and =mu4e=.
+While ~underline-only-accented~ also uses just an underline, only this one
+is colored.
+
+Consider setting the variable ~x-underline-at-descent-line~ to a non-nil
+value for better results with underlines.
+
+This style affects several packages that enable ~hl-line-mode~, such as
+=elfeed= and =mu4e=.
** Option for line numbers (display-line-numbers-mode)
:properties:
@@ -787,8 +826,8 @@ Symbol: ~modus-themes-subtle-line-numbers~
Possible value:
-1. =nil= (default)
-2. =t=
+1. ~nil~ (default)
+2. ~t~
The default style for ~display-line-numbers-mode~ and its global variant
is to apply a subtle gray background to the line numbers. The current
@@ -799,7 +838,7 @@ Similarly, the faces for ~display-line-numbers-major-tick~
and its
counterpart ~display-line-numbers-minor-tick~ use appropriate styles that
involve a bespoke background and foreground combination.
-With a non-nil value (=t=), line numbers have no background of their own.
+With a non-nil value (~t~), line numbers have no background of their own.
Instead they retain the primary background of the theme, blending with
the rest of the buffer. Foreground values for all relevant faces are
updated to accommodate this aesthetic.
@@ -816,7 +855,7 @@ Symbol: ~modus-themes-paren-match~
Possible values:
-1. =nil= (default)
+1. ~nil~ (default)
2. ~subtle-bold~
3. ~intense~
4. ~intense-bold~
@@ -847,10 +886,12 @@ Symbol: ~modus-themes-region~
Possible values:
-1. =nil= (default)
+1. ~nil~ (default)
2. ~no-extend~
3. ~bg-only~
4. ~bg-only-no-extend~
+5. ~accent~
+6. ~accent-no-extend~
Nil means to only use a prominent gray background with a neutral
foreground. The foreground overrides all syntax highlighting. The
@@ -866,6 +907,11 @@ colors. It extends to the edge of the window.
Option ~bg-only-no-extend~ is a combination of the ~bg-only~ and ~no-extend~
options.
+Option ~accent~ is like the default, though it uses a more colorful
+background, while ~accent-no-extend~ is the same except it draws the
+region only up to the end of each line instead of extending to the edge
+of the window.
+
** Option for diff buffer looks
:properties:
:alt_title: Diffs
@@ -878,7 +924,7 @@ Symbol: ~modus-themes-diffs~
Possible values:
-1. =nil= (default)
+1. ~nil~ (default)
2. ~desaturated~
3. ~fg-only~
4. ~bg-only~
@@ -935,7 +981,7 @@ Symbol: ~modus-themes-org-blocks~
Possible values:
-1. =nil= (default)
+1. ~nil~ (default)
2. ~grayscale~
3. ~rainbow~
@@ -960,6 +1006,9 @@ major-mode so that the colors are applied consistently
throughout: use
Or start typing in each code block (inefficient at scale, but it still
works).
+The extent of Org block delimiter lines is controlled by the variable
+~org-fontify-whole-block-delimiter-line~.
+
** Option for org-habit graph styles
:properties:
:alt_title: Org agenda habits
@@ -972,7 +1021,7 @@ Symbol: ~modus-themes-org-habit~
Possible values:
-1. =nil= (default)
+1. ~nil~ (default)
2. ~simplified~
3. ~traffic-light~
@@ -1014,11 +1063,10 @@ than other customization options documented in this
manual.
Symbol: ~modus-themes-headings~
-Possible values, which can be specified for each heading level (examples
-further below):
+Possible values, which can be specified for each heading level N
+(examples further below):
-+ nil (default fallback option---covers all heading levels)
-+ =t= (default style for a single heading, when the fallback differs)
++ ~nil~ (~t~ is also available for backward compatibility)
+ ~no-bold~
+ ~line~
+ ~line-no-bold~
@@ -1058,19 +1106,19 @@ To set a uniform value for all heading levels, use this
pattern:
'((t . section)))
;; Default aesthetic for every heading
-(setq modus-themes-headings
- '())
+(setq modus-themes-headings nil)
#+end_src
The default style for headings uses a fairly desaturated foreground
-value in combination with bold typographic weight. To specify this
+color in combination with bold typographic weight. To specify this
style for a given level N, assuming you wish to have another fallback
-option, just specify the value =t= like this:
+option, just assign the value ~nil~ like this:
#+begin_src emacs-lisp
(setq modus-themes-headings
- '((1 . t)
+ '((1 . nil)
(2 . line)
+ (3) ; same as nil
(t . rainbow-line-no-bold)))
#+end_src
@@ -1122,6 +1170,9 @@ A description of all other possible styles beyond the
default:
+ ~no-color-no-bold~ is like ~no-color~ but without the bold weight.
+Remember to also inspect relevant variables that Org provides, such as:
+~org-fontify-whole-heading-line~ and ~org-fontify-done-headline~.
+
** Option for scaled headings
:properties:
:alt_title: Scaled headings
@@ -1134,12 +1185,12 @@ Symbol: ~modus-themes-scale-headings~
Possible values:
-1. =nil= (default)
-2. =t=
+1. ~nil~ (default)
+2. ~t~
The default is to use the same size for headings and paragraph text.
-With a non-nil value (=t=) make headings larger in height relative to the
+With a non-nil value (~t~) make headings larger in height relative to the
main text. This is noticeable in modes like Org, Markdown, and Info.
*** Control the scale of headings
@@ -1217,8 +1268,8 @@ Symbol: ~modus-themes-variable-pitch-ui~
Possible values:
-1. =nil= (default)
-2. =t=
+1. ~nil~ (default)
+2. ~t~
This option concerns User Interface elements that are under the direct
control of Emacs. In particular: the mode line, header line, tab bar,
@@ -1227,7 +1278,7 @@ and tab line.
The default is to use the same font as the rest of Emacs, which usually
is a monospaced family.
-With a non-nil value (=t=) apply a proportionately spaced typeface. This
+With a non-nil value (~t~) apply a proportionately spaced typeface. This
is done by assigning the ~variable-pitch~ face to the relevant items.
[[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org and
others]].
@@ -1244,13 +1295,13 @@ Symbol: ~modus-themes-variable-pitch-headings~
Possible values:
-1. =nil= (default)
-2. =t=
+1. ~nil~ (default)
+2. ~t~
The default is to use the main font family, which typically is
monospaced.
-With a non-nil value (=t=) apply a proportionately spaced typeface, else
+With a non-nil value (~t~) apply a proportionately spaced typeface, else
"variable-pitch", to headings (such as in Org mode).
[[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org and
others]].
@@ -1357,7 +1408,7 @@ With that granted, let us expand the example to actually
change the
If you evaluate this form, your cursor will become blue. But if you
change themes, such as with ~modus-themes-toggle~, your edits will be
-lost, because the newly loaded theme will override the =:background=
+lost, because the newly loaded theme will override the ~:background~
attribute you had assigned to that face.
For such changes to persist, we need to make them after loading the
@@ -1458,7 +1509,7 @@ Getting a list of colors may have its applications,
though what you are
most likely interested in is how to use those variables to configure
several faces at once. To do so we can rely on the built-in
~custom-set-faces~ function, which sets face specifications for the
-special =user= theme. That "theme" gets applied on top of regular themes
+special ~user~ theme. That "theme" gets applied on top of regular themes
like ~modus-operandi~ and ~modus-vivendi~.
This is how it works:
@@ -1502,7 +1553,7 @@ Thus:
[[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][A theme-agnostic hook for theme
loading]].
To discover the faces defined by all loaded libraries, you may do
-{{{kbd(M-x list-faces-display)}}}. Be warned that when you =:inherit= a face
+{{{kbd(M-x list-faces-display)}}}. Be warned that when you ~:inherit~ a face
you are introducing an implicit dependency, so try to avoid doing so for
libraries other than the built-in {{{file(faces.el)}}} (or at least understand
that things may break if you inherit from a yet-to-be-loaded face).
@@ -1524,6 +1575,68 @@ the previous section. Adapt the above example like this:
...))
#+end_src
+** Remap face with local value (DIY)
+:properties:
+:custom_id: h:7a93cb6f-4eca-4d56-a85c-9dcd813d6b0f
+:end:
+#+cindex: Remapping faces
+
+There are cases where we need to change the buffer-local attributes of a
+face. This might be because we have our own minor mode that re-uses a
+face for a particular purpose, such as a line selection tool that
+activates ~hl-line-mode~, but we wish to keep it distinct from other
+buffers. This is where ~face-remap-add-relative~ can be applied and may
+be combined with ~modus-themes-with-colors~ to deliver consistent results.
+
+[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the
themes' palette (DIY)]].
+
+In this example we will write a simple interactive function that adjusts
+the background color of the ~region~ face. This is the sample code:
+
+#+begin_src emacs-lisp
+(defvar my-rainbow-region-colors
+ (modus-themes-with-colors
+ `((red . ,red-subtle-bg)
+ (green . ,green-subtle-bg)
+ (yellow . ,yellow-subtle-bg)
+ (blue . ,blue-subtle-bg)
+ (magenta . ,magenta-subtle-bg)
+ (cyan . ,cyan-subtle-bg)))
+ "Sample list of color values for `my-rainbow-region'.")
+
+(defun my-rainbow-region (color)
+ "Remap buffer-local attribute of `region' using COLOR."
+ (interactive
+ (list
+ (completing-read "Pick a color: " my-rainbow-region-colors)))
+ (face-remap-add-relative
+ 'region
+ `( :background ,(alist-get (intern color) my-rainbow-region-colors)
+ :foreground ,(face-attribute 'default :foreground))))
+#+end_src
+
+When ~my-rainbow-region~ is called interactively, it prompts for a color
+to use. The list of candidates is drawn from the car of each
+association in ~my-rainbow-region-colors~ (so "red", "green", etc.).
+
+To extend this principle, we may write wrapper functions that pass a
+color directly. Those can be useful in tandem with hooks. Consider
+this example:
+
+#+begin_src emacs-lisp
+(defun my-rainbow-region-magenta ()
+ (my-rainbow-region 'magenta))
+
+(add-hook 'diff-mode-hook #'my-rainbow-region-magenta)
+#+end_src
+
+Whenever we enter a ~diff-mode~ buffer, we now get a magenta-colored
+region.
+
+Perhaps you may wish to generalise those findings in to a set of
+functions that also accept an arbitrary face. We shall leave the
+experimentation up to you.
+
** Override colors (DIY)
:properties:
:custom_id: h:307d95dd-8dbd-4ece-a543-10ae86f155a6
@@ -1627,16 +1740,89 @@ with {{{kbd(M-x modus-themes-toggle)}}} will also use
the overrides.
Given that this is a user-level customisation, one is free to implement
whatever color values they desire, even if the possible combinations
fall below the minimum 7:1 contrast ratio that governs the design of the
-themes (the WCAG AAA legibility standard). Preferences aside, it is
-advised to inspect the source code of ~modus-themes-operandi-colors~ and
-~modus-themes-vivendi-colors~ to read the inline commentary: it explains
-what the intended use of each palette subset is.
+themes (the WCAG AAA legibility standard). Alternatively, this can also
+be done programmatically ([[#h:4589acdc-2505-41fc-9f5e-699cfc45ab00][Override
color saturation]]).
+
+For manual interventions it is advised to inspect the source code of
+~modus-themes-operandi-colors~ and ~modus-themes-vivendi-colors~ for the
+inline commentary: it explains what the intended use of each palette
+subset is.
Furthermore, users may benefit from the ~modus-themes-contrast~ function
that we provide: [[#h:02e25930-e71a-493d-828a-8907fc80f874][test color
combinations]]. It measures the contrast
ratio between two color values, so it can help in overriding the palette
(or a subset thereof) without making the end result inaccessible.
+** Override color saturation (DIY)
+:properties:
+:custom_id: h:4589acdc-2505-41fc-9f5e-699cfc45ab00
+:end:
+#+cindex: Change a theme's color saturation
+
+In the previous section we documented how one can override color values
+manually ([[#h:307d95dd-8dbd-4ece-a543-10ae86f155a6][Override colors]]). Here
we use a programmatic approach which
+leverages the built-in ~color-saturate-name~ function to adjust the
+saturation of all color values used by the active Modus theme. Our goal
+is to prepare a counterpart of the active theme's palette that holds
+modified color values, adjusted for a percent change in saturation. A
+positive number amplifies the effect, while a negative one will move
+towards a grayscale spectrum.
+
+We start with a function that can be either called from Lisp or invoked
+interactively. In the former scenario, we pass to it the rate of change
+we want. While in the latter, a minibuffer prompt asks for a number to
+apply the desired effect. In either case, we intend to assign anew the
+value of ~modus-themes-operandi-color-overrides~ (light theme) and the
+same for ~modus-themes-vivendi-color-overrides~ (dark theme).
+
+#+begin_src emacs-lisp
+(defun my-modus-themes-saturate (percent)
+ "Saturate current Modus theme palette overrides by PERCENT."
+ (interactive
+ (list (read-number "Saturation by percent: ")))
+ (let* ((theme (modus-themes--current-theme))
+ (palette (pcase theme
+ ('modus-operandi modus-themes-operandi-colors)
+ ('modus-vivendi modus-themes-vivendi-colors)
+ (_ (error "No Modus theme is active"))))
+ (overrides (pcase theme
+ ('modus-operandi 'modus-themes-operandi-color-overrides)
+ ('modus-vivendi 'modus-themes-vivendi-color-overrides)
+ (_ (error "No Modus theme is active")))))
+ (let (name cons colors)
+ (dolist (cons palette)
+ (setq name (color-saturate-name (cdr cons) percent))
+ (setq name (format "%s" name))
+ (setq cons `(,(car cons) . ,name))
+ (push cons colors))
+ (set overrides colors))
+ (pcase theme
+ ('modus-operandi (modus-themes-load-operandi))
+ ('modus-vivendi (modus-themes-load-vivendi)))))
+
+;; sample Elisp calls (or call `my-modus-themes-saturate' interactively)
+(my-modus-themes-saturate 50)
+(my-modus-themes-saturate -75)
+#+end_src
+
+Using the above has an immediate effect, as it reloads the active Modus
+theme.
+
+To disable the effect, one must reset the aforementioned variables to
+~nil~. Or specify a command for it, such as by taking inspiration from
+the ~modus-themes-toggle~ we already provide:
+
+#+begin_src emacs-lisp
+(defun my-modus-themes-revert-overrides ()
+ "Reset palette overrides and reload active Modus theme."
+ (interactive)
+ (setq modus-themes-operandi-color-overrides nil
+ modus-themes-vivendi-color-overrides nil)
+ (pcase (modus-themes--current-theme)
+ ('modus-operandi (modus-themes-load-operandi))
+ ('modus-vivendi (modus-themes-load-vivendi))))
+#+end_src
+
** Font configurations for Org and others (DIY)
:properties:
:custom_id: h:defcf4fc-8fa8-4c29-b12e-7119582cc929
@@ -1677,9 +1863,9 @@ reading the doc string of ~set-face-attribute~):
(set-face-attribute 'fixed-pitch nil :family "DejaVu Sans Mono" :height 1.0)
#+end_src
-Note the differences in the =:height= property. The =default= face must
+Note the differences in the ~:height~ property. The ~default~ face must
specify an absolute value, which is the point size × 10. So if you want
-to use a font at point size =11=, you set the height to =110=.[fn:: =:height=
+to use a font at point size =11=, you set the height to =110=.[fn:: ~:height~
values do not need to be rounded to multiples of ten: the likes of =115=
are perfectly valid—some typefaces will change to account for those
finer increments.] Whereas every other face must have a value that is
@@ -1689,6 +1875,8 @@ importance: it ensures that all fonts can scale
gracefully when using
something like the ~text-scale-adjust~ command which only operates on the
base font size (i.e. the ~default~ face's absolute height).
+[[#h:e6c5451f-6763-4be7-8fdb-b4706a422a4c][Note for EWW and Elfeed fonts (SHR
fonts)]].
+
** Custom Org user faces (DIY)
:properties:
:custom_id: h:89f0678d-c5c3-4a57-a526-668b2bb2d7ad
@@ -1871,6 +2059,68 @@ package:
(circadian-setup))
#+end_src
+** Backdrop for pdf-tools (DIY)
+:properties:
+:custom_id: h:ff69dfe1-29c0-447a-915c-b5ff7c5509cd
+:end:
+#+cindex: Remapping pdf-tools backdrop
+
+Most PDF files use a white background for their page, making it
+impossible to discern the file's boundaries in the buffer while using
+the Modus Operandi theme. To introduce a distinction between the
+buffer's backdrop and the PDF page's background, the former must be
+rendered as some shade of gray. Ideally, ~pdf-tools~ would provide a face
+that the themes could support directly, though this does not seem to be
+the case for the time being. We must thus employ the face remapping
+technique that is documented elsewhere in this document to change the
+buffer-local value of the ~default~ face.
+
+[[#h:7a93cb6f-4eca-4d56-a85c-9dcd813d6b0f][Remap face with local value (DIY)]].
+
+To remap the buffer's backdrop, we start with a function like this one:
+
+#+begin_src emacs-lisp
+(defun my-pdf-tools-backdrop ()
+ (face-remap-add-relative
+ 'default
+ `(:background ,(modus-themes-color 'bg-alt))))
+
+(add-hook 'pdf-tools-enabled-hook #'my-pdf-tools-backdrop)
+#+end_src
+
+The idea is to assign that function to a hook that gets called when
+~pdf-tools~ renders the document: ~pdf-tools-enabled-hook~. This is enough
+when you only use one theme. However it has the downside of setting the
+background color value only at render time. In other words, the face
+remapping function does not get evaluated anew whenever the theme
+changes, such as upon invoking {{{kbd(M-x modus-themes-toggle)}}}.
+
+To have our face remapping adapt gracefully while switching between the
+Modus themes, we need to also account for the current theme and control
+the activation of ~pdf-view-midnight-minor-mode~. To which end we arrive
+at something like the following, which builds on the above example:
+
+#+begin_src emacs-lisp
+(defun my-pdf-tools-backdrop ()
+ (face-remap-add-relative
+ 'default
+ `(:background ,(modus-themes-color 'bg-alt))))
+
+(defun my-pdf-tools-midnight-mode-toggle ()
+ (when (derived-mode-p 'pdf-view-mode)
+ (if (eq (car custom-enabled-themes) 'modus-vivendi)
+ (pdf-view-midnight-minor-mode 1)
+ (pdf-view-midnight-minor-mode -1))
+ (my-pdf-tools-backdrop)))
+
+(add-hook 'pdf-tools-enabled-hook #'my-pdf-tools-midnight-mode-toggle)
+(add-hook 'modus-themes-after-load-theme-hook
#'my-pdf-tools-midnight-mode-toggle)
+#+end_src
+
+With those in place, PDFs have a distinct backdrop for their page, while
+they automatically switch to their dark mode when ~modus-themes-toggle~ is
+called from inside a buffer whose major-mode is ~pdf-view-mode~.
+
** A theme-agnostic hook for theme loading (DIY)
:properties:
:custom_id: h:86f6906b-f090-46cc-9816-1fe8aeb38776
@@ -1976,6 +2226,7 @@ have lots of extensions, so the "full support" may not be
100% true…
+ compilation-mode
+ completions
+ consult
++ corfu
+ counsel*
+ counsel-css
+ counsel-notmuch
@@ -2018,8 +2269,9 @@ have lots of extensions, so the "full support" may not be
100% true…
+ eldoc-box
+ elfeed
+ elfeed-score
++ embark
+ emms
-+ enhanced-ruby-mode
++ enh-ruby-mode (enhanced-ruby-mode)
+ epa
+ equake
+ erc
@@ -2149,6 +2401,7 @@ have lots of extensions, so the "full support" may not be
100% true…
+ outline-minor-faces
+ package (what you get with {{{kbd(M-x list-packages)}}})
+ page-break-lines
++ pandoc-mode
+ paradox
+ paren-face
+ parrot
@@ -2206,7 +2459,11 @@ have lots of extensions, so the "full support" may not
be 100% true…
+ sx
+ symbol-overlay
+ syslog-mode
++ tab-bar-groups
++ tab-bar-mode
++ tab-line-mode
+ table (built-in table.el)
++ telega
+ telephone-line
+ terraform-mode
+ term
@@ -2221,6 +2478,7 @@ have lots of extensions, so the "full support" may not be
100% true…
+ vc (built-in mode line status for version control)
+ vc-annotate (the out put of {{{kbd(C-x v g)}}})
+ vdiff
++ vertico
+ vimish-fold
+ visible-mark
+ visual-regexp
@@ -2274,6 +2532,42 @@ inherit from some basic faces. Please confirm.
This section covers information that may be of interest to users of
individual packages.
+** Note for dimmer.el
+:properties:
+:custom_id: h:8eb4b758-d318-4480-9ead-357a571beb93
+:end:
+
+The {{{file(dimmer.el)}}} library by Neil Okamoto can be configured to
+automatically dim the colors of inactive Emacs windows. To guarantee
+consistent results with the Modus themes, we suggest some tweaks to the
+default styles, such as in this minimal setup:
+
+#+begin_src emacs-lisp
+(use-package dimmer
+ :config
+ (setq dimmer-fraction 0.3)
+ (setq dimmer-adjustment-mode :foreground)
+ (setq dimmer-use-colorspace :rgb)
+
+ (dimmer-mode 1))
+#+end_src
+
+Of the above, we strongly recommend the RGB color space because it is
+the one that remains faithful to the hueness of the colors used by the
+themes. Whereas the default CIELAB space has a tendency to distort
+colors in addition to applying the dim effect, which can be somewhat
+disorienting.
+
+The value of the ~dimmer-fraction~ has been selected empirically. Users
+might prefer to tweak it further (increasing it makes the dim effect
+more pronounced).
+
+Changing the ~dimmer-adjustment-mode~ is a matter of preference. Though
+because the Modus themes use black and white as their base colors, any
+other value for that variable will turn the main background gray. This
+inadvertently leads to the opposite of the intended utility of this
+package: it draws too much attention to unfocused windows.
+
** Note for display-fill-column-indicator-mode
:properties:
:custom_id: h:2a602816-bc1b-45bf-9675-4cbbd7bf6cab
@@ -2521,6 +2815,21 @@ specifications the webpage provides.
Consult {{{kbd(C-h v shr-use-colors)}}}.
+
+** Note for EWW and Elfeed fonts (SHR fonts)
+:properties:
+:custom_id: h:e6c5451f-6763-4be7-8fdb-b4706a422a4c
+:end:
+
+EWW and Elfeed rely on the Simple HTML Renderer to display their
+content. The {{{file(shr.el)}}} library contains the variable ~shr-use-fonts~
+that controls whether the text in the buffer is set to a ~variable-pitch~
+typeface (proportionately spaced) or if just retains whatever the
+default font family is. Its default value is non-nil, which means that
+~variable-pitch~ is applied.
+
+[[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org and
others]].
+
** Note for Helm grep
:properties:
:custom_id: h:d28879a2-8e4b-4525-986e-14c0f873d229
@@ -2748,26 +3057,28 @@ The Modus themes are a collective effort. Every bit of
work matters.
+ Contributions to code or documentation :: Anders Johansson, Basil
L.{{{space()}}} Contovounesios, Carlo Zancanaro, Eli Zaretskii, Kostadin
- Ninev, Madhavan Krishnan, Markus Beppler, Matthew Stevenson, Nicolas
- De Jaeghere, Shreyas Ragavan, Stefan Kangas, Vincent Murphy, Xinglu
- Chen.
+ Ninev, Madhavan Krishnan, Markus Beppler, Matthew Stevenson, Mauro
+ Aranda, Nicolas De Jaeghere, Shreyas Ragavan, Stefan Kangas, Vincent
+ Murphy, Xinglu Chen.
+ Ideas and user feedback :: Aaron Jensen, Adam Spiers, Adrian Manea,
Alex Griffin, Alex Peitsinis, Alexey Shmalko, Alok Singh, Anders
Johansson, André Alexandre Gomes, Arif Rezai, Basil L.{{{space()}}}
Contovounesios, Burgess Chang, Christian Tietze, Christopher Dimech,
Damien Cassou, Daniel Mendler, Dario Gjorgjevski, David Edmondson,
- Davor Rotim, Divan Santana, Gerry Agbobada, Gianluca Recchia, Gustavo
- Barros, Hörmetjan Yiltiz, Ilja Kocken, Iris Garcia, Jeremy Friesen,
- John Haman, Joshua O'Connor, Kevin Fleming, Kostadin Ninev, Len Trigg,
- Manuel Uberti, Mark Burton, Markus Beppler, Michael Goldenberg, Morgan
- Smith, Murilo Pereira, Nicolas De Jaeghere, Paul Poloskov, Pete
- Kazmier, Peter Wu, Philip K., Pierre Téchoueyres, Roman Rudakov, Ryan
- Phillips, Sam Kleinman, Shreyas Ragavan, Simon Pugnet, Tassilo Horn,
- Thibaut Verron, Trey Merkley, Togan Muftuoglu, Toon Claes, Uri Sharf,
- Utkarsh Singh, Vincent Foley. As well as users: Ben, CsBigDataHub1,
- Emacs Contrib, Eugene, Fourchaux, Fredrik, Moesasji, Nick, TheBlob42,
- bepolymathe, doolio, fleimgruber, iSeeU, jixiuf, okamsn.
+ Davor Rotim, Divan Santana, Emanuele Michele Alberto Monterosso,
+ Farasha Euker, Gerry Agbobada, Gianluca Recchia, Gustavo Barros,
+ Hörmetjan Yiltiz, Ilja Kocken, Iris Garcia, Jeremy Friesen, John
+ Haman, Joshua O'Connor, Kevin Fleming, Kévin Le Gouguec, Kostadin
+ Ninev, Len Trigg, Manuel Uberti, Mark Burton, Markus Beppler, Mauro
+ Aranda, Michael Goldenberg, Morgan Smith, Murilo Pereira, Nicky van
+ Foreest, Nicolas De Jaeghere, Paul Poloskov, Pete Kazmier, Peter Wu,
+ Philip K., Pierre Téchoueyres, Roman Rudakov, Ryan Phillips, Sam
+ Kleinman, Shreyas Ragavan, Simon Pugnet, Tassilo Horn, Thibaut Verron,
+ Trey Merkley, Togan Muftuoglu, Toon Claes, Uri Sharf, Utkarsh Singh,
+ Vincent Foley. As well as users: Ben, CsBigDataHub1, Emacs Contrib,
+ Eugene, Fourchaux, Fredrik, Moesasji, Nick, TheBlob42, Trey,
+ bepolymathe, doolio, fleimgruber, iSeeU, jixiuf, okamsn, pRot0ta1p.
+ Packaging :: Basil L.{{{space()}}} Contovounesios, Eli Zaretskii, Glenn
Morris, Mauro Aranda, Richard Stallman, Stefan Kangas (core Emacs),
@@ -2819,6 +3130,7 @@ And here are the canonical sources of this project's
documentation:
#+texinfo: @include doclicense.texi
#+begin_export html
+<pre>
GNU Free Documentation License
Version 1.3, 3 November 2008
@@ -3270,6 +3582,7 @@ If your document contains nontrivial examples of program
code, we
recommend releasing these examples in parallel under your choice of
free software license, such as the GNU General Public License,
to permit their use in free software.
+</pre>
#+end_export
#+html: <!--
diff --git a/doc/misc/reftex.texi b/doc/misc/reftex.texi
index 599252f..f1074d3 100644
--- a/doc/misc/reftex.texi
+++ b/doc/misc/reftex.texi
@@ -254,73 +254,6 @@ version 20.2. It has also been bundled and pre-installed
with XEmacs
plug-in package which is available from the @value{XEMACSFTP}. See the
XEmacs 21.x documentation on package installation for details.
-Users of earlier Emacs distributions (including Emacs 19) or people
-craving for new features and bugs can get a copy of the @RefTeX{}
-distribution from the maintainer's web page. @xref{Imprint}, for more
-information. The following instructions will guide you through the
-process of installing such a distribution.
-
-@subsection Building and Installing
-
-Note: Currently installation is supported for Emacs only. XEmacs users
-might want to refer to the @RefTeX{} package available through the
-package system of XEmacs.
-
-@subsubheading Installation with make
-
-In order to install RefTeX, unpack the distribution and edit the header
-of the Makefile. Basically, you need to change the path specifications
-for Emacs Lisp files and info files. Also, enter the name of your Emacs
-executable (usually either @samp{emacs} or @samp{xemacs}).
-
-Then, type
-
-@example
-make
-make install
-@end example
-
-to compile and install the code and documentation.
-
-Per default @RefTeX{} is installed in its own subdirectory which might
-not be on your load path. In this case, add it to load path with a
-command like the following, replacing the sample directory with the one
-where @RefTeX{} is installed in your case.
-
-@example
-(add-to-list 'load-path "/path/to/reftex")
-@end example
-
-Put this command into your init file before other @RefTeX{}-related
-settings.
-
-@subsubheading Installation by Hand
-
-If you want to get your hands dirty, there is also the possibility to
-install by manually copying files.
-
-@enumerate a
-@item
-Copy the reftex*.el lisp files to a directory on your load path. Make
-sure that no old copy of @RefTeX{} shadows these files.
-@item
-Byte compile the files. The sequence of compiling should be:
-reftex-var.el, reftex.el, and then all the others.
-@item
-Copy the info file reftex.info to the info directory.
-@end enumerate
-
-@subsection Loading @RefTeX{}
-
-In order to make the most important functions for entering @RefTeX{}
-mode available add the following line to your init file.
-
-@example
-(require 'reftex)
-@end example
-
-@subsection Entering @RefTeX{} Mode
-
@findex turn-on-reftex
@findex reftex-mode
@vindex LaTeX-mode-hook
@@ -3259,9 +3192,9 @@ with the @kbd{g} key. To get this behavior, use instead
@AUCTeX{} is without doubt the best major mode for editing @TeX{} and @LaTeX{}
files with Emacs (@pxref{Top,AUCTeX,,auctex, The AUCTeX User Manual}).
-If @AUCTeX{} is not part of your Emacs distribution, you can get
-it@footnote{XEmacs 21.x users may want to install the corresponding
-XEmacs package.} by FTP from the @value{AUCTEXSITE}.
+You can get it from its home page at @value{AUCTEXSITE}, but since
+it is available from GNU ELPA, you can simply install it from @kbd{M-x
+list-packages}.
@menu
* AUCTeX-RefTeX Interface:: How both packages work together
@@ -3611,18 +3544,6 @@ after the @samp{@{step+@}}, also when specifying how to
get
context.
@item
-@b{Idle timers in XEmacs}@*
-@cindex Idle timer restart
-@vindex reftex-use-itimer-in-xemacs
-In XEmacs, idle timer restart does not work reliably after fast
-keystrokes. Therefore @RefTeX{} currently uses the post command
-hook to start the timer used for automatic crossref information. When
-this bug gets fixed, a real idle timer can be requested with
-@lisp
-(setq reftex-use-itimer-in-xemacs t)
-@end lisp
-
-@item
@b{Viper mode}@*
@cindex Viper mode
@cindex Key bindings, problems with Viper mode
diff --git a/doc/misc/sem-user.texi b/doc/misc/sem-user.texi
index c37291a..70a1948 100644
--- a/doc/misc/sem-user.texi
+++ b/doc/misc/sem-user.texi
@@ -142,7 +142,7 @@ Move point ``up'' one reference
(@code{senator-go-to-up-reference}).
The meaning of ``up'' is language-dependent; in C++, for instance,
this means moving to the parent of the current tag.
-@item C-c, @key{SPC}
+@item C-c , @key{SPC}
Display a list of possible completions for the symbol at point
(@code{semantic-complete-analyze-inline}). This also activates a
special set of keybindings for choosing a completion: @key{RET}
diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi
index 5ea0275..ebfc14d 100644
--- a/doc/misc/tramp.texi
+++ b/doc/misc/tramp.texi
@@ -5067,33 +5067,46 @@ remote files}.
@item
-I get a warning @samp{Tramp has been compiled with Emacs a.b, this is Emacs
c.d}
+How to prevent @value{tramp} from clearing the @code{recentf-list}?
-@value{tramp} comes with compatibility code for different Emacs
-versions. When you see this warning, you don't use the Emacs built-in
-version of @value{tramp}. In case you have installed @value{tramp}
-from GNU ELPA, you must delete and reinstall it.
-@ifset installchapter
-In case you have installed it from its Git repository, @ref{Recompilation}.
-@end ifset
+When @value{tramp} cleans a connection, it removes the respective
+remote file name(s) from @code{recentf-list}. This is needed, because
+an unresponsive remote host could trigger @code{recentf} to connect
+that host again and again.
+
+If you find the cleanup disturbing, because the file names in
+@code{recentf-list} are precious to you, you could add the following
+two forms in your @file{~/.emacs} after loading the @code{tramp} and
+@code{recentf} packages:
+@lisp
+@group
+(remove-hook
+ 'tramp-cleanup-connection-hook
+ #'tramp-recentf-cleanup)
+@end group
+@group
+(remove-hook
+ 'tramp-cleanup-all-connections-hook
+ #'tramp-recentf-cleanup-all)
+@end group
+@end lisp
+
+@item
+I get a warning @samp{Tramp has been compiled with Emacs a.b, this is Emacs
c.d}
@item
I get an error @samp{tramp-file-name-handler: Invalid function:
tramp-compat-with-mutex}
-Likely, you have a running Emacs session with loaded @value{tramp},
-and you try to upgrade it to another version from GNU ELPA. Since
-@value{tramp} is not forward compatible, you must unload / reload it.
-Try the following steps:
-
-@example
-@kbd{M-x tramp-unload-tramp @key{RET}}
-@kbd{M-x load-library @key{RET} tramp @key{RET}}
-@end example
-
-If this doesn't work, you must restart Emacs with proper
-@code{load-path} for the new @value{tramp} version.
+@value{tramp} comes with compatibility code for different Emacs
+versions. When you see such a message (the text might differ), you
+don't use the Emacs built-in version of @value{tramp}. In case you
+have installed @value{tramp} from GNU ELPA, see the package README
+file for instructions how to recompile it.
+@ifset installchapter
+@xref{Recompilation}.
+@end ifset
@item
diff --git a/doc/misc/woman.texi b/doc/misc/woman.texi
index 4470afc..33b3a33 100644
--- a/doc/misc/woman.texi
+++ b/doc/misc/woman.texi
@@ -105,11 +105,9 @@ Mile End Road, London E1 4NS, UK
@chapter Introduction
@cindex introduction
-This version of WoMan should run with GNU Emacs 20.3 or later on any
-platform. It has not been tested, and may not run, with any other
-version of Emacs. It was developed primarily on various versions of
-Microsoft Windows, but has also been tested on MS-DOS, and various
-versions of UNIX and GNU/Linux.
+WoMan was developed primarily on various versions of Microsoft
+Windows, but has also been tested on MS-DOS, and various versions of
+UNIX and GNU/Linux.
WoMan is distributed with GNU Emacs.
diff --git a/etc/NEWS b/etc/NEWS
index 2d66a93..9bf232a 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -24,10 +24,14 @@ applies, and please also update docstrings as needed.
* Installation Changes in Emacs 28.1
+** Emacs now optionally supports native compilation of Lisp files.
+To enable this, configure Emacs with the '--with-native-compilation' option.
+This requires the libgccjit library to be installed and functional.
+
---
** Support for building with Motif has been removed.
-** Cairo graphics library is now used by default if found.
+** The Cairo graphics library is now used by default if present.
'--with-cairo' is now the default, if the appropriate development files
are found by 'configure'. Note that building with Cairo means using
Pango instead of libXFT for font support. Since Pango 1.44 has
@@ -90,6 +94,17 @@ lacks the terminfo database, you can instruct Emacs to
support 24-bit
true color by setting 'COLORTERM=truecolor' in the environment. This is
useful on systems such as FreeBSD which ships only with "etc/termcap".
+** Emacs now supports loading a Secure Computing filter.
+This is supported only on capable GNU/Linux systems. To activate,
+invoke Emacs with the '--seccomp=FILE' command-line option. FILE must
+name a binary file containing an array of 'struct sock_filter'
+structures. Emacs will then install that list of Secure Computing
+filters into its own process early during the startup process. You
+can use this functionality to put an Emacs process in a sandbox to
+avoid security issues when executing untrusted code. See the manual
+page for 'seccomp' system call, for details about Secure Computing
+filters.
+
* Changes in Emacs 28.1
@@ -265,6 +280,9 @@ input using the minibuffer.
* Editing Changes in Emacs 28.1
+++
+** A prefix arg now causes 'delete-other-frames' to only iconify frames
+
++++
** New command 'execute-extended-command-for-buffer'.
This new command, bound to 'M-S-x', works like
'execute-extended-command', but limits the set of commands to the
@@ -367,6 +385,12 @@ trying to be non-destructive.
This command opens a new buffer called "*Memory Report*" and gives a
summary of where Emacs is using memory currently.
++++
+** New user option 'isearch-repeat-on-direction-change'.
+When this option is set, direction changes in Isearch move to another
+search match, if there is one, instead of moving point to the other
+end of the current match.
+
** Outline
+++
@@ -477,6 +501,13 @@ documented.
SMIE is now always enabled and 'ruby-use-smie' only controls whether
indentation is done using SMIE or with the old ad-hoc code.
+** Icomplete
+
++++
+*** New minor mode Icomplete-Vertical mode.
+This mode is intended to be used with Icomplete or Fido, to display the
+list of completions candidates vertically instead of horizontally.
+
---
** Specific warnings can now be disabled from the warning buffer.
When a warning is displayed to the user, the resulting buffer now has
@@ -929,6 +960,21 @@ take the actual screenshot, and defaults to "ImageMagick
import".
A server entry retrieved by auth-source can request a desired smtp
authentication mechanism by setting a value for the key 'smtp-auth'.
+** Search and Replace
+
+*** New key 'M-s M-.' starts isearch with the thing found at point.
+This key is bound to the new command 'isearch-forward-thing-at-point'.
+The new user option 'isearch-forward-thing-at-point' defines
+a list of symbols to try to get the "thing" at point. By default,
+the first element of the list is 'region' that tries to yank
+the currently active region to the search string.
+
+*** New user option 'isearch-wrap-pause' defines how to wrap the search.
+There are choices to disable wrapping completely and to wrap immediately.
+When wrapping immediately, it consistently handles the numeric arguments
+of 'C-s' ('isearch-repeat-forward') and 'C-r' ('isearch-repeat-backward'),
+continuing with the remaining count after wrapping.
+
** Grep
+++
@@ -947,6 +993,9 @@ skipped.
** Help
---
+*** The 'help-for-help' ('C-h C-h') screen has been redesigned.
+
+---
*** Keybindings in 'help-mode' use the new 'help-key-binding' face.
This face is added by 'substitute-command-keys' to any "\[command]"
substitution. The return value of that function should consequently
@@ -1056,6 +1105,10 @@ the commands 'customize', 'customize-group',
'customize-apropos' and
To customize obsolete user options, use 'customize-option' or
'customize-saved'.
+*** New SVG icons for checkboxes and arrows.
+They will be used automatically instead of the old icons. If Emacs is
+built without SVG support, the old icons will be used instead.
+
** Edebug
*** Obsoletions
@@ -1233,6 +1286,14 @@ key binding
/ u package-menu-filter-upgradable
/ / package-menu-filter-clear
+*** Option to automatically native-compile packages upon installation.
+Customize the user option 'package-native-compile' to enable automatic
+native compilation of packages when they are installed. That option
+is nil by default; if set non-nil, and if your Emacs was built with
+native-compilation support, each package will be natively compiled
+when it is installed, by invoking an asynchronous Emacs subprocess to
+run the native-compilation of the package files.
+
---
*** Column widths in 'list-packages' display can now be customized.
See the new user options 'package-name-column-width',
@@ -1511,6 +1572,22 @@ This controls whether to use smoothing or not for an
image. Values
include nil (no smoothing), t (do smoothing) or a predicate function
that's called with the image object and should return nil/t.
++++
+*** SVG images now support user stylesheets.
+The ':css' image attribute can be used to override the default CSS
+stylesheet for an image. The default sets 'font-family' and
+'font-size' to match the current face, so an image with 'height="1em"'
+will match the font size in use where it is embedded.
+
+This feature relies on librsvg 2.48 or above being available.
+
++++
+*** Image properties support 'em' sizes.
+Size image properties, for example ':height', ':max-height', etc., can
+be given a cons of the form '(SIZE . em)', where SIZE is an integer or
+float which is multiplied by the font size to calculate the image
+size, and em is a symbol.
+
** EWW
+++
@@ -1615,6 +1692,13 @@ choosing the exact definition to go to, and this should
do TRT.
If chosen, file names in "*xref*" buffers will be displayed relative
to the 'project-root' of the current project, when available.
++++
+*** The TAB key binding in *xref* buffers is obsolete.
+Use 'C-u RET' instead. The TAB binding in *xref* buffers is still
+supported, but we plan on removing it in a future version; at that
+time, the command 'xref-quit-and-goto-xref' will no longer have a key
+binding in 'xref--xref-buffer-mode-map'.
+
** json.el
---
@@ -1676,6 +1760,42 @@ type for highlighting the entire message but not the
sender's nick.
The 'erc-status-sidebar' package which provides a HexChat-like
activity overview sidebar for joined IRC channels is now part of ERC.
++++
+*** erc-tls now supports specifying a TLS client certificate.
+The 'erc-tls' function has been updated to allow specifying a TLS
+client certificate for authentication, as an alternative to NickServ
+password-based authentication. This is referred to as "CertFP" (short
+for Certificate Fingerprint) by several IRC networks.
+
+To use a certificate with 'erc-tls', specify the ':client-certificate'
+optional parameter, whose value should be as described in the
+documentation of 'open-network-stream': if non-nil, it should either
+be a list where the first element is the file name of the private key
+corresponding to a client certificate and the second element is the
+file name of the client certificate itself to use when connecting over
+TLS, or t, which means that 'auth-source' will be queried for the
+private key and the certificate.
+
+Examples of use:
+
+ (erc-tls :server "chat.freenode.net" :port 6697
+ :client-certificate
+ '("/home/bandali/my-cert.key"
+ "/home/bandali/my-cert.crt"))
+
+ (erc-tls :server "chat.freenode.net" :port 6697
+ :client-certificate
+ `(,(expand-file-name "~/cert-freenode.key")
+ ,(expand-file-name "~/cert-freenode.crt")))
+
+ (erc-tls :server "chat.freenode.net" :port 6697
+ :client-certificate t)
+
+In the case of ':client-certificate t', you will need to add a line
+like the following to your authinfo file (e.g. "~/.authinfo.gpg"):
+
+ machine chat.freenode.net key /home/bandali/my-cert.key cert
/home/bandali/my-cert.crt
+
** Battery
---
@@ -2172,6 +2292,10 @@ The following user options have been renamed:
The old names are now obsolete.
+---
+*** 'world-clock-mode' can no longer be turned on interactively.
+Use 'world-clock' to turn on that mode.
+
** D-Bus
+++
@@ -2238,6 +2362,10 @@ You can type 'C-x u u' instead of 'C-x u C-x u' to undo
many changes,
'M-g n n p p' to navigate next-error matches. Any other key exits
transient mode and then is executed normally. 'repeat-exit-key'
defines an additional key to exit mode like 'isearch-exit' ('RET').
+With 'repeat-keep-prefix' you can keep the prefix arg of the previous command.
+For example, this can help to reverse the window navigation direction
+with e.g. 'C-x o M-- o o'. Also it can help to set a new step with
+e.g. 'C-x { C-5 { { {' will set the window resizing step to 5 columns.
* New Modes and Packages in Emacs 28.1
@@ -2266,6 +2394,13 @@ This is a mode for searching a RFC 2229 dictionary
server.
the mouse in 'dictionary-tooltip-dictionary' (which must be customized
first).
+** transient.el
+
+This library implements support for powerful keyboard-driven menus.
+Such menus can be used as simple visual command dispatchers. More
+complex menus take advantage of infix arguments, which are somewhat
+similar to prefix arguments, but are more flexible and discoverable.
+
* Incompatible Editing Changes in Emacs 28.1
@@ -2314,6 +2449,11 @@ This is to keep the same behavior as Eshell.
* Incompatible Lisp Changes in Emacs 28.1
++++
+** The use of positional arguments in 'define-minor-mode' is obsolete.
+These were actually rendered obsolete in Emacs-21 but were never
+marked as such.
+
** 'facemenu-color-alist' is now obsolete, and is not used.
** 'facemenu.el' is no longer preloaded.
@@ -2329,6 +2469,10 @@ This affects the suffix specified by completion
'annotation-function'.
The mark will be set to point to the end of the new buffer.
+++
+** An active minibuffer now has major mode 'minibuffer-mode', not the
+erroneous 'minibuffer-inactive-mode' it formerly had.
+
++++
** Some properties from completion tables are now preserved.
If 'minibuffer-allow-text-properties' is non-nil, doing completion
over a table of strings with properties will no longer remove all the
@@ -2378,11 +2522,6 @@ parameter.
by mistake and were not useful to Lisp code.
---
-** Loading 'generic-x' unconditionally loads all modes.
-The user option 'generic-extras-enable-list' is now obsolete, and
-setting it has no effect.
-
----
** The 'load-dangerous-libraries' variable is now obsolete.
It was used to allow loading Lisp libraries compiled by XEmacs, a
modified version of Emacs which is no longer actively maintained.
@@ -2498,10 +2637,21 @@ back in Emacs 23.1. The affected functions are:
'make-obsolete',
** The 'values' variable is now obsolete.
++++
+** The '&define' keyword in an Edebug specification now disables backtracking.
+The implementation was buggy, and multiple &define forms in an &or
+form should be exceedingly rare. See the Info node 'Backtracking' in
+the Emacs Lisp reference manual for background.
+
* Lisp Changes in Emacs 28.1
+++
+** New function 'sxhash-equal-including-properties'.
+This is identical to 'sxhash-equal' but accounting also for string
+properties.
+
++++
** 'unlock-buffer' displays warnings instead of signaling.
Instead of signaling 'file-error' conditions for file system level
errors, the function now calls 'display-warning' and continues as if
@@ -2591,9 +2741,11 @@ one to another in the init file. The same user option
also controls
whether the function 'read-answer' accepts short answers.
+++
-** 'set-window-configuration' now takes an optional 'dont-set-frame'
-parameter which, when non-nil, instructs the function not to select
-the frame recorded in the configuration.
+** 'set-window-configuration' now takes two optional parameters,
+'dont-set-frame' and 'dont-set-miniwindow'. The first of these, when
+non-nil, instructs the function not to select the frame recorded in
+the configuration. The second prevents the current minibuffer being
+replaced by the one stored in the configuration.
+++
** 'define-globalized-minor-mode' now takes a ':predicate' parameter.
@@ -2607,6 +2759,11 @@ argument ELLIPSIS, will now indicate truncation using
'…' when
the selected frame can display it, and using "..." otherwise.
+++
+** 'string-width' now accepts two optional arguments FROM and TO.
+This allows calculating the width of a substring without consing a
+new string.
+
++++
** New command 'make-directory-autoloads'.
This does the same as the old command 'update-directory-autoloads',
but has different semantics: Instead of passing in the output file via
@@ -2872,6 +3029,12 @@ arrays nor objects.
The special events 'dbus-event' and 'file-notify' are now ignored in
'while-no-input' when added to this variable.
++++
+** 'condition-case' now allows for a success handler.
+It is written as (:success BODY...) where BODY is executed whenever
+the protected form terminates without error, with the specified
+variable bound to the the value of the protected form.
+
* Changes in Emacs 28.1 on Non-Free Operating Systems
diff --git a/etc/TODO b/etc/TODO
index 9448617..f806b6c 100644
--- a/etc/TODO
+++ b/etc/TODO
@@ -500,6 +500,13 @@ access in cases which need more than Lisp.
** Fix portable dumping so that you can redump without using -batch
+*** Redumps and native compiler "preloaded" sub-folder.
+In order to depose new .eln files being compiled into the "preloaded"
+sub-folder the native compiler needs to know in advance if this file
+will be preloaded or not. As .eln files are not moved afterwards
+subsequent redumps might refer to .eln file out of the "preloaded"
+sub-folder.
+
** Imenu could be extended into a file-structure browsing mechanism
This could use code like that of customize-groups.
diff --git a/etc/images/README b/etc/images/README
index 00aac4f..9bbe796 100644
--- a/etc/images/README
+++ b/etc/images/README
@@ -104,3 +104,30 @@ same conditions.
The *.pbm files were generally converted from *.xpm by running GIMP or
ImageMagick's 'convert'.
+
+
+* The following icons are from the Adwaita Icon Theme (made by the
+GNOME project). They are not part of Emacs, but are distributed and
+used by Emacs. They are licensed under either the GNU LGPL v3 or the
+Creative Commons Attribution-Share Alike 3.0 United States License.
+
+To view a copy of the CC-BY-SA licence, visit
+http://creativecommons.org/licenses/by-sa/3.0/ or send a letter to Creative
+Commons, 171 Second Street, Suite 300, San Francisco, California 94105, USA.
+
+For more information see the adwaita-icon-theme repository at:
+
+ https://gitlab.gnome.org/GNOME/adwaita-icon-theme
+
+Emacs images and their source in the Adwaita/scalable directory:
+
+ checked.svg ui/checkbox-checked-symbolic.svg
+ unchecked.svg ui/checkbox-symbolic.svg
+ checkbox-mixed.svg ui/checkbox-mixed-symbolic.svg
+ radio.svg ui/radio-symbolic.svg
+ radio-mixed.svg ui/radio-mixed-symbolic.svg
+ radio-checked.svg ui/radio-checked-symbolic.svg
+ down.svg ui/pan-down-symbolic.svg
+ left.svg ui/pan-start-symbolic.svg
+ right.svg ui/pan-end-symbolic.svg
+ up.svg ui/pan-up-symbolic.svg
diff --git a/etc/images/checkbox-mixed.svg b/etc/images/checkbox-mixed.svg
new file mode 100644
index 0000000..6e46b80
--- /dev/null
+++ b/etc/images/checkbox-mixed.svg
@@ -0,0 +1,6 @@
+<svg xmlns="http://www.w3.org/2000/svg"; height="1em" viewBox="0 0 16 16">
+ <g>
+ <path d="M3.5 1A2.506 2.506 0 0 0 1 3.5v9C1 13.876 2.124 15 3.5 15h9c1.376
0 2.5-1.124 2.5-2.5v-9C15 2.124 13.876 1 12.5 1zm0 1h9c.84 0 1.5 .66 1.5
1.5v9c0 .84-.66 1.5-1.5 1.5h-9c-.84 0-1.5-.66-1.5-1.5v-9C2 2.66 2.66 2 3.5 2z"
overflow="visible" />
+ <path d="M5 6a2 2 0 1 0 0 4h6a2 2 0 1 0 0 -4z" overflow="visible" />
+ </g>
+</svg>
diff --git a/etc/images/checked.svg b/etc/images/checked.svg
new file mode 100644
index 0000000..4cbdef0
--- /dev/null
+++ b/etc/images/checked.svg
@@ -0,0 +1,6 @@
+<svg xmlns="http://www.w3.org/2000/svg"; height="1em" viewBox="0 0 16 16">
+ <g>
+ <path d="M3.5 1A2.506 2.506 0 0 0 1 3.5v9C1 13.876 2.124 15 3.5 15h9c1.376
0 2.5-1.124 2.5-2.5v-9C15 2.124 13.876 1 12.5 1zm0 1h9c.84 0 1.5 .66 1.5
1.5v9c0 .84-.66 1.5-1.5 1.5h-9c-.84 0-1.5-.66-1.5-1.5v-9C2 2.66 2.66 2 3.5 2z"
overflow="visible" />
+ <path d="M14.5 3l-.5-.5L7.5 9 5 6.5l-2 2L7.5 13l7-7z" overflow="visible" />
+ </g>
+</svg>
diff --git a/etc/images/down.svg b/etc/images/down.svg
new file mode 100644
index 0000000..e276042
--- /dev/null
+++ b/etc/images/down.svg
@@ -0,0 +1,40 @@
+<?xml version='1.0' encoding='UTF-8' standalone='no'?>
+<svg xmlns:cc='http://creativecommons.org/ns#'
xmlns:dc='http://purl.org/dc/elements/1.1/'
sodipodi:docname='pan-down-symbolic.svg'
inkscape:export-filename='/home/sam/source-symbolic.png'
inkscape:export-xdpi='270' inkscape:export-ydpi='270' height='16' id='svg7384'
xmlns:inkscape='http://www.inkscape.org/namespaces/inkscape'
xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#'
xmlns:sodipodi='http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd'
style='enable-background:new' xmlns:svg [...]
+ <sodipodi:namedview inkscape:bbox-nodes='true' inkscape:bbox-paths='false'
bordercolor='#000000' borderlayer='false' borderopacity='0.50196078'
inkscape:current-layer='layer10' inkscape:cx='-8.85234' inkscape:cy='7.9624984'
inkscape:document-rotation='0' gridtolerance='10' inkscape:guide-bbox='true'
guidetolerance='10' id='namedview88' inkscape:measure-end='0,0'
inkscape:measure-start='0,0' inkscape:object-nodes='true'
inkscape:object-paths='true' objecttolerance='10' pagecolor='#e2e2e [...]
+ <inkscape:grid color='#000000' dotted='false' empcolor='#0800ff'
empopacity='0.4627451' empspacing='4' enabled='true' id='grid4866'
opacity='0.16470588' originx='-152.00586' originy='-952'
snapvisiblegridlinesonly='true' spacingx='1' spacingy='1' type='xygrid'
visible='true'/>
+ <inkscape:grid dotted='true' empcolor='#3f3fff' empopacity='0'
empspacing='4' id='grid3540' originx='-152.00586' originy='-952' spacingx='0.5'
spacingy='0.5' type='xygrid'/>
+ </sodipodi:namedview>
+ <metadata id='metadata90'>
+ <rdf:RDF>
+ <cc:Work rdf:about=''>
+ <dc:format>image/svg+xml</dc:format>
+ <dc:type rdf:resource='http://purl.org/dc/dcmitype/StillImage'/>
+ <dc:title>Gnome Symbolic Icons</dc:title>
+ <cc:license
rdf:resource='http://creativecommons.org/licenses/by-sa/4.0/'/>
+ </cc:Work>
+ <cc:License rdf:about='http://creativecommons.org/licenses/by-sa/4.0/'>
+ <cc:permits rdf:resource='http://creativecommons.org/ns#Reproduction'/>
+ <cc:permits rdf:resource='http://creativecommons.org/ns#Distribution'/>
+ <cc:requires rdf:resource='http://creativecommons.org/ns#Notice'/>
+ <cc:requires rdf:resource='http://creativecommons.org/ns#Attribution'/>
+ <cc:permits
rdf:resource='http://creativecommons.org/ns#DerivativeWorks'/>
+ <cc:requires rdf:resource='http://creativecommons.org/ns#ShareAlike'/>
+ </cc:License>
+ </rdf:RDF>
+ </metadata>
+ <title id='title8473'>Gnome Symbolic Icons</title>
+ <defs id='defs7386'/>
+ <g inkscape:groupmode='layer' id='layer10' inkscape:label='ui'
transform='translate(-152.00586,-952)'>
+ <path inkscape:connector-curvature='0' d='m 166,957 -5.99414,5.99999 L
154,957 Z' id='path6424' sodipodi:nodetypes='cccc'
style='fill:#2e3436;fill-opacity:1;stroke:none'/>
+ </g>
+ <g inkscape:groupmode='layer' id='layer1' inkscape:label='status'
transform='translate(-152.00586,-888)'/>
+ <g inkscape:groupmode='layer' id='layer11' inkscape:label='legacy'
transform='translate(-152.00586,-952)'/>
+ <g inkscape:groupmode='layer' id='layer7' inkscape:label='places'
transform='translate(-152.00586,-888)'/>
+ <g inkscape:groupmode='layer' id='layer6' inkscape:label='mimetypes'
transform='translate(-152.00586,-888)'/>
+ <g inkscape:groupmode='layer' id='layer5' inkscape:label='emotes'
transform='translate(-152.00586,-888)'/>
+ <g inkscape:groupmode='layer' id='layer9' inkscape:label='emblems'
transform='translate(-152.00586,-888)'/>
+ <g inkscape:groupmode='layer' id='layer2' inkscape:label='devices'
transform='translate(-152.00586,-888)'/>
+ <g inkscape:groupmode='layer' id='layer8' inkscape:label='categories'
transform='translate(-152.00586,-888)'/>
+ <g inkscape:groupmode='layer' id='layer3' inkscape:label='apps'
transform='translate(-152.00586,-888)'/>
+ <g inkscape:groupmode='layer' id='layer4' inkscape:label='actions'
transform='translate(-152.00586,-888)'/>
+</svg>
diff --git a/etc/images/left.svg b/etc/images/left.svg
new file mode 100644
index 0000000..d6429bc
--- /dev/null
+++ b/etc/images/left.svg
@@ -0,0 +1,40 @@
+<?xml version='1.0' encoding='UTF-8' standalone='no'?>
+<svg xmlns:cc='http://creativecommons.org/ns#'
xmlns:dc='http://purl.org/dc/elements/1.1/'
sodipodi:docname='pan-start-symbolic.svg'
inkscape:export-filename='/home/sam/source-symbolic.png'
inkscape:export-xdpi='270' inkscape:export-ydpi='270' height='16' id='svg7384'
xmlns:inkscape='http://www.inkscape.org/namespaces/inkscape'
xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#'
xmlns:sodipodi='http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd'
style='enable-background:new' xmlns:sv [...]
+ <sodipodi:namedview inkscape:bbox-nodes='true' inkscape:bbox-paths='false'
bordercolor='#000000' borderlayer='false' borderopacity='0.50196078'
inkscape:current-layer='layer10' inkscape:cx='51.147672' inkscape:cy='7.96251'
inkscape:document-rotation='0' gridtolerance='10' inkscape:guide-bbox='true'
guidetolerance='10' id='namedview88' inkscape:measure-end='0,0'
inkscape:measure-start='0,0' inkscape:object-nodes='true'
inkscape:object-paths='true' objecttolerance='10' pagecolor='#e2e2e2 [...]
+ <inkscape:grid color='#000000' dotted='false' empcolor='#0800ff'
empopacity='0.4627451' empspacing='4' enabled='true' id='grid4866'
opacity='0.16470588' originx='-92.005848' originy='-951.99999'
snapvisiblegridlinesonly='true' spacingx='1' spacingy='1' type='xygrid'
visible='true'/>
+ <inkscape:grid dotted='true' empcolor='#3f3fff' empopacity='0'
empspacing='4' id='grid3540' originx='-92.005848' originy='-951.99999'
spacingx='0.5' spacingy='0.5' type='xygrid'/>
+ </sodipodi:namedview>
+ <metadata id='metadata90'>
+ <rdf:RDF>
+ <cc:Work rdf:about=''>
+ <dc:format>image/svg+xml</dc:format>
+ <dc:type rdf:resource='http://purl.org/dc/dcmitype/StillImage'/>
+ <dc:title>Gnome Symbolic Icons</dc:title>
+ <cc:license
rdf:resource='http://creativecommons.org/licenses/by-sa/4.0/'/>
+ </cc:Work>
+ <cc:License rdf:about='http://creativecommons.org/licenses/by-sa/4.0/'>
+ <cc:permits rdf:resource='http://creativecommons.org/ns#Reproduction'/>
+ <cc:permits rdf:resource='http://creativecommons.org/ns#Distribution'/>
+ <cc:requires rdf:resource='http://creativecommons.org/ns#Notice'/>
+ <cc:requires rdf:resource='http://creativecommons.org/ns#Attribution'/>
+ <cc:permits
rdf:resource='http://creativecommons.org/ns#DerivativeWorks'/>
+ <cc:requires rdf:resource='http://creativecommons.org/ns#ShareAlike'/>
+ </cc:License>
+ </rdf:RDF>
+ </metadata>
+ <title id='title8473'>Gnome Symbolic Icons</title>
+ <defs id='defs7386'/>
+ <g inkscape:groupmode='layer' id='layer10' inkscape:label='ui'
transform='translate(-92.005848,-951.99999)'>
+ <path inkscape:connector-curvature='0' d='M 103,966 97.00585,959.99999
103,954 Z' id='path6400' sodipodi:nodetypes='cccc'
style='fill:#2e3436;fill-opacity:1;stroke:none'/>
+ </g>
+ <g inkscape:groupmode='layer' id='layer1' inkscape:label='status'
transform='translate(-92.005848,-887.99999)'/>
+ <g inkscape:groupmode='layer' id='layer11' inkscape:label='legacy'
transform='translate(-92.005848,-951.99999)'/>
+ <g inkscape:groupmode='layer' id='layer7' inkscape:label='places'
transform='translate(-92.005848,-887.99999)'/>
+ <g inkscape:groupmode='layer' id='layer6' inkscape:label='mimetypes'
transform='translate(-92.005848,-887.99999)'/>
+ <g inkscape:groupmode='layer' id='layer5' inkscape:label='emotes'
transform='translate(-92.005848,-887.99999)'/>
+ <g inkscape:groupmode='layer' id='layer9' inkscape:label='emblems'
transform='translate(-92.005848,-887.99999)'/>
+ <g inkscape:groupmode='layer' id='layer2' inkscape:label='devices'
transform='translate(-92.005848,-887.99999)'/>
+ <g inkscape:groupmode='layer' id='layer8' inkscape:label='categories'
transform='translate(-92.005848,-887.99999)'/>
+ <g inkscape:groupmode='layer' id='layer3' inkscape:label='apps'
transform='translate(-92.005848,-887.99999)'/>
+ <g inkscape:groupmode='layer' id='layer4' inkscape:label='actions'
transform='translate(-92.005848,-887.99999)'/>
+</svg>
diff --git a/etc/images/radio-checked.svg b/etc/images/radio-checked.svg
new file mode 100644
index 0000000..8950b44
--- /dev/null
+++ b/etc/images/radio-checked.svg
@@ -0,0 +1,6 @@
+<svg xmlns="http://www.w3.org/2000/svg"; height="1em" viewBox="0 0 16 16">
+ <g>
+ <path d="M8 5a3.001 3.001 0 0 0 0 6 3.001 3.001 0 0 0 0 -6z"
overflow="visible"/>
+ <path d="M8.004 1C4.144 1 1 4.144 1 8.004c0 3.86 3.144 7.006 7.004 7.006
3.86 0 7.006-3.146 7.006-7.006C15.01 4.144 11.864 1 8.004 1zm0 1a6.002 6.002 0
0 1 6.006 6.004 6.004 6.004 0 0 1 -6.006 6.006A6.002 6.002 0 0 1 2 8.004 6 6 0
0 1 8.004 2z" overflow="visible"/>
+ </g>
+</svg>
diff --git a/etc/images/radio-mixed.svg b/etc/images/radio-mixed.svg
new file mode 100644
index 0000000..1b3bfa7
--- /dev/null
+++ b/etc/images/radio-mixed.svg
@@ -0,0 +1,6 @@
+<svg xmlns="http://www.w3.org/2000/svg"; height="1em" viewBox="0 0 16 16">
+ <g>
+ <path d="M8 1C4.142 1 1 4.142 1 8s3.142 7 7 7 7-3.142 7-7-3.142-7-7-7zm0
1c3.316 0 6 2.684 6 6s-2.684 6-6 6-6-2.684-6-6 2.684-6 6-6z" overflow="visible"
/>
+ <path d="M5 6a2 2 0 1 0 0 4h6a2 2 0 1 0 0 -4z" overflow="visible" />
+ </g>
+</svg>
diff --git a/etc/images/radio.svg b/etc/images/radio.svg
new file mode 100644
index 0000000..2593a78
--- /dev/null
+++ b/etc/images/radio.svg
@@ -0,0 +1,3 @@
+<svg xmlns="http://www.w3.org/2000/svg"; height="1em" viewBox="0 0 16 16">
+ <path d="M8 1C4.142 1 1 4.142 1 8s3.142 7 7 7 7-3.142 7-7-3.142-7-7-7zm0
1c3.316 0 6 2.684 6 6s-2.684 6-6 6-6-2.684-6-6 2.684-6 6-6z" overflow="visible"
/>
+</svg>
diff --git a/etc/images/right.svg b/etc/images/right.svg
new file mode 100644
index 0000000..d58cd36
--- /dev/null
+++ b/etc/images/right.svg
@@ -0,0 +1,40 @@
+<?xml version='1.0' encoding='UTF-8' standalone='no'?>
+<svg xmlns:cc='http://creativecommons.org/ns#'
xmlns:dc='http://purl.org/dc/elements/1.1/'
sodipodi:docname='pan-end-symbolic.svg'
inkscape:export-filename='/home/sam/source-symbolic.png'
inkscape:export-xdpi='270' inkscape:export-ydpi='270' height='16' id='svg7384'
xmlns:inkscape='http://www.inkscape.org/namespaces/inkscape'
xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#'
xmlns:sodipodi='http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd'
style='enable-background:new' xmlns:svg= [...]
+ <sodipodi:namedview inkscape:bbox-nodes='true' inkscape:bbox-paths='false'
bordercolor='#000000' borderlayer='false' borderopacity='0.50196078'
inkscape:current-layer='layer10' inkscape:cx='31.147668' inkscape:cy='7.96251'
inkscape:document-rotation='0' gridtolerance='10' inkscape:guide-bbox='true'
guidetolerance='10' id='namedview88' inkscape:measure-end='0,0'
inkscape:measure-start='0,0' inkscape:object-nodes='true'
inkscape:object-paths='true' objecttolerance='10' pagecolor='#e2e2e2 [...]
+ <inkscape:grid color='#000000' dotted='false' empcolor='#0800ff'
empopacity='0.4627451' empspacing='4' enabled='true' id='grid4866'
opacity='0.16470588' originx='-112.00585' originy='-951.99999'
snapvisiblegridlinesonly='true' spacingx='1' spacingy='1' type='xygrid'
visible='true'/>
+ <inkscape:grid dotted='true' empcolor='#3f3fff' empopacity='0'
empspacing='4' id='grid3540' originx='-112.00585' originy='-951.99999'
spacingx='0.5' spacingy='0.5' type='xygrid'/>
+ </sodipodi:namedview>
+ <metadata id='metadata90'>
+ <rdf:RDF>
+ <cc:Work rdf:about=''>
+ <dc:format>image/svg+xml</dc:format>
+ <dc:type rdf:resource='http://purl.org/dc/dcmitype/StillImage'/>
+ <dc:title>Gnome Symbolic Icons</dc:title>
+ <cc:license
rdf:resource='http://creativecommons.org/licenses/by-sa/4.0/'/>
+ </cc:Work>
+ <cc:License rdf:about='http://creativecommons.org/licenses/by-sa/4.0/'>
+ <cc:permits rdf:resource='http://creativecommons.org/ns#Reproduction'/>
+ <cc:permits rdf:resource='http://creativecommons.org/ns#Distribution'/>
+ <cc:requires rdf:resource='http://creativecommons.org/ns#Notice'/>
+ <cc:requires rdf:resource='http://creativecommons.org/ns#Attribution'/>
+ <cc:permits
rdf:resource='http://creativecommons.org/ns#DerivativeWorks'/>
+ <cc:requires rdf:resource='http://creativecommons.org/ns#ShareAlike'/>
+ </cc:License>
+ </rdf:RDF>
+ </metadata>
+ <title id='title8473'>Gnome Symbolic Icons</title>
+ <defs id='defs7386'/>
+ <g inkscape:groupmode='layer' id='layer10' inkscape:label='ui'
transform='translate(-112.00585,-951.99999)'>
+ <path inkscape:connector-curvature='0' d='m 117,966 6.00585,-6.00001 L
117,954 Z' id='path6412' sodipodi:nodetypes='cccc'
style='fill:#2e3436;fill-opacity:1;stroke:none'/>
+ </g>
+ <g inkscape:groupmode='layer' id='layer1' inkscape:label='status'
transform='translate(-112.00585,-887.99999)'/>
+ <g inkscape:groupmode='layer' id='layer11' inkscape:label='legacy'
transform='translate(-112.00585,-951.99999)'/>
+ <g inkscape:groupmode='layer' id='layer7' inkscape:label='places'
transform='translate(-112.00585,-887.99999)'/>
+ <g inkscape:groupmode='layer' id='layer6' inkscape:label='mimetypes'
transform='translate(-112.00585,-887.99999)'/>
+ <g inkscape:groupmode='layer' id='layer5' inkscape:label='emotes'
transform='translate(-112.00585,-887.99999)'/>
+ <g inkscape:groupmode='layer' id='layer9' inkscape:label='emblems'
transform='translate(-112.00585,-887.99999)'/>
+ <g inkscape:groupmode='layer' id='layer2' inkscape:label='devices'
transform='translate(-112.00585,-887.99999)'/>
+ <g inkscape:groupmode='layer' id='layer8' inkscape:label='categories'
transform='translate(-112.00585,-887.99999)'/>
+ <g inkscape:groupmode='layer' id='layer3' inkscape:label='apps'
transform='translate(-112.00585,-887.99999)'/>
+ <g inkscape:groupmode='layer' id='layer4' inkscape:label='actions'
transform='translate(-112.00585,-887.99999)'/>
+</svg>
diff --git a/etc/images/unchecked.svg b/etc/images/unchecked.svg
new file mode 100644
index 0000000..09bab8d
--- /dev/null
+++ b/etc/images/unchecked.svg
@@ -0,0 +1,3 @@
+<svg xmlns="http://www.w3.org/2000/svg"; height="1em" viewBox="0 0 16 16">
+ <path d="M3.5 1A2.506 2.506 0 0 0 1 3.5v9C1 13.876 2.124 15 3.5 15h9c1.376 0
2.5-1.124 2.5-2.5v-9C15 2.124 13.876 1 12.5 1zm0 1h9c.84 0 1.5 .66 1.5 1.5v9c0
.84-.66 1.5-1.5 1.5h-9c-.84 0-1.5-.66-1.5-1.5v-9C2 2.66 2.66 2 3.5 2z"
overflow="visible" />
+</svg>
diff --git a/etc/images/up.svg b/etc/images/up.svg
new file mode 100644
index 0000000..9e1a245
--- /dev/null
+++ b/etc/images/up.svg
@@ -0,0 +1,40 @@
+<?xml version='1.0' encoding='UTF-8' standalone='no'?>
+<svg xmlns:cc='http://creativecommons.org/ns#'
xmlns:dc='http://purl.org/dc/elements/1.1/'
sodipodi:docname='pan-up-symbolic.svg'
inkscape:export-filename='/home/sam/source-symbolic.png'
inkscape:export-xdpi='270' inkscape:export-ydpi='270' height='16' id='svg7384'
xmlns:inkscape='http://www.inkscape.org/namespaces/inkscape'
xmlns:rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#'
xmlns:sodipodi='http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd'
style='enable-background:new' xmlns:svg=' [...]
+ <sodipodi:namedview inkscape:bbox-nodes='true' inkscape:bbox-paths='false'
bordercolor='#000000' borderlayer='false' borderopacity='0.50196078'
inkscape:current-layer='layer10' inkscape:cx='11.14767' inkscape:cy='7.9625016'
inkscape:document-rotation='0' gridtolerance='10' inkscape:guide-bbox='true'
guidetolerance='10' id='namedview88' inkscape:measure-end='0,0'
inkscape:measure-start='0,0' inkscape:object-nodes='true'
inkscape:object-paths='true' objecttolerance='10' pagecolor='#e2e2e [...]
+ <inkscape:grid color='#000000' dotted='false' empcolor='#0800ff'
empopacity='0.4627451' empspacing='4' enabled='true' id='grid4866'
opacity='0.16470588' originx='-132.00585' originy='-952'
snapvisiblegridlinesonly='true' spacingx='1' spacingy='1' type='xygrid'
visible='true'/>
+ <inkscape:grid dotted='true' empcolor='#3f3fff' empopacity='0'
empspacing='4' id='grid3540' originx='-132.00585' originy='-952' spacingx='0.5'
spacingy='0.5' type='xygrid'/>
+ </sodipodi:namedview>
+ <metadata id='metadata90'>
+ <rdf:RDF>
+ <cc:Work rdf:about=''>
+ <dc:format>image/svg+xml</dc:format>
+ <dc:type rdf:resource='http://purl.org/dc/dcmitype/StillImage'/>
+ <dc:title>Gnome Symbolic Icons</dc:title>
+ <cc:license
rdf:resource='http://creativecommons.org/licenses/by-sa/4.0/'/>
+ </cc:Work>
+ <cc:License rdf:about='http://creativecommons.org/licenses/by-sa/4.0/'>
+ <cc:permits rdf:resource='http://creativecommons.org/ns#Reproduction'/>
+ <cc:permits rdf:resource='http://creativecommons.org/ns#Distribution'/>
+ <cc:requires rdf:resource='http://creativecommons.org/ns#Notice'/>
+ <cc:requires rdf:resource='http://creativecommons.org/ns#Attribution'/>
+ <cc:permits
rdf:resource='http://creativecommons.org/ns#DerivativeWorks'/>
+ <cc:requires rdf:resource='http://creativecommons.org/ns#ShareAlike'/>
+ </cc:License>
+ </rdf:RDF>
+ </metadata>
+ <title id='title8473'>Gnome Symbolic Icons</title>
+ <defs id='defs7386'/>
+ <g inkscape:groupmode='layer' id='layer10' inkscape:label='ui'
transform='translate(-132.00585,-952)'>
+ <path inkscape:connector-curvature='0' d='M 146,963 140.00585,956.99999
134,963 Z' id='path6418' sodipodi:nodetypes='cccc'
style='fill:#2e3436;fill-opacity:1;stroke:none'/>
+ </g>
+ <g inkscape:groupmode='layer' id='layer1' inkscape:label='status'
transform='translate(-132.00585,-888)'/>
+ <g inkscape:groupmode='layer' id='layer11' inkscape:label='legacy'
transform='translate(-132.00585,-952)'/>
+ <g inkscape:groupmode='layer' id='layer7' inkscape:label='places'
transform='translate(-132.00585,-888)'/>
+ <g inkscape:groupmode='layer' id='layer6' inkscape:label='mimetypes'
transform='translate(-132.00585,-888)'/>
+ <g inkscape:groupmode='layer' id='layer5' inkscape:label='emotes'
transform='translate(-132.00585,-888)'/>
+ <g inkscape:groupmode='layer' id='layer9' inkscape:label='emblems'
transform='translate(-132.00585,-888)'/>
+ <g inkscape:groupmode='layer' id='layer2' inkscape:label='devices'
transform='translate(-132.00585,-888)'/>
+ <g inkscape:groupmode='layer' id='layer8' inkscape:label='categories'
transform='translate(-132.00585,-888)'/>
+ <g inkscape:groupmode='layer' id='layer3' inkscape:label='apps'
transform='translate(-132.00585,-888)'/>
+ <g inkscape:groupmode='layer' id='layer4' inkscape:label='actions'
transform='translate(-132.00585,-888)'/>
+</svg>
diff --git a/etc/themes/manoj-dark-theme.el b/etc/themes/manoj-dark-theme.el
index 1f4891c..5a52711 100644
--- a/etc/themes/manoj-dark-theme.el
+++ b/etc/themes/manoj-dark-theme.el
@@ -1,4 +1,4 @@
-;;; manoj-dark.el --- A dark theme from Manoj -*- lexical-binding:t -*-
+;;; manoj-dark-theme.el --- A dark theme from Manoj -*- lexical-binding:t -*-
;; Copyright (C) 2011-2021 Free Software Foundation, Inc.
diff --git a/etc/themes/modus-operandi-theme.el
b/etc/themes/modus-operandi-theme.el
index 64763a1..77c2e11 100644
--- a/etc/themes/modus-operandi-theme.el
+++ b/etc/themes/modus-operandi-theme.el
@@ -4,7 +4,7 @@
;; Author: Protesilaos Stavrou <info@protesilaos.com>
;; URL: https://gitlab.com/protesilaos/modus-themes
-;; Version: 1.2.3
+;; Version: 1.3.2
;; Package-Requires: ((emacs "26.1"))
;; Keywords: faces, theme, accessibility
@@ -52,6 +52,9 @@
(eval-and-compile
(unless (and (fboundp 'require-theme)
+ load-file-name
+ (equal (file-name-directory load-file-name)
+ (expand-file-name "themes/" data-directory))
(require-theme 'modus-themes t))
(require 'modus-themes)))
diff --git a/etc/themes/modus-themes.el b/etc/themes/modus-themes.el
index ad20707..08e634e 100644
--- a/etc/themes/modus-themes.el
+++ b/etc/themes/modus-themes.el
@@ -4,7 +4,8 @@
;; Author: Protesilaos Stavrou <info@protesilaos.com>
;; URL: https://gitlab.com/protesilaos/modus-themes
-;; Version: 1.2.4
+;; Version: 1.3.2
+;; Last-Modified: <2021-04-18 06:25:05 +0300>
;; Package-Requires: ((emacs "26.1"))
;; Keywords: faces, theme, accessibility
@@ -50,7 +51,7 @@
;; modus-themes-mode-line (choice)
;; modus-themes-diffs (choice)
;; modus-themes-syntax (choice)
-;; modus-themes-intense-hl-line (boolean)
+;; modus-themes-hl-line (choice)
;; modus-themes-subtle-line-numbers (boolean)
;; modus-themes-paren-match (choice)
;; modus-themes-region (choice)
@@ -112,6 +113,7 @@
;; compilation-mode
;; completions
;; consult
+;; corfu
;; counsel
;; counsel-css
;; counsel-notmuch
@@ -155,8 +157,9 @@
;; eldoc-box
;; elfeed
;; elfeed-score
+;; embark
;; emms
-;; enhanced-ruby-mode
+;; enh-ruby-mode (enhanced-ruby-mode)
;; epa
;; equake
;; erc
@@ -284,6 +287,7 @@
;; outline-minor-faces
;; package (M-x list-packages)
;; page-break-lines
+;; pandoc-mode
;; paradox
;; paren-face
;; parrot
@@ -339,10 +343,12 @@
;; swoop
;; sx
;; symbol-overlay
+;; syslog-mode
+;; tab-bar-groups
;; tab-bar-mode
;; tab-line-mode
-;; syslog-mode
;; table (built-in table.el)
+;; telega
;; telephone-line
;; terraform-mode
;; term
@@ -357,6 +363,7 @@
;; vc (built-in mode line status for version control)
;; vc-annotate (C-x v g)
;; vdiff
+;; vertico
;; vimish-fold
;; visible-mark
;; visual-regexp
@@ -389,7 +396,7 @@
;;; News:
;;
;; Users updating from older versions to >= 1.0.0, are advised to read
-;; the anouncement on the emacs-devel mailing list:
+;; the announcement on the emacs-devel mailing list:
;; <https://lists.gnu.org/archive/html/emacs-devel/2021-03/msg00300.html>.
;;
;; The web page of the change log is also available:
@@ -434,9 +441,11 @@
(bg-alt . "#f0f0f0") (fg-alt . "#505050")
;; specifically for on/off states and must be combined with
;; themselves, though the backgrounds are also meant to be used with
- ;; other "active" values, defined further below
+ ;; other "active" values, defined further below; bg-active-accent
+ ;; can work as a substitute for bg-active
(bg-active . "#d7d7d7") (fg-active . "#0a0a0a")
(bg-inactive . "#efefef") (fg-inactive . "#404148")
+ (bg-active-accent . "#d0d6ff")
;; these special values are intended as alternatives to the base
;; values for cases where we need to avoid confusion between the
;; highlighted constructs; they must either be used as pairs based
@@ -496,20 +505,20 @@
;; those foregrounds are meant exclusively for bg-active, bg-inactive
(red-active . "#8a0000")
(green-active . "#004c2e")
- (yellow-active . "#702d1f")
+ (yellow-active . "#702f00")
(blue-active . "#0030b4")
(magenta-active . "#5c2092")
(cyan-active . "#003f8a")
;; the "subtle" values below be combined with fg-dim, while the
;; "intense" should be paired with fg-main
(red-subtle-bg . "#f2b0a2")
- (red-intense-bg . "#ff8892")
+ (red-intense-bg . "#ff9f9f")
(green-subtle-bg . "#aecf90")
(green-intense-bg . "#5ada88")
(yellow-subtle-bg . "#e4c340")
(yellow-intense-bg . "#f5df23")
(blue-subtle-bg . "#b5d0ff")
- (blue-intense-bg . "#6aaeff")
+ (blue-intense-bg . "#77baff")
(magenta-subtle-bg . "#f0d3ff")
(magenta-intense-bg . "#d5baff")
(cyan-subtle-bg . "#c0efff")
@@ -544,7 +553,7 @@
(red-refine-bg . "#ffcccc") (red-refine-fg . "#780000")
(green-refine-bg . "#aceaac") (green-refine-fg . "#004c00")
(yellow-refine-bg . "#fff29a") (yellow-refine-fg . "#604000")
- (blue-refine-bg . "#8ac7ff") (blue-refine-fg . "#002288")
+ (blue-refine-bg . "#8fcfff") (blue-refine-fg . "#002f88")
(magenta-refine-bg . "#ffccff") (magenta-refine-fg . "#770077")
(cyan-refine-bg . "#8eecf4") (cyan-refine-fg . "#004850")
;; the "nuanced" backgrounds can be combined with all of the above
@@ -563,22 +572,22 @@
;; work with all accents that cover those two, plus bg-main
;;
;; bg-hl-alt and bg-hl-alt-intense should only be used when no
- ;; other greyscale or fairly neutral background is available to
+ ;; other grayscale or fairly neutral background is available to
;; properly draw attention to a given construct
;;
;; bg-header is between bg-active and bg-inactive, so it
;; can be combined with any of the "active" values, plus the
;; "special" and base foreground colors
;;
- ;; bg-paren-match, bg-paren-match-intense, bg-region and
- ;; bg-tab-active must be combined with fg-main, while
- ;; bg-tab-inactive should be combined with fg-dim, whereas
+ ;; bg-paren-match, bg-paren-match-intense, bg-region,
+ ;; bg-region-accent and bg-tab-active must be combined with fg-main,
+ ;; while bg-tab-inactive should be combined with fg-dim, whereas
;; bg-tab-inactive-alt goes together with fg-main
;;
;; bg-tab-bar is only intended for the bar that holds the tabs and
;; can only be combined with fg-main
;;
- ;; fg-tab-active is meant to be combined with bg-tab-active,
+ ;; fg-tab-accent is meant to be combined with bg-tab-active,
;; though only for styling special elements, such as underlining
;; the current tab
;;
@@ -606,12 +615,22 @@
(bg-paren-match . "#e0af82")
(bg-paren-match-intense . "#c488ff")
(bg-region . "#bcbcbc")
+ (bg-region-accent . "#afafef")
(bg-tab-bar . "#d5d5d5")
(bg-tab-active . "#f6f6f6")
(bg-tab-inactive . "#bdbdbd")
(bg-tab-inactive-alt . "#999999")
- (fg-tab-active . "#30169e")
+ (fg-tab-accent . "#30169e")
+
+ (red-tab . "#680000")
+ (green-tab . "#003900")
+ (yellow-tab . "#393000")
+ (orange-tab . "#502300")
+ (blue-tab . "#000080")
+ (cyan-tab . "#052f60")
+ (magenta-tab . "#5f004d")
+ (purple-tab . "#400487")
(fg-escape-char-construct . "#8b1030")
(fg-escape-char-backslash . "#654d0f")
@@ -651,10 +670,6 @@
(bg-diff-focus-changed . "#ecdfbf") (fg-diff-focus-changed . "#392900")
(bg-diff-focus-removed . "#efcbcf") (fg-diff-focus-removed . "#4a0000")
- (bg-diff-neutral-0 . "#979797") (fg-diff-neutral-0 . "#040404")
- (bg-diff-neutral-1 . "#b0b0b0") (fg-diff-neutral-1 . "#252525")
- (bg-diff-neutral-2 . "#cccccc") (fg-diff-neutral-2 . "#3a3a3a")
-
(bg-mark-sel . "#a0f0cf") (fg-mark-sel . "#005040")
(bg-mark-del . "#ffccbb") (fg-mark-del . "#840040")
(bg-mark-alt . "#f5d88f") (fg-mark-alt . "#782900"))
@@ -677,13 +692,15 @@ symbol and the latter as a string.")
(defconst modus-themes-vivendi-colors
'(;; base values
(bg-main . "#000000") (fg-main . "#ffffff")
- (bg-dim . "#110b11") (fg-dim . "#e0e6f0")
- (bg-alt . "#181a20") (fg-alt . "#a8a8a8")
+ (bg-dim . "#100f10") (fg-dim . "#e0e6f0")
+ (bg-alt . "#191a1b") (fg-alt . "#a8a8a8")
;; specifically for on/off states and must be combined with
;; themselves, though the backgrounds are also meant to be used with
- ;; other "active" values, defined further below
+ ;; other "active" values, defined further below; bg-active-accent
+ ;; can work as a substitute for bg-active
(bg-active . "#323232") (fg-active . "#f4f4f4")
(bg-inactive . "#1e1e1e") (fg-inactive . "#bfc0c4")
+ (bg-active-accent . "#2a2a66")
;; these special values are intended as alternatives to the base
;; values for cases where we need to avoid confusion between the
;; highlighted constructs; they must either be used as pairs based
@@ -791,7 +808,7 @@ symbol and the latter as a string.")
(red-refine-bg . "#77002a") (red-refine-fg . "#ffb9ab")
(green-refine-bg . "#00422a") (green-refine-fg . "#9ff0cf")
(yellow-refine-bg . "#693200") (yellow-refine-fg . "#e2d980")
- (blue-refine-bg . "#242679") (blue-refine-fg . "#8ec6ff")
+ (blue-refine-bg . "#242679") (blue-refine-fg . "#8ecfff")
(magenta-refine-bg . "#71206a") (magenta-refine-fg . "#ffcaf0")
(cyan-refine-bg . "#004065") (cyan-refine-fg . "#8ae4f2")
;; the "nuanced" backgrounds can be combined with all of the above
@@ -810,22 +827,22 @@ symbol and the latter as a string.")
;; work with all accents that cover those two, plus bg-main
;;
;; bg-hl-alt and bg-hl-alt-intense should only be used when no
- ;; other greyscale or fairly neutral background is available to
+ ;; other grayscale or fairly neutral background is available to
;; properly draw attention to a given construct
;;
;; bg-header is between bg-active and bg-inactive, so it
;; can be combined with any of the "active" values, plus the
;; "special" and base foreground colors
;;
- ;; bg-paren-match, bg-paren-match-intense, bg-region and
- ;; bg-tab-active must be combined with fg-main, while
- ;; bg-tab-inactive should be combined with fg-dim, whereas
+ ;; bg-paren-match, bg-paren-match-intense, bg-region,
+ ;; bg-region-accent and bg-tab-active must be combined with fg-main,
+ ;; while bg-tab-inactive should be combined with fg-dim, whereas
;; bg-tab-inactive-alt goes together with fg-main
;;
;; bg-tab-bar is only intended for the bar that holds the tabs and
;; can only be combined with fg-main
;;
- ;; fg-tab-active is meant to be combined with bg-tab-active,
+ ;; fg-tab-accent is meant to be combined with bg-tab-active,
;; though only for styling special elements, such as underlining
;; the current tab
;;
@@ -853,12 +870,22 @@ symbol and the latter as a string.")
(bg-paren-match . "#5f362f")
(bg-paren-match-intense . "#7416b5")
(bg-region . "#3c3c3c")
+ (bg-region-accent . "#4f3d88")
(bg-tab-bar . "#2c2c2c")
(bg-tab-active . "#0e0e0e")
(bg-tab-inactive . "#3d3d3d")
(bg-tab-inactive-alt . "#595959")
- (fg-tab-active . "#5ac3cf")
+ (fg-tab-accent . "#5ac3cf")
+
+ (red-tab . "#ffc0bf")
+ (green-tab . "#88ef88")
+ (yellow-tab . "#d2e580")
+ (orange-tab . "#f5ca80")
+ (blue-tab . "#92d9ff")
+ (cyan-tab . "#60e7e0")
+ (magenta-tab . "#ffb8ff")
+ (purple-tab . "#cfcaff")
(fg-escape-char-construct . "#e7a59a")
(fg-escape-char-backslash . "#abab00")
@@ -898,10 +925,6 @@ symbol and the latter as a string.")
(bg-diff-focus-changed . "#4a3a10") (fg-diff-focus-changed . "#d0daaf")
(bg-diff-focus-removed . "#5e2526") (fg-diff-focus-removed . "#eebdba")
- (bg-diff-neutral-0 . "#575757") (fg-diff-neutral-0 . "#fcfcfc")
- (bg-diff-neutral-1 . "#454545") (fg-diff-neutral-1 . "#dddddd")
- (bg-diff-neutral-2 . "#313131") (fg-diff-neutral-2 . "#bfbfbf")
-
(bg-mark-sel . "#002f2f") (fg-mark-sel . "#60cfa2")
(bg-mark-del . "#5a0000") (fg-mark-del . "#ff99aa")
(bg-mark-alt . "#3f2210") (fg-mark-alt . "#f0aa20"))
@@ -916,219 +939,219 @@ symbol and the latter as a string.")
;; These faces are used internally to ensure consistency between various
;; groups and to streamline the evaluation of relevant customization
;; options.
-(defface modus-theme-subtle-red nil
+(defface modus-themes-subtle-red nil
"Subtle red background combined with a dimmed foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-subtle-green nil
+(defface modus-themes-subtle-green nil
"Subtle green background combined with a dimmed foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-subtle-yellow nil
+(defface modus-themes-subtle-yellow nil
"Subtle yellow background combined with a dimmed foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-subtle-blue nil
+(defface modus-themes-subtle-blue nil
"Subtle blue background combined with a dimmed foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-subtle-magenta nil
+(defface modus-themes-subtle-magenta nil
"Subtle magenta background combined with a dimmed foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-subtle-cyan nil
+(defface modus-themes-subtle-cyan nil
"Subtle cyan background combined with a dimmed foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-subtle-neutral nil
+(defface modus-themes-subtle-neutral nil
"Subtle gray background combined with a dimmed foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-intense-red nil
+(defface modus-themes-intense-red nil
"Intense red background combined with the main foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-intense-green nil
+(defface modus-themes-intense-green nil
"Intense green background combined with the main foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-intense-yellow nil
+(defface modus-themes-intense-yellow nil
"Intense yellow background combined with the main foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-intense-blue nil
+(defface modus-themes-intense-blue nil
"Intense blue background combined with the main foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-intense-magenta nil
+(defface modus-themes-intense-magenta nil
"Intense magenta background combined with the main foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-intense-cyan nil
+(defface modus-themes-intense-cyan nil
"Intense cyan background combined with the main foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-intense-neutral nil
+(defface modus-themes-intense-neutral nil
"Intense gray background combined with the main foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-refine-red nil
+(defface modus-themes-refine-red nil
"Combination of accented red background and foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-refine-green nil
+(defface modus-themes-refine-green nil
"Combination of accented green background and foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-refine-yellow nil
+(defface modus-themes-refine-yellow nil
"Combination of accented yellow background and foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-refine-blue nil
+(defface modus-themes-refine-blue nil
"Combination of accented blue background and foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-refine-magenta nil
+(defface modus-themes-refine-magenta nil
"Combination of accented magenta background and foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-refine-cyan nil
+(defface modus-themes-refine-cyan nil
"Combination of accented cyan background and foreground.
This is used for general purpose highlighting, mostly in buffers
or for completion interfaces.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-active-red nil
+(defface modus-themes-active-red nil
"A red background meant for use on the modeline or similar.
This is combined with the modelines primary foreground value.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-active-green nil
+(defface modus-themes-active-green nil
"A green background meant for use on the modeline or similar.
This is combined with the modelines primary foreground value.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-active-yellow nil
+(defface modus-themes-active-yellow nil
"A yellow background meant for use on the modeline or similar.
This is combined with the modelines primary foreground value.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-active-blue nil
+(defface modus-themes-active-blue nil
"A blue background meant for use on the modeline or similar.
This is combined with the modelines primary foreground value.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-active-magenta nil
+(defface modus-themes-active-magenta nil
"A magenta background meant for use on the modeline or similar.
This is combined with the modelines primary foreground value.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-active-cyan nil
+(defface modus-themes-active-cyan nil
"A cyan background meant for use on the modeline or similar.
This is combined with the modelines primary foreground value.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-fringe-red nil
+(defface modus-themes-fringe-red nil
"A red background meant for use on the fringe or similar.
This is combined with the main foreground value.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-fringe-green nil
+(defface modus-themes-fringe-green nil
"A green background meant for use on the fringe or similar.
This is combined with the main foreground value.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-fringe-yellow nil
+(defface modus-themes-fringe-yellow nil
"A yellow background meant for use on the fringe or similar.
This is combined with the main foreground value.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-fringe-blue nil
+(defface modus-themes-fringe-blue nil
"A blue background meant for use on the fringe or similar.
This is combined with the main foreground value.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-fringe-magenta nil
+(defface modus-themes-fringe-magenta nil
"A magenta background meant for use on the fringe or similar.
This is combined with the main foreground value.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-fringe-cyan nil
+(defface modus-themes-fringe-cyan nil
"A cyan background meant for use on the fringe or similar.
This is combined with the main foreground value.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-nuanced-red nil
+(defface modus-themes-nuanced-red nil
"A nuanced red background.
This does not specify a foreground of its own. Instead it is meant to
serve as the backdrop for elements such as Org blocks, headings, and any
@@ -1136,7 +1159,7 @@ other surface that needs to retain the colors on display.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-nuanced-green nil
+(defface modus-themes-nuanced-green nil
"A nuanced green background.
This does not specify a foreground of its own. Instead it is meant to
serve as the backdrop for elements such as Org blocks, headings, and any
@@ -1144,7 +1167,7 @@ other surface that needs to retain the colors on display.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-nuanced-yellow nil
+(defface modus-themes-nuanced-yellow nil
"A nuanced yellow background.
This does not specify a foreground of its own. Instead it is meant to
serve as the backdrop for elements such as Org blocks, headings, and any
@@ -1152,7 +1175,7 @@ other surface that needs to retain the colors on display.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-nuanced-blue nil
+(defface modus-themes-nuanced-blue nil
"A nuanced blue background.
This does not specify a foreground of its own. Instead it is meant to
serve as the backdrop for elements such as Org blocks, headings, and any
@@ -1160,7 +1183,7 @@ other surface that needs to retain the colors on display.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-nuanced-magenta nil
+(defface modus-themes-nuanced-magenta nil
"A nuanced magenta background.
This does not specify a foreground of its own. Instead it is meant to
serve as the backdrop for elements such as Org blocks, headings, and any
@@ -1168,7 +1191,7 @@ other surface that needs to retain the colors on display.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-nuanced-cyan nil
+(defface modus-themes-nuanced-cyan nil
"A nuanced cyan background.
This does not specify a foreground of its own. Instead it is meant to
serve as the backdrop for elements such as Org blocks, headings, and any
@@ -1176,7 +1199,7 @@ other surface that needs to retain the colors on display.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-special-cold nil
+(defface modus-themes-special-cold nil
"Combines the 'special cold' background and foreground values.
This is intended for cases when a neutral gray background is not
suitable and where a combination of more saturated colors would not be
@@ -1184,7 +1207,7 @@ appropriate.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-special-mild nil
+(defface modus-themes-special-mild nil
"Combines the 'special mild' background and foreground values.
This is intended for cases when a neutral gray background is not
suitable and where a combination of more saturated colors would not be
@@ -1192,7 +1215,7 @@ appropriate.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-special-warm nil
+(defface modus-themes-special-warm nil
"Combines the 'special warm' background and foreground values.
This is intended for cases when a neutral gray background is not
suitable and where a combination of more saturated colors would not be
@@ -1200,7 +1223,7 @@ appropriate.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-special-calm nil
+(defface modus-themes-special-calm nil
"Combines the 'special calm' background and foreground values.
This is intended for cases when a neutral gray background is not
suitable and where a combination of more saturated colors would not be
@@ -1208,180 +1231,180 @@ appropriate.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-diff-added nil
+(defface modus-themes-diff-added nil
"Combines green colors for the 'added' state in diffs.
The applied colors are contingent on the value assigned to
`modus-themes-diffs'.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-diff-changed nil
+(defface modus-themes-diff-changed nil
"Combines yellow colors for the 'changed' state in diffs.
The applied colors are contingent on the value assigned to
`modus-themes-diffs'.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-diff-removed nil
+(defface modus-themes-diff-removed nil
"Combines red colors for the 'removed' state in diffs.
The applied colors are contingent on the value assigned to
`modus-themes-diffs'.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-diff-refine-added nil
+(defface modus-themes-diff-refine-added nil
"Combines green colors for word-wise 'added' state in diffs.
The applied colors are contingent on the value assigned to
`modus-themes-diffs'.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-diff-refine-changed nil
+(defface modus-themes-diff-refine-changed nil
"Combines yellow colors for word-wise 'changed' state in diffs.
The applied colors are contingent on the value assigned to
`modus-themes-diffs'.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-diff-refine-removed nil
+(defface modus-themes-diff-refine-removed nil
"Combines red colors for word-wise 'removed' state in diffs.
The applied colors are contingent on the value assigned to
`modus-themes-diffs'.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-diff-focus-added nil
+(defface modus-themes-diff-focus-added nil
"Combines green colors for the focused 'added' state in diffs.
The applied colors are contingent on the value assigned to
`modus-themes-diffs'.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-diff-focus-changed nil
+(defface modus-themes-diff-focus-changed nil
"Combines yellow colors for the focused 'changed' state in.
The applied colors are contingent on the value assigned to
`modus-themes-diffs'.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-diff-focus-removed nil
+(defface modus-themes-diff-focus-removed nil
"Combines red colors for the focused 'removed' state in diffs.
The applied colors are contingent on the value assigned to
`modus-themes-diffs'.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-diff-heading nil
+(defface modus-themes-diff-heading nil
"Combines blue colors for the diff hunk heading.
The applied colors are contingent on the value assigned to
`modus-themes-diffs'.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-pseudo-header nil
+(defface modus-themes-pseudo-header nil
"Generic style for some elements that function like headings.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-mark-alt nil
- "Combines yellow colors for marking special lines
+(defface modus-themes-mark-alt nil
+ "Combines yellow colors for marking special lines.
This is intended for use in modes such as Dired, Ibuffer, Proced.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-mark-del nil
- "Combines red colors for marking deletable lines
+(defface modus-themes-mark-del nil
+ "Combines red colors for marking deletable lines.
This is intended for use in modes such as Dired, Ibuffer, Proced.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-mark-sel nil
- "Combines green colors for marking lines
+(defface modus-themes-mark-sel nil
+ "Combines green colors for marking lines.
This is intended for use in modes such as Dired, Ibuffer, Proced.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-mark-symbol nil
+(defface modus-themes-mark-symbol nil
"Applies a blue color and other styles for mark indicators.
This is intended for use in modes such as Dired, Ibuffer, Proced.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-heading-1 nil
- "General purpose face for use in headings level 1
+(defface modus-themes-heading-1 nil
+ "General purpose face for use in headings level 1.
The exact attributes assigned to this face are contingent on the values
assigned to the `modus-themes-headings' variable.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-heading-2 nil
+(defface modus-themes-heading-2 nil
"General purpose face for use in headings level 2.
The exact attributes assigned to this face are contingent on the values
assigned to the `modus-themes-headings' variable.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-heading-3 nil
+(defface modus-themes-heading-3 nil
"General purpose face for use in headings level 3.
The exact attributes assigned to this face are contingent on the values
assigned to the `modus-themes-headings' variable.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-heading-4 nil
+(defface modus-themes-heading-4 nil
"General purpose face for use in headings level 4.
The exact attributes assigned to this face are contingent on the values
assigned to the `modus-themes-headings' variable.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-heading-5 nil
+(defface modus-themes-heading-5 nil
"General purpose face for use in headings level 5.
The exact attributes assigned to this face are contingent on the values
assigned to the `modus-themes-headings' variable.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-heading-6 nil
+(defface modus-themes-heading-6 nil
"General purpose face for use in headings level 6.
The exact attributes assigned to this face are contingent on the values
assigned to the `modus-themes-headings' variable.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-heading-7 nil
+(defface modus-themes-heading-7 nil
"General purpose face for use in headings level 7.
The exact attributes assigned to this face are contingent on the values
assigned to the `modus-themes-headings' variable.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-heading-8 nil
+(defface modus-themes-heading-8 nil
"General purpose face for use in headings level 8.
The exact attributes assigned to this face are contingent on the values
assigned to the `modus-themes-headings' variable.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-hl-line nil
+(defface modus-themes-hl-line nil
"General purpose face for the current line.
The exact attributes assigned to this face are contingent on the values
-assigned to the `modus-themes-intense-hl-line' variable.
+assigned to the `modus-themes-hl-line' variable.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-bold nil
+(defface modus-themes-bold nil
"Generic face for applying a conditional bold weight.
This behaves in accordance with `modus-themes-bold-constructs'.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-slant nil
+(defface modus-themes-slant nil
"Generic face for applying a conditional slant (italics).
This behaves in accordance with `modus-themes-slanted-constructs'.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-variable-pitch nil
+(defface modus-themes-variable-pitch nil
"Generic face for applying a conditional `variable-pitch'.
This behaves in accordance with `modus-themes-no-mixed-fonts',
`modus-themes-variable-pitch-headings' for all heading levels, and
@@ -1389,7 +1412,7 @@ This behaves in accordance with
`modus-themes-no-mixed-fonts',
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-graph-red-0 nil
+(defface modus-themes-graph-red-0 nil
"Special subdued red face for use in graphs.
This is intended to be applied in contexts such as the Org agenda habit
graph where faithfulness to the semantics of a color value is of
@@ -1397,7 +1420,7 @@ paramount importance.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-graph-red-1 nil
+(defface modus-themes-graph-red-1 nil
"Special prominent red face for use in graphs.
This is intended to be applied in contexts such as the Org agenda habit
graph where faithfulness to the semantics of a color value is of
@@ -1405,7 +1428,7 @@ paramount importance.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-graph-green-0 nil
+(defface modus-themes-graph-green-0 nil
"Special subdued green face for use in graphs.
This is intended to be applied in contexts such as the Org agenda habit
graph where faithfulness to the semantics of a color value is of
@@ -1413,7 +1436,7 @@ paramount importance.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-graph-green-1 nil
+(defface modus-themes-graph-green-1 nil
"Special prominent green face for use in graphs.
This is intended to be applied in contexts such as the Org agenda habit
graph where faithfulness to the semantics of a color value is of
@@ -1421,7 +1444,7 @@ paramount importance.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-graph-yellow-0 nil
+(defface modus-themes-graph-yellow-0 nil
"Special subdued yellow face for use in graphs.
This is intended to be applied in contexts such as the Org agenda habit
graph where faithfulness to the semantics of a color value is of
@@ -1429,7 +1452,7 @@ paramount importance.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-graph-yellow-1 nil
+(defface modus-themes-graph-yellow-1 nil
"Special prominent yellow face for use in graphs.
This is intended to be applied in contexts such as the Org agenda habit
graph where faithfulness to the semantics of a color value is of
@@ -1437,7 +1460,7 @@ paramount importance.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-graph-blue-0 nil
+(defface modus-themes-graph-blue-0 nil
"Special subdued blue face for use in graphs.
This is intended to be applied in contexts such as the Org agenda habit
graph where faithfulness to the semantics of a color value is of
@@ -1445,7 +1468,7 @@ paramount importance.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-graph-blue-1 nil
+(defface modus-themes-graph-blue-1 nil
"Special prominent blue face for use in graphs.
This is intended to be applied in contexts such as the Org agenda habit
graph where faithfulness to the semantics of a color value is of
@@ -1453,7 +1476,7 @@ paramount importance.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-graph-magenta-0 nil
+(defface modus-themes-graph-magenta-0 nil
"Special subdued magenta face for use in graphs.
This is intended to be applied in contexts such as the Org agenda habit
graph where faithfulness to the semantics of a color value is of
@@ -1461,7 +1484,7 @@ paramount importance.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-graph-magenta-1 nil
+(defface modus-themes-graph-magenta-1 nil
"Special prominent magenta face for use in graphs.
This is intended to be applied in contexts such as the Org agenda habit
graph where faithfulness to the semantics of a color value is of
@@ -1469,7 +1492,7 @@ paramount importance.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-graph-cyan-0 nil
+(defface modus-themes-graph-cyan-0 nil
"Special subdued cyan face for use in graphs.
This is intended to be applied in contexts such as the Org agenda habit
graph where faithfulness to the semantics of a color value is of
@@ -1477,7 +1500,7 @@ paramount importance.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-graph-cyan-1 nil
+(defface modus-themes-graph-cyan-1 nil
"Special prominent cyan face for use in graphs.
This is intended to be applied in contexts such as the Org agenda habit
graph where faithfulness to the semantics of a color value is of
@@ -1485,27 +1508,51 @@ paramount importance.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-lang-note nil
+(defface modus-themes-lang-note nil
"Generic face for linter or spell checker notes.
The exact attributes and color combinations are controlled by
`modus-themes-lang-checkers'.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-lang-warning nil
+(defface modus-themes-lang-warning nil
"Generic face for linter or spell checker warnings.
The exact attributes and color combinations are controlled by
`modus-themes-lang-checkers'.
The actual styling of the face is done by `modus-themes-faces'.")
-(defface modus-theme-lang-error nil
+(defface modus-themes-lang-error nil
"Generic face for linter or spell checker errors.
The exact attributes and color combinations are controlled by
`modus-themes-lang-checkers'.
The actual styling of the face is done by `modus-themes-faces'.")
+(defface modus-themes-reset-soft nil
+ "Generic face to set most face properties to nil.
+
+This is intended to be inherited by faces that should not retain
+properties from their context (e.g. an overlay over an underlined
+text should not be underlined as well) yet still blend in. Also
+see `modus-themes-reset-hard'.
+
+The actual styling of the face is done by `modus-themes-faces'.")
+
+(defface modus-themes-reset-hard nil
+ "Generic face to set all face properties to nil.
+
+This is intended to be inherited by faces that should not retain
+properties from their context (e.g. an overlay over an underlined
+text should not be underlined as well) and not blend in. Also
+see `modus-themes-reset-soft'.
+
+The actual styling of the face is done by `modus-themes-faces'.")
+
+(defface modus-themes-key-binding nil
+ "Generic face for key bindings.
+The actual styling of the face is done by `modus-themes-faces'.")
+
;;; Customization options
@@ -1592,8 +1639,31 @@ mixing fonts."
:type 'boolean
:link '(info-link "(modus-themes) No mixed fonts"))
-(defcustom modus-themes-headings
- '((t . nil))
+(defconst modus-themes--headings-choice
+ '(choice
+ (const :format "[%v] %t\n" :tag "Fairly desaturated foreground with bold
weight (default)" nil)
+ (const :format "[%v] %t\n" :tag "Same as the default
(backward-compatible)" t)
+ (const :format "[%v] %t\n" :tag "Like the default without bold weight"
no-bold)
+ (const :format "[%v] %t\n" :tag "Like the default plus overline" line)
+ (const :format "[%v] %t\n" :tag "Like `line' without bold weight"
line-no-bold)
+ (const :format "[%v] %t\n" :tag "Like the default but with more colorful
foreground" rainbow)
+ (const :format "[%v] %t\n" :tag "Like `rainbow' plus overline"
rainbow-line)
+ (const :format "[%v] %t\n" :tag "Like `rainbow' without bold weight"
rainbow-no-bold)
+ (const :format "[%v] %t\n" :tag "Like `rainbow-line' without bold weight"
rainbow-line-no-bold)
+ (const :format "[%v] %t\n" :tag "Like the default plus subtle background"
highlight)
+ (const :format "[%v] %t\n" :tag "Like `highlight' without bold weight"
highlight-no-bold)
+ (const :format "[%v] %t\n" :tag "Like `highlight' with more colorful
foreground" rainbow-highlight)
+ (const :format "[%v] %t\n" :tag "Like `rainbow-highlight' without bold
weight" rainbow-highlight-no-bold)
+ (const :format "[%v] %t\n" :tag "Like `highlight' plus overline" section)
+ (const :format "[%v] %t\n" :tag "Like `section' without bold weight"
section-no-bold)
+ (const :format "[%v] %t\n" :tag "Like `section' with more colorful
foreground" rainbow-section)
+ (const :format "[%v] %t\n" :tag "Like `rainbow-section' without bold
weight" rainbow-section-no-bold)
+ (const :format "[%v] %t\n" :tag "Do not use any distinct foreground color;
just bold weight" no-color)
+ (const :format "[%v] %t\n" :tag "Like `no-bold' but without the distinct
foreground color" no-color-no-bold))
+ "Refer to the doc string of `modus-themes-headings'.
+This is a helper variable intended for internal use.")
+
+(defcustom modus-themes-headings nil
"Alist of styles for headings, with optional value per level.
To control faces per level from 1-8, use something like this:
@@ -1608,17 +1678,18 @@ To set a uniform value for all heading levels, use this
pattern:
(setq modus-themes-headings
'((t . rainbow-line-no-bold)))
-The default uses a fairly desaturated foreground value in
+The default value uses a fairly desaturated foreground color in
combination with a bold typographic weight. To specify this
style for a given level N (assuming you wish to have another
-fallback option), just specify the value t like this:
+fallback option), just specify the value nil like this:
(setq modus-themes-headings
- '((1 . t)
+ '((1 . nil)
(2 . line)
+ (3) ; same as nil
(t . rainbow-line-no-bold)))
-A description of all possible values:
+A description of all other possible values:
+ `no-bold' retains the default text color while removing the
typographic weight.
@@ -1669,30 +1740,14 @@ A description of all possible values:
+ `no-color-no-bold' is like `no-color' but without the bold
weight."
:group 'modus-themes
- :package-version '(modus-themes . "1.2.0")
+ :package-version '(modus-themes . "1.3.0")
:version "28.1"
- :type
- '(alist
- :key-type symbol
- :value-type
- (choice (const :tag "Fairly desaturated foreground with bold weight
(default)" t)
- (const :tag "Like the default without bold weight" no-bold)
- (const :tag "Like the default plus overline" line)
- (const :tag "Like `line' without bold weight" line-no-bold)
- (const :tag "Like the default but with more colorful foreground"
rainbow)
- (const :tag "Like `rainbow' plus overline" rainbow-line)
- (const :tag "Like `rainbow' without bold weight" rainbow-no-bold)
- (const :tag "Like `rainbow-line' without bold weight"
rainbow-line-no-bold)
- (const :tag "Like the default plus subtle background" highlight)
- (const :tag "Like `highlight' without bold weight"
highlight-no-bold)
- (const :tag "Like `highlight' with more colorful foreground"
rainbow-highlight)
- (const :tag "Like `rainbow-highlight' without bold weight"
rainbow-highlight-no-bold)
- (const :tag "Like `highlight' plus overline" section)
- (const :tag "Like `section' without bold weight" section-no-bold)
- (const :tag "Like `section' with more colorful foreground"
rainbow-section)
- (const :tag "Like `rainbow-section' without bold weight"
rainbow-section-no-bold)
- (const :tag "Do not use any distinct foreground color; just bold
weight" no-color)
- (const :tag "Like `no-bold' but without the distinct foreground
color" no-color-no-bold)))
+ :type `(alist
+ :options ,(mapcar (lambda (el)
+ (list el modus-themes--headings-choice))
+ '(1 2 3 4 5 6 7 8 t))
+ :key-type symbol
+ :value-type ,modus-themes--headings-choice)
:link '(info-link "(modus-themes) Heading styles"))
(defcustom modus-themes-scale-headings nil
@@ -1830,16 +1885,16 @@ accordance with it in cases where it changes, such as
while using
"Define the visibility of fringes.
Nil means the fringes have no background color. Option `subtle'
-will apply a greyscale value that is visible yet close to the
+will apply a grayscale value that is visible yet close to the
main buffer background color. Option `intense' will use a more
-pronounced greyscale value."
+pronounced grayscale value."
:group 'modus-themes
:package-version '(modus-themes . "1.0.0")
:version "28.1"
:type '(choice
- (const :tag "No visible fringes (default)" nil)
- (const :tag "Subtle greyscale background" subtle)
- (const :tag "Intense greyscale background" intense))
+ (const :format "[%v] %t\n" :tag "No visible fringes (default)" nil)
+ (const :format "[%v] %t\n" :tag "Subtle grayscale background" subtle)
+ (const :format "[%v] %t\n" :tag "Intense grayscale background"
intense))
:link '(info-link "(modus-themes) Fringes"))
(defcustom modus-themes-lang-checkers nil
@@ -1867,13 +1922,13 @@ most intense combination of face properties."
:package-version '(modus-themes . "1.1.0")
:version "28.1"
:type '(choice
- (const :tag "Only color-coded wavy underline (default)" nil)
- (const :tag "Like the default, but with a straight underline"
straight-underline)
- (const :tag "Color-coded wavy underline; subtle foreground"
subtle-foreground)
- (const :tag "Combines `straight-underline' and `subtle-foreground'"
subtle-foreground-straight-underline)
- (const :tag "Color-coded wavy underline; intense foreground"
intense-foreground)
- (const :tag "Combines `straight-underline' and `intense-foreground'"
intense-foreground-straight-underline)
- (const :tag "Color-coded background, foreground, straight underline"
colored-background))
+ (const :format "[%v] %t\n" :tag "Only color-coded wavy underline
(default)" nil)
+ (const :format "[%v] %t\n" :tag "Like the default, but with a
straight underline" straight-underline)
+ (const :format "[%v] %t\n" :tag "Color-coded wavy underline; subtle
foreground" subtle-foreground)
+ (const :format "[%v] %t\n" :tag "Combines `straight-underline' and
`subtle-foreground'" subtle-foreground-straight-underline)
+ (const :format "[%v] %t\n" :tag "Color-coded wavy underline; intense
foreground" intense-foreground)
+ (const :format "[%v] %t\n" :tag "Combines `straight-underline' and
`intense-foreground'" intense-foreground-straight-underline)
+ (const :format "[%v] %t\n" :tag "Color-coded background, foreground,
straight underline" colored-background))
:link '(info-link "(modus-themes) Language checkers"))
(defcustom modus-themes-org-blocks nil
@@ -1897,10 +1952,10 @@ association list)."
:package-version '(modus-themes . "1.0.0")
:version "28.1"
:type '(choice
- (const :tag "No Org block background (default)" nil)
- (const :tag "Subtle gray block background" grayscale)
- (const :tag "Subtle gray block background (alt spelling)" greyscale)
- (const :tag "Color-coded background per programming language"
rainbow))
+ (const :format "[%v] %t\n" :tag "No Org block background (default)"
nil)
+ (const :format "[%v] %t\n" :tag "Subtle gray block background"
grayscale)
+ (const :format "[%v] %t\n" :tag "Subtle gray block background (alt
spelling)" greyscale)
+ (const :format "[%v] %t\n" :tag "Color-coded background per
programming language" rainbow))
:link '(info-link "(modus-themes) Org mode blocks"))
(defcustom modus-themes-org-habit nil
@@ -1936,17 +1991,17 @@ highlights the alert and overdue states."
:package-version '(modus-themes . "1.1.0")
:version "28.1"
:type '(choice
- (const :tag "Respect the original design of org-habit (default)" nil)
- (const :tag "Like the default, but do not distinguish between
present and future variants" simplified)
- (const :tag "Like `simplified', but only use red, yellow, green"
traffic-light))
+ (const :format "[%v] %t\n" :tag "Respect the original design of
org-habit (default)" nil)
+ (const :format "[%v] %t\n" :tag "Like the default, but do not
distinguish between present and future variants" simplified)
+ (const :format "[%v] %t\n" :tag "Like `simplified', but only use
red, yellow, green" traffic-light))
:link '(info-link "(modus-themes) Org agenda habits"))
(defcustom modus-themes-mode-line nil
"Adjust the overall style of the mode line.
-Nil is a two-dimensional rectangle with a border around it. The
-active and the inactive modelines use different shades of
-greyscale values for the background and foreground.
+The default (nil) is a two-dimensional rectangle with a border
+around it. The active and the inactive modelines use different
+shades of grayscale values for the background and foreground.
A `3d' value will apply a three-dimensional effect to the active
modeline. The inactive modelines remain two-dimensional and are
@@ -1969,17 +2024,25 @@ and `moody' options respectively, while removing the
borders.
However, to ensure that the inactive modelines remain visible,
they apply a slightly more prominent background to them than what
their counterparts do (same inactive background as with the
-default)."
+default).
+
+Similarly, `accented', `accented-3d', and `accented-moody'
+correspond to the default (nil), `3d', and `moody' styles
+respectively, except that the active mode line uses a colored
+background instead of the standard shade of gray."
:group 'modus-themes
- :package-version '(modus-themes . "1.0.0")
+ :package-version '(modus-themes . "1.3.0")
:version "28.1"
:type '(choice
- (const :tag "Two-dimensional box (default)" nil)
- (const :tag "Three-dimensional style for the active mode line" 3d)
- (const :tag "No box effects, which are optimal for use with the
`moody' library" moody)
- (const :tag "Like the default, but without border effects"
borderless)
- (const :tag "Like `3d', but without noticeable border" borderless-3d)
- (const :tag "Like `moody', but without noticeable border"
borderless-moody))
+ (const :format "[%v] %t\n" :tag "Two-dimensional box (default)" nil)
+ (const :format "[%v] %t\n" :tag "Three-dimensional style for the
active mode line" 3d)
+ (const :format "[%v] %t\n" :tag "No box effects, which are optimal
for use with the `moody' library" moody)
+ (const :format "[%v] %t\n" :tag "Like the default, but without
border effects" borderless)
+ (const :format "[%v] %t\n" :tag "Like `3d', but without noticeable
border" borderless-3d)
+ (const :format "[%v] %t\n" :tag "Like `moody', but without
noticeable border" borderless-moody)
+ (const :format "[%v] %t\n" :tag "Two-dimensional box with a colored
background" accented)
+ (const :format "[%v] %t\n" :tag "Like `3d', but with a colored
background" accented-3d)
+ (const :format "[%v] %t\n" :tag "Like `moody', but with a colored
background" accented-moody))
:link '(info-link "(modus-themes) Mode line"))
(defcustom modus-themes-diffs nil
@@ -1998,7 +2061,7 @@ Option `fg-only' will remove all accented backgrounds,
except
from word-wise changes. It instead uses color-coded foreground
values to differentiate between added/removed/changed lines. If
a background is necessary, such as with `ediff', then a subtle
-greyscale value is used.
+grayscale value is used.
Option `bg-only' applies a background but does not override the
text's foreground. This makes it suitable for a non-nil value
@@ -2014,11 +2077,11 @@ of optimizing for such a use-case."
:package-version '(modus-themes . "1.2.0")
:version "28.1"
:type '(choice
- (const :tag "Intensely colored backgrounds (default)" nil)
- (const :tag "Slightly accented backgrounds with tinted text"
desaturated)
- (const :tag "No backgrounds, except for refined diffs" fg-only)
- (const :tag "Apply color-coded backgrounds; keep syntax colors in
tact" bg-only)
- (const :tag "Optimized for red-green color defficiency"
deuteranopia))
+ (const :format "[%v] %t\n" :tag "Intensely colored backgrounds
(default)" nil)
+ (const :format "[%v] %t\n" :tag "Slightly accented backgrounds with
tinted text" desaturated)
+ (const :format "[%v] %t\n" :tag "No backgrounds, except for refined
diffs" fg-only)
+ (const :format "[%v] %t\n" :tag "Apply color-coded backgrounds; keep
syntax colors in tact" bg-only)
+ (const :format "[%v] %t\n" :tag "Optimized for red-green color
defficiency" deuteranopia))
:link '(info-link "(modus-themes) Diffs"))
(defcustom modus-themes-completions nil
@@ -2048,9 +2111,9 @@ revert to an even more nuanced aesthetic."
:package-version '(modus-themes . "1.0.0")
:version "28.1"
:type '(choice
- (const :tag "Respect the framework's established aesthetic
(default)" nil)
- (const :tag "Subtle backgrounds for various elements" moderate)
- (const :tag "Radical alternative to the framework's looks"
opinionated))
+ (const :format "[%v] %t\n" :tag "Respect the framework's established
aesthetic (default)" nil)
+ (const :format "[%v] %t\n" :tag "Subtle backgrounds for various
elements" moderate)
+ (const :format "[%v] %t\n" :tag "Radical alternative to the
framework's looks" opinionated))
:link '(info-link "(modus-themes) Completion UIs"))
(defcustom modus-themes-prompts nil
@@ -2069,18 +2132,18 @@ Options `subtle-gray' and `intense-gray' are like their
`subtle-accented' and `intense-accented' counterparts, except
they use grayscale values instead of accented ones."
:group 'modus-themes
- :package-version '(modus-themes . "1.0.0")
+ :package-version '(modus-themes . "1.1.0")
:version "28.1"
:type '(choice
;; `subtle' is the same as `subtle-accented', while `intense' is
;; equal to `intense-accented' for backward compatibility
- (const :tag "No prompt background (default)" nil)
- (const :tag "Subtle accented background for the prompt"
subtle-accented)
- (const :tag "Same as `subtle-accented' for compatibility with older
versions" subtle)
- (const :tag "Intense accented background and foreground for the
prompt" intense-accented)
- (const :tag "Same as `intense-accented' for compatibility with older
versions" intense)
- (const :tag "Like `subtle-accented' but grayscale" subtle-gray)
- (const :tag "Like `intense-accented' but grayscale" intense-gray))
+ (const :format "[%v] %t\n" :tag "No prompt background (default)" nil)
+ (const :format "[%v] %t\n" :tag "Subtle accented background for the
prompt" subtle-accented)
+ (const :format "[%v] %t\n" :tag "Same as `subtle-accented' for
compatibility with older versions" subtle)
+ (const :format "[%v] %t\n" :tag "Intense accented background and
foreground for the prompt" intense-accented)
+ (const :format "[%v] %t\n" :tag "Same as `intense-accented' for
compatibility with older versions" intense)
+ (const :format "[%v] %t\n" :tag "Like `subtle-accented' but
grayscale" subtle-gray)
+ (const :format "[%v] %t\n" :tag "Like `intense-accented' but
grayscale" intense-gray))
:link '(info-link "(modus-themes) Command prompts"))
(defcustom modus-themes-intense-hl-line nil
@@ -2091,6 +2154,45 @@ they use grayscale values instead of accented ones."
:type 'boolean
:link '(info-link "(modus-themes) Line highlighting"))
+(make-obsolete 'modus-themes-intense-hl-line 'modus-themes-hl-line "1.3.0")
+
+(defcustom modus-themes-hl-line nil
+ "Control the current line highlight of HL-line mode.
+
+The default (nil) is to apply a subtle neutral background to the
+current line.
+
+Option `intense-background' uses a prominent neutral background.
+
+Option `accented-background' uses a subtle colored background.
+
+Option `underline-neutral' combines a subtle neutral background
+with a gray underline.
+
+Option `underline-accented' draws an underline while applying a
+subtle colored background.
+
+Option `underline-only-neutral' uses just a neutral underline,
+without any added change to the background.
+
+Option `underline-only-accented' uses just a colored underline,
+without any added change to the background.
+
+Set `x-underline-at-descent-line' to a non-nil value for better
+results with underlines."
+ :group 'modus-themes
+ :package-version '(modus-themes . "1.3.0")
+ :version "28.1"
+ :type '(choice
+ (const :format "[%v] %t\n" :tag "Subtle neutral background
(default)" nil)
+ (const :format "[%v] %t\n" :tag "Prominent neutral background"
intense-background)
+ (const :format "[%v] %t\n" :tag "Subtle colored background"
accented-background)
+ (const :format "[%v] %t\n" :tag "Underline with a subtle neutral
background" underline-neutral)
+ (const :format "[%v] %t\n" :tag "Underline with a subtle colored
background" underline-accented)
+ (const :format "[%v] %t\n" :tag "Just a neutral underline, without a
background" underline-only-neutral)
+ (const :format "[%v] %t\n" :tag "Just an accented underline, without
a background" underline-only-accented))
+ :link '(info-link "(modus-themes) Line highlighting"))
+
(defcustom modus-themes-subtle-line-numbers nil
"Use more subtle style for command `display-line-numbers-mode'."
:group 'modus-themes
@@ -2115,10 +2217,10 @@ uses a bold weight."
:package-version '(modus-themes . "1.0.0")
:version "28.1"
:type '(choice
- (const :tag "Sublte tinted background (default)" nil)
- (const :tag "Like the default, but also use bold typographic weight"
subtle-bold)
- (const :tag "Intense saturated background" intense)
- (const :tag "Like `intense' but with bold weight" intense-bold))
+ (const :format "[%v] %t\n" :tag "Sublte tinted background (default)"
nil)
+ (const :format "[%v] %t\n" :tag "Like the default, but also use bold
typographic weight" subtle-bold)
+ (const :format "[%v] %t\n" :tag "Intense saturated background"
intense)
+ (const :format "[%v] %t\n" :tag "Like `intense' but with bold
weight" intense-bold))
:link '(info-link "(modus-themes) Matching parentheses"))
(defcustom modus-themes-syntax nil
@@ -2155,14 +2257,14 @@ Option `faint-yellow-comments' combines the `faint'
style with
:package-version '(modus-themes . "1.2.0")
:version "28.1"
:type '(choice
- (const :tag "Balanced use of blue, cyan, magenta, purple variants
(default)" nil)
- (const :tag "Like the default, but with desaturated color values"
faint)
- (const :tag "Apply yellow tint to comments, keep the default style
for the rest" yellow-comments)
- (const :tag "Use green for strings, keep the default style for the
rest" green-strings)
- (const :tag "Use green for strings, yellow for comments, keep the
default style for the rest" yellow-comments-green-strings)
- (const :tag "Refashion syntax highlighting with more colors, gray
comments" alt-syntax)
- (const :tag "Like `alt-syntax' but with yellow comments"
alt-syntax-yellow-comments)
- (const :tag "Like `faint' but with yellow comments"
faint-yellow-comments))
+ (const :format "[%v] %t\n" :tag "Balanced use of blue, cyan,
magenta, purple variants (default)" nil)
+ (const :format "[%v] %t\n" :tag "Like the default, but with
desaturated color values" faint)
+ (const :format "[%v] %t\n" :tag "Apply yellow tint to comments, keep
the default style for the rest" yellow-comments)
+ (const :format "[%v] %t\n" :tag "Use green for strings, keep the
default style for the rest" green-strings)
+ (const :format "[%v] %t\n" :tag "Use green for strings, yellow for
comments, keep the default style for the rest" yellow-comments-green-strings)
+ (const :format "[%v] %t\n" :tag "Refashion syntax highlighting with
more colors, gray comments" alt-syntax)
+ (const :format "[%v] %t\n" :tag "Like `alt-syntax' but with yellow
comments" alt-syntax-yellow-comments)
+ (const :format "[%v] %t\n" :tag "Like `faint' but with yellow
comments" faint-yellow-comments))
:link '(info-link "(modus-themes) Syntax styles"))
(defcustom modus-themes-links nil
@@ -2174,11 +2276,11 @@ foreground.
Option `faint' applies desaturated colors to the link's text and
underline.
-Option `neutral-underline' applies a subtle grey underline, while
+Option `neutral-underline' applies a subtle gray underline, while
retaining the link's foreground.
Option `faint-neutral-underline' combines a desaturated text
-color with a subtle grey underline.
+color with a subtle gray underline.
Option `no-underline' removes link underlines altogether, while
retaining their original fairly vivid color.
@@ -2193,13 +2295,13 @@ using a subtle underline below it."
:package-version '(modus-themes . "1.2.0")
:version "28.1"
:type '(choice
- (const :tag "Undeline link using the same color as the text
(default)" nil)
- (const :tag "Like the default, but apply less intense colors to
links" faint)
- (const :tag "Change the color of link underlines to a neutral grey"
neutral-underline)
- (const :tag "Desaturated foreground with neutral grey underline"
faint-neutral-underline)
- (const :tag "Remove underline property from links, keeping their
foreground as-is" no-underline)
- (const :tag "Apply underline only; use default foreground"
underline-only)
- (const :tag "Like `underline-only' but with a subtle underline"
neutral-underline-only))
+ (const :format "[%v] %t\n" :tag "Undeline link using the same color
as the text (default)" nil)
+ (const :format "[%v] %t\n" :tag "Like the default, but apply less
intense colors to links" faint)
+ (const :format "[%v] %t\n" :tag "Change the color of link underlines
to a neutral gray" neutral-underline)
+ (const :format "[%v] %t\n" :tag "Desaturated foreground with neutral
gray underline" faint-neutral-underline)
+ (const :format "[%v] %t\n" :tag "Remove underline property from
links, keeping their foreground as-is" no-underline)
+ (const :format "[%v] %t\n" :tag "Apply underline only; use default
foreground" underline-only)
+ (const :format "[%v] %t\n" :tag "Like `underline-only' but with a
subtle underline" neutral-underline-only))
:link '(info-link "(modus-themes) Link styles"))
(defcustom modus-themes-region nil
@@ -2218,15 +2320,24 @@ override any existing colors. It extends to the edge
of the
window.
Option `bg-only-no-extend' is a combination of the `bg-only' and
-`no-extend' options."
+`no-extend' options.
+
+Option `accent' uses a more colorful background with a neutral
+foreground. It overrides all syntax highlighting and extends to
+the edge of the window.
+
+Option `accent-no-extend' is like the above, but stretches only
+to the end of each line within the region."
:group 'modus-themes
- :package-version '(modus-themes . "1.0.0")
+ :package-version '(modus-themes . "1.3.0")
:version "28.1"
:type '(choice
- (const :tag "Intense background; overrides colors; extends to edge
of window (default)" nil)
- (const :tag "As with the default, but does not extend" no-extend)
- (const :tag "Subtle background; preserves colors; extends to edge of
window" bg-only)
- (const :tag "As with the `subtle' option, but does not extend"
bg-only-no-extend))
+ (const :format "[%v] %t\n" :tag "Intense background; overrides
colors; extends to edge of window (default)" nil)
+ (const :format "[%v] %t\n" :tag "As with the default, but does not
extend" no-extend)
+ (const :format "[%v] %t\n" :tag "Subtle background; preserves
colors; extends to edge of window" bg-only)
+ (const :format "[%v] %t\n" :tag "As with the `subtle' option, but
does not extend" bg-only-no-extend)
+ (const :format "[%v] %t\n" :tag "Like the default, but with an
accented background" accent)
+ (const :format "[%v] %t\n" :tag "As with the `accent' option, but
does not extend" accent-no-extend))
:link '(info-link "(modus-themes) Active region"))
@@ -2382,8 +2493,8 @@ Those are stored in `modus-themes-faces' and
(defun modus-themes--fringe (mainbg subtlebg intensebg)
"Conditional use of background colors for fringes.
-MAINBG is the default. SUBTLEBG should be a subtle greyscale
-value. INTENSEBG must be a more pronounced greyscale color."
+MAINBG is the default. SUBTLEBG should be a subtle grayscale
+value. INTENSEBG must be a more pronounced grayscale color."
(pcase modus-themes-fringes
('intense (list :background intensebg))
('subtle (list :background subtlebg))
@@ -2431,9 +2542,9 @@ combinable with INTENSEFG."
('intense (list :background intensebg :foreground intensefg))
('subtle-accented (list :background subtlebg :foreground subtlefg))
('subtle (list :background subtlebg :foreground subtlefg))
- ('subtle-gray (list :inherit 'modus-theme-subtle-neutral))
- ('intense-gray (list :inherit 'modus-theme-intense-neutral))
- (_ (list :background nil :foreground mainfg))))
+ ('subtle-gray (list :inherit 'modus-themes-subtle-neutral))
+ ('intense-gray (list :inherit 'modus-themes-intense-neutral))
+ (_ (list :background 'unspecified :foreground mainfg))))
(defun modus-themes--paren (normalbg intensebg)
"Conditional use of intense colors for matching parentheses.
@@ -2582,10 +2693,10 @@ theme's source code)."
BG, FG, BGACCENT, FGACCENT apply a background and foreground
color respectively.
-The former pair is a greyscale combination that should be more
+The former pair is a grayscale combination that should be more
distinct than the background of the block. It is applied to the
default styles or when `modus-themes-org-blocks' is set
-to `greyscale'.
+to `grayscale' (or `greyscale').
The latter pair should be more subtle than the background of the
block, as it is used when `modus-themes-org-blocks' is
@@ -2606,13 +2717,14 @@ instead. Same for SIMPLE."
(_ (list :background default))))
(defun modus-themes--mode-line-attrs
- (fg bg fg-alt bg-alt border border-3d &optional alt-style border-width
fg-distant)
+ (fg bg fg-alt bg-alt fg-accent bg-accent border border-3d &optional
alt-style border-width fg-distant)
"Color combinations for `modus-themes-mode-line'.
FG and BG are the default colors. FG-ALT and BG-ALT are meant to
accommodate the options for a 3D modeline or a `moody' compliant
-one. BORDER applies to all permutations of the modeline, except
-the three-dimensional effect, where BORDER-3D is used instead.
+one. FG-ACCENT and BG-ACCENT are used for all variants. BORDER
+applies to all permutations of the modeline, except the
+three-dimensional effect, where BORDER-3D is used instead.
Optional ALT-STYLE applies an appropriate style to the mode
line's box property.
@@ -2644,6 +2756,17 @@ property."
`(:background ,bg :foreground ,fg
:underline ,bg :overline ,bg
:distant-foreground ,fg-distant))
+ ('accented
+ `(:foreground ,fg-accent :background ,bg-accent :box ,border))
+ ('accented-3d
+ `(:background ,bg-accent :foreground ,fg-accent
+ :box (:line-width ,(or border-width 1)
+ :color ,border-3d
+ :style ,(and alt-style 'released-button))))
+ ('accented-moody
+ `(:background ,bg-accent :foreground ,fg-accent
+ :underline ,border :overline ,border
+ :distant-foreground ,fg-distant))
(_
`(:foreground ,fg :background ,bg :box ,border))))
@@ -2730,7 +2853,7 @@ These are intended for Helm, Ivy, etc."
"Conditional application of link styles.
FG is the link's default color for its text and underline
property. FGFAINT is a desaturated color for the text and
-underline. UNDERLINE is a grey color only for the undeline."
+underline. UNDERLINE is a gray color only for the undeline."
(pcase modus-themes-links
('faint (list :foreground fgfaint :underline t))
('neutral-underline (list :foreground fg :underline underline))
@@ -2757,18 +2880,39 @@ AMOUNT is a customization option."
(when modus-themes-scale-headings
(list :height amount)))
-(defun modus-themes--region (bg fg bgsubtle)
+(defun modus-themes--region (bg fg bgsubtle bgaccent)
"Apply `modus-themes-region' styles.
BG and FG are the main values that are used by default. BGSUBTLE
is a subtle background value that can be combined with all colors
-used to fontify text and code syntax."
+used to fontify text and code syntax. BGACCENT is a colored
+background that combines well with FG."
(pcase modus-themes-region
('bg-only (list :background bgsubtle))
('bg-only-no-extend (list :background bgsubtle :extend nil))
('no-extend (list :background bg :foreground fg :extend nil))
+ ('accent (list :background bgaccent :foreground fg))
+ ('accent-no-extend (list :background bgaccent :foreground fg :extend nil))
(_ (list :background bg :foreground fg))))
+(defun modus-themes--hl-line (bgdefault bgintense bgaccent lineneutral
lineaccent)
+ "Apply `modus-themes-hl-line' styles.
+
+BGDEFAULT is a subtle neutral background. BGINTENSE is like the
+default, but more prominent. BGACCENT is a subtle accented
+background. LINENEUTRAL and LINEACCENT are a color values that
+can remain distinct against the buffer's possible backgrounds:
+the former is neutral, the latter is accented. LINEONLY must be
+a prominent neutral color."
+ (pcase modus-themes-hl-line
+ ('intense-background (list :background bgintense))
+ ('accented-background (list :background bgaccent))
+ ('underline-neutral (list :background bgdefault :underline lineneutral))
+ ('underline-accented (list :background bgaccent :underline lineaccent))
+ ('underline-only-neutral (list :background 'unspecified :underline
lineneutral))
+ ('underline-only-accented (list :background 'unspecified :underline
lineaccent))
+ (_ (list :background bgdefault))))
+
;;;; Utilities for DIY users
@@ -2929,112 +3073,112 @@ by virtue of calling either of
`modus-themes-load-operandi' and
;;;; custom faces
;; these bespoke faces are inherited by other constructs below
;;;;; subtle colored backgrounds
- `(modus-theme-subtle-red ((,class :background ,red-subtle-bg :foreground
,fg-dim)))
- `(modus-theme-subtle-green ((,class :background ,green-subtle-bg
:foreground ,fg-dim)))
- `(modus-theme-subtle-yellow ((,class :background ,yellow-subtle-bg
:foreground ,fg-dim)))
- `(modus-theme-subtle-blue ((,class :background ,blue-subtle-bg :foreground
,fg-dim)))
- `(modus-theme-subtle-magenta ((,class :background ,magenta-subtle-bg
:foreground ,fg-dim)))
- `(modus-theme-subtle-cyan ((,class :background ,cyan-subtle-bg :foreground
,fg-dim)))
- `(modus-theme-subtle-neutral ((,class :background ,bg-inactive :foreground
,fg-inactive)))
+ `(modus-themes-subtle-red ((,class :background ,red-subtle-bg :foreground
,fg-dim)))
+ `(modus-themes-subtle-green ((,class :background ,green-subtle-bg
:foreground ,fg-dim)))
+ `(modus-themes-subtle-yellow ((,class :background ,yellow-subtle-bg
:foreground ,fg-dim)))
+ `(modus-themes-subtle-blue ((,class :background ,blue-subtle-bg
:foreground ,fg-dim)))
+ `(modus-themes-subtle-magenta ((,class :background ,magenta-subtle-bg
:foreground ,fg-dim)))
+ `(modus-themes-subtle-cyan ((,class :background ,cyan-subtle-bg
:foreground ,fg-dim)))
+ `(modus-themes-subtle-neutral ((,class :background ,bg-inactive
:foreground ,fg-inactive)))
;;;;; intense colored backgrounds
- `(modus-theme-intense-red ((,class :background ,red-intense-bg :foreground
,fg-main)))
- `(modus-theme-intense-green ((,class :background ,green-intense-bg
:foreground ,fg-main)))
- `(modus-theme-intense-yellow ((,class :background ,yellow-intense-bg
:foreground ,fg-main)))
- `(modus-theme-intense-blue ((,class :background ,blue-intense-bg
:foreground ,fg-main)))
- `(modus-theme-intense-magenta ((,class :background ,magenta-intense-bg
:foreground ,fg-main)))
- `(modus-theme-intense-cyan ((,class :background ,cyan-intense-bg
:foreground ,fg-main)))
- `(modus-theme-intense-neutral ((,class :background ,bg-active :foreground
,fg-main)))
+ `(modus-themes-intense-red ((,class :background ,red-intense-bg
:foreground ,fg-main)))
+ `(modus-themes-intense-green ((,class :background ,green-intense-bg
:foreground ,fg-main)))
+ `(modus-themes-intense-yellow ((,class :background ,yellow-intense-bg
:foreground ,fg-main)))
+ `(modus-themes-intense-blue ((,class :background ,blue-intense-bg
:foreground ,fg-main)))
+ `(modus-themes-intense-magenta ((,class :background ,magenta-intense-bg
:foreground ,fg-main)))
+ `(modus-themes-intense-cyan ((,class :background ,cyan-intense-bg
:foreground ,fg-main)))
+ `(modus-themes-intense-neutral ((,class :background ,bg-active :foreground
,fg-main)))
;;;;; refined background and foreground combinations
;; general purpose styles that use an accented foreground against an
;; accented background
- `(modus-theme-refine-red ((,class :background ,red-refine-bg :foreground
,red-refine-fg)))
- `(modus-theme-refine-green ((,class :background ,green-refine-bg
:foreground ,green-refine-fg)))
- `(modus-theme-refine-yellow ((,class :background ,yellow-refine-bg
:foreground ,yellow-refine-fg)))
- `(modus-theme-refine-blue ((,class :background ,blue-refine-bg :foreground
,blue-refine-fg)))
- `(modus-theme-refine-magenta ((,class :background ,magenta-refine-bg
:foreground ,magenta-refine-fg)))
- `(modus-theme-refine-cyan ((,class :background ,cyan-refine-bg :foreground
,cyan-refine-fg)))
+ `(modus-themes-refine-red ((,class :background ,red-refine-bg :foreground
,red-refine-fg)))
+ `(modus-themes-refine-green ((,class :background ,green-refine-bg
:foreground ,green-refine-fg)))
+ `(modus-themes-refine-yellow ((,class :background ,yellow-refine-bg
:foreground ,yellow-refine-fg)))
+ `(modus-themes-refine-blue ((,class :background ,blue-refine-bg
:foreground ,blue-refine-fg)))
+ `(modus-themes-refine-magenta ((,class :background ,magenta-refine-bg
:foreground ,magenta-refine-fg)))
+ `(modus-themes-refine-cyan ((,class :background ,cyan-refine-bg
:foreground ,cyan-refine-fg)))
;;;;; "active" combinations, mostly for use on the mode line
- `(modus-theme-active-red ((,class :background ,red-active :foreground
,bg-active)))
- `(modus-theme-active-green ((,class :background ,green-active :foreground
,bg-active)))
- `(modus-theme-active-yellow ((,class :background ,yellow-active
:foreground ,bg-active)))
- `(modus-theme-active-blue ((,class :background ,blue-active :foreground
,bg-active)))
- `(modus-theme-active-magenta ((,class :background ,magenta-active
:foreground ,bg-active)))
- `(modus-theme-active-cyan ((,class :background ,cyan-active :foreground
,bg-active)))
+ `(modus-themes-active-red ((,class :background ,red-active :foreground
,bg-active)))
+ `(modus-themes-active-green ((,class :background ,green-active :foreground
,bg-active)))
+ `(modus-themes-active-yellow ((,class :background ,yellow-active
:foreground ,bg-active)))
+ `(modus-themes-active-blue ((,class :background ,blue-active :foreground
,bg-active)))
+ `(modus-themes-active-magenta ((,class :background ,magenta-active
:foreground ,bg-active)))
+ `(modus-themes-active-cyan ((,class :background ,cyan-active :foreground
,bg-active)))
;;;;; nuanced backgrounds
;; useful for adding an accented background that is suitable for all
;; main foreground colors (intended for use in Org source blocks)
- `(modus-theme-nuanced-red ((,class :background ,red-nuanced-bg :extend t)))
- `(modus-theme-nuanced-green ((,class :background ,green-nuanced-bg :extend
t)))
- `(modus-theme-nuanced-yellow ((,class :background ,yellow-nuanced-bg
:extend t)))
- `(modus-theme-nuanced-blue ((,class :background ,blue-nuanced-bg :extend
t)))
- `(modus-theme-nuanced-magenta ((,class :background ,magenta-nuanced-bg
:extend t)))
- `(modus-theme-nuanced-cyan ((,class :background ,cyan-nuanced-bg :extend
t)))
+ `(modus-themes-nuanced-red ((,class :background ,red-nuanced-bg :extend
t)))
+ `(modus-themes-nuanced-green ((,class :background ,green-nuanced-bg
:extend t)))
+ `(modus-themes-nuanced-yellow ((,class :background ,yellow-nuanced-bg
:extend t)))
+ `(modus-themes-nuanced-blue ((,class :background ,blue-nuanced-bg :extend
t)))
+ `(modus-themes-nuanced-magenta ((,class :background ,magenta-nuanced-bg
:extend t)))
+ `(modus-themes-nuanced-cyan ((,class :background ,cyan-nuanced-bg :extend
t)))
;;;;; fringe-specific combinations
- `(modus-theme-fringe-red ((,class :background ,red-fringe-bg :foreground
,fg-main)))
- `(modus-theme-fringe-green ((,class :background ,green-fringe-bg
:foreground ,fg-main)))
- `(modus-theme-fringe-yellow ((,class :background ,yellow-fringe-bg
:foreground ,fg-main)))
- `(modus-theme-fringe-blue ((,class :background ,blue-fringe-bg :foreground
,fg-main)))
- `(modus-theme-fringe-magenta ((,class :background ,magenta-fringe-bg
:foreground ,fg-main)))
- `(modus-theme-fringe-cyan ((,class :background ,cyan-fringe-bg :foreground
,fg-main)))
+ `(modus-themes-fringe-red ((,class :background ,red-fringe-bg :foreground
,fg-main)))
+ `(modus-themes-fringe-green ((,class :background ,green-fringe-bg
:foreground ,fg-main)))
+ `(modus-themes-fringe-yellow ((,class :background ,yellow-fringe-bg
:foreground ,fg-main)))
+ `(modus-themes-fringe-blue ((,class :background ,blue-fringe-bg
:foreground ,fg-main)))
+ `(modus-themes-fringe-magenta ((,class :background ,magenta-fringe-bg
:foreground ,fg-main)))
+ `(modus-themes-fringe-cyan ((,class :background ,cyan-fringe-bg
:foreground ,fg-main)))
;;;;; special base values
;; these are closer to the grayscale than the accents defined above
;; and should only be used when the next closest alternative would be
- ;; a greyscale value than an accented one
- `(modus-theme-special-cold ((,class :background ,bg-special-cold
:foreground ,fg-special-cold)))
- `(modus-theme-special-mild ((,class :background ,bg-special-mild
:foreground ,fg-special-mild)))
- `(modus-theme-special-warm ((,class :background ,bg-special-warm
:foreground ,fg-special-warm)))
- `(modus-theme-special-calm ((,class :background ,bg-special-calm
:foreground ,fg-special-calm)))
+ ;; a grayscale value than an accented one
+ `(modus-themes-special-cold ((,class :background ,bg-special-cold
:foreground ,fg-special-cold)))
+ `(modus-themes-special-mild ((,class :background ,bg-special-mild
:foreground ,fg-special-mild)))
+ `(modus-themes-special-warm ((,class :background ,bg-special-warm
:foreground ,fg-special-warm)))
+ `(modus-themes-special-calm ((,class :background ,bg-special-calm
:foreground ,fg-special-calm)))
;;;;; diff-specific combinations
;; intended for `diff-mode' or equivalent
- `(modus-theme-diff-added
+ `(modus-themes-diff-added
((,class ,@(modus-themes--diff
bg-main green
bg-diff-focus-added fg-diff-focus-added
green-nuanced-bg fg-diff-added
bg-diff-focus-added-deuteran fg-diff-focus-added-deuteran))))
- `(modus-theme-diff-changed
+ `(modus-themes-diff-changed
((,class ,@(modus-themes--diff
bg-main yellow
bg-diff-focus-changed fg-diff-focus-changed
yellow-nuanced-bg fg-diff-changed))))
- `(modus-theme-diff-removed
+ `(modus-themes-diff-removed
((,class ,@(modus-themes--diff
bg-main red
bg-diff-focus-removed fg-diff-focus-removed
red-nuanced-bg fg-diff-removed))))
- `(modus-theme-diff-refine-added
+ `(modus-themes-diff-refine-added
((,class ,@(modus-themes--diff
bg-diff-added fg-diff-added
bg-diff-refine-added fg-diff-refine-added
bg-diff-focus-added fg-diff-focus-added
bg-diff-refine-added-deuteran
fg-diff-refine-added-deuteran))))
- `(modus-theme-diff-refine-changed
+ `(modus-themes-diff-refine-changed
((,class ,@(modus-themes--diff
bg-diff-changed fg-diff-changed
bg-diff-refine-changed fg-diff-refine-changed
bg-diff-focus-changed fg-diff-focus-changed))))
- `(modus-theme-diff-refine-removed
+ `(modus-themes-diff-refine-removed
((,class ,@(modus-themes--diff
bg-diff-removed fg-diff-removed
bg-diff-refine-removed fg-diff-refine-removed
bg-diff-focus-removed fg-diff-focus-removed))))
- `(modus-theme-diff-focus-added
+ `(modus-themes-diff-focus-added
((,class ,@(modus-themes--diff
bg-dim green
bg-diff-focus-added fg-diff-focus-added
bg-diff-added fg-diff-added
bg-diff-focus-added-deuteran fg-diff-focus-added-deuteran))))
- `(modus-theme-diff-focus-changed
+ `(modus-themes-diff-focus-changed
((,class ,@(modus-themes--diff
bg-dim yellow
bg-diff-focus-changed fg-diff-focus-changed
bg-diff-changed fg-diff-changed))))
- `(modus-theme-diff-focus-removed
+ `(modus-themes-diff-focus-removed
((,class ,@(modus-themes--diff
bg-dim red
bg-diff-focus-removed fg-diff-focus-removed
bg-diff-removed fg-diff-removed))))
- `(modus-theme-diff-heading
+ `(modus-themes-diff-heading
((,class ,@(modus-themes--diff
bg-main blue
bg-diff-heading fg-diff-heading
@@ -3043,65 +3187,70 @@ by virtue of calling either of
`modus-themes-load-operandi' and
t))))
;;;;; mark indicators
;; color combinations intended for Dired, Ibuffer, or equivalent
- `(modus-theme-pseudo-header ((,class :inherit bold :foreground ,fg-main)))
- `(modus-theme-mark-alt ((,class :inherit bold :background ,bg-mark-alt
:foreground ,fg-mark-alt)))
- `(modus-theme-mark-del ((,class :inherit bold :background ,bg-mark-del
:foreground ,fg-mark-del)))
- `(modus-theme-mark-sel ((,class :inherit bold :background ,bg-mark-sel
:foreground ,fg-mark-sel)))
- `(modus-theme-mark-symbol ((,class :inherit bold :foreground ,blue-alt)))
+ `(modus-themes-pseudo-header ((,class :inherit bold :foreground ,fg-main)))
+ `(modus-themes-mark-alt ((,class :inherit bold :background ,bg-mark-alt
:foreground ,fg-mark-alt)))
+ `(modus-themes-mark-del ((,class :inherit bold :background ,bg-mark-del
:foreground ,fg-mark-del)))
+ `(modus-themes-mark-sel ((,class :inherit bold :background ,bg-mark-sel
:foreground ,fg-mark-sel)))
+ `(modus-themes-mark-symbol ((,class :inherit bold :foreground ,blue-alt)))
;;;;; heading levels
;; styles for regular headings used in Org, Markdown, Info, etc.
- `(modus-theme-heading-1
+ `(modus-themes-heading-1
((,class ,@(modus-themes--heading
1 fg-main magenta-alt-other magenta-nuanced-bg bg-region)
,@(modus-themes--scale modus-themes-scale-4))))
- `(modus-theme-heading-2
+ `(modus-themes-heading-2
((,class ,@(modus-themes--heading
2 fg-special-warm magenta-alt red-nuanced-bg bg-region)
,@(modus-themes--scale modus-themes-scale-3))))
- `(modus-theme-heading-3
+ `(modus-themes-heading-3
((,class ,@(modus-themes--heading
3 fg-special-cold blue blue-nuanced-bg bg-region)
,@(modus-themes--scale modus-themes-scale-2))))
- `(modus-theme-heading-4
+ `(modus-themes-heading-4
((,class ,@(modus-themes--heading
4 fg-special-mild cyan cyan-nuanced-bg bg-region)
,@(modus-themes--scale modus-themes-scale-1))))
- `(modus-theme-heading-5
+ `(modus-themes-heading-5
((,class ,@(modus-themes--heading
5 fg-special-calm green-alt-other green-nuanced-bg
bg-region))))
- `(modus-theme-heading-6
+ `(modus-themes-heading-6
((,class ,@(modus-themes--heading
6 yellow-nuanced-fg yellow-alt-other yellow-nuanced-bg
bg-region))))
- `(modus-theme-heading-7
+ `(modus-themes-heading-7
((,class ,@(modus-themes--heading
7 red-nuanced-fg red-alt red-nuanced-bg bg-region))))
- `(modus-theme-heading-8
+ `(modus-themes-heading-8
((,class ,@(modus-themes--heading
8 fg-dim magenta bg-alt bg-region))))
;;;;; graph-specific faces
- `(modus-theme-graph-red-0 ((,class :background ,red-graph-0-bg)))
- `(modus-theme-graph-red-1 ((,class :background ,red-graph-1-bg)))
- `(modus-theme-graph-green-0 ((,class :background ,green-graph-0-bg)))
- `(modus-theme-graph-green-1 ((,class :background ,green-graph-1-bg)))
- `(modus-theme-graph-yellow-0 ((,class :background ,yellow-graph-0-bg)))
- `(modus-theme-graph-yellow-1 ((,class :background ,yellow-graph-1-bg)))
- `(modus-theme-graph-blue-0 ((,class :background ,blue-graph-0-bg)))
- `(modus-theme-graph-blue-1 ((,class :background ,blue-graph-1-bg)))
- `(modus-theme-graph-magenta-0 ((,class :background ,magenta-graph-0-bg)))
- `(modus-theme-graph-magenta-1 ((,class :background ,magenta-graph-1-bg)))
- `(modus-theme-graph-cyan-0 ((,class :background ,cyan-graph-0-bg)))
- `(modus-theme-graph-cyan-1 ((,class :background ,cyan-graph-1-bg)))
+ `(modus-themes-graph-red-0 ((,class :background ,red-graph-0-bg)))
+ `(modus-themes-graph-red-1 ((,class :background ,red-graph-1-bg)))
+ `(modus-themes-graph-green-0 ((,class :background ,green-graph-0-bg)))
+ `(modus-themes-graph-green-1 ((,class :background ,green-graph-1-bg)))
+ `(modus-themes-graph-yellow-0 ((,class :background ,yellow-graph-0-bg)))
+ `(modus-themes-graph-yellow-1 ((,class :background ,yellow-graph-1-bg)))
+ `(modus-themes-graph-blue-0 ((,class :background ,blue-graph-0-bg)))
+ `(modus-themes-graph-blue-1 ((,class :background ,blue-graph-1-bg)))
+ `(modus-themes-graph-magenta-0 ((,class :background ,magenta-graph-0-bg)))
+ `(modus-themes-graph-magenta-1 ((,class :background ,magenta-graph-1-bg)))
+ `(modus-themes-graph-cyan-0 ((,class :background ,cyan-graph-0-bg)))
+ `(modus-themes-graph-cyan-1 ((,class :background ,cyan-graph-1-bg)))
;;;;; language checkers
- `(modus-theme-lang-error ((,class ,@(modus-themes--lang-check
fg-lang-underline-error fg-lang-error red red-nuanced-bg))))
- `(modus-theme-lang-note ((,class ,@(modus-themes--lang-check
fg-lang-underline-note fg-lang-note blue-alt blue-nuanced-bg))))
- `(modus-theme-lang-warning ((,class ,@(modus-themes--lang-check
fg-lang-underline-warning fg-lang-warning yellow yellow-nuanced-bg))))
+ `(modus-themes-lang-error ((,class ,@(modus-themes--lang-check
fg-lang-underline-error fg-lang-error red red-nuanced-bg))))
+ `(modus-themes-lang-note ((,class ,@(modus-themes--lang-check
fg-lang-underline-note fg-lang-note blue-alt blue-nuanced-bg))))
+ `(modus-themes-lang-warning ((,class ,@(modus-themes--lang-check
fg-lang-underline-warning fg-lang-warning yellow yellow-nuanced-bg))))
;;;;; other custom faces
- `(modus-theme-bold ((,class ,@(modus-themes--bold-weight))))
- `(modus-theme-hl-line ((,class :background ,(if
modus-themes-intense-hl-line
- bg-hl-line-intense
bg-hl-line)
- :extend t)))
- `(modus-theme-slant ((,class :inherit italic :slant
,@(modus-themes--slant))))
- `(modus-theme-variable-pitch ((,class ,@(modus-themes--variable-pitch))))
+ `(modus-themes-bold ((,class ,@(modus-themes--bold-weight))))
+ `(modus-themes-hl-line ((,class ,@(modus-themes--hl-line bg-hl-line
bg-hl-line-intense blue-nuanced-bg
+ bg-region
blue-intense-bg)
+ :extend t)))
+ `(modus-themes-key-binding ((,class :inherit bold :foreground
,blue-alt-other)))
+ `(modus-themes-slant ((,class :inherit italic :slant
,@(modus-themes--slant))))
+ `(modus-themes-variable-pitch ((,class ,@(modus-themes--variable-pitch))))
+ `(modus-themes-reset-soft ((,class :background ,bg-main :foreground
,fg-main
+ :weight normal :slant normal
:strike-through nil
+ :box nil :underline nil :overline nil
:extend nil)))
+ `(modus-themes-reset-hard ((,class :inherit (fixed-pitch
modus-themes-reset-soft))))
;;;; standard faces
;;;;; absolute essentials
`(default ((,class :background ,bg-main :foreground ,fg-main)))
@@ -3114,7 +3263,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(bold-italic ((,class :inherit (bold italic))))
`(buffer-menu-buffer ((,class :inherit bold)))
`(comint-highlight-input ((,class :inherit bold)))
- `(comint-highlight-prompt ((,class :inherit modus-theme-bold
+ `(comint-highlight-prompt ((,class :inherit modus-themes-bold
,@(modus-themes--prompt
cyan
blue-nuanced-bg blue-alt
@@ -3124,8 +3273,10 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(file-name-shadow ((,class :foreground ,fg-unfocused)))
`(header-line ((,class ,@(modus-themes--variable-pitch-ui)
:background ,bg-header :foreground ,fg-header)))
- `(header-line-highlight ((,class :inherit modus-theme-active-blue)))
- `(help-argument-name ((,class :inherit modus-theme-slant :foreground
,cyan)))
+ `(header-line-highlight ((,class :inherit modus-themes-active-blue)))
+ `(help-argument-name ((,class :inherit modus-themes-slant :foreground
,cyan)))
+ `(help-key-binding ((,class :box (:line-width (1 . -1) :color ,bg-region)
; NOTE: box syntax is for Emacs28
+ :background ,bg-inactive)))
`(homoglyph ((,class :foreground ,red-alt-faint)))
`(ibuffer-locked-buffer ((,class :foreground ,yellow-alt-other-faint)))
`(italic ((,class :slant italic)))
@@ -3137,10 +3288,10 @@ by virtue of calling either of
`modus-themes-load-operandi' and
cyan-refine-bg fg-main))))
`(mm-command-output ((,class :foreground ,red-alt-other)))
`(mm-uu-extract ((,class :background ,bg-dim :foreground
,fg-special-mild)))
- `(next-error ((,class :inherit modus-theme-subtle-red)))
- `(rectangle-preview ((,class :inherit modus-theme-special-mild)))
- `(region ((,class ,@(modus-themes--region bg-region fg-main
bg-hl-alt-intense))))
- `(secondary-selection ((,class :inherit modus-theme-special-cold)))
+ `(next-error ((,class :inherit modus-themes-subtle-red)))
+ `(rectangle-preview ((,class :inherit modus-themes-special-mild)))
+ `(region ((,class ,@(modus-themes--region bg-region fg-main
bg-hl-alt-intense bg-region-accent))))
+ `(secondary-selection ((,class :inherit modus-themes-special-cold)))
`(shadow ((,class :foreground ,fg-alt)))
`(success ((,class :inherit bold :foreground ,green)))
`(trailing-whitespace ((,class :background ,red-intense-bg)))
@@ -3163,7 +3314,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(widget-single-line-field ((,class :inherit widget-field)))
;;;;; ag
`(ag-hit-face ((,class :foreground ,fg-special-cold)))
- `(ag-match-face ((,class :inherit modus-theme-special-calm)))
+ `(ag-match-face ((,class :inherit modus-themes-special-calm)))
;;;;; alert
`(alert-high-face ((,class :inherit bold :foreground ,red-alt)))
`(alert-low-face ((,class :foreground ,fg-special-mild)))
@@ -3207,28 +3358,28 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(all-the-icons-silver ((,class :foreground ,fg-special-cold)))
`(all-the-icons-yellow ((,class :foreground ,yellow)))
;;;;; annotate
- `(annotate-annotation ((,class :inherit modus-theme-subtle-blue)))
- `(annotate-annotation-secondary ((,class :inherit
modus-theme-subtle-green)))
+ `(annotate-annotation ((,class :inherit modus-themes-subtle-blue)))
+ `(annotate-annotation-secondary ((,class :inherit
modus-themes-subtle-green)))
`(annotate-highlight ((,class :background ,blue-nuanced-bg :underline
,blue-intense)))
`(annotate-highlight-secondary ((,class :background ,green-nuanced-bg
:underline ,green-intense)))
;;;;; anzu
- `(anzu-match-1 ((,class :inherit modus-theme-subtle-cyan)))
- `(anzu-match-2 ((,class :inherit modus-theme-subtle-green)))
- `(anzu-match-3 ((,class :inherit modus-theme-subtle-yellow)))
+ `(anzu-match-1 ((,class :inherit modus-themes-subtle-cyan)))
+ `(anzu-match-2 ((,class :inherit modus-themes-subtle-green)))
+ `(anzu-match-3 ((,class :inherit modus-themes-subtle-yellow)))
`(anzu-mode-line ((,class :inherit bold :foreground ,green-active)))
`(anzu-mode-line-no-match ((,class :inherit bold :foreground ,red-active)))
- `(anzu-replace-highlight ((,class :inherit modus-theme-refine-yellow
:underline t)))
- `(anzu-replace-to ((,class :inherit (modus-theme-intense-green bold))))
+ `(anzu-replace-highlight ((,class :inherit modus-themes-refine-yellow
:underline t)))
+ `(anzu-replace-to ((,class :inherit (modus-themes-intense-green bold))))
;;;;; apropos
`(apropos-function-button ((,class :inherit button
,@(modus-themes--link-color
magenta-alt-other
magenta-alt-other-faint))))
- `(apropos-keybinding ((,class :inherit bold :foreground ,cyan)))
+ `(apropos-keybinding ((,class :inherit modus-themes-key-binding)))
`(apropos-misc-button ((,class :inherit button
,@(modus-themes--link-color
cyan-alt-other cyan-alt-other-faint))))
- `(apropos-property ((,class :inherit modus-theme-bold :foreground
,magenta-alt)))
- `(apropos-symbol ((,class :inherit modus-theme-bold :foreground
,blue-alt-other)))
+ `(apropos-property ((,class :inherit modus-themes-bold :foreground
,magenta-alt)))
+ `(apropos-symbol ((,class :inherit modus-themes-bold :foreground
,magenta)))
`(apropos-user-option-button ((,class :inherit button
,@(modus-themes--link-color
green-alt-other
green-alt-other-faint))))
@@ -3242,25 +3393,25 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(apt-sources-list-type ((,class :foreground ,magenta)))
`(apt-sources-list-uri ((,class :foreground ,blue)))
;;;;; artbollocks-mode
- `(artbollocks-face ((,class :inherit modus-theme-lang-note)))
+ `(artbollocks-face ((,class :inherit modus-themes-lang-note)))
`(artbollocks-lexical-illusions-face ((,class :background ,bg-alt
:foreground ,red-alt :underline t)))
- `(artbollocks-passive-voice-face ((,class :inherit
modus-theme-lang-warning)))
- `(artbollocks-weasel-words-face ((,class :inherit modus-theme-lang-error)))
+ `(artbollocks-passive-voice-face ((,class :inherit
modus-themes-lang-warning)))
+ `(artbollocks-weasel-words-face ((,class :inherit
modus-themes-lang-error)))
;;;;; auctex and Tex
`(font-latex-bold-face ((,class :inherit bold :foreground
,fg-special-calm)))
- `(font-latex-doctex-documentation-face ((,class :inherit modus-theme-slant
:foreground ,fg-special-cold)))
- `(font-latex-doctex-preprocessor-face ((,class :inherit modus-theme-bold
:foreground ,red-alt-other)))
+ `(font-latex-doctex-documentation-face ((,class :inherit
modus-themes-slant :foreground ,fg-special-cold)))
+ `(font-latex-doctex-preprocessor-face ((,class :inherit modus-themes-bold
:foreground ,red-alt-other)))
`(font-latex-italic-face ((,class :inherit italic :foreground
,fg-special-calm)))
`(font-latex-math-face ((,class :foreground ,cyan-alt-other)))
`(font-latex-script-char-face ((,class :foreground ,cyan-alt-other)))
- `(font-latex-sectioning-0-face ((,class :inherit
modus-theme-variable-pitch :foreground ,blue-nuanced-fg)))
- `(font-latex-sectioning-1-face ((,class :inherit (bold
modus-theme-variable-pitch) :foreground ,blue-nuanced-fg)))
- `(font-latex-sectioning-2-face ((,class :inherit (bold
modus-theme-variable-pitch) :foreground ,blue-nuanced-fg)))
- `(font-latex-sectioning-3-face ((,class :inherit (bold
modus-theme-variable-pitch) :foreground ,blue-nuanced-fg)))
- `(font-latex-sectioning-4-face ((,class :inherit (bold
modus-theme-variable-pitch) :foreground ,blue-nuanced-fg)))
- `(font-latex-sectioning-5-face ((,class :inherit
modus-theme-variable-pitch :foreground ,blue-nuanced-fg)))
- `(font-latex-sedate-face ((,class :inherit modus-theme-bold :foreground
,magenta-alt-other)))
- `(font-latex-slide-title-face ((,class :inherit (bold
modus-theme-variable-pitch) :foreground ,cyan-nuanced-fg
+ `(font-latex-sectioning-0-face ((,class :inherit
modus-themes-variable-pitch :foreground ,blue-nuanced-fg)))
+ `(font-latex-sectioning-1-face ((,class :inherit (bold
modus-themes-variable-pitch) :foreground ,blue-nuanced-fg)))
+ `(font-latex-sectioning-2-face ((,class :inherit (bold
modus-themes-variable-pitch) :foreground ,blue-nuanced-fg)))
+ `(font-latex-sectioning-3-face ((,class :inherit (bold
modus-themes-variable-pitch) :foreground ,blue-nuanced-fg)))
+ `(font-latex-sectioning-4-face ((,class :inherit (bold
modus-themes-variable-pitch) :foreground ,blue-nuanced-fg)))
+ `(font-latex-sectioning-5-face ((,class :inherit
modus-themes-variable-pitch :foreground ,blue-nuanced-fg)))
+ `(font-latex-sedate-face ((,class :inherit modus-themes-bold :foreground
,magenta-alt-other)))
+ `(font-latex-slide-title-face ((,class :inherit (bold
modus-themes-variable-pitch) :foreground ,cyan-nuanced-fg
,@(modus-themes--scale
modus-themes-scale-4))))
`(font-latex-string-face ((,class :inherit font-lock-string-face)))
`(font-latex-subscript-face ((,class :height 0.95)))
@@ -3277,17 +3428,18 @@ by virtue of calling either of
`modus-themes-load-operandi' and
;;;;; auto-dim-other-buffers
`(auto-dim-other-buffers-face ((,class :background ,bg-alt)))
;;;;; avy
- `(avy-background-face ((,class :background ,bg-dim :foreground ,fg-dim)))
- `(avy-goto-char-timer-face ((,class :inherit (modus-theme-intense-yellow
bold))))
- `(avy-lead-face ((,class :inherit (modus-theme-intense-magenta bold))))
- `(avy-lead-face-0 ((,class :inherit (modus-theme-intense-blue bold))))
- `(avy-lead-face-1 ((,class :inherit (modus-theme-intense-red bold))))
- `(avy-lead-face-2 ((,class :inherit (modus-theme-intense-green bold))))
+ `(avy-background-face ((,class :background ,bg-dim :foreground ,fg-dim
:extend t)))
+ `(avy-goto-char-timer-face ((,class :inherit (modus-themes-intense-yellow
bold))))
+ `(avy-lead-face ((,class :inherit (modus-themes-intense-magenta bold
modus-themes-reset-soft))))
+ `(avy-lead-face-0 ((,class :inherit (modus-themes-refine-cyan bold
modus-themes-reset-soft))))
+ `(avy-lead-face-1 ((,class :inherit (modus-themes-intense-neutral bold
modus-themes-reset-soft))))
+ `(avy-lead-face-2 ((,class :inherit (modus-themes-refine-red bold
modus-themes-reset-soft))))
;;;;; aw (ace-window)
- `(aw-background-face ((,class :background ,bg-dim :foreground ,fg-dim)))
- `(aw-key-face ((,class :inherit bold :foreground ,blue-intense)))
- `(aw-leading-char-face ((,class :inherit bold :height 1.5 :slant normal
:background ,bg-main :foreground ,red-intense)))
- `(aw-minibuffer-leading-char-face ((,class :foreground ,magenta-active)))
+ `(aw-background-face ((,class :foreground ,fg-unfocused)))
+ `(aw-key-face ((,class :inherit modus-themes-key-binding)))
+ `(aw-leading-char-face ((,class :inherit (bold modus-themes-reset-soft)
:height 1.5
+ :foreground ,red-intense)))
+ `(aw-minibuffer-leading-char-face ((,class :inherit
(modus-themes-intense-red bold))))
`(aw-mode-line-face ((,class :inherit bold)))
;;;;; awesome-tray
`(awesome-tray-module-awesome-tab-face ((,class :inherit bold :foreground
,red-alt-other)))
@@ -3307,47 +3459,47 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(bbdb-organization ((,class :foreground ,red-alt-other)))
`(bbdb-field-name ((,class :foreground ,cyan-alt-other)))
;;;;; binder
- `(binder-sidebar-highlight ((,class :inherit modus-theme-subtle-cyan)))
- `(binder-sidebar-marked ((,class :inherit modus-theme-mark-sel)))
- `(binder-sidebar-missing ((,class :inherit modus-theme-subtle-red)))
+ `(binder-sidebar-highlight ((,class :inherit modus-themes-subtle-cyan)))
+ `(binder-sidebar-marked ((,class :inherit modus-themes-mark-sel)))
+ `(binder-sidebar-missing ((,class :inherit modus-themes-subtle-red)))
`(binder-sidebar-tags ((,class :foreground ,cyan)))
;;;;; bm
- `(bm-face ((,class :inherit modus-theme-subtle-yellow :extend t)))
- `(bm-fringe-face ((,class :inherit modus-theme-fringe-yellow)))
- `(bm-fringe-persistent-face ((,class :inherit modus-theme-fringe-blue)))
- `(bm-persistent-face ((,class :inherit modus-theme-intense-blue :extend
t)))
+ `(bm-face ((,class :inherit modus-themes-subtle-yellow :extend t)))
+ `(bm-fringe-face ((,class :inherit modus-themes-fringe-yellow)))
+ `(bm-fringe-persistent-face ((,class :inherit modus-themes-fringe-blue)))
+ `(bm-persistent-face ((,class :inherit modus-themes-intense-blue :extend
t)))
;;;;; bongo
- `(bongo-album-title ((,class :foreground ,yellow-active)))
+ `(bongo-album-title ((,class :foreground ,fg-active)))
`(bongo-artist ((,class :foreground ,magenta-active)))
`(bongo-currently-playing-track ((,class :inherit bold)))
- `(bongo-elapsed-track-part ((,class :inherit modus-theme-subtle-magenta
:underline t)))
+ `(bongo-elapsed-track-part ((,class :inherit modus-themes-subtle-magenta
:underline t)))
`(bongo-filled-seek-bar ((,class :background ,blue-intense-bg :foreground
,fg-main)))
`(bongo-marked-track ((,class :foreground ,fg-mark-alt)))
`(bongo-marked-track-line ((,class :background ,bg-mark-alt)))
`(bongo-played-track ((,class :foreground ,fg-unfocused :strike-through
t)))
- `(bongo-track-length ((,class :foreground ,fg-active)))
- `(bongo-track-title ((,class :foreground ,cyan-active)))
+ `(bongo-track-length ((,class :foreground ,fg-alt)))
+ `(bongo-track-title ((,class :foreground ,blue-active)))
`(bongo-unfilled-seek-bar ((,class :background ,bg-special-cold
:foreground ,fg-main)))
;;;;; boon
- `(boon-modeline-cmd ((,class :inherit modus-theme-active-blue)))
- `(boon-modeline-ins ((,class :inherit modus-theme-active-red)))
- `(boon-modeline-off ((,class :inherit modus-theme-active-yellow)))
- `(boon-modeline-spc ((,class :inherit modus-theme-active-green)))
+ `(boon-modeline-cmd ((,class :inherit modus-themes-active-blue)))
+ `(boon-modeline-ins ((,class :inherit modus-themes-active-red)))
+ `(boon-modeline-off ((,class :inherit modus-themes-active-yellow)))
+ `(boon-modeline-spc ((,class :inherit modus-themes-active-green)))
;;;;; breakpoint (built-in gdb-mi.el)
`(breakpoint-disabled ((,class :inherit shadow)))
`(breakpoint-enabled ((,class :inherit bold :foreground ,red)))
;;;;; buffer-expose
`(buffer-expose-ace-char-face ((,class :inherit bold :foreground
,red-active)))
`(buffer-expose-mode-line-face ((,class :foreground ,cyan-active)))
- `(buffer-expose-selected-face ((,class :inherit modus-theme-special-mild)))
+ `(buffer-expose-selected-face ((,class :inherit
modus-themes-special-mild)))
;;;;; calendar and diary
- `(calendar-month-header ((,class :inherit modus-theme-pseudo-header)))
+ `(calendar-month-header ((,class :inherit modus-themes-pseudo-header)))
`(calendar-today ((,class :inherit bold :underline t)))
- `(calendar-weekday-header ((,class :inherit shadow)))
- `(calendar-weekend-header ((,class :inherit shadow)))
- `(diary ((,class :background ,green-nuanced-bg :foreground
,green-alt-other)))
+ `(calendar-weekday-header ((,class :foreground ,fg-unfocused)))
+ `(calendar-weekend-header ((,class :foreground ,fg-unfocused)))
+ `(diary ((,class :background ,blue-nuanced-bg :foreground
,blue-alt-other)))
`(diary-anniversary ((,class :foreground ,red-alt-other)))
- `(diary-time ((,class :foreground ,blue-alt)))
+ `(diary-time ((,class :foreground ,cyan)))
`(holiday ((,class :background ,magenta-nuanced-bg :foreground
,magenta-alt)))
;;;;; calfw
`(cfw:face-annotation ((,class :foreground ,fg-special-warm)))
@@ -3360,9 +3512,9 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(cfw:face-holiday ((,class :foreground ,magenta-alt-other)))
`(cfw:face-periods ((,class :foreground ,cyan-alt-other)))
`(cfw:face-saturday ((,class :inherit bold :foreground ,cyan-alt-other)))
- `(cfw:face-select ((,class :inherit modus-theme-intense-blue)))
+ `(cfw:face-select ((,class :inherit modus-themes-intense-blue)))
`(cfw:face-sunday ((,class :inherit bold :foreground ,cyan-alt-other)))
- `(cfw:face-title ((,class :inherit modus-theme-variable-pitch
+ `(cfw:face-title ((,class :inherit modus-themes-variable-pitch
:foreground ,fg-special-cold
,@(modus-themes--scale modus-themes-scale-5))))
`(cfw:face-today ((,class :background ,bg-inactive)))
@@ -3372,7 +3524,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(cfw:face-toolbar-button-on ((,class :inherit bold :background
,blue-nuanced-bg
:foreground ,blue-alt)))
;;;;; centaur-tabs
- `(centaur-tabs-active-bar-face ((,class :background ,fg-tab-active)))
+ `(centaur-tabs-active-bar-face ((,class :background ,fg-tab-accent)))
`(centaur-tabs-close-mouse-face ((,class :inherit bold :foreground
,red-active :underline t)))
`(centaur-tabs-close-selected ((,class :inherit centaur-tabs-selected)))
`(centaur-tabs-close-unselected ((,class :inherit
centaur-tabs-unselected)))
@@ -3403,7 +3555,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
;;;;; cider
`(cider-debug-code-overlay-face ((,class :background ,bg-alt)))
`(cider-debug-prompt-face ((,class :foreground ,magenta-alt :underline t)))
- `(cider-deprecated-face ((,class :inherit modus-theme-refine-yellow)))
+ `(cider-deprecated-face ((,class :inherit modus-themes-refine-yellow)))
`(cider-docview-emphasis-face ((,class :inherit italic :foreground
,fg-special-cold)))
`(cider-docview-literal-face ((,class :foreground ,blue-alt)))
`(cider-docview-strong-face ((,class :inherit bold :foreground
,fg-special-cold)))
@@ -3416,7 +3568,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(cider-instrumented-face ((,class :box (:line-width -1 :color ,red :style
nil) :background ,bg-dim)))
`(cider-reader-conditional-face ((,class :inherit italic :foreground
,fg-special-warm)))
`(cider-repl-input-face ((,class :inherit bold)))
- `(cider-repl-prompt-face ((,class :foreground ,cyan-alt-other)))
+ `(cider-repl-prompt-face ((,class :inherit comint-highlight-prompt)))
`(cider-repl-stderr-face ((,class :inherit bold :foreground ,red)))
`(cider-repl-stdout-face ((,class :foreground ,blue)))
`(cider-result-overlay-face ((,class :box (:line-width -1 :color ,blue
:style nil) :background ,bg-dim)))
@@ -3430,15 +3582,15 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(cider-stacktrace-promoted-button-face ((,class :box (:line-width 3
:color ,fg-alt :style released-button) :foreground ,red)))
`(cider-stacktrace-suppressed-button-face ((,class :box (:line-width 3
:color ,fg-alt :style pressed-button)
:background ,bg-alt
:foreground ,fg-alt)))
- `(cider-test-error-face ((,class :inherit modus-theme-subtle-red)))
- `(cider-test-failure-face ((,class :inherit (modus-theme-intense-red
bold))))
- `(cider-test-success-face ((,class :inherit modus-theme-intense-green)))
+ `(cider-test-error-face ((,class :inherit modus-themes-subtle-red)))
+ `(cider-test-failure-face ((,class :inherit (modus-themes-intense-red
bold))))
+ `(cider-test-success-face ((,class :inherit modus-themes-intense-green)))
`(cider-traced-face ((,class :box (:line-width -1 :color ,cyan :style nil)
:background ,bg-dim)))
`(cider-warning-highlight-face ((,class :foreground ,yellow :underline t)))
;;;;; circe (and lui)
`(circe-fool-face ((,class :inherit shadow)))
`(circe-highlight-nick-face ((,class :inherit bold :foreground ,blue)))
- `(circe-prompt-face ((,class :inherit bold :foreground ,cyan-alt-other)))
+ `(circe-prompt-face ((,class :inherit comint-highlight-prompt)))
`(circe-server-face ((,class :foreground ,fg-unfocused)))
`(lui-button-face ((,class :inherit button)))
`(lui-highlight-face ((,class :foreground ,magenta-alt)))
@@ -3447,8 +3599,8 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(color-rg-font-lock-column-number ((,class :foreground
,magenta-alt-other)))
`(color-rg-font-lock-command ((,class :inherit bold :foreground ,fg-main)))
`(color-rg-font-lock-file ((,class :inherit bold :foreground
,fg-special-cold)))
- `(color-rg-font-lock-flash ((,class :inherit modus-theme-intense-blue)))
- `(color-rg-font-lock-function-location ((,class :inherit
modus-theme-special-calm)))
+ `(color-rg-font-lock-flash ((,class :inherit modus-themes-intense-blue)))
+ `(color-rg-font-lock-function-location ((,class :inherit
modus-themes-special-calm)))
`(color-rg-font-lock-header-line-directory ((,class :foreground
,blue-active)))
`(color-rg-font-lock-header-line-edit-mode ((,class :foreground
,magenta-active)))
`(color-rg-font-lock-header-line-keyword ((,class :foreground
,green-active)))
@@ -3456,42 +3608,42 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(color-rg-font-lock-line-number ((,class :foreground ,fg-special-warm)))
`(color-rg-font-lock-mark-changed ((,class :inherit bold :foreground
,blue)))
`(color-rg-font-lock-mark-deleted ((,class :inherit bold :foreground
,red)))
- `(color-rg-font-lock-match ((,class :inherit modus-theme-special-calm)))
+ `(color-rg-font-lock-match ((,class :inherit modus-themes-special-calm)))
`(color-rg-font-lock-position-splitter ((,class :inherit shadow)))
;;;;; column-enforce-mode
- `(column-enforce-face ((,class :inherit modus-theme-refine-yellow)))
+ `(column-enforce-face ((,class :inherit modus-themes-refine-yellow)))
;;;;; company-mode
`(company-echo-common ((,class :foreground ,magenta-alt-other)))
`(company-preview ((,class :background ,bg-dim :foreground ,fg-dim)))
`(company-preview-common ((,class :foreground ,blue-alt)))
- `(company-preview-search ((,class :inherit modus-theme-special-calm)))
+ `(company-preview-search ((,class :inherit modus-themes-special-calm)))
`(company-scrollbar-bg ((,class :background ,bg-active)))
`(company-scrollbar-fg ((,class :background ,fg-active)))
- `(company-template-field ((,class :inherit modus-theme-intense-magenta)))
+ `(company-template-field ((,class :inherit modus-themes-intense-magenta)))
`(company-tooltip ((,class :background ,bg-alt :foreground ,fg-alt)))
- `(company-tooltip-annotation ((,class :inherit modus-theme-slant
:foreground ,fg-special-cold)))
+ `(company-tooltip-annotation ((,class :inherit modus-themes-slant
:foreground ,fg-special-cold)))
`(company-tooltip-annotation-selection ((,class :inherit bold :foreground
,fg-main)))
`(company-tooltip-common ((,class :inherit bold :foreground ,blue-alt)))
`(company-tooltip-common-selection ((,class :foreground ,fg-main)))
- `(company-tooltip-mouse ((,class :inherit modus-theme-intense-blue)))
- `(company-tooltip-search ((,class :inherit (modus-theme-refine-cyan
bold))))
- `(company-tooltip-search-selection ((,class :inherit
(modus-theme-intense-green bold) :underline t)))
- `(company-tooltip-selection ((,class :inherit (modus-theme-subtle-cyan
bold))))
+ `(company-tooltip-mouse ((,class :inherit modus-themes-intense-blue)))
+ `(company-tooltip-search ((,class :inherit (modus-themes-refine-cyan
bold))))
+ `(company-tooltip-search-selection ((,class :inherit
(modus-themes-intense-green bold) :underline t)))
+ `(company-tooltip-selection ((,class :inherit (modus-themes-subtle-cyan
bold))))
;;;;; company-posframe
`(company-posframe-active-backend-name ((,class :inherit bold :background
,bg-active :foreground ,blue-active)))
`(company-posframe-inactive-backend-name ((,class :background ,bg-active
:foreground ,fg-active)))
`(company-posframe-metadata ((,class :background ,bg-inactive :foreground
,fg-inactive)))
;;;;; compilation feedback
`(compilation-column-number ((,class :foreground ,magenta-alt-other)))
- `(compilation-error ((,class :inherit modus-theme-bold :foreground ,red)))
- `(compilation-info ((,class :inherit modus-theme-bold :foreground
,fg-special-cold)))
+ `(compilation-error ((,class :inherit modus-themes-bold :foreground ,red)))
+ `(compilation-info ((,class :inherit modus-themes-bold :foreground
,fg-special-cold)))
`(compilation-line-number ((,class :foreground ,fg-special-warm)))
- `(compilation-mode-line-exit ((,class :inherit modus-theme-bold
:foreground ,blue-active)))
- `(compilation-mode-line-fail ((,class :inherit modus-theme-bold
:foreground ,red-active)))
- `(compilation-mode-line-run ((,class :inherit modus-theme-bold :foreground
,magenta-active)))
- `(compilation-warning ((,class :inherit modus-theme-bold :foreground
,yellow)))
+ `(compilation-mode-line-exit ((,class :inherit modus-themes-bold
:foreground ,blue-active)))
+ `(compilation-mode-line-fail ((,class :inherit modus-themes-bold
:foreground ,red-active)))
+ `(compilation-mode-line-run ((,class :inherit modus-themes-bold
:foreground ,magenta-active)))
+ `(compilation-warning ((,class :inherit modus-themes-bold :foreground
,yellow)))
;;;;; completions
- `(completions-annotations ((,class :inherit modus-theme-slant :foreground
,cyan-faint)))
+ `(completions-annotations ((,class :inherit modus-themes-slant :foreground
,cyan-faint)))
`(completions-common-part ((,class ,@(modus-themes--standard-completions
blue-alt blue-nuanced-bg
cyan-refine-bg cyan-refine-fg))))
@@ -3505,17 +3657,22 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(consult-bookmark ((,class :foreground ,blue)))
`(consult-file ((,class :foreground ,fg-special-cold)))
`(consult-imenu-prefix ((,class :inherit shadow)))
- `(consult-key ((,class :inherit modus-themes-bold :foreground
,magenta-alt-other)))
+ `(consult-key ((,class :inherit modus-themes-key-binding)))
`(consult-line-number ((,class :foreground ,fg-special-warm)))
`(consult-line-number-prefix ((,class :foreground ,fg-unfocused)))
`(consult-narrow-indicator ((,class :foreground ,magenta-alt)))
- `(consult-preview-cursor ((,class :inherit modus-theme-intense-blue)))
- `(consult-preview-error ((,class :inherit modus-theme-intense-red)))
+ `(consult-preview-cursor ((,class :inherit modus-themes-intense-blue)))
+ `(consult-preview-error ((,class :inherit modus-themes-intense-red)))
`(consult-preview-line ((,class :background ,bg-hl-alt-intense)))
+;;;;; corfu
+ `(corfu-background ((,class :background ,bg-alt :foreground ,fg-alt)))
+ `(corfu-current ((,class :inherit bold :background ,cyan-subtle-bg)))
+ `(corfu-bar ((,class :background ,fg-alt :foreground ,fg-alt)))
+ `(corfu-border ((,class :background ,bg-active :foreground ,bg-region)))
;;;;; counsel
`(counsel-active-mode ((,class :foreground ,magenta-alt-other)))
`(counsel-application-name ((,class :foreground ,red-alt-other)))
- `(counsel-key-binding ((,class :inherit bold :foreground ,blue-alt-other)))
+ `(counsel-key-binding ((,class :inherit modus-themes-key-binding)))
`(counsel-outline-1 ((,class :inherit org-level-1)))
`(counsel-outline-2 ((,class :inherit org-level-2)))
`(counsel-outline-3 ((,class :inherit org-level-3)))
@@ -3525,7 +3682,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(counsel-outline-7 ((,class :inherit org-level-7)))
`(counsel-outline-8 ((,class :inherit org-level-8)))
`(counsel-outline-default ((,class :foreground ,fg-main)))
- `(counsel-variable-documentation ((,class :inherit modus-theme-slant
:foreground ,yellow-alt-other)))
+ `(counsel-variable-documentation ((,class :inherit modus-themes-slant
:foreground ,yellow-alt-other)))
;;;;; counsel-css
`(counsel-css-selector-depth-face-1 ((,class :foreground ,blue)))
`(counsel-css-selector-depth-face-2 ((,class :foreground ,cyan)))
@@ -3554,9 +3711,9 @@ by virtue of calling either of
`modus-themes-load-operandi' and
;;;;; csv-mode
`(csv-separator-face ((,class :background ,bg-special-cold :foreground
,fg-main)))
;;;;; ctrlf
- `(ctrlf-highlight-active ((,class :inherit (modus-theme-intense-green
bold))))
- `(ctrlf-highlight-line ((,class :inherit modus-theme-hl-line)))
- `(ctrlf-highlight-passive ((,class :inherit modus-theme-refine-cyan)))
+ `(ctrlf-highlight-active ((,class :inherit (modus-themes-intense-green
bold))))
+ `(ctrlf-highlight-line ((,class :inherit modus-themes-hl-line)))
+ `(ctrlf-highlight-passive ((,class :inherit modus-themes-refine-cyan)))
;;;;; custom (M-x customize)
`(custom-button ((,class :box (:line-width 2 :color nil :style
released-button)
:background ,bg-active :foreground ,fg-main)))
@@ -3564,18 +3721,18 @@ by virtue of calling either of
`modus-themes-load-operandi' and
:background ,bg-active :foreground
,fg-active)))
`(custom-button-pressed ((,class :box (:line-width 2 :color nil :style
pressed-button)
:background ,bg-active :foreground
,fg-main)))
- `(custom-changed ((,class :inherit modus-theme-subtle-cyan)))
+ `(custom-changed ((,class :inherit modus-themes-subtle-cyan)))
`(custom-comment ((,class :inherit shadow)))
`(custom-comment-tag ((,class :background ,bg-alt :foreground
,yellow-alt-other)))
`(custom-face-tag ((,class :inherit bold :foreground ,blue-intense)))
`(custom-group-tag ((,class :inherit bold :foreground ,green-intense)))
- `(custom-group-tag-1 ((,class :inherit modus-theme-special-warm)))
- `(custom-invalid ((,class :inherit (modus-theme-intense-red bold))))
- `(custom-modified ((,class :inherit modus-theme-subtle-cyan)))
- `(custom-rogue ((,class :inherit modus-theme-refine-magenta)))
+ `(custom-group-tag-1 ((,class :inherit modus-themes-special-warm)))
+ `(custom-invalid ((,class :inherit (modus-themes-intense-red bold))))
+ `(custom-modified ((,class :inherit modus-themes-subtle-cyan)))
+ `(custom-rogue ((,class :inherit modus-themes-refine-magenta)))
`(custom-set ((,class :foreground ,blue-alt)))
`(custom-state ((,class :foreground ,cyan-alt-other)))
- `(custom-themed ((,class :inherit modus-theme-subtle-blue)))
+ `(custom-themed ((,class :inherit modus-themes-subtle-blue)))
`(custom-variable-tag ((,class :inherit bold :foreground ,cyan)))
;;;;; dap-mode
`(dap-mouse-eval-thing-face ((,class :box (:line-width -1 :color
,blue-active :style nil)
@@ -3587,7 +3744,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(dap-ui-locals-scope-face ((,class :inherit bold :foreground ,magenta
:underline t)))
`(dap-ui-locals-variable-face ((,class :inherit bold :foreground ,cyan)))
`(dap-ui-locals-variable-leaf-face ((,class :inherit italic :foreground
,cyan-alt-other)))
- `(dap-ui-marker-face ((,class :inherit modus-theme-subtle-blue)))
+ `(dap-ui-marker-face ((,class :inherit modus-themes-subtle-blue)))
`(dap-ui-sessions-stack-frame-face ((,class :inherit bold :foreground
,magenta-alt)))
`(dap-ui-sessions-terminated-active-face ((,class :inherit bold
:foreground ,fg-alt)))
`(dap-ui-sessions-terminated-face ((,class :inherit shadow)))
@@ -3599,7 +3756,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(dashboard-text-banner ((,class :foreground ,fg-dim)))
;;;;; deadgrep
`(deadgrep-filename-face ((,class :inherit bold :foreground
,fg-special-cold)))
- `(deadgrep-match-face ((,class :inherit modus-theme-special-calm)))
+ `(deadgrep-match-face ((,class :inherit modus-themes-special-calm)))
`(deadgrep-meta-face ((,class :inherit shadow)))
`(deadgrep-regexp-metachar-face ((,class :inherit bold :foreground
,yellow-intense)))
`(deadgrep-search-term-face ((,class :inherit bold :foreground
,green-intense)))
@@ -3620,11 +3777,11 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(define-word-face-1 ((,class :foreground ,yellow)))
`(define-word-face-2 ((,class :foreground ,fg-main)))
;;;;; deft
- `(deft-filter-string-error-face ((,class :inherit modus-theme-refine-red)))
+ `(deft-filter-string-error-face ((,class :inherit
modus-themes-refine-red)))
`(deft-filter-string-face ((,class :foreground ,green-intense)))
`(deft-header-face ((,class :inherit bold :foreground ,fg-special-warm)))
`(deft-separator-face ((,class :inherit shadow)))
- `(deft-summary-face ((,class :inherit modus-theme-slant :foreground
,fg-alt)))
+ `(deft-summary-face ((,class :inherit modus-themes-slant :foreground
,fg-alt)))
`(deft-time-face ((,class :foreground ,fg-special-cold)))
`(deft-title-face ((,class :inherit bold :foreground ,fg-main)))
;;;;; dictionary
@@ -3633,34 +3790,34 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(dictionary-word-definition-face (()))
`(dictionary-word-entry-face ((,class :inherit font-lock-comment-face)))
;;;;; diff-hl
- `(diff-hl-change ((,class :inherit modus-theme-fringe-yellow)))
- `(diff-hl-delete ((,class :inherit modus-theme-fringe-red)))
+ `(diff-hl-change ((,class :inherit modus-themes-fringe-yellow)))
+ `(diff-hl-delete ((,class :inherit modus-themes-fringe-red)))
`(diff-hl-dired-change ((,class :inherit diff-hl-change)))
`(diff-hl-dired-delete ((,class :inherit diff-hl-delete)))
`(diff-hl-dired-ignored ((,class :inherit dired-ignored)))
`(diff-hl-dired-insert ((,class :inherit diff-hl-insert)))
`(diff-hl-dired-unknown ((,class :inherit dired-ignored)))
- `(diff-hl-insert ((,class :inherit modus-theme-fringe-green)))
- `(diff-hl-reverted-hunk-highlight ((,class :inherit
(modus-theme-active-magenta bold))))
+ `(diff-hl-insert ((,class :inherit modus-themes-fringe-green)))
+ `(diff-hl-reverted-hunk-highlight ((,class :inherit
(modus-themes-active-magenta bold))))
;;;;; diff-mode
- `(diff-added ((,class :inherit modus-theme-diff-added)))
- `(diff-changed ((,class :inherit modus-theme-diff-changed :extend t)))
+ `(diff-added ((,class :inherit modus-themes-diff-added)))
+ `(diff-changed ((,class :inherit modus-themes-diff-changed :extend t)))
`(diff-context ((,class ,@(modus-themes--diff-text fg-main fg-unfocused))))
- `(diff-error ((,class :inherit modus-theme-intense-red)))
+ `(diff-error ((,class :inherit modus-themes-intense-red)))
`(diff-file-header ((,class :inherit (bold diff-header))))
- `(diff-function ((,class :inherit modus-theme-diff-heading)))
+ `(diff-function ((,class :inherit modus-themes-diff-heading)))
`(diff-header ((,class ,@(modus-themes--diff-text cyan-faint fg-main))))
- `(diff-hunk-header ((,class :inherit (bold modus-theme-diff-heading))))
+ `(diff-hunk-header ((,class :inherit (bold modus-themes-diff-heading))))
`(diff-index ((,class :inherit bold :foreground ,blue-alt)))
`(diff-indicator-added ((,class :inherit (diff-added bold)
:foreground ,@(modus-themes--diff-deuteran
blue green))))
`(diff-indicator-changed ((,class :inherit (diff-changed bold) :foreground
,yellow)))
`(diff-indicator-removed ((,class :inherit (diff-removed bold) :foreground
,red)))
- `(diff-nonexistent ((,class :inherit (modus-theme-neutral bold))))
- `(diff-refine-added ((,class :inherit modus-theme-diff-refine-added)))
- `(diff-refine-changed ((,class :inherit modus-theme-diff-refine-changed)))
- `(diff-refine-removed ((,class :inherit modus-theme-diff-refine-removed)))
- `(diff-removed ((,class :inherit modus-theme-diff-removed)))
+ `(diff-nonexistent ((,class :inherit (modus-themes-neutral bold))))
+ `(diff-refine-added ((,class :inherit modus-themes-diff-refine-added)))
+ `(diff-refine-changed ((,class :inherit modus-themes-diff-refine-changed)))
+ `(diff-refine-removed ((,class :inherit modus-themes-diff-refine-removed)))
+ `(diff-removed ((,class :inherit modus-themes-diff-removed)))
;;;;; dim-autoload
`(dim-autoload-cookie-line ((,class :inherit font-lock-comment-face)))
;;;;; dir-treeview
@@ -3680,7 +3837,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(dir-treeview-image-icon-face ((,class :inherit
dir-treeview-default-icon-face :foreground ,green-alt)))
`(dir-treeview-indent-face ((,class :inherit shadow)))
`(dir-treeview-label-mouse-face ((,class :inherit highlight)))
- `(dir-treeview-start-dir-face ((,class :inherit
modus-theme-pseudo-header)))
+ `(dir-treeview-start-dir-face ((,class :inherit
modus-themes-pseudo-header)))
`(dir-treeview-symlink-face ((,class :inherit button
,@(modus-themes--link-color
cyan cyan-faint))))
@@ -3689,27 +3846,27 @@ by virtue of calling either of
`modus-themes-load-operandi' and
;;;;; dired
`(dired-broken-symlink ((,class :inherit button :foreground ,red)))
`(dired-directory ((,class :foreground ,blue)))
- `(dired-flagged ((,class :inherit modus-theme-mark-del)))
- `(dired-header ((,class :inherit modus-theme-pseudo-header)))
+ `(dired-flagged ((,class :inherit modus-themes-mark-del)))
+ `(dired-header ((,class :inherit modus-themes-pseudo-header)))
`(dired-ignored ((,class :inherit shadow)))
- `(dired-mark ((,class :inherit modus-theme-mark-symbol)))
- `(dired-marked ((,class :inherit modus-theme-mark-sel)))
+ `(dired-mark ((,class :inherit modus-themes-mark-symbol)))
+ `(dired-marked ((,class :inherit modus-themes-mark-sel)))
`(dired-perm-write ((,class :foreground ,fg-special-warm)))
`(dired-symlink ((,class :inherit button
,@(modus-themes--link-color
cyan-alt cyan-alt-faint))))
`(dired-warning ((,class :inherit bold :foreground ,yellow)))
;;;;; dired-async
- `(dired-async-failures ((,class :inherit modus-theme-bold :foreground
,red-active)))
- `(dired-async-message ((,class :inherit modus-theme-bold :foreground
,green-active)))
- `(dired-async-mode-message ((,class :inherit modus-theme-bold :foreground
,cyan-active)))
+ `(dired-async-failures ((,class :inherit bold :foreground ,red-active)))
+ `(dired-async-message ((,class :inherit bold :foreground ,blue-active)))
+ `(dired-async-mode-message ((,class :inherit bold :foreground
,cyan-active)))
;;;;; dired-git
`(dired-git-branch-else ((,class :inherit bold :foreground ,magenta-alt)))
`(dired-git-branch-master ((,class :inherit bold :foreground
,magenta-alt-other)))
;;;;; dired-git-info
`(dgi-commit-message-face ((,class :foreground ,fg-special-mild)))
;;;;; dired-narrow
- `(dired-narrow-blink ((,class :inherit (modus-theme-subtle-cyan bold))))
+ `(dired-narrow-blink ((,class :inherit (modus-themes-subtle-cyan bold))))
;;;;; dired-subtree
;; remove backgrounds from dired-subtree faces, else they break
;; dired-{flagged,marked} and any other face that sets a background
@@ -3727,21 +3884,21 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(diredc-face-chmod-font-lock-read ((,class :foreground ,fg-main)))
`(diredc-face-chmod-font-lock-write ((,class :foreground ,cyan)))
;;;;; diredfl
- `(diredfl-autofile-name ((,class :inherit modus-theme-special-cold)))
+ `(diredfl-autofile-name ((,class :inherit modus-themes-special-cold)))
`(diredfl-compressed-file-name ((,class :foreground ,fg-special-warm)))
`(diredfl-compressed-file-suffix ((,class :foreground ,red-alt)))
`(diredfl-date-time ((,class :foreground ,cyan-alt-other)))
- `(diredfl-deletion ((,class :inherit modus-theme-mark-del)))
- `(diredfl-deletion-file-name ((,class :inherit modus-theme-mark-del)))
- `(diredfl-dir-heading ((,class :inherit modus-theme-pseudo-header)))
+ `(diredfl-deletion ((,class :inherit modus-themes-mark-del)))
+ `(diredfl-deletion-file-name ((,class :inherit modus-themes-mark-del)))
+ `(diredfl-dir-heading ((,class :inherit modus-themes-pseudo-header)))
`(diredfl-dir-name ((,class :inherit dired-directory)))
`(diredfl-dir-priv ((,class :foreground ,blue-alt)))
`(diredfl-exec-priv ((,class :foreground ,magenta)))
`(diredfl-executable-tag ((,class :foreground ,magenta-alt)))
`(diredfl-file-name ((,class :foreground ,fg-main)))
`(diredfl-file-suffix ((,class :foreground ,cyan)))
- `(diredfl-flag-mark ((,class :inherit modus-theme-mark-sel)))
- `(diredfl-flag-mark-line ((,class :inherit modus-theme-mark-sel)))
+ `(diredfl-flag-mark ((,class :inherit modus-themes-mark-sel)))
+ `(diredfl-flag-mark-line ((,class :inherit modus-themes-mark-sel)))
`(diredfl-ignored-file-name ((,class :inherit shadow)))
`(diredfl-link-priv ((,class :foreground ,blue-alt-other)))
`(diredfl-no-priv ((,class :inherit shadow)))
@@ -3750,24 +3907,24 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(diredfl-rare-priv ((,class :foreground ,red-alt)))
`(diredfl-read-priv ((,class :foreground ,fg-main)))
`(diredfl-symlink ((,class :inherit dired-symlink)))
- `(diredfl-tagged-autofile-name ((,class :inherit
modus-theme-refine-magenta)))
+ `(diredfl-tagged-autofile-name ((,class :inherit
modus-themes-refine-magenta)))
`(diredfl-write-priv ((,class :foreground ,cyan)))
;;;;; dired+
- `(diredp-autofile-name ((,class :inherit modus-theme-special-cold)))
+ `(diredp-autofile-name ((,class :inherit modus-themes-special-cold)))
`(diredp-compressed-file-name ((,class :foreground ,fg-special-warm)))
`(diredp-compressed-file-suffix ((,class :foreground ,red-alt)))
`(diredp-date-time ((,class :foreground ,cyan-alt-other)))
- `(diredp-deletion ((,class :inherit modus-theme-mark-del)))
- `(diredp-deletion-file-name ((,class :inherit modus-theme-mark-del)))
- `(diredp-dir-heading ((,class :inherit modus-theme-pseudo-header)))
+ `(diredp-deletion ((,class :inherit modus-themes-mark-del)))
+ `(diredp-deletion-file-name ((,class :inherit modus-themes-mark-del)))
+ `(diredp-dir-heading ((,class :inherit modus-themes-pseudo-header)))
`(diredp-dir-name ((,class :inherit dired-directory)))
`(diredp-dir-priv ((,class :foreground ,blue-alt)))
`(diredp-exec-priv ((,class :foreground ,magenta)))
`(diredp-executable-tag ((,class :foreground ,magenta-alt)))
`(diredp-file-name ((,class :foreground ,fg-main)))
`(diredp-file-suffix ((,class :foreground ,cyan)))
- `(diredp-flag-mark ((,class :inherit modus-theme-mark-sel)))
- `(diredp-flag-mark-line ((,class :inherit modus-theme-mark-sel)))
+ `(diredp-flag-mark ((,class :inherit modus-themes-mark-sel)))
+ `(diredp-flag-mark-line ((,class :inherit modus-themes-mark-sel)))
`(diredp-ignored-file-name ((,class :inherit shadow)))
`(diredp-link-priv ((,class :foreground ,blue-alt-other)))
`(diredp-mode-line-flagged ((,class :foreground ,red-active)))
@@ -3779,7 +3936,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(diredp-rare-priv ((,class :foreground ,red-alt)))
`(diredp-read-priv ((,class :foreground ,fg-main)))
`(diredp-symlink ((,class :inherit dired-symlink)))
- `(diredp-tagged-autofile-name ((,class :inherit
modus-theme-refine-magenta)))
+ `(diredp-tagged-autofile-name ((,class :inherit
modus-themes-refine-magenta)))
`(diredp-write-priv ((,class :foreground ,cyan)))
;;;;; disk-usage
`(disk-usage-children ((,class :foreground ,yellow)))
@@ -3791,7 +3948,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
;;;;; display-fill-column-indicator-mode
`(fill-column-indicator ((,class :foreground ,bg-active)))
;;;;; doom-modeline
- `(doom-modeline-bar ((,class :inherit modus-theme-active-blue)))
+ `(doom-modeline-bar ((,class :inherit modus-themes-active-blue)))
`(doom-modeline-bar-inactive ((,class :background ,fg-inactive :foreground
,bg-main)))
`(doom-modeline-battery-charging ((,class :foreground ,green-active)))
`(doom-modeline-battery-critical ((,class :inherit bold :foreground
,red-active)))
@@ -3820,7 +3977,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(doom-modeline-lsp-error ((,class :inherit bold :foreground ,red-active)))
`(doom-modeline-lsp-success ((,class :inherit bold :foreground
,green-active)))
`(doom-modeline-lsp-warning ((,class :inherit bold :foreground
,yellow-active)))
- `(doom-modeline-panel ((,class :inherit modus-theme-active-blue)))
+ `(doom-modeline-panel ((,class :inherit modus-themes-active-blue)))
`(doom-modeline-persp-buffer-not-in-persp ((,class :inherit italic
:foreground ,yellow-active)))
`(doom-modeline-persp-name ((,class :foreground ,fg-active)))
`(doom-modeline-project-dir ((,class :inherit bold :foreground
,blue-active)))
@@ -3830,13 +3987,13 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(doom-modeline-urgent ((,class :inherit bold :foreground ,red-active)))
`(doom-modeline-warning ((,class :inherit bold :foreground
,yellow-active)))
;;;;; dynamic-ruler
- `(dynamic-ruler-negative-face ((,class :inherit
modus-theme-intense-neutral)))
- `(dynamic-ruler-positive-face ((,class :inherit
modus-theme-intense-yellow)))
+ `(dynamic-ruler-negative-face ((,class :inherit
modus-themes-intense-neutral)))
+ `(dynamic-ruler-positive-face ((,class :inherit
modus-themes-intense-yellow)))
;;;;; easy-jekyll
`(easy-jekyll-help-face ((,class :background ,bg-dim :foreground
,cyan-alt-other)))
;;;;; easy-kill
- `(easy-kill-origin ((,class :inherit modus-theme-subtle-red)))
- `(easy-kill-selection ((,class :inherit modus-theme-subtle-yellow)))
+ `(easy-kill-origin ((,class :inherit modus-themes-subtle-red)))
+ `(easy-kill-selection ((,class :inherit modus-themes-subtle-yellow)))
;;;;; ebdb
`(ebdb-address-default ((,class :foreground ,fg-special-calm)))
`(ebdb-defunct ((,class :inherit shadow)))
@@ -3850,46 +4007,32 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(ebdb-phone-default ((,class :foreground ,cyan)))
`(eieio-custom-slot-tag-face ((,class :foreground ,red-alt)))
;;;;; ediff
- ;; NOTE: here we break from the pattern of inheriting from the
- ;; modus-theme-diff-* faces.
- `(ediff-current-diff-A ((,class ,@(modus-themes--diff
- bg-dim red
- bg-diff-removed fg-diff-removed
- red-nuanced-bg red-faint))))
+ `(ediff-current-diff-A ((,class :inherit modus-themes-diff-removed)))
`(ediff-current-diff-Ancestor ((,class ,@(modus-themes--diff
- bg-dim fg-special-cold
+ bg-alt fg-special-cold
bg-special-cold fg-special-cold
blue-nuanced-bg blue))))
- `(ediff-current-diff-B ((,class ,@(modus-themes--diff
- bg-dim green
- bg-diff-added fg-diff-added
- green-nuanced-bg green-faint
- bg-diff-added-deuteran
fg-diff-added-deuteran))))
- `(ediff-current-diff-C ((,class ,@(modus-themes--diff
- bg-dim yellow
- bg-diff-changed fg-diff-changed
- yellow-nuanced-bg yellow-faint))))
- `(ediff-even-diff-A ((,class :background ,bg-diff-neutral-1 :foreground
,fg-diff-neutral-1)))
- `(ediff-even-diff-Ancestor ((,class :background ,bg-diff-neutral-2
:foreground ,fg-diff-neutral-1)))
- `(ediff-even-diff-B ((,class :background ,bg-diff-neutral-1 :foreground
,fg-diff-neutral-1)))
- `(ediff-even-diff-C ((,class :background ,bg-diff-neutral-2 :foreground
,fg-diff-neutral-2)))
- `(ediff-fine-diff-A ((,class :background ,bg-diff-focus-removed
:foreground ,fg-diff-focus-removed)))
- `(ediff-fine-diff-Ancestor ((,class :inherit modus-theme-refine-cyan)))
- `(ediff-fine-diff-B
- ((,class :background ,@(modus-themes--diff-deuteran
bg-diff-focus-added-deuteran bg-diff-focus-added)
- :foreground ,@(modus-themes--diff-deuteran
fg-diff-focus-added-deuteran fg-diff-focus-added))))
- `(ediff-fine-diff-C ((,class :background ,bg-diff-focus-changed
:foreground ,fg-diff-focus-changed)))
- `(ediff-odd-diff-A ((,class :background ,bg-diff-neutral-2 :foreground
,fg-diff-neutral-2)))
- `(ediff-odd-diff-Ancestor ((,class :background ,bg-diff-neutral-0
:foreground ,fg-diff-neutral-0)))
- `(ediff-odd-diff-B ((,class :background ,bg-diff-neutral-2 :foreground
,fg-diff-neutral-2)))
- `(ediff-odd-diff-C ((,class :background ,bg-diff-neutral-1 :foreground
,fg-diff-neutral-1)))
+ `(ediff-current-diff-B ((,class :inherit modus-themes-diff-added)))
+ `(ediff-current-diff-C ((,class :inherit modus-themes-diff-changed)))
+ `(ediff-even-diff-A ((,class :background ,bg-alt)))
+ `(ediff-even-diff-Ancestor ((,class :background ,bg-alt)))
+ `(ediff-even-diff-B ((,class :background ,bg-alt)))
+ `(ediff-even-diff-C ((,class :background ,bg-alt)))
+ `(ediff-fine-diff-A ((,class :inherit modus-themes-diff-refine-removed)))
+ `(ediff-fine-diff-Ancestor ((,class :inherit modus-themes-refine-cyan)))
+ `(ediff-fine-diff-B ((,class :inherit modus-themes-diff-refine-added)))
+ `(ediff-fine-diff-C ((,class :inherit modus-themes-diff-refine-changed)))
+ `(ediff-odd-diff-A ((,class :inherit ediff-even-diff-A)))
+ `(ediff-odd-diff-Ancestor ((,class :inherit ediff-even-diff-Ancestor)))
+ `(ediff-odd-diff-B ((,class :inherit ediff-even-diff-B)))
+ `(ediff-odd-diff-C ((,class :inherit ediff-even-diff-C)))
;;;;; eglot
- `(eglot-mode-line ((,class :inherit modus-theme-bold :foreground
,magenta-active)))
+ `(eglot-mode-line ((,class :inherit modus-themes-bold :foreground
,magenta-active)))
;;;;; el-search
`(el-search-highlight-in-prompt-face ((,class :inherit bold :foreground
,magenta-alt)))
- `(el-search-match ((,class :inherit modus-theme-intense-green)))
- `(el-search-other-match ((,class :inherit modus-theme-special-mild)))
- `(el-search-occur-match ((,class :inherit modus-theme-special-calm)))
+ `(el-search-match ((,class :inherit modus-themes-intense-green)))
+ `(el-search-other-match ((,class :inherit modus-themes-special-mild)))
+ `(el-search-occur-match ((,class :inherit modus-themes-special-calm)))
;;;;; eldoc
;; NOTE: see https://github.com/purcell/package-lint/issues/187
(list 'eldoc-highlight-function-argument `((,class :inherit bold
:foreground ,blue-alt-other)))
@@ -3916,17 +4059,19 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(elfeed-score-error-level-face ((,class :foreground ,red)))
`(elfeed-score-info-level-face ((,class :foreground ,cyan)))
`(elfeed-score-warn-level-face ((,class :foreground ,yellow)))
+;;;;; embark
+ `(embark-keybinding ((,class :inherit modus-themes-key-binding)))
;;;;; emms
`(emms-playlist-track-face ((,class :foreground ,blue)))
`(emms-playlist-selected-face ((,class :inherit bold :foreground
,magenta)))
-;;;;; enhanced-ruby-mode
- `(enh-ruby-heredoc-delimiter-face ((,class :foreground ,blue-alt-other)))
+;;;;; enh-ruby-mode (enhanced-ruby-mode)
+ `(enh-ruby-heredoc-delimiter-face ((,class :inherit
font-lock-constant-face)))
`(enh-ruby-op-face ((,class :foreground ,fg-main)))
- `(enh-ruby-regexp-delimiter-face ((,class :foreground ,green)))
- `(enh-ruby-regexp-face ((,class :foreground ,magenta)))
- `(enh-ruby-string-delimiter-face ((,class :foreground ,blue-alt)))
- `(erm-syn-errline ((,class :foreground ,red :underline t)))
- `(erm-syn-warnline ((,class :foreground ,yellow :underline t)))
+ `(enh-ruby-regexp-delimiter-face ((,class :inherit
font-lock-regexp-grouping-construct)))
+ `(enh-ruby-regexp-face ((,class :inherit font-lock-string-face)))
+ `(enh-ruby-string-delimiter-face ((,class :inherit font-lock-string-face)))
+ `(erm-syn-errline ((,class :inherit modus-themes-lang-error)))
+ `(erm-syn-warnline ((,class :inherit modus-themes-lang-warning)))
;;;;; epa
`(epa-field-body ((,class :foreground ,fg-main)))
`(epa-field-name ((,class :inherit bold :foreground ,fg-dim)))
@@ -3951,7 +4096,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(erc-button ((,class :inherit button)))
`(erc-command-indicator-face ((,class :inherit bold :foreground
,cyan-alt)))
`(erc-current-nick-face ((,class :foreground ,magenta-alt-other)))
- `(erc-dangerous-host-face ((,class :inherit modus-theme-intense-red)))
+ `(erc-dangerous-host-face ((,class :inherit modus-themes-intense-red)))
`(erc-direct-msg-face ((,class :foreground ,magenta)))
`(erc-error-face ((,class :inherit bold :foreground ,red)))
`(erc-fool-face ((,class :foreground ,fg-inactive)))
@@ -3966,7 +4111,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(erc-nick-prefix-face ((,class :inherit erc-nick-default-face)))
`(erc-notice-face ((,class :foreground ,fg-unfocused)))
`(erc-pal-face ((,class :inherit bold :foreground ,red-alt)))
- `(erc-prompt-face ((,class :inherit bold :foreground ,cyan-alt-other)))
+ `(erc-prompt-face ((,class :inherit comint-highlight-prompt)))
`(erc-timestamp-face ((,class :foreground ,blue-nuanced-fg)))
`(erc-underline-face ((,class :underline t)))
`(bg:erc-color-face0 ((,class :background "white")))
@@ -4005,15 +4150,15 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(eros-result-overlay-face ((,class :box (:line-width -1 :color ,blue)
:background ,bg-dim :foreground
,fg-dim)))
;;;;; ert
- `(ert-test-result-expected ((,class :inherit modus-theme-intense-green)))
- `(ert-test-result-unexpected ((,class :inherit modus-theme-intense-red)))
+ `(ert-test-result-expected ((,class :inherit modus-themes-intense-green)))
+ `(ert-test-result-unexpected ((,class :inherit modus-themes-intense-red)))
;;;;; eshell
`(eshell-ls-archive ((,class :inherit bold :foreground ,cyan-alt)))
`(eshell-ls-backup ((,class :foreground ,yellow-alt)))
`(eshell-ls-clutter ((,class :foreground ,red-alt)))
`(eshell-ls-directory ((,class :inherit bold :foreground ,blue-alt)))
`(eshell-ls-executable ((,class :foreground ,magenta-alt)))
- `(eshell-ls-missing ((,class :inherit modus-theme-intense-red)))
+ `(eshell-ls-missing ((,class :inherit modus-themes-intense-red)))
`(eshell-ls-product ((,class :foreground ,fg-special-warm)))
`(eshell-ls-readonly ((,class :foreground ,fg-special-cold)))
`(eshell-ls-special ((,class :inherit bold :foreground ,magenta)))
@@ -4021,7 +4166,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
,@(modus-themes--link-color
cyan cyan-faint))))
`(eshell-ls-unreadable ((,class :background ,bg-inactive :foreground
,fg-inactive)))
- `(eshell-prompt ((,class :inherit modus-theme-bold
+ `(eshell-prompt ((,class :inherit modus-themes-bold
,@(modus-themes--prompt
green-alt-other
green-nuanced-bg green-alt
@@ -4043,16 +4188,16 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(eshell-git-prompt-robyrussell-git-dirty-face ((,class :foreground
,yellow)))
`(eshell-git-prompt-robyrussell-git-face ((,class :foreground ,blue)))
;;;;; eshell-prompt-extras (epe)
- `(epe-dir-face ((,class :inherit modus-theme-bold :foreground ,blue)))
+ `(epe-dir-face ((,class :inherit modus-themes-bold :foreground ,blue)))
`(epe-git-dir-face ((,class :foreground ,red-alt-other)))
`(epe-git-face ((,class :foreground ,cyan-alt)))
`(epe-pipeline-delimiter-face ((,class :foreground ,green-alt)))
`(epe-pipeline-host-face ((,class :foreground ,blue)))
`(epe-pipeline-time-face ((,class :foreground ,fg-special-warm)))
`(epe-pipeline-user-face ((,class :foreground ,magenta)))
- `(epe-remote-face ((,class :inherit modus-theme-slant :foreground
,fg-alt)))
+ `(epe-remote-face ((,class :inherit modus-themes-slant :foreground
,fg-alt)))
`(epe-status-face ((,class :foreground ,magenta-alt-other)))
- `(epe-venv-face ((,class :inherit modus-theme-slant :foreground ,fg-alt)))
+ `(epe-venv-face ((,class :inherit modus-themes-slant :foreground ,fg-alt)))
;;;;; eshell-syntax-highlighting
`(eshell-syntax-highlighting-alias-face ((,class :foreground ,cyan)))
`(eshell-syntax-highlighting-comment-face ((,class :inherit shadow)))
@@ -4065,103 +4210,104 @@ by virtue of calling either of
`modus-themes-load-operandi' and
;;;;; evil-mode
`(evil-ex-commands ((,class :foreground ,magenta-alt-other)))
`(evil-ex-info ((,class :foreground ,cyan-alt-other)))
- `(evil-ex-lazy-highlight ((,class :inherit modus-theme-refine-cyan)))
- `(evil-ex-search ((,class :inherit modus-theme-intense-green)))
- `(evil-ex-substitute-matches ((,class :inherit modus-theme-refine-yellow
:underline t)))
- `(evil-ex-substitute-replacement ((,class :inherit
(modus-theme-intense-green bold))))
+ `(evil-ex-lazy-highlight ((,class :inherit modus-themes-refine-cyan)))
+ `(evil-ex-search ((,class :inherit modus-themes-intense-green)))
+ `(evil-ex-substitute-matches ((,class :inherit modus-themes-refine-yellow
:underline t)))
+ `(evil-ex-substitute-replacement ((,class :inherit
(modus-themes-intense-green bold))))
;;;;; evil-goggles
- `(evil-goggles-change-face ((,class :inherit modus-theme-refine-yellow)))
- `(evil-goggles-commentary-face ((,class :inherit
(modus-theme-subtle-neutral modus-theme-slant))))
- `(evil-goggles-default-face ((,class :inherit modus-theme-subtle-neutral)))
- `(evil-goggles-delete-face ((,class :inherit modus-theme-refine-red)))
+ `(evil-goggles-change-face ((,class :inherit modus-themes-refine-yellow)))
+ `(evil-goggles-commentary-face ((,class :inherit
(modus-themes-subtle-neutral modus-themes-slant))))
+ `(evil-goggles-default-face ((,class :inherit
modus-themes-subtle-neutral)))
+ `(evil-goggles-delete-face ((,class :inherit modus-themes-refine-red)))
`(evil-goggles-fill-and-move-face ((,class :inherit
evil-goggles-default-face)))
`(evil-goggles-indent-face ((,class :inherit evil-goggles-default-face)))
- `(evil-goggles-join-face ((,class :inherit modus-theme-subtle-green)))
+ `(evil-goggles-join-face ((,class :inherit modus-themes-subtle-green)))
`(evil-goggles-nerd-commenter-face ((,class :inherit
evil-goggles-commentary-face)))
- `(evil-goggles-paste-face ((,class :inherit modus-theme-subtle-cyan)))
- `(evil-goggles-record-macro-face ((,class :inherit
modus-theme-special-cold)))
- `(evil-goggles-replace-with-register-face ((,class :inherit
modus-theme-refine-magenta)))
- `(evil-goggles-set-marker-face ((,class :inherit
modus-theme-intense-magenta)))
+ `(evil-goggles-paste-face ((,class :inherit modus-themes-subtle-cyan)))
+ `(evil-goggles-record-macro-face ((,class :inherit
modus-themes-special-cold)))
+ `(evil-goggles-replace-with-register-face ((,class :inherit
modus-themes-refine-magenta)))
+ `(evil-goggles-set-marker-face ((,class :inherit
modus-themes-intense-magenta)))
`(evil-goggles-shift-face ((,class :inherit evil-goggles-default-face)))
`(evil-goggles-surround-face ((,class :inherit evil-goggles-default-face)))
- `(evil-goggles-yank-face ((,class :inherit modus-theme-subtle-blue)))
+ `(evil-goggles-yank-face ((,class :inherit modus-themes-subtle-blue)))
;;;;; evil-snipe
- `(evil-snipe-first-match-face ((,class :inherit (bold
modus-theme-intense-blue))))
- `(evil-snipe-matches-face ((,class :inherit modus-theme-refine-magenta)))
+ `(evil-snipe-first-match-face ((,class :inherit (bold
modus-themes-intense-blue))))
+ `(evil-snipe-matches-face ((,class :inherit modus-themes-refine-magenta)))
;;;;; evil-visual-mark-mode
- `(evil-visual-mark-face ((,class :inherit modus-theme-intense-magenta)))
+ `(evil-visual-mark-face ((,class :inherit modus-themes-intense-magenta)))
;;;;; eww
- `(eww-invalid-certificate ((,class :foreground ,red-active)))
- `(eww-valid-certificate ((,class :foreground ,green-active)))
- `(eww-form-checkbox ((,class :box (:line-width 1 :color ,fg-inactive
:style released-button) :background ,bg-inactive :foreground ,fg-main)))
- `(eww-form-file ((,class :box (:line-width 1 :color ,fg-inactive :style
released-button) :background ,bg-active :foreground ,fg-main)))
- `(eww-form-select ((,class :inherit eww-form-checkbox)))
- `(eww-form-submit ((,class :inherit eww-form-file)))
- `(eww-form-text ((,class :box (:line-width 1 :color ,fg-inactive :style
none) :background ,bg-active :foreground ,fg-active)))
- `(eww-form-textarea ((,class :background ,bg-alt :foreground ,fg-main)))
+ `(eww-invalid-certificate ((,class :foreground ,red-faint)))
+ `(eww-valid-certificate ((,class :foreground ,blue-faint)))
+ `(eww-form-checkbox ((,class :inherit eww-form-text)))
+ `(eww-form-file ((,class :inherit eww-form-submit)))
+ `(eww-form-select ((,class :inherit eww-form-submit)))
+ `(eww-form-submit ((,class :box (:line-width 2 :style released-button)
+ :background ,bg-active)))
+ `(eww-form-text ((,class :box ,bg-active :background ,bg-alt)))
+ `(eww-form-textarea ((,class :background ,bg-alt)))
;;;;; eyebrowse
`(eyebrowse-mode-line-active ((,class :inherit bold :foreground
,blue-active)))
;;;;; fancy-dabbrev
`(fancy-dabbrev-menu-face ((,class :background ,bg-alt :foreground
,fg-alt)))
`(fancy-dabbrev-preview-face ((,class :inherit shadow :underline t)))
- `(fancy-dabbrev-selection-face ((,class :inherit (modus-theme-intense-cyan
bold))))
+ `(fancy-dabbrev-selection-face ((,class :inherit
(modus-themes-intense-cyan bold))))
;;;;; flycheck
- `(flycheck-error ((,class :inherit modus-theme-lang-error)))
+ `(flycheck-error ((,class :inherit modus-themes-lang-error)))
`(flycheck-error-list-checker-name ((,class :foreground ,magenta-active)))
`(flycheck-error-list-column-number ((,class :foreground
,fg-special-cold)))
- `(flycheck-error-list-error ((,class :inherit modus-theme-bold :foreground
,red)))
+ `(flycheck-error-list-error ((,class :inherit modus-themes-bold
:foreground ,red)))
`(flycheck-error-list-filename ((,class :foreground ,blue)))
- `(flycheck-error-list-highlight ((,class :inherit modus-theme-hl-line)))
+ `(flycheck-error-list-highlight ((,class :inherit modus-themes-hl-line)))
`(flycheck-error-list-id ((,class :foreground ,magenta-alt-other)))
`(flycheck-error-list-id-with-explainer ((,class :inherit
flycheck-error-list-id :box t)))
`(flycheck-error-list-info ((,class :foreground ,cyan)))
`(flycheck-error-list-line-number ((,class :foreground ,fg-special-warm)))
`(flycheck-error-list-warning ((,class :foreground ,yellow)))
- `(flycheck-fringe-error ((,class :inherit modus-theme-fringe-red)))
- `(flycheck-fringe-info ((,class :inherit modus-theme-fringe-cyan)))
- `(flycheck-fringe-warning ((,class :inherit modus-theme-fringe-yellow)))
- `(flycheck-info ((,class :inherit modus-theme-lang-note)))
+ `(flycheck-fringe-error ((,class :inherit modus-themes-fringe-red)))
+ `(flycheck-fringe-info ((,class :inherit modus-themes-fringe-cyan)))
+ `(flycheck-fringe-warning ((,class :inherit modus-themes-fringe-yellow)))
+ `(flycheck-info ((,class :inherit modus-themes-lang-note)))
`(flycheck-verify-select-checker ((,class :box (:line-width 1 :color nil
:style released-button))))
- `(flycheck-warning ((,class :inherit modus-theme-lang-warning)))
+ `(flycheck-warning ((,class :inherit modus-themes-lang-warning)))
;;;;; flycheck-color-mode-line
`(flycheck-color-mode-line-error-face ((,class :inherit
flycheck-fringe-error)))
`(flycheck-color-mode-line-info-face ((,class :inherit
flycheck-fringe-info)))
`(flycheck-color-mode-line-running-face ((,class :inherit italic
:foreground ,fg-inactive)))
`(flycheck-color-mode-line-info-face ((,class :inherit
flycheck-fringe-warning)))
;;;;; flycheck-indicator
- `(flycheck-indicator-disabled ((,class :inherit modus-theme-slant
:foreground ,fg-inactive)))
- `(flycheck-indicator-error ((,class :inherit modus-theme-bold :foreground
,red-active)))
- `(flycheck-indicator-info ((,class :inherit modus-theme-bold :foreground
,blue-active)))
- `(flycheck-indicator-running ((,class :inherit modus-theme-bold
:foreground ,magenta-active)))
- `(flycheck-indicator-success ((,class :inherit modus-theme-bold
:foreground ,green-active)))
- `(flycheck-indicator-warning ((,class :inherit modus-theme-bold
:foreground ,yellow-active)))
+ `(flycheck-indicator-disabled ((,class :inherit modus-themes-slant
:foreground ,fg-inactive)))
+ `(flycheck-indicator-error ((,class :inherit modus-themes-bold :foreground
,red-active)))
+ `(flycheck-indicator-info ((,class :inherit modus-themes-bold :foreground
,blue-active)))
+ `(flycheck-indicator-running ((,class :inherit modus-themes-bold
:foreground ,magenta-active)))
+ `(flycheck-indicator-success ((,class :inherit modus-themes-bold
:foreground ,green-active)))
+ `(flycheck-indicator-warning ((,class :inherit modus-themes-bold
:foreground ,yellow-active)))
;;;;; flycheck-posframe
`(flycheck-posframe-background-face ((,class :background ,bg-alt)))
`(flycheck-posframe-border-face ((,class :inherit shadow)))
`(flycheck-posframe-error-face ((,class :inherit bold :foreground ,red)))
- `(flycheck-posframe-face ((,class :inherit modus-theme-slant :foreground
,fg-main)))
+ `(flycheck-posframe-face ((,class :inherit modus-themes-slant :foreground
,fg-main)))
`(flycheck-posframe-info-face ((,class :inherit bold :foreground ,cyan)))
`(flycheck-posframe-warning-face ((,class :inherit bold :foreground
,yellow)))
;;;;; flymake
- `(flymake-error ((,class :inherit modus-theme-lang-error)))
- `(flymake-note ((,class :inherit modus-theme-lang-note)))
- `(flymake-warning ((,class :inherit modus-theme-lang-warning)))
+ `(flymake-error ((,class :inherit modus-themes-lang-error)))
+ `(flymake-note ((,class :inherit modus-themes-lang-note)))
+ `(flymake-warning ((,class :inherit modus-themes-lang-warning)))
;;;;; flyspell
- `(flyspell-duplicate ((,class :inherit modus-theme-lang-warning)))
- `(flyspell-incorrect ((,class :inherit modus-theme-lang-error)))
+ `(flyspell-duplicate ((,class :inherit modus-themes-lang-warning)))
+ `(flyspell-incorrect ((,class :inherit modus-themes-lang-error)))
;;;;; flyspell-correct
- `(flyspell-correct-highlight-face ((,class :inherit
modus-theme-refine-green)))
+ `(flyspell-correct-highlight-face ((,class :inherit
modus-themes-refine-green)))
;;;;; flx
`(flx-highlight-face ((,class ,@(modus-themes--extra-completions
- 'modus-theme-subtle-magenta
- 'modus-theme-intense-magenta
- 'modus-theme-nuanced-magenta
+ 'modus-themes-subtle-magenta
+ 'modus-themes-intense-magenta
+ 'modus-themes-nuanced-magenta
magenta-alt
'bold))))
;;;;; freeze-it
`(freeze-it-show ((,class :background ,bg-dim :foreground
,fg-special-warm)))
;;;;; frog-menu
- `(frog-menu-action-keybinding-face ((,class :foreground ,blue-alt-other)))
+ `(frog-menu-action-keybinding-face ((,class :inherit
modus-themes-key-binding)))
`(frog-menu-actions-face ((,class :foreground ,magenta)))
`(frog-menu-border ((,class :background ,bg-active)))
`(frog-menu-candidates-face ((,class :foreground ,fg-main)))
@@ -4170,27 +4316,27 @@ by virtue of calling either of
`modus-themes-load-operandi' and
;;;;; focus
`(focus-unfocused ((,class :foreground ,fg-unfocused)))
;;;;; fold-this
- `(fold-this-overlay ((,class :inherit modus-theme-special-mild)))
+ `(fold-this-overlay ((,class :inherit modus-themes-special-mild)))
;;;;; font-lock
- `(font-lock-builtin-face ((,class :inherit modus-theme-bold
+ `(font-lock-builtin-face ((,class :inherit modus-themes-bold
,@(modus-themes--syntax-extra
magenta-alt magenta-alt-faint
blue-alt))))
`(font-lock-comment-delimiter-face ((,class :inherit
font-lock-comment-face)))
- `(font-lock-comment-face ((,class :inherit modus-theme-slant
+ `(font-lock-comment-face ((,class :inherit modus-themes-slant
,@(modus-themes--syntax-comment
fg-alt fg-comment-yellow))))
`(font-lock-constant-face ((,class ,@(modus-themes--syntax-extra
blue-alt-other blue-alt-other-faint
magenta-alt-other))))
- `(font-lock-doc-face ((,class :inherit modus-theme-slant
+ `(font-lock-doc-face ((,class :inherit modus-themes-slant
,@(modus-themes--syntax-docstring
fg-docstring green-alt-other-faint
green-alt-other-faint
magenta-nuanced-fg))))
`(font-lock-function-name-face ((,class ,@(modus-themes--syntax-extra
magenta magenta-faint
magenta-alt))))
- `(font-lock-keyword-face ((,class :inherit modus-theme-bold
+ `(font-lock-keyword-face ((,class :inherit modus-themes-bold
,@(modus-themes--syntax-extra
magenta-alt-other
magenta-alt-other-faint cyan-alt-other))))
- `(font-lock-negation-char-face ((,class :inherit modus-theme-bold
+ `(font-lock-negation-char-face ((,class :inherit modus-themes-bold
,@(modus-themes--syntax-foreground
yellow yellow-faint))))
`(font-lock-preprocessor-face ((,class ,@(modus-themes--syntax-foreground
@@ -4205,12 +4351,12 @@ by virtue of calling either of
`modus-themes-load-operandi' and
red magenta-alt))))
`(font-lock-string-face ((,class ,@(modus-themes--syntax-string
blue-alt blue-alt-faint green
green-alt))))
- `(font-lock-type-face ((,class :inherit modus-theme-bold
+ `(font-lock-type-face ((,class :inherit modus-themes-bold
,@(modus-themes--syntax-extra
cyan-alt-other cyan-alt-faint
cyan-alt))))
`(font-lock-variable-name-face ((,class ,@(modus-themes--syntax-extra
cyan cyan-faint
blue-alt-faint))))
- `(font-lock-warning-face ((,class :inherit modus-theme-bold
+ `(font-lock-warning-face ((,class :inherit modus-themes-bold
,@(modus-themes--syntax-foreground
yellow-active yellow-alt-faint))))
;;;;; forge
@@ -4219,26 +4365,26 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(forge-topic-closed ((,class :inherit shadow)))
`(forge-topic-merged ((,class :inherit shadow)))
`(forge-topic-open ((,class :foreground ,fg-special-mild)))
- `(forge-topic-unmerged ((,class :inherit modus-theme-slant :foreground
,magenta)))
+ `(forge-topic-unmerged ((,class :inherit modus-themes-slant :foreground
,magenta)))
`(forge-topic-unread ((,class :inherit bold :foreground ,fg-main)))
;;;;; fountain-mode
`(fountain-character ((,class :foreground ,blue-alt-other)))
- `(fountain-comment ((,class :inherit modus-theme-slant :foreground
,fg-alt)))
+ `(fountain-comment ((,class :inherit modus-themes-slant :foreground
,fg-alt)))
`(fountain-dialog ((,class :foreground ,blue-alt)))
`(fountain-metadata-key ((,class :foreground ,green-alt-other)))
`(fountain-metadata-value ((,class :foreground ,blue)))
`(fountain-non-printing ((,class :inherit shadow)))
- `(fountain-note ((,class :inherit modus-theme-slant :foreground ,yellow)))
+ `(fountain-note ((,class :inherit modus-themes-slant :foreground ,yellow)))
`(fountain-page-break ((,class :inherit bold :foreground ,red-alt)))
`(fountain-page-number ((,class :inherit bold :foreground ,red-alt-other)))
`(fountain-paren ((,class :foreground ,cyan)))
`(fountain-scene-heading ((,class :inherit bold :foreground
,blue-nuanced-fg)))
- `(fountain-section-heading ((,class :inherit modus-theme-heading-1)))
- `(fountain-section-heading-1 ((,class :inherit modus-theme-heading-1)))
- `(fountain-section-heading-2 ((,class :inherit modus-theme-heading-2)))
- `(fountain-section-heading-3 ((,class :inherit modus-theme-heading-3)))
- `(fountain-section-heading-4 ((,class :inherit modus-theme-heading-4)))
- `(fountain-section-heading-5 ((,class :inherit modus-theme-heading-5)))
+ `(fountain-section-heading ((,class :inherit modus-themes-heading-1)))
+ `(fountain-section-heading-1 ((,class :inherit modus-themes-heading-1)))
+ `(fountain-section-heading-2 ((,class :inherit modus-themes-heading-2)))
+ `(fountain-section-heading-3 ((,class :inherit modus-themes-heading-3)))
+ `(fountain-section-heading-4 ((,class :inherit modus-themes-heading-4)))
+ `(fountain-section-heading-5 ((,class :inherit modus-themes-heading-5)))
`(fountain-synopsis ((,class :foreground ,cyan-alt)))
`(fountain-trans ((,class :foreground ,yellow-alt-other)))
;;;;; geiser
@@ -4255,40 +4401,40 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(geiser-font-lock-xref-link ((,class :inherit button)))
;;;;; git-commit
`(git-commit-comment-action ((,class :inherit font-lock-comment-face)))
- `(git-commit-comment-branch-local ((,class :inherit modus-theme-slant
:foreground ,blue-alt)))
- `(git-commit-comment-branch-remote ((,class :inherit modus-theme-slant
:foreground ,magenta-alt)))
- `(git-commit-comment-detached ((,class :inherit modus-theme-slant
:foreground ,cyan-alt)))
- `(git-commit-comment-file ((,class :inherit modus-theme-slant
+ `(git-commit-comment-branch-local ((,class :inherit modus-themes-slant
:foreground ,blue-alt)))
+ `(git-commit-comment-branch-remote ((,class :inherit modus-themes-slant
:foreground ,magenta-alt)))
+ `(git-commit-comment-detached ((,class :inherit modus-themes-slant
:foreground ,cyan-alt)))
+ `(git-commit-comment-file ((,class :inherit modus-themes-slant
,@(modus-themes--syntax-comment
fg-special-cold red-nuanced-fg))))
- `(git-commit-comment-heading ((,class :inherit (bold modus-theme-slant)
+ `(git-commit-comment-heading ((,class :inherit (bold modus-themes-slant)
,@(modus-themes--syntax-comment
fg-dim fg-special-warm))))
`(git-commit-keyword ((,class :foreground ,magenta)))
`(git-commit-known-pseudo-header ((,class :foreground ,cyan-alt-other)))
- `(git-commit-nonempty-second-line ((,class :inherit
modus-theme-refine-yellow)))
- `(git-commit-overlong-summary ((,class :inherit
modus-theme-refine-yellow)))
+ `(git-commit-nonempty-second-line ((,class :inherit
modus-themes-refine-yellow)))
+ `(git-commit-overlong-summary ((,class :inherit
modus-themes-refine-yellow)))
`(git-commit-pseudo-header ((,class :foreground ,blue)))
`(git-commit-summary ((,class :inherit bold :foreground ,cyan)))
;;;;; git-gutter
- `(git-gutter:added ((,class :inherit modus-theme-fringe-green)))
- `(git-gutter:deleted ((,class :inherit modus-theme-fringe-red)))
- `(git-gutter:modified ((,class :inherit modus-theme-fringe-yellow)))
- `(git-gutter:separator ((,class :inherit modus-theme-fringe-cyan)))
- `(git-gutter:unchanged ((,class :inherit modus-theme-fringe-magenta)))
+ `(git-gutter:added ((,class :inherit modus-themes-fringe-green)))
+ `(git-gutter:deleted ((,class :inherit modus-themes-fringe-red)))
+ `(git-gutter:modified ((,class :inherit modus-themes-fringe-yellow)))
+ `(git-gutter:separator ((,class :inherit modus-themes-fringe-cyan)))
+ `(git-gutter:unchanged ((,class :inherit modus-themes-fringe-magenta)))
;;;;; git-gutter-fr
- `(git-gutter-fr:added ((,class :inherit modus-theme-fringe-green)))
- `(git-gutter-fr:deleted ((,class :inherit modus-theme-fringe-red)))
- `(git-gutter-fr:modified ((,class :inherit modus-theme-fringe-yellow)))
+ `(git-gutter-fr:added ((,class :inherit modus-themes-fringe-green)))
+ `(git-gutter-fr:deleted ((,class :inherit modus-themes-fringe-red)))
+ `(git-gutter-fr:modified ((,class :inherit modus-themes-fringe-yellow)))
;;;;; git-{gutter,fringe}+
- `(git-gutter+-added ((,class :inherit modus-theme-fringe-green)))
- `(git-gutter+-deleted ((,class :inherit modus-theme-fringe-red)))
- `(git-gutter+-modified ((,class :inherit modus-theme-fringe-yellow)))
- `(git-gutter+-separator ((,class :inherit modus-theme-fringe-cyan)))
- `(git-gutter+-unchanged ((,class :inherit modus-theme-fringe-magenta)))
- `(git-gutter-fr+-added ((,class :inherit modus-theme-fringe-green)))
- `(git-gutter-fr+-deleted ((,class :inherit modus-theme-fringe-red)))
- `(git-gutter-fr+-modified ((,class :inherit modus-theme-fringe-yellow)))
+ `(git-gutter+-added ((,class :inherit modus-themes-fringe-green)))
+ `(git-gutter+-deleted ((,class :inherit modus-themes-fringe-red)))
+ `(git-gutter+-modified ((,class :inherit modus-themes-fringe-yellow)))
+ `(git-gutter+-separator ((,class :inherit modus-themes-fringe-cyan)))
+ `(git-gutter+-unchanged ((,class :inherit modus-themes-fringe-magenta)))
+ `(git-gutter-fr+-added ((,class :inherit modus-themes-fringe-green)))
+ `(git-gutter-fr+-deleted ((,class :inherit modus-themes-fringe-red)))
+ `(git-gutter-fr+-modified ((,class :inherit modus-themes-fringe-yellow)))
;;;;; git-lens
`(git-lens-added ((,class :inherit bold :foreground ,green)))
`(git-lens-deleted ((,class :inherit bold :foreground ,red)))
@@ -4296,10 +4442,10 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(git-lens-modified ((,class :inherit bold :foreground ,yellow)))
`(git-lens-renamed ((,class :inherit bold :foreground ,magenta)))
;;;;; git-rebase
- `(git-rebase-comment-hash ((,class :inherit modus-theme-slant
+ `(git-rebase-comment-hash ((,class :inherit modus-themes-slant
,@(modus-themes--syntax-comment
fg-special-cold red-nuanced-fg))))
- `(git-rebase-comment-heading ((,class :inherit (bold modus-theme-slant)
+ `(git-rebase-comment-heading ((,class :inherit (bold modus-themes-slant)
,@(modus-themes--syntax-comment
fg-dim fg-special-warm))))
`(git-rebase-description ((,class :foreground ,fg-main)))
@@ -4328,7 +4474,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(gnus-cite-attribution ((,class :inherit italic :foreground ,fg-main)))
`(gnus-emphasis-bold ((,class :inherit bold)))
`(gnus-emphasis-bold-italic ((,class :inherit bold-italic)))
- `(gnus-emphasis-highlight-words ((,class :inherit
modus-theme-refine-yellow)))
+ `(gnus-emphasis-highlight-words ((,class :inherit
modus-themes-refine-yellow)))
`(gnus-emphasis-italic ((,class :inherit italic)))
`(gnus-emphasis-underline-bold ((,class :inherit gnus-emphasis-bold
:underline t)))
`(gnus-emphasis-underline-bold-italic ((,class :inherit
gnus-emphasis-bold-italic :underline t)))
@@ -4363,13 +4509,13 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(gnus-server-agent ((,class :inherit bold :foreground ,cyan)))
`(gnus-server-closed ((,class :inherit bold :foreground ,magenta)))
`(gnus-server-cloud ((,class :inherit bold :foreground ,cyan-alt)))
- `(gnus-server-cloud-host ((,class :inherit modus-theme-refine-cyan)))
+ `(gnus-server-cloud-host ((,class :inherit modus-themes-refine-cyan)))
`(gnus-server-denied ((,class :inherit bold :foreground ,red)))
`(gnus-server-offline ((,class :inherit bold :foreground ,yellow)))
`(gnus-server-opened ((,class :inherit bold :foreground ,green)))
`(gnus-signature ((,class :inherit italic :foreground ,fg-special-cold)))
`(gnus-splash ((,class :inherit shadow)))
- `(gnus-summary-cancelled ((,class :inherit modus-theme-mark-alt)))
+ `(gnus-summary-cancelled ((,class :inherit modus-themes-mark-alt :extend
t)))
`(gnus-summary-high-ancient ((,class :inherit bold :foreground ,fg-alt)))
`(gnus-summary-high-read ((,class :inherit bold :foreground
,fg-special-cold)))
`(gnus-summary-high-ticked ((,class :inherit bold :foreground
,red-alt-other)))
@@ -4385,11 +4531,11 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(gnus-summary-normal-ticked ((,class :foreground ,red-alt-other)))
`(gnus-summary-normal-undownloaded ((,class :foreground ,yellow)))
`(gnus-summary-normal-unread ((,class :foreground ,fg-main)))
- `(gnus-summary-selected ((,class :inherit modus-theme-subtle-blue)))
+ `(gnus-summary-selected ((,class :inherit modus-themes-subtle-blue :extend
t)))
;;;;; golden-ratio-scroll-screen
`(golden-ratio-scroll-highlight-line-face ((,class :background
,cyan-subtle-bg :foreground ,fg-main)))
;;;;; helm
- `(helm-M-x-key ((,class :inherit bold :foreground ,magenta-alt-other)))
+ `(helm-M-x-key ((,class :inherit modus-themes-key-binding)))
`(helm-action ((,class :underline t)))
`(helm-bookmark-addressbook ((,class :foreground ,green-alt)))
`(helm-bookmark-directory ((,class :inherit bold :foreground ,blue)))
@@ -4418,9 +4564,9 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(helm-etags-file ((,class :foreground ,fg-dim :underline t)))
`(helm-ff-backup-file ((,class :inherit shadow)))
`(helm-ff-denied ((,class ,@(modus-themes--extra-completions
- 'modus-theme-subtle-red
- 'modus-theme-intense-red
- 'modus-theme-nuanced-red
+ 'modus-themes-subtle-red
+ 'modus-themes-intense-red
+ 'modus-themes-nuanced-red
red))))
`(helm-ff-directory ((,class :inherit helm-buffer-directory)))
`(helm-ff-dirs ((,class :inherit bold :foreground ,blue-alt-other)))
@@ -4433,20 +4579,20 @@ by virtue of calling either of
`modus-themes-load-operandi' and
,@(modus-themes--link-color
red red-faint))))
`(helm-ff-pipe ((,class ,@(modus-themes--extra-completions
- 'modus-theme-refine-magenta
- 'modus-theme-subtle-magenta
- 'modus-theme-nuanced-magenta
+ 'modus-themes-refine-magenta
+ 'modus-themes-subtle-magenta
+ 'modus-themes-nuanced-magenta
magenta))))
`(helm-ff-prefix ((,class ,@(modus-themes--extra-completions
- 'modus-theme-refine-yellow
- 'modus-theme-subtle-yellow
- 'modus-theme-nuanced-yellow
+ 'modus-themes-refine-yellow
+ 'modus-themes-subtle-yellow
+ 'modus-themes-nuanced-yellow
yellow-alt-other))))
`(helm-ff-socket ((,class :foreground ,red-alt-other)))
`(helm-ff-suid ((,class ,@(modus-themes--extra-completions
- 'modus-theme-subtle-red
- 'modus-theme-refine-red
- 'modus-theme-nuanced-yellow
+ 'modus-themes-subtle-red
+ 'modus-themes-refine-red
+ 'modus-themes-nuanced-yellow
red-alt))))
`(helm-ff-symlink ((,class :inherit button
,@(modus-themes--link-color
@@ -4457,59 +4603,59 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(helm-grep-file ((,class :inherit bold :foreground ,fg-special-cold)))
`(helm-grep-finish ((,class :foreground ,green-active)))
`(helm-grep-lineno ((,class :foreground ,fg-special-warm)))
- `(helm-grep-match ((,class :inherit modus-theme-special-calm)))
+ `(helm-grep-match ((,class :inherit modus-themes-special-calm)))
`(helm-header ((,class :inherit bold :foreground ,fg-special-cold)))
`(helm-header-line-left-margin ((,class :inherit bold :foreground
,yellow-intense)))
`(helm-history-deleted ((,class ,@(modus-themes--extra-completions
- 'modus-theme-subtle-red
- 'modus-theme-intense-red
- 'modus-theme-nuanced-red
+ 'modus-themes-subtle-red
+ 'modus-themes-intense-red
+ 'modus-themes-nuanced-red
red
'bold))))
`(helm-history-remote ((,class :foreground ,red-alt-other)))
`(helm-lisp-completion-info ((,class :foreground ,fg-special-warm)))
`(helm-lisp-show-completion ((,class ,@(modus-themes--extra-completions
- 'modus-theme-subtle-yellow
- 'modus-theme-refine-yellow
- 'modus-theme-nuanced-yellow
+ 'modus-themes-subtle-yellow
+ 'modus-themes-refine-yellow
+ 'modus-themes-nuanced-yellow
yellow
'bold))))
`(helm-locate-finish ((,class :foreground ,green-active)))
`(helm-match ((,class ,@(modus-themes--extra-completions
- 'modus-theme-subtle-cyan
- 'modus-theme-refine-cyan
- 'modus-theme-nuanced-cyan
+ 'modus-themes-subtle-cyan
+ 'modus-themes-refine-cyan
+ 'modus-themes-nuanced-cyan
cyan
'bold))))
`(helm-match-item ((,class ,@(modus-themes--extra-completions
- 'modus-theme-subtle-neutral
- 'modus-theme-subtle-cyan
- 'modus-theme-nuanced-cyan
+ 'modus-themes-subtle-neutral
+ 'modus-themes-subtle-cyan
+ 'modus-themes-nuanced-cyan
cyan-alt-other))))
`(helm-minibuffer-prompt ((,class :inherit minibuffer-prompt)))
`(helm-moccur-buffer ((,class :inherit button
,@(modus-themes--link-color
cyan-alt-other cyan-alt-other-faint))))
`(helm-mode-prefix ((,class ,@(modus-themes--extra-completions
- 'modus-theme-subtle-magenta
- 'modus-theme-intense-magenta
- 'modus-theme-nuanced-magenta
+ 'modus-themes-subtle-magenta
+ 'modus-themes-intense-magenta
+ 'modus-themes-nuanced-magenta
magenta-alt
'bold))))
`(helm-non-file-buffer ((,class :inherit shadow)))
`(helm-prefarg ((,class :foreground ,red-active)))
`(helm-resume-need-update ((,class ,@(modus-themes--extra-completions
- 'modus-theme-subtle-magenta
- 'modus-theme-refine-magenta
- 'modus-theme-nuanced-magenta
+ 'modus-themes-subtle-magenta
+ 'modus-themes-refine-magenta
+ 'modus-themes-nuanced-magenta
magenta-alt-other))))
`(helm-selection ((,class ,@(modus-themes--extra-completions
- 'modus-theme-subtle-blue
- 'modus-theme-refine-blue
- 'modus-theme-special-cold
+ 'modus-themes-subtle-blue
+ 'modus-themes-refine-blue
+ 'modus-themes-special-cold
nil
'bold))))
- `(helm-selection-line ((,class :inherit modus-theme-special-cold)))
+ `(helm-selection-line ((,class :inherit modus-themes-special-cold)))
`(helm-separator ((,class :foreground ,fg-special-mild)))
`(helm-time-zone-current ((,class :foreground ,green)))
`(helm-time-zone-home ((,class :foreground ,magenta)))
@@ -4517,7 +4663,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
,@(modus-themes--scale
modus-themes-scale-4))))
`(helm-top-columns ((,class :inherit helm-header)))
`(helm-ucs-char ((,class :foreground ,yellow-alt-other)))
- `(helm-visible-mark ((,class :inherit modus-theme-subtle-cyan)))
+ `(helm-visible-mark ((,class :inherit modus-themes-subtle-cyan)))
;;;;; helm-ls-git
`(helm-ls-git-added-copied-face ((,class :foreground ,green-intense)))
`(helm-ls-git-added-modified-face ((,class :foreground ,yellow-intense)))
@@ -4530,16 +4676,16 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(helm-ls-git-untracked-face ((,class :foreground ,fg-special-cold)))
;;;;; helm-switch-shell
`(helm-switch-shell-new-shell-face ((,class
,@(modus-themes--extra-completions
- 'modus-theme-subtle-magenta
- 'modus-theme-refine-magenta
- 'modus-theme-nuanced-magenta
+ 'modus-themes-subtle-magenta
+ 'modus-themes-refine-magenta
+
'modus-themes-nuanced-magenta
magenta-alt-other
'bold))))
;;;;; helm-xref
`(helm-xref-file-name ((,class :inherit bold :foreground
,fg-special-cold)))
`(helm-xref-file-name ((,class :foreground ,fg-special-warm)))
;;;;; helpful
- `(helpful-heading ((,class :inherit modus-theme-heading-1)))
+ `(helpful-heading ((,class :inherit modus-themes-heading-1)))
;;;;; highlight region or ad-hoc regexp
`(hi-aquamarine ((,class :background ,cyan-subtle-bg :foreground
,fg-main)))
`(hi-black-b ((,class :inherit bold :background ,fg-main :foreground
,bg-main)))
@@ -4553,10 +4699,11 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(hi-red-b ((,class :inherit bold :background ,red-intense-bg :foreground
,fg-main)))
`(hi-salmon ((,class :background ,red-subtle-bg :foreground ,fg-main)))
`(hi-yellow ((,class :background ,yellow-subtle-bg :foreground ,fg-main)))
- `(highlight ((,class :inherit modus-theme-subtle-blue)))
- `(highlight-changes ((,class :foreground ,yellow-alt-other)))
- `(highlight-changes-delete ((,class :foreground ,red-alt-other :underline
t)))
- `(hl-line ((,class :inherit modus-theme-hl-line)))
+ `(highlight ((,class :inherit modus-themes-subtle-blue)))
+ `(highlight-changes ((,class :foreground ,red-alt :underline nil)))
+ `(highlight-changes-delete ((,class :background ,red-nuanced-bg
+ :foreground ,red :underline t)))
+ `(hl-line ((,class :inherit modus-themes-hl-line)))
;;;;; highlight-blocks
`(highlight-blocks-depth-1-face ((,class :background ,bg-dim :foreground
,fg-main)))
`(highlight-blocks-depth-2-face ((,class :background ,bg-alt :foreground
,fg-main)))
@@ -4578,12 +4725,12 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(hes-escape-backslash-face ((,class :inherit bold :foreground
,fg-escape-char-construct)))
`(hes-escape-sequence-face ((,class :inherit bold :foreground
,fg-escape-char-backslash)))
;;;;; highlight-indentation
- `(highlight-indentation-face ((,class :inherit modus-theme-hl-line)))
+ `(highlight-indentation-face ((,class :inherit modus-themes-hl-line)))
`(highlight-indentation-current-column-face ((,class :background
,bg-active)))
;;;;; highlight-numbers
`(highlight-numbers-number ((,class :foreground ,blue-alt-other)))
;;;;; highlight-symbol
- `(highlight-symbol-face ((,class :inherit modus-theme-special-mild)))
+ `(highlight-symbol-face ((,class :inherit modus-themes-special-mild)))
;;;;; highlight-thing
`(highlight-thing ((,class :background ,bg-alt :foreground ,cyan)))
;;;;; hl-defined
@@ -4593,7 +4740,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
;;;;; hl-fill-column
`(hl-fill-column-face ((,class :background ,bg-active :foreground
,fg-active)))
;;;;; hl-todo
- `(hl-todo ((,class :inherit (bold modus-theme-slant) :foreground
,red-alt-other)))
+ `(hl-todo ((,class :inherit (bold modus-themes-slant) :foreground
,red-alt-other)))
;;;;; hydra
`(hydra-face-amaranth ((,class :inherit bold :foreground ,yellow)))
`(hydra-face-blue ((,class :inherit bold :foreground ,blue-alt)))
@@ -4623,7 +4770,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
magenta bg-alt
bg-active fg-main))))
`(ido-incomplete-regexp ((,class :inherit error)))
- `(ido-indicator ((,class :inherit modus-theme-subtle-yellow)))
+ `(ido-indicator ((,class :inherit modus-themes-subtle-yellow)))
`(ido-only-match ((,class :inherit bold
,@(modus-themes--standard-completions
green green-nuanced-bg
@@ -4631,8 +4778,8 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(ido-subdir ((,class :foreground ,blue)))
`(ido-virtual ((,class :foreground ,fg-special-warm)))
;;;;; iedit
- `(iedit-occurrence ((,class :inherit modus-theme-refine-blue)))
- `(iedit-read-only-occurrence ((,class :inherit
modus-theme-intense-yellow)))
+ `(iedit-occurrence ((,class :inherit modus-themes-refine-blue)))
+ `(iedit-read-only-occurrence ((,class :inherit
modus-themes-intense-yellow)))
;;;;; iflipb
`(iflipb-current-buffer-face ((,class :inherit bold :foreground
,cyan-alt)))
`(iflipb-other-buffer-face ((,class :inherit shadow)))
@@ -4648,10 +4795,10 @@ by virtue of calling either of
`modus-themes-load-operandi' and
;;;;; indium
`(indium-breakpoint-face ((,class :foreground ,red-active)))
`(indium-frame-url-face ((,class :inherit button :foreground ,fg-alt)))
- `(indium-keyword-face ((,class :foreground ,magenta-alt-other)))
- `(indium-litable-face ((,class :inherit modus-theme-slant :foreground
,fg-special-warm)))
- `(indium-repl-error-face ((,class :inherit bold :foreground ,red)))
- `(indium-repl-prompt-face ((,class :foreground ,cyan-alt-other)))
+ `(indium-keyword-face ((,class :inherit font-lock-keyword-face)))
+ `(indium-litable-face ((,class :inherit modus-themes-slant :foreground
,fg-special-warm)))
+ `(indium-repl-error-face ((,class :inherit error)))
+ `(indium-repl-prompt-face ((,class :inherit comint-highlight-prompt)))
`(indium-repl-stdout-face ((,class :foreground ,fg-main)))
;;;;; info
`(Info-quoted ((,class ,@(modus-themes--mixed-fonts) ; the capitalization
is canonical
@@ -4659,16 +4806,16 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(info-header-node ((,class :inherit bold :foreground ,fg-alt)))
`(info-header-xref ((,class :foreground ,blue-active)))
`(info-index-match ((,class :inherit match)))
- `(info-menu-header ((,class :inherit modus-theme-heading-3)))
+ `(info-menu-header ((,class :inherit modus-themes-heading-3)))
`(info-menu-star ((,class :foreground ,red)))
`(info-node ((,class :inherit bold)))
- `(info-title-1 ((,class :inherit modus-theme-heading-1)))
- `(info-title-2 ((,class :inherit modus-theme-heading-2)))
- `(info-title-3 ((,class :inherit modus-theme-heading-3)))
- `(info-title-4 ((,class :inherit modus-theme-heading-4)))
+ `(info-title-1 ((,class :inherit modus-themes-heading-1)))
+ `(info-title-2 ((,class :inherit modus-themes-heading-2)))
+ `(info-title-3 ((,class :inherit modus-themes-heading-3)))
+ `(info-title-4 ((,class :inherit modus-themes-heading-4)))
;;;;; info-colors
`(info-colors-lisp-code-block ((,class :inherit fixed-pitch)))
- `(info-colors-ref-item-command ((,class :foreground ,magenta)))
+ `(info-colors-ref-item-command ((,class :inherit
font-lock-function-name-face)))
`(info-colors-ref-item-constant ((,class :inherit
font-lock-constant-face)))
`(info-colors-ref-item-function ((,class :inherit
font-lock-function-name-face)))
`(info-colors-ref-item-macro ((,class :inherit font-lock-keyword-face)))
@@ -4688,35 +4835,35 @@ by virtue of calling either of
`modus-themes-load-operandi' and
;;;;; ioccur
`(ioccur-cursor ((,class :foreground ,fg-main)))
`(ioccur-invalid-regexp ((,class :foreground ,red)))
- `(ioccur-match-face ((,class :inherit modus-theme-special-calm)))
- `(ioccur-match-overlay-face ((,class :inherit modus-theme-special-cold
:extend t)))
+ `(ioccur-match-face ((,class :inherit modus-themes-special-calm)))
+ `(ioccur-match-overlay-face ((,class :inherit modus-themes-special-cold
:extend t)))
`(ioccur-num-line-face ((,class :foreground ,fg-special-warm)))
- `(ioccur-overlay-face ((,class :inherit modus-theme-refine-blue :extend
t)))
- `(ioccur-regexp-face ((,class :inherit (modus-theme-intense-magenta
bold))))
+ `(ioccur-overlay-face ((,class :inherit modus-themes-refine-blue :extend
t)))
+ `(ioccur-regexp-face ((,class :inherit (modus-themes-intense-magenta
bold))))
`(ioccur-title-face ((,class :inherit bold :foreground ,red-alt
,@(modus-themes--scale
modus-themes-scale-4))))
;;;;; isearch, occur, and the like
- `(isearch ((,class :inherit (modus-theme-intense-green bold))))
- `(isearch-fail ((,class :inherit modus-theme-refine-red)))
- `(isearch-group-1 ((,class :inherit modus-theme-intense-blue)))
- `(isearch-group-2 ((,class :inherit modus-theme-intense-magenta)))
- `(lazy-highlight ((,class :inherit modus-theme-refine-cyan)))
- `(match ((,class :inherit modus-theme-special-calm)))
- `(query-replace ((,class :inherit (modus-theme-intense-yellow bold))))
+ `(isearch ((,class :inherit (modus-themes-intense-green bold))))
+ `(isearch-fail ((,class :inherit modus-themes-refine-red)))
+ `(isearch-group-1 ((,class :inherit modus-themes-intense-blue)))
+ `(isearch-group-2 ((,class :inherit modus-themes-intense-magenta)))
+ `(lazy-highlight ((,class :inherit modus-themes-refine-cyan)))
+ `(match ((,class :inherit modus-themes-special-calm)))
+ `(query-replace ((,class :inherit (modus-themes-intense-yellow bold))))
;;;;; isl (isearch-light)
- `(isl-line ((,class :inherit modus-theme-subtle-green)))
- `(isl-match ((,class :inherit modus-theme-refine-cyan)))
- `(isl-number ((,class :inherit modus-theme-bold :foreground
,green-active)))
- `(isl-on ((,class :inherit (bold modus-theme-intense-green))))
- `(isl-string ((,class :inherit modus-theme-bold :foreground ,cyan-active)))
+ `(isl-line ((,class :inherit modus-themes-subtle-green)))
+ `(isl-match ((,class :inherit modus-themes-refine-cyan)))
+ `(isl-number ((,class :inherit modus-themes-bold :foreground
,green-active)))
+ `(isl-on ((,class :inherit (bold modus-themes-intense-green))))
+ `(isl-string ((,class :inherit modus-themes-bold :foreground
,cyan-active)))
;;;;; ivy
`(ivy-action ((,class :inherit bold :foreground ,red-alt)))
`(ivy-completions-annotations ((,class :inherit completions-annotations)))
`(ivy-confirm-face ((,class :foreground ,cyan)))
`(ivy-current-match ((,class ,@(modus-themes--extra-completions
- 'modus-theme-refine-cyan
- 'modus-theme-intense-cyan
- 'modus-theme-special-cold
+ 'modus-themes-refine-cyan
+ 'modus-themes-intense-cyan
+ 'modus-themes-special-cold
nil
'bold))))
`(ivy-cursor ((,class :background ,fg-main :foreground ,bg-main)))
@@ -4725,36 +4872,36 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(ivy-highlight-face ((,class :foreground ,magenta)))
`(ivy-match-required-face ((,class :inherit error)))
`(ivy-minibuffer-match-face-1 ((,class ,@(modus-themes--extra-completions
- 'modus-theme-subtle-neutral
- 'modus-theme-intense-neutral
- 'modus-theme-nuanced-cyan
+ 'modus-themes-subtle-neutral
+ 'modus-themes-intense-neutral
+ 'modus-themes-nuanced-cyan
fg-alt))))
`(ivy-minibuffer-match-face-2 ((,class ,@(modus-themes--extra-completions
- 'modus-theme-subtle-green
- 'modus-theme-refine-green
- 'modus-theme-nuanced-green
+ 'modus-themes-subtle-green
+ 'modus-themes-refine-green
+ 'modus-themes-nuanced-green
green-alt-other
'bold))))
`(ivy-minibuffer-match-face-3 ((,class ,@(modus-themes--extra-completions
- 'modus-theme-subtle-blue
- 'modus-theme-refine-blue
- 'modus-theme-nuanced-blue
+ 'modus-themes-subtle-blue
+ 'modus-themes-refine-blue
+ 'modus-themes-nuanced-blue
blue-alt-other
'bold))))
`(ivy-minibuffer-match-face-4 ((,class ,@(modus-themes--extra-completions
- 'modus-theme-subtle-magenta
- 'modus-theme-refine-magenta
- 'modus-theme-nuanced-magenta
+ 'modus-themes-subtle-magenta
+ 'modus-themes-refine-magenta
+ 'modus-themes-nuanced-magenta
magenta-alt-other
'bold))))
`(ivy-minibuffer-match-highlight ((,class
,@(modus-themes--extra-completions
- 'modus-theme-subtle-cyan
- 'modus-theme-intense-cyan
- 'modus-theme-nuanced-cyan
+ 'modus-themes-subtle-cyan
+ 'modus-themes-intense-cyan
+ 'modus-themes-nuanced-cyan
cyan-alt-other
'bold))))
- `(ivy-modified-buffer ((,class :inherit modus-theme-slant :foreground
,yellow)))
- `(ivy-modified-outside-buffer ((,class :inherit modus-theme-slant
:foreground ,yellow-alt)))
+ `(ivy-modified-buffer ((,class :inherit modus-themes-slant :foreground
,yellow)))
+ `(ivy-modified-outside-buffer ((,class :inherit modus-themes-slant
:foreground ,yellow-alt)))
`(ivy-org ((,class :foreground ,cyan-alt-other)))
`(ivy-prompt-match ((,class :inherit ivy-current-match)))
`(ivy-remote ((,class :foreground ,magenta)))
@@ -4762,9 +4909,9 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(ivy-subdir ((,class :foreground ,blue-alt-other)))
`(ivy-virtual ((,class :foreground ,magenta-alt-other)))
`(ivy-yanked-word ((,class ,@(modus-themes--extra-completions
- 'modus-theme-subtle-blue
- 'modus-theme-refine-blue
- 'modus-theme-nuanced-blue
+ 'modus-themes-subtle-blue
+ 'modus-themes-refine-blue
+ 'modus-themes-nuanced-blue
blue-alt))))
;;;;; ivy-posframe
`(ivy-posframe ((,class :background ,bg-dim :foreground ,fg-main)))
@@ -4773,55 +4920,51 @@ by virtue of calling either of
`modus-themes-load-operandi' and
;;;;; jira (org-jira)
`(jiralib-comment-face ((,class :background ,bg-alt)))
`(jiralib-comment-header-face ((,class :inherit bold)))
- `(jiralib-issue-info-face ((,class :inherit modus-theme-special-warm)))
- `(jiralib-issue-info-header-face ((,class :inherit
(modus-theme-special-warm bold))))
+ `(jiralib-issue-info-face ((,class :inherit modus-themes-special-warm)))
+ `(jiralib-issue-info-header-face ((,class :inherit
(modus-themes-special-warm bold))))
`(jiralib-issue-summary-face ((,class :inherit bold)))
`(jiralib-link-filter-face ((,class :underline t)))
`(jiralib-link-issue-face ((,class :underline t)))
`(jiralib-link-project-face ((,class :underline t)))
;;;;; journalctl-mode
- `(journalctl-error-face ((,class :inherit bold :foreground ,red)))
- `(journalctl-finished-face ((,class :inherit bold :foreground ,green)))
+ `(journalctl-error-face ((,class :inherit error)))
+ `(journalctl-finished-face ((,class :inherit success)))
`(journalctl-host-face ((,class :foreground ,blue)))
`(journalctl-process-face ((,class :foreground ,cyan-alt-other)))
`(journalctl-starting-face ((,class :foreground ,green)))
`(journalctl-timestamp-face ((,class :foreground ,fg-special-cold)))
- `(journalctl-warning-face ((,class :inherit bold :foreground ,yellow)))
+ `(journalctl-warning-face ((,class :inherit warning)))
;;;;; js2-mode
- `(js2-error ((,class :foreground ,red)))
- `(js2-external-variable ((,class :foreground ,cyan-alt-other)))
- `(js2-function-call ((,class :foreground ,magenta)))
- `(js2-function-param ((,class :foreground ,blue)))
- `(js2-instance-member ((,class :foreground ,magenta-alt-other)))
+ `(js2-error ((,class :inherit modus-themes-lang-error)))
+ `(js2-external-variable ((,class :inherit font-lock-variable-name-face)))
+ `(js2-function-call ((,class :inherit font-lock-function-name-face)))
+ `(js2-function-param ((,class :inherit font-lock-constant-face)))
+ `(js2-instance-member ((,class :inherit font-lock-keyword-face)))
`(js2-jsdoc-html-tag-delimiter ((,class :foreground ,fg-main)))
- `(js2-jsdoc-html-tag-name ((,class :foreground ,cyan)))
- `(js2-jsdoc-tag ((,class :foreground ,fg-special-calm)))
- `(js2-jsdoc-type ((,class :foreground ,fg-special-cold)))
- `(js2-jsdoc-value ((,class :foreground ,fg-special-warm)))
+ `(js2-jsdoc-html-tag-name ((,class :inherit font-lock-function-name-face)))
+ `(js2-jsdoc-tag ((,class :inherit (font-lock-builtin-face
font-lock-comment-face) :weight normal)))
+ `(js2-jsdoc-type ((,class :inherit (font-lock-type-face
font-lock-comment-face) :weight normal)))
+ `(js2-jsdoc-value ((,class :inherit (font-lock-constant-face
font-lock-comment-face) :weight normal)))
`(js2-object-property ((,class :foreground ,fg-main)))
`(js2-object-property-access ((,class :foreground ,fg-main)))
- `(js2-private-function-call ((,class :foreground ,green-alt-other)))
- `(js2-private-member ((,class :foreground ,fg-special-mild)))
- `(js2-warning ((,class :foreground ,yellow-alt :underline t)))
+ `(js2-private-function-call ((,class :inherit
font-lock-preprocessor-face)))
+ `(js2-private-member ((,class :inherit font-lock-warning-face)))
+ `(js2-warning ((,class :inherit modus-themes-lang-warning)))
;;;;; julia
- `(julia-macro-face ((,class :inherit modus-theme-bold :foreground
,magenta)))
- `(julia-quoted-symbol-face ((,class :foreground ,blue-alt-other)))
+ `(julia-macro-face ((,class :inherit font-lock-builtin-face)))
+ `(julia-quoted-symbol-face ((,class :inherit font-lock-constant-face)))
;;;;; jupyter
`(jupyter-eval-overlay ((,class :inherit bold :foreground ,blue)))
`(jupyter-repl-input-prompt ((,class :foreground ,cyan-alt-other)))
`(jupyter-repl-output-prompt ((,class :foreground ,magenta-alt-other)))
- `(jupyter-repl-traceback ((,class :inherit modus-theme-intense-red)))
+ `(jupyter-repl-traceback ((,class :inherit modus-themes-intense-red)))
;;;;; kaocha-runner
`(kaocha-runner-error-face ((,class :foreground ,red)))
`(kaocha-runner-success-face ((,class :foreground ,green)))
`(kaocha-runner-warning-face ((,class :foreground ,yellow)))
;;;;; keycast
`(keycast-command ((,class :inherit bold :foreground ,blue-active)))
- `(keycast-key ((,class ,@(modus-themes--mode-line-attrs
- bg-main blue-active
- bg-main blue-active
- blue-active blue-intense
- 'alt-style -3))))
+ `(keycast-key ((,class :background ,blue-active :foreground ,bg-main)))
;;;;; line numbers (display-line-numbers-mode and global variant)
`(line-number
((,class :inherit default
@@ -4844,27 +4987,24 @@ by virtue of calling either of
`modus-themes-load-operandi' and
fg-alt bg-inactive
fg-inactive))))
;;;;; lsp-mode
- `(lsp-face-highlight-read ((,class :inherit modus-theme-subtle-blue
:underline t)))
- `(lsp-face-highlight-textual ((,class :inherit modus-theme-subtle-blue)))
- `(lsp-face-highlight-write ((,class :inherit (modus-theme-refine-blue
bold))))
+ `(lsp-face-highlight-read ((,class :inherit modus-themes-subtle-blue
:underline t)))
+ `(lsp-face-highlight-textual ((,class :inherit modus-themes-subtle-blue)))
+ `(lsp-face-highlight-write ((,class :inherit (modus-themes-refine-blue
bold))))
`(lsp-face-semhl-constant ((,class :foreground ,blue-alt-other)))
- `(lsp-face-semhl-deprecated
- ((,(append '((supports :underline (:style wave))) class)
- :foreground ,yellow :underline (:style wave))
- (,class :foreground ,yellow :underline t)))
+ `(lsp-face-semhl-deprecated ((,class :inherit modus-themes-lang-warning)))
`(lsp-face-semhl-enummember ((,class :foreground ,blue-alt-other)))
`(lsp-face-semhl-field ((,class :foreground ,cyan-alt)))
- `(lsp-face-semhl-field-static ((,class :inherit modus-theme-slant
:foreground ,cyan-alt)))
+ `(lsp-face-semhl-field-static ((,class :inherit modus-themes-slant
:foreground ,cyan-alt)))
`(lsp-face-semhl-function ((,class :foreground ,magenta)))
`(lsp-face-semhl-method ((,class :foreground ,magenta)))
- `(lsp-face-semhl-namespace ((,class :inherit modus-theme-bold :foreground
,magenta-alt)))
+ `(lsp-face-semhl-namespace ((,class :inherit modus-themes-bold :foreground
,magenta-alt)))
`(lsp-face-semhl-preprocessor ((,class :foreground ,red-alt-other)))
- `(lsp-face-semhl-static-method ((,class :inherit modus-theme-slant
:foreground ,magenta)))
+ `(lsp-face-semhl-static-method ((,class :inherit modus-themes-slant
:foreground ,magenta)))
`(lsp-face-semhl-type-class ((,class :foreground ,magenta-alt)))
`(lsp-face-semhl-type-enum ((,class :foreground ,magenta-alt)))
- `(lsp-face-semhl-type-primitive ((,class :inherit modus-theme-slant
:foreground ,magenta-alt)))
- `(lsp-face-semhl-type-template ((,class :inherit modus-theme-slant
:foreground ,magenta-alt)))
- `(lsp-face-semhl-type-typedef ((,class :inherit modus-theme-slant
:foreground ,magenta-alt)))
+ `(lsp-face-semhl-type-primitive ((,class :inherit modus-themes-slant
:foreground ,magenta-alt)))
+ `(lsp-face-semhl-type-template ((,class :inherit modus-themes-slant
:foreground ,magenta-alt)))
+ `(lsp-face-semhl-type-typedef ((,class :inherit modus-themes-slant
:foreground ,magenta-alt)))
`(lsp-face-semhl-variable ((,class :foreground ,cyan)))
`(lsp-face-semhl-variable-local ((,class :foreground ,cyan)))
`(lsp-face-semhl-variable-parameter ((,class :foreground ,cyan-alt-other)))
@@ -4876,11 +5016,11 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(lsp-ui-peek-filename ((,class :foreground ,fg-special-warm)))
`(lsp-ui-peek-footer ((,class :background ,bg-header :foreground
,fg-header)))
`(lsp-ui-peek-header ((,class :background ,bg-header :foreground
,fg-header)))
- `(lsp-ui-peek-highlight ((,class :inherit modus-theme-subtle-blue)))
+ `(lsp-ui-peek-highlight ((,class :inherit modus-themes-subtle-blue)))
`(lsp-ui-peek-line-number ((,class :inherit shadow)))
`(lsp-ui-peek-list ((,class :background ,bg-dim)))
`(lsp-ui-peek-peek ((,class :background ,bg-alt)))
- `(lsp-ui-peek-selection ((,class :inherit modus-theme-subtle-cyan)))
+ `(lsp-ui-peek-selection ((,class :inherit modus-themes-subtle-cyan)))
`(lsp-ui-sideline-code-action ((,class :foreground ,yellow)))
`(lsp-ui-sideline-current-symbol ((,class :inherit bold :height 0.99 :box
(:line-width -1 :style nil) :foreground ,fg-main)))
`(lsp-ui-sideline-symbol ((,class :inherit bold :height 0.99 :box
(:line-width -1 :style nil) :foreground ,fg-alt)))
@@ -4899,11 +5039,11 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(magit-bisect-good ((,class :foreground ,green-alt-other)))
`(magit-bisect-skip ((,class :foreground ,yellow-alt-other)))
`(magit-blame-date ((,class :foreground ,blue)))
- `(magit-blame-dimmed ((,class :inherit shadow)))
+ `(magit-blame-dimmed ((,class :inherit (shadow modus-themes-reset-hard))))
`(magit-blame-hash ((,class :foreground ,fg-special-warm)))
- `(magit-blame-heading ((,class :background ,bg-alt)))
- `(magit-blame-highlight ((,class :inherit modus-theme-nuanced-cyan)))
- `(magit-blame-margin ((,class :inherit magit-blame-highlight)))
+ `(magit-blame-heading ((,class :inherit modus-themes-reset-hard
:background ,bg-alt :extend t)))
+ `(magit-blame-highlight ((,class :inherit modus-themes-nuanced-cyan)))
+ `(magit-blame-margin ((,class :inherit (magit-blame-highlight
modus-themes-reset-hard))))
`(magit-blame-name ((,class :foreground ,magenta-alt-other)))
`(magit-blame-summary ((,class :foreground ,cyan-alt-other)))
`(magit-branch-current ((,class :foreground ,blue-alt-other :box t)))
@@ -4914,7 +5054,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(magit-cherry-equivalent ((,class :background ,bg-main :foreground
,magenta-intense)))
`(magit-cherry-unmatched ((,class :background ,bg-main :foreground
,cyan-intense)))
;; NOTE: here we break from the pattern of inheriting from the
- ;; modus-theme-diff-* faces, though only for the standard actions,
+ ;; modus-themes-diff-* faces, though only for the standard actions,
;; not the highlighted ones. This is because Magit's interaction
;; model relies on highlighting the current diff hunk.
`(magit-diff-added ((,class ,@(modus-themes--diff
@@ -4922,37 +5062,37 @@ by virtue of calling either of
`modus-themes-load-operandi' and
bg-diff-added fg-diff-added
green-nuanced-bg fg-diff-added
bg-diff-added-deuteran
fg-diff-added-deuteran))))
- `(magit-diff-added-highlight ((,class :inherit
modus-theme-diff-focus-added)))
+ `(magit-diff-added-highlight ((,class :inherit
modus-themes-diff-focus-added)))
`(magit-diff-base ((,class ,@(modus-themes--diff
bg-main yellow
bg-diff-changed fg-diff-changed
yellow-nuanced-bg fg-diff-changed))))
- `(magit-diff-base-highlight ((,class :inherit
modus-theme-diff-focus-changed)))
+ `(magit-diff-base-highlight ((,class :inherit
modus-themes-diff-focus-changed)))
`(magit-diff-context ((,class :foreground ,fg-unfocused)))
`(magit-diff-context-highlight ((,class ,@(modus-themes--diff
bg-dim fg-dim
bg-inactive fg-inactive
bg-dim fg-alt))))
`(magit-diff-file-heading ((,class :inherit bold :foreground
,fg-special-cold)))
- `(magit-diff-file-heading-highlight ((,class :inherit
(modus-theme-special-cold bold))))
- `(magit-diff-file-heading-selection ((,class :inherit
modus-theme-refine-cyan)))
+ `(magit-diff-file-heading-highlight ((,class :inherit
(modus-themes-special-cold bold))))
+ `(magit-diff-file-heading-selection ((,class :inherit
modus-themes-refine-cyan)))
;; NOTE: here we break from the pattern of inheriting from the
- ;; modus-theme-diff-* faces.
+ ;; modus-themes-diff-* faces.
`(magit-diff-hunk-heading ((,class :inherit bold :background ,bg-active
:foreground ,fg-inactive)))
`(magit-diff-hunk-heading-highlight
((,class :inherit bold
:background ,@(modus-themes--diff-deuteran bg-region
bg-diff-heading)
:foreground ,@(modus-themes--diff-deuteran fg-main
fg-diff-heading))))
- `(magit-diff-hunk-heading-selection ((,class :inherit
modus-theme-refine-blue)))
+ `(magit-diff-hunk-heading-selection ((,class :inherit
modus-themes-refine-blue)))
`(magit-diff-hunk-region ((,class :inherit bold)))
`(magit-diff-lines-boundary ((,class :background ,fg-main)))
- `(magit-diff-lines-heading ((,class :inherit modus-theme-refine-magenta)))
+ `(magit-diff-lines-heading ((,class :inherit modus-themes-refine-magenta)))
`(magit-diff-removed ((,class ,@(modus-themes--diff
bg-main red
bg-diff-removed fg-diff-removed
red-nuanced-bg fg-diff-removed))))
- `(magit-diff-removed-highlight ((,class :inherit
modus-theme-diff-focus-removed)))
+ `(magit-diff-removed-highlight ((,class :inherit
modus-themes-diff-focus-removed)))
`(magit-diffstat-added ((,class :foreground ,@(modus-themes--diff-deuteran
blue green))))
`(magit-diffstat-removed ((,class :foreground ,red)))
`(magit-dimmed ((,class :foreground ,fg-unfocused)))
@@ -4960,7 +5100,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(magit-hash ((,class :inherit shadow)))
`(magit-head ((,class :inherit magit-branch-local)))
`(magit-header-line ((,class :inherit bold :foreground ,magenta-active)))
- `(magit-header-line-key ((,class :inherit bold :foreground ,blue-active)))
+ `(magit-header-line-key ((,class :inherit modus-themes-key-binding)))
`(magit-header-line-log-select ((,class :inherit bold :foreground
,fg-main)))
`(magit-keyword ((,class :foreground ,magenta)))
`(magit-keyword-squash ((,class :inherit bold :foreground
,yellow-alt-other)))
@@ -4986,7 +5126,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(magit-refname-wip ((,class :inherit shadow)))
`(magit-section ((,class :background ,bg-dim :foreground ,fg-main)))
`(magit-section-heading ((,class :inherit bold :foreground ,cyan)))
- `(magit-section-heading-selection ((,class :inherit
(modus-theme-refine-cyan bold))))
+ `(magit-section-heading-selection ((,class :inherit
(modus-themes-refine-cyan bold))))
`(magit-section-highlight ((,class :background ,bg-alt)))
`(magit-sequence-done ((,class :foreground ,green-alt)))
`(magit-sequence-drop ((,class :foreground ,red-alt)))
@@ -5011,16 +5151,22 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(makefile-space ((,class :background ,magenta-nuanced-bg)))
;;;;; man
`(Man-overstrike ((,class :inherit bold :foreground ,magenta)))
- `(Man-reverse ((,class :inherit modus-theme-subtle-magenta)))
+ `(Man-reverse ((,class :inherit modus-themes-subtle-magenta)))
`(Man-underline ((,class :foreground ,cyan :underline t)))
;;;;; marginalia
`(marginalia-archive ((,class :foreground ,green-nuanced-fg)))
`(marginalia-date ((,class :foreground ,blue-nuanced-fg)))
`(marginalia-char ((,class :foreground ,red-active)))
- `(marginalia-documentation ((,class :foreground ,fg-special-cold :inherit
modus-theme-slant)))
+ `(marginalia-documentation ((,class :foreground ,fg-special-cold :inherit
modus-themes-slant)))
`(marginalia-file-modes ((,class :inherit shadow)))
`(marginalia-file-name ((,class :foreground ,fg-special-mild)))
`(marginalia-file-owner ((,class :foreground ,red-nuanced-fg)))
+ ;; Here we make an exception of not applying the bespoke
+ ;; `modus-themes-key-binding' for two reasons: (1) completion
+ ;; highlights can be fairly intense, so we do not want more
+ ;; components to compete with them for attention, (2) the
+ ;; `marginalia-key' may not be used for key bindings specifically,
+ ;; so we might end up applying styles in places we should not.
`(marginalia-key ((,class :foreground ,magenta-active)))
`(marginalia-mode ((,class :foreground ,cyan-active)))
`(marginalia-modified ((,class :foreground ,yellow-active)))
@@ -5030,21 +5176,21 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(marginalia-variable ((,class :foreground ,yellow-nuanced-fg)))
`(marginalia-version ((,class :foreground ,cyan-active)))
;;;;; markdown-mode
- `(markdown-blockquote-face ((,class :inherit modus-theme-slant :foreground
,fg-special-cold)))
+ `(markdown-blockquote-face ((,class :inherit modus-themes-slant
:foreground ,fg-special-cold)))
`(markdown-bold-face ((,class :inherit bold)))
`(markdown-code-face ((,class ,@(modus-themes--mixed-fonts) :background
,bg-dim :extend t)))
`(markdown-comment-face ((,class :inherit font-lock-comment-face)))
`(markdown-footnote-marker-face ((,class :inherit bold :foreground
,cyan-alt)))
- `(markdown-footnote-text-face ((,class :inherit modus-theme-slant
:foreground ,fg-main)))
+ `(markdown-footnote-text-face ((,class :inherit modus-themes-slant
:foreground ,fg-main)))
`(markdown-gfm-checkbox-face ((,class :foreground ,cyan-alt-other)))
- `(markdown-header-delimiter-face ((,class :inherit modus-theme-bold
:foreground ,fg-dim)))
+ `(markdown-header-delimiter-face ((,class :inherit modus-themes-bold
:foreground ,fg-dim)))
`(markdown-header-face ((t nil)))
- `(markdown-header-face-1 ((,class :inherit modus-theme-heading-1)))
- `(markdown-header-face-2 ((,class :inherit modus-theme-heading-2)))
- `(markdown-header-face-3 ((,class :inherit modus-theme-heading-3)))
- `(markdown-header-face-4 ((,class :inherit modus-theme-heading-4)))
- `(markdown-header-face-5 ((,class :inherit modus-theme-heading-5)))
- `(markdown-header-face-6 ((,class :inherit modus-theme-heading-6)))
+ `(markdown-header-face-1 ((,class :inherit modus-themes-heading-1)))
+ `(markdown-header-face-2 ((,class :inherit modus-themes-heading-2)))
+ `(markdown-header-face-3 ((,class :inherit modus-themes-heading-3)))
+ `(markdown-header-face-4 ((,class :inherit modus-themes-heading-4)))
+ `(markdown-header-face-5 ((,class :inherit modus-themes-heading-5)))
+ `(markdown-header-face-6 ((,class :inherit modus-themes-heading-6)))
`(markdown-header-rule-face ((,class :inherit bold :foreground
,fg-special-warm)))
`(markdown-hr-face ((,class :inherit bold :foreground ,fg-special-warm)))
`(markdown-html-attr-name-face ((,class ,@(modus-themes--mixed-fonts)
@@ -5065,9 +5211,9 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(markdown-language-keyword-face ((,class ,@(modus-themes--mixed-fonts)
:background ,bg-alt
:foreground ,fg-alt)))
- `(markdown-line-break-face ((,class :inherit modus-theme-refine-cyan
:underline t)))
+ `(markdown-line-break-face ((,class :inherit modus-themes-refine-cyan
:underline t)))
`(markdown-link-face ((,class :inherit button)))
- `(markdown-link-title-face ((,class :inherit modus-theme-slant :foreground
,fg-special-cold)))
+ `(markdown-link-title-face ((,class :inherit modus-themes-slant
:foreground ,fg-special-cold)))
`(markdown-list-face ((,class :foreground ,fg-dim)))
`(markdown-markup-face ((,class :inherit shadow)))
`(markdown-math-face ((,class :foreground ,magenta-alt-other)))
@@ -5090,13 +5236,13 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(markup-command-face ((,class :foreground ,fg-inactive)))
`(markup-comment-face ((,class :inherit font-lock-comment-face)))
`(markup-complex-replacement-face ((,class :box (:line-width 2 :color nil
:style released-button)
- :inherit
modus-theme-refine-magenta)))
+ :inherit
modus-themes-refine-magenta)))
`(markup-emphasis-face ((,class :inherit italic :foreground
,fg-special-cold)))
`(markup-error-face ((,class :inherit bold :foreground ,red)))
`(markup-gen-face ((,class :foreground ,magenta-alt)))
`(markup-internal-reference-face ((,class :inherit button :foreground
,fg-alt)))
`(markup-italic-face ((,class :inherit italic :foreground
,fg-special-cold)))
- `(markup-list-face ((,class :inherit modus-theme-special-calm)))
+ `(markup-list-face ((,class :inherit modus-themes-special-calm)))
`(markup-meta-face ((,class :foreground ,fg-inactive)))
`(markup-meta-hide-face ((,class :inherit shadow)))
`(markup-passthrough-face ((,class :inherit fixed-pitch :foreground
,cyan)))
@@ -5107,9 +5253,9 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(markup-strong-face ((,class :inherit bold :foreground ,red-nuanced-fg)))
`(markup-subscript-face ((,class :height 0.8 :foreground
,fg-special-cold)))
`(markup-superscript-face ((,class :height 0.8 :foreground
,fg-special-cold)))
- `(markup-table-cell-face ((,class :inherit modus-theme-special-cold)))
- `(markup-table-face ((,class :inherit modus-theme-subtle-cyan)))
- `(markup-table-row-face ((,class :inherit modus-theme-subtle-cyan)))
+ `(markup-table-cell-face ((,class :inherit modus-themes-special-cold)))
+ `(markup-table-face ((,class :inherit modus-themes-subtle-cyan)))
+ `(markup-table-row-face ((,class :inherit modus-themes-subtle-cyan)))
`(markup-title-0-face ((,class :height 3.0 :foreground ,blue-nuanced-fg)))
`(markup-title-1-face ((,class :height 2.4 :foreground ,blue-nuanced-fg)))
`(markup-title-2-face ((,class :height 1.8 :foreground ,blue-nuanced-fg)))
@@ -5117,7 +5263,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(markup-title-4-face ((,class :height 1.2 :foreground ,blue-nuanced-fg)))
`(markup-title-5-face ((,class :height 1.2 :foreground ,blue-nuanced-fg
:underline t)))
`(markup-value-face ((,class :foreground ,fg-inactive)))
- `(markup-verbatim-face ((,class :inherit modus-theme-special-mild)))
+ `(markup-verbatim-face ((,class :inherit modus-themes-special-mild)))
;;;;; mentor
`(mentor-download-message ((,class :foreground ,fg-special-warm)))
`(mentor-download-name ((,class :foreground ,fg-special-cold)))
@@ -5126,7 +5272,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(mentor-download-speed-down ((,class :foreground ,cyan-alt)))
`(mentor-download-speed-up ((,class :foreground ,red-alt)))
`(mentor-download-state ((,class :foreground ,yellow-alt)))
- `(mentor-highlight-face ((,class :inherit modus-theme-subtle-blue)))
+ `(mentor-highlight-face ((,class :inherit modus-themes-subtle-blue)))
`(mentor-tracker-name ((,class :foreground ,magenta-alt)))
;;;;; messages
`(message-cited-text-1 ((,class :foreground ,blue-faint)))
@@ -5141,7 +5287,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(message-header-to ((,class :inherit bold :foreground
,magenta-alt-other)))
`(message-header-xheader ((,class :foreground ,blue-alt)))
`(message-mml ((,class :foreground ,yellow)))
- `(message-separator ((,class :inherit modus-theme-intense-neutral)))
+ `(message-separator ((,class :inherit modus-themes-intense-neutral)))
;;;;; minibuffer-line
`(minibuffer-line ((,class :foreground ,fg-main)))
;;;;; minimap
@@ -5159,14 +5305,19 @@ by virtue of calling either of
`modus-themes-load-operandi' and
;;;;; modeline
`(mode-line ((,class ,@(modus-themes--variable-pitch-ui)
,@(modus-themes--mode-line-attrs
- fg-active bg-active fg-dim bg-active
- fg-alt bg-active 'alt-style nil bg-main))))
+ fg-active bg-active
+ fg-dim bg-active
+ fg-main bg-active-accent
+ fg-alt bg-active
+ 'alt-style nil bg-main))))
`(mode-line-buffer-id ((,class :inherit bold)))
`(mode-line-emphasis ((,class :inherit bold :foreground ,blue-active)))
- `(mode-line-highlight ((,class :inherit modus-theme-active-blue :box
(:line-width -1 :style pressed-button))))
+ `(mode-line-highlight ((,class :inherit modus-themes-active-blue :box
(:line-width -1 :style pressed-button))))
`(mode-line-inactive ((,class ,@(modus-themes--variable-pitch-ui)
,@(modus-themes--mode-line-attrs
- fg-inactive bg-inactive fg-alt bg-dim
+ fg-inactive bg-inactive
+ fg-alt bg-dim
+ fg-inactive bg-inactive
bg-region bg-active))))
;;;;; mood-line
`(mood-line-modified ((,class :foreground ,magenta-active)))
@@ -5189,28 +5340,28 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(mu4e-cited-6-face ((,class :foreground ,magenta)))
`(mu4e-cited-7-face ((,class :foreground ,green-alt)))
`(mu4e-compose-header-face ((,class :inherit mu4e-compose-separator-face)))
- `(mu4e-compose-separator-face ((,class :inherit
modus-theme-intense-neutral)))
+ `(mu4e-compose-separator-face ((,class :inherit
modus-themes-intense-neutral)))
`(mu4e-contact-face ((,class :inherit message-header-to)))
`(mu4e-context-face ((,class :foreground ,blue-active)))
`(mu4e-draft-face ((,class :foreground ,magenta-alt)))
`(mu4e-flagged-face ((,class :foreground ,red-alt)))
- `(mu4e-footer-face ((,class :inherit modus-theme-slant :foreground
,fg-special-cold)))
+ `(mu4e-footer-face ((,class :inherit modus-themes-slant :foreground
,fg-special-cold)))
`(mu4e-forwarded-face ((,class :foreground ,magenta-alt-other)))
`(mu4e-header-face ((,class :inherit shadow)))
- `(mu4e-header-highlight-face ((,class :inherit modus-theme-hl-line)))
+ `(mu4e-header-highlight-face ((,class :inherit modus-themes-hl-line)))
`(mu4e-header-key-face ((,class :inherit message-header-name)))
`(mu4e-header-marks-face ((,class :inherit
mu4e-special-header-value-face)))
`(mu4e-header-title-face ((,class :foreground ,fg-special-mild)))
`(mu4e-header-value-face ((,class :inherit message-header-other)))
- `(mu4e-highlight-face ((,class :inherit bold :foreground ,blue-alt-other)))
+ `(mu4e-highlight-face ((,class :inherit modus-themes-key-binding)))
`(mu4e-link-face ((,class :inherit button)))
`(mu4e-modeline-face ((,class :foreground ,magenta-active)))
- `(mu4e-moved-face ((,class :inherit modus-theme-slant :foreground
,yellow)))
+ `(mu4e-moved-face ((,class :inherit modus-themes-slant :foreground
,yellow)))
`(mu4e-ok-face ((,class :inherit bold :foreground ,green)))
- `(mu4e-region-code ((,class :inherit modus-theme-special-calm)))
+ `(mu4e-region-code ((,class :inherit modus-themes-special-calm)))
`(mu4e-replied-face ((,class :foreground ,blue)))
`(mu4e-special-header-value-face ((,class :inherit
message-header-subject)))
- `(mu4e-system-face ((,class :inherit modus-theme-slant :foreground
,fg-mark-del)))
+ `(mu4e-system-face ((,class :inherit modus-themes-slant :foreground
,fg-mark-del)))
`(mu4e-title-face ((,class :foreground ,fg-main)))
`(mu4e-trashed-face ((,class :foreground ,red)))
`(mu4e-unread-face ((,class :inherit bold)))
@@ -5218,7 +5369,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(mu4e-view-body-face ((,class :foreground ,fg-main)))
`(mu4e-warning-face ((,class :inherit warning)))
;;;;; mu4e-conversation
- `(mu4e-conversation-header ((,class :inherit modus-theme-special-cold)))
+ `(mu4e-conversation-header ((,class :inherit modus-themes-special-cold)))
`(mu4e-conversation-sender-1 ((,class :foreground ,fg-special-warm)))
`(mu4e-conversation-sender-2 ((,class :foreground ,fg-special-cold)))
`(mu4e-conversation-sender-3 ((,class :foreground ,fg-special-mild)))
@@ -5250,20 +5401,20 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(neo-vc-needs-merge-face ((,class :foreground ,magenta-alt)))
`(neo-vc-needs-update-face ((,class :underline t)))
`(neo-vc-removed-face ((,class :strike-through t)))
- `(neo-vc-unlocked-changes-face ((,class :inherit modus-theme-refine-blue)))
+ `(neo-vc-unlocked-changes-face ((,class :inherit
modus-themes-refine-blue)))
`(neo-vc-up-to-date-face ((,class :inherit shadow)))
`(neo-vc-user-face ((,class :foreground ,magenta)))
;;;;; no-emoji
`(no-emoji ((,class :foreground ,cyan)))
;;;;; notmuch
- `(notmuch-crypto-decryption ((,class :inherit modus-theme-refine-magenta)))
+ `(notmuch-crypto-decryption ((,class :inherit modus-themes-special-mild)))
`(notmuch-crypto-part-header ((,class :foreground ,magenta-alt-other)))
- `(notmuch-crypto-signature-bad ((,class :inherit modus-theme-intense-red)))
- `(notmuch-crypto-signature-good ((,class :inherit
modus-theme-refine-green)))
- `(notmuch-crypto-signature-good-key ((,class :inherit
modus-theme-refine-yellow)))
- `(notmuch-crypto-signature-unknown ((,class :inherit
modus-theme-refine-red)))
+ `(notmuch-crypto-signature-bad ((,class :inherit
modus-themes-intense-red)))
+ `(notmuch-crypto-signature-good ((,class :inherit
modus-themes-refine-blue)))
+ `(notmuch-crypto-signature-good-key ((,class :inherit
modus-themes-refine-cyan)))
+ `(notmuch-crypto-signature-unknown ((,class :inherit
modus-themes-refine-red)))
`(notmuch-hello-logo-background ((,class :background "gray50")))
- `(notmuch-message-summary-face ((,class :inherit
modus-theme-nuanced-cyan)))
+ `(notmuch-message-summary-face ((,class :inherit
modus-themes-nuanced-cyan)))
`(notmuch-search-count ((,class :inherit shadow)))
`(notmuch-search-date ((,class :foreground ,cyan)))
`(notmuch-search-flagged-face ((,class :foreground ,red-alt)))
@@ -5271,14 +5422,8 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(notmuch-search-non-matching-authors ((,class :inherit shadow)))
`(notmuch-search-subject ((,class :foreground ,fg-dim)))
`(notmuch-search-unread-face ((,class :inherit bold)))
- `(notmuch-tag-added
- ((,(append '((supports :underline (:style wave))) class)
- :underline (:color ,green :style wave))
- (,class :foreground ,green :underline t)))
- `(notmuch-tag-deleted
- ((,(append '((supports :underline (:style wave))) class)
- :underline (:color ,red :style wave))
- (,class :foreground ,red :underline t)))
+ `(notmuch-tag-added ((,class :inherit modus-themes-lang-note)))
+ `(notmuch-tag-deleted ((,class :inherit modus-themes-lang-error)))
`(notmuch-tag-face ((,class :inherit bold :foreground ,blue-alt)))
`(notmuch-tag-flagged ((,class :foreground ,red-alt)))
`(notmuch-tag-unread ((,class :foreground ,magenta-alt)))
@@ -5300,15 +5445,15 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(nxml-cdata-section-CDATA ((,class :inherit error)))
`(nxml-cdata-section-delimiter ((,class :inherit error)))
`(nxml-char-ref-delimiter ((,class :foreground ,fg-special-mild)))
- `(nxml-char-ref-number ((,class :inherit modus-theme-bold :foreground
,fg-special-mild)))
- `(nxml-delimited-data ((,class :inherit modus-theme-slant :foreground
,fg-special-cold)))
+ `(nxml-char-ref-number ((,class :inherit modus-themes-bold :foreground
,fg-special-mild)))
+ `(nxml-delimited-data ((,class :inherit modus-themes-slant :foreground
,fg-special-cold)))
`(nxml-delimiter ((,class :foreground ,fg-dim)))
`(nxml-element-colon ((,class :foreground ,fg-main)))
`(nxml-element-local-name ((,class :inherit font-lock-function-name-face)))
`(nxml-element-prefix ((,class :inherit font-lock-builtin-face)))
`(nxml-entity-ref-delimiter ((,class :foreground ,fg-special-mild)))
- `(nxml-entity-ref-name ((,class :inherit modus-theme-bold :foreground
,fg-special-mild)))
- `(nxml-glyph ((,class :inherit modus-theme-intense-neutral)))
+ `(nxml-entity-ref-name ((,class :inherit modus-themes-bold :foreground
,fg-special-mild)))
+ `(nxml-glyph ((,class :inherit modus-themes-intense-neutral)))
`(nxml-hash ((,class :inherit (bold font-lock-string-face))))
`(nxml-heading ((,class :inherit bold)))
`(nxml-name ((,class :inherit font-lock-builtin-face)))
@@ -5316,11 +5461,10 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(nxml-namespace-attribute-prefix ((,class :inherit
font-lock-variable-name-face)))
`(nxml-processing-instruction-target ((,class :inherit
font-lock-keyword-face)))
`(nxml-prolog-keyword ((,class :inherit font-lock-keyword-face)))
- `(nxml-ref ((,class :inherit modus-theme-bold :foreground
,fg-special-mild)))
+ `(nxml-ref ((,class :inherit modus-themes-bold :foreground
,fg-special-mild)))
`(rng-error ((,class :inherit error)))
;;;;; objed
- `(objed-hl ((,class :background ,(if modus-themes-intense-hl-line
- bg-hl-alt-intense bg-hl-alt))))
+ `(objed-hl ((,class :background ,(if modus-themes-hl-line
bg-hl-alt-intense bg-hl-alt))))
`(objed-mark ((,class :background ,bg-active)))
`(objed-mode-line ((,class :foreground ,cyan-active)))
;;;;; orderless
@@ -5343,7 +5487,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
;;;;; org
`(org-agenda-calendar-event ((,class :foreground ,fg-main)))
`(org-agenda-calendar-sexp ((,class :foreground ,cyan-alt)))
- `(org-agenda-clocking ((,class :inherit modus-theme-special-cold :extend
t)))
+ `(org-agenda-clocking ((,class :inherit modus-themes-special-cold :extend
t)))
`(org-agenda-column-dateline ((,class :background ,bg-alt)))
`(org-agenda-current-time ((,class :inherit bold :foreground
,blue-alt-other)))
`(org-agenda-date ((,class :foreground ,cyan)))
@@ -5372,9 +5516,9 @@ by virtue of calling either of
`modus-themes-load-operandi' and
:background ,bg-inactive :foreground ,fg-active)))
`(org-checkbox-statistics-done ((,class :inherit org-done)))
`(org-checkbox-statistics-todo ((,class :inherit org-todo)))
- `(org-clock-overlay ((,class :inherit modus-theme-special-cold)))
+ `(org-clock-overlay ((,class :inherit modus-themes-special-cold)))
`(org-code ((,class ,@(modus-themes--mixed-fonts)
- :background ,red-nuanced-bg :foreground ,magenta)))
+ :background ,magenta-nuanced-bg :foreground
,magenta-nuanced-fg)))
`(org-column ((,class :background ,bg-alt)))
`(org-column-title ((,class :inherit bold :underline t :background
,bg-alt)))
`(org-date ((,class :inherit ,(if modus-themes-no-mixed-fonts
@@ -5383,11 +5527,11 @@ by virtue of calling either of
`modus-themes-load-operandi' and
,@(modus-themes--link-color
cyan cyan-faint))))
`(org-date-selected ((,class :inherit bold :foreground ,blue-alt
:inverse-video t)))
- `(org-dispatcher-highlight ((,class :inherit (bold modus-theme-mark-alt))))
+ `(org-dispatcher-highlight ((,class :inherit (bold
modus-themes-mark-alt))))
`(org-document-info ((,class :foreground ,fg-special-cold)))
`(org-document-info-keyword ((,class ,@(modus-themes--mixed-fonts)
:foreground ,fg-alt)))
- `(org-document-title ((,class :inherit (bold modus-theme-variable-pitch)
:foreground ,fg-special-cold
+ `(org-document-title ((,class :inherit (bold modus-themes-variable-pitch)
:foreground ,fg-special-cold
,@(modus-themes--scale
modus-themes-scale-5))))
`(org-done ((,class :foreground ,green)))
`(org-drawer ((,class ,@(modus-themes--mixed-fonts)
@@ -5430,32 +5574,30 @@ by virtue of calling either of
`modus-themes-load-operandi' and
green-graph-1-bg
green-graph-0-bg
green-graph-1-bg))))
- `(org-headline-done ((,class :inherit modus-theme-variable-pitch
:foreground ,green-nuanced-fg)))
- `(org-headline-todo ((,class :inherit modus-theme-variable-pitch
:foreground ,red-nuanced-fg)))
+ `(org-headline-done ((,class :inherit modus-themes-variable-pitch
:foreground ,green-nuanced-fg)))
+ `(org-headline-todo ((,class :inherit modus-themes-variable-pitch
:foreground ,red-nuanced-fg)))
`(org-hide ((,class :foreground ,bg-main)))
`(org-indent ((,class :inherit (fixed-pitch org-hide))))
`(org-latex-and-related ((,class :foreground ,magenta-refine-fg)))
- `(org-level-1 ((,class :inherit modus-theme-heading-1)))
- `(org-level-2 ((,class :inherit modus-theme-heading-2)))
- `(org-level-3 ((,class :inherit modus-theme-heading-3)))
- `(org-level-4 ((,class :inherit modus-theme-heading-4)))
- `(org-level-5 ((,class :inherit modus-theme-heading-5)))
- `(org-level-6 ((,class :inherit modus-theme-heading-6)))
- `(org-level-7 ((,class :inherit modus-theme-heading-7)))
- `(org-level-8 ((,class :inherit modus-theme-heading-8)))
+ `(org-level-1 ((,class :inherit modus-themes-heading-1)))
+ `(org-level-2 ((,class :inherit modus-themes-heading-2)))
+ `(org-level-3 ((,class :inherit modus-themes-heading-3)))
+ `(org-level-4 ((,class :inherit modus-themes-heading-4)))
+ `(org-level-5 ((,class :inherit modus-themes-heading-5)))
+ `(org-level-6 ((,class :inherit modus-themes-heading-6)))
+ `(org-level-7 ((,class :inherit modus-themes-heading-7)))
+ `(org-level-8 ((,class :inherit modus-themes-heading-8)))
`(org-link ((,class :inherit button)))
`(org-list-dt ((,class :inherit bold)))
`(org-macro ((,class ,@(modus-themes--mixed-fonts)
- :background ,blue-nuanced-bg :foreground
,magenta-alt-other)))
+ :background ,cyan-nuanced-bg :foreground
,cyan-nuanced-fg)))
`(org-meta-line ((,class ,@(modus-themes--mixed-fonts) :foreground
,fg-alt)))
`(org-mode-line-clock ((,class :foreground ,fg-main)))
- `(org-mode-line-clock-overrun ((,class :inherit modus-theme-active-red)))
+ `(org-mode-line-clock-overrun ((,class :inherit modus-themes-active-red)))
`(org-priority ((,class :foreground ,magenta)))
`(org-property-value ((,class ,@(modus-themes--mixed-fonts)
:foreground ,fg-special-cold)))
- `(org-quote ((,class :inherit modus-theme-slant
- ,@(modus-themes--org-block bg-dim)
- :foreground ,fg-special-cold)))
+ `(org-quote ((,class ,@(modus-themes--org-block bg-dim))))
`(org-scheduled ((,class :foreground ,magenta-alt)))
`(org-scheduled-previously ((,class :foreground ,yellow-alt-other)))
`(org-scheduled-today ((,class :foreground ,magenta-alt-other)))
@@ -5464,7 +5606,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
:foreground ,fg-alt)))
`(org-table ((,class ,@(modus-themes--mixed-fonts)
:foreground ,fg-special-cold)))
- `(org-table-header ((,class :inherit (fixed-pitch
modus-theme-intense-neutral))))
+ `(org-table-header ((,class :inherit (fixed-pitch
modus-themes-intense-neutral))))
`(org-tag ((,class :foreground ,magenta-nuanced-fg)))
`(org-tag-group ((,class :inherit bold :foreground ,cyan-nuanced-fg)))
`(org-target ((,class :underline t)))
@@ -5477,8 +5619,8 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(org-verse ((,class :inherit org-quote)))
`(org-warning ((,class :inherit bold :foreground ,red-alt-other)))
;;;;; org-journal
- `(org-journal-calendar-entry-face ((,class :inherit modus-theme-slant
:foreground ,yellow-alt-other)))
- `(org-journal-calendar-scheduled-face ((,class :inherit modus-theme-slant
:foreground ,red-alt-other)))
+ `(org-journal-calendar-entry-face ((,class :inherit modus-themes-slant
:foreground ,yellow-alt-other)))
+ `(org-journal-calendar-scheduled-face ((,class :inherit modus-themes-slant
:foreground ,red-alt-other)))
`(org-journal-highlight ((,class :foreground ,magenta-alt)))
;;;;; org-noter
`(org-noter-no-notes-exist-face ((,class :inherit bold :foreground
,red-active)))
@@ -5507,27 +5649,27 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(org-superstar-item ((,class :foreground ,fg-main)))
`(org-superstar-leading ((,class :foreground ,fg-whitespace)))
;;;;; org-table-sticky-header
- `(org-table-sticky-header-face ((,class :inherit
modus-theme-intense-neutral)))
+ `(org-table-sticky-header-face ((,class :inherit
modus-themes-intense-neutral)))
;;;;; org-tree-slide
`(org-tree-slide-header-overlay-face
- ((,class :inherit (bold modus-theme-variable-pitch) :background ,bg-main
+ ((,class :inherit (bold modus-themes-variable-pitch) :background ,bg-main
:foreground ,fg-special-cold :overline nil
,@(modus-themes--scale modus-themes-scale-5))))
;;;;; org-treescope
- `(org-treescope-faces--markerinternal-midday ((,class :inherit
modus-theme-intense-blue)))
- `(org-treescope-faces--markerinternal-range ((,class :inherit
modus-theme-special-mild)))
+ `(org-treescope-faces--markerinternal-midday ((,class :inherit
modus-themes-intense-blue)))
+ `(org-treescope-faces--markerinternal-range ((,class :inherit
modus-themes-special-mild)))
;;;;; origami
`(origami-fold-header-face ((,class :background ,bg-dim :foreground
,fg-dim :box t)))
`(origami-fold-replacement-face ((,class :background ,bg-alt :foreground
,fg-alt)))
;;;;; outline-mode
- `(outline-1 ((,class :inherit modus-theme-heading-1)))
- `(outline-2 ((,class :inherit modus-theme-heading-2)))
- `(outline-3 ((,class :inherit modus-theme-heading-3)))
- `(outline-4 ((,class :inherit modus-theme-heading-4)))
- `(outline-5 ((,class :inherit modus-theme-heading-5)))
- `(outline-6 ((,class :inherit modus-theme-heading-6)))
- `(outline-7 ((,class :inherit modus-theme-heading-7)))
- `(outline-8 ((,class :inherit modus-theme-heading-8)))
+ `(outline-1 ((,class :inherit modus-themes-heading-1)))
+ `(outline-2 ((,class :inherit modus-themes-heading-2)))
+ `(outline-3 ((,class :inherit modus-themes-heading-3)))
+ `(outline-4 ((,class :inherit modus-themes-heading-4)))
+ `(outline-5 ((,class :inherit modus-themes-heading-5)))
+ `(outline-6 ((,class :inherit modus-themes-heading-6)))
+ `(outline-7 ((,class :inherit modus-themes-heading-7)))
+ `(outline-8 ((,class :inherit modus-themes-heading-8)))
;;;;; outline-minor-faces
`(outline-minor-0 ((,class :background ,bg-alt)))
;;;;; package (M-x list-packages)
@@ -5538,7 +5680,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(package-status-available ((,class :foreground ,fg-special-mild)))
`(package-status-built-in ((,class :foreground ,magenta)))
`(package-status-dependency ((,class :foreground ,magenta-alt-other)))
- `(package-status-disabled ((,class :inherit modus-theme-subtle-red)))
+ `(package-status-disabled ((,class :inherit modus-themes-subtle-red)))
`(package-status-external ((,class :foreground ,cyan-alt-other)))
`(package-status-held ((,class :foreground ,yellow-alt)))
`(package-status-incompat ((,class :inherit bold :foreground ,yellow)))
@@ -5547,14 +5689,20 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(package-status-unsigned ((,class :inherit bold :foreground ,red-alt)))
;;;;; page-break-lines
`(page-break-lines ((,class :inherit default :foreground
,fg-window-divider-outer)))
+;;;;; pandoc-mode
+ `(pandoc-citation-key-face ((,class :background ,bg-dim :foreground
,magenta-alt)))
+ `(pandoc-directive-@@-face ((,class :background ,bg-dim :foreground
,blue-alt-other)))
+ `(pandoc-directive-braces-face ((,class :foreground ,blue-alt-other)))
+ `(pandoc-directive-contents-face ((,class :foreground ,cyan-alt-other)))
+ `(pandoc-directive-type-face ((,class :foreground ,magenta)))
;;;;; paradox
`(paradox-archive-face ((,class :foreground ,fg-special-mild)))
`(paradox-comment-face ((,class :inherit font-lock-comment-face)))
- `(paradox-commit-tag-face ((,class :inherit modus-theme-refine-magenta
:box t)))
+ `(paradox-commit-tag-face ((,class :inherit modus-themes-refine-magenta
:box t)))
`(paradox-description-face ((,class :foreground ,fg-special-cold)))
`(paradox-description-face-multiline ((,class :foreground
,fg-special-cold)))
- `(paradox-download-face ((,class :inherit modus-theme-bold :foreground
,blue-alt-other)))
- `(paradox-highlight-face ((,class :inherit modus-theme-bold :foreground
,cyan-alt-other)))
+ `(paradox-download-face ((,class :inherit modus-themes-bold :foreground
,blue-alt-other)))
+ `(paradox-highlight-face ((,class :inherit modus-themes-bold :foreground
,cyan-alt-other)))
`(paradox-homepage-button-face ((,class :foreground ,magenta-alt-other
:underline t)))
`(paradox-mode-line-face ((,class :inherit bold :foreground ,cyan-active)))
`(paradox-name-face ((,class :foreground ,blue :underline t)))
@@ -5563,7 +5711,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
;;;;; paren-face
`(parenthesis ((,class :foreground ,fg-unfocused)))
;;;;; parrot
- `(parrot-rotate-rotation-highlight-face ((,class :inherit
modus-theme-refine-magenta)))
+ `(parrot-rotate-rotation-highlight-face ((,class :inherit
modus-themes-refine-magenta)))
;;;;; pass
`(pass-mode-directory-face ((,class :inherit bold :foreground
,fg-special-cold)))
`(pass-mode-entry-face ((,class :background ,bg-main :foreground
,fg-main)))
@@ -5573,7 +5721,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(pdf-occur-document-face ((,class :inherit shadow)))
`(pdf-occur-page-face ((,class :inherit shadow)))
;;;;; persp-mode
- `(persp-face-lighter-buffer-not-in-persp ((,class :inherit
modus-theme-intense-red)))
+ `(persp-face-lighter-buffer-not-in-persp ((,class :inherit
modus-themes-intense-red)))
`(persp-face-lighter-default ((,class :inherit bold :foreground
,blue-active)))
`(persp-face-lighter-nil-persp ((,class :inherit bold :foreground
,fg-active)))
;;;;; perspective
@@ -5582,30 +5730,30 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(phi-grep-heading-face ((,class :inherit bold :foreground ,red-alt
,@(modus-themes--scale
modus-themes-scale-4))))
`(phi-grep-line-number-face ((,class :foreground ,fg-special-warm)))
- `(phi-grep-match-face ((,class :inherit modus-theme-special-calm)))
- `(phi-grep-modified-face ((,class :inherit modus-theme-refine-yellow)))
- `(phi-grep-overlay-face ((,class :inherit modus-theme-refine-blue)))
+ `(phi-grep-match-face ((,class :inherit modus-themes-special-calm)))
+ `(phi-grep-modified-face ((,class :inherit modus-themes-refine-yellow)))
+ `(phi-grep-overlay-face ((,class :inherit modus-themes-refine-blue)))
;;;;; phi-search
- `(phi-replace-preview-face ((,class :inherit modus-theme-intense-magenta)))
- `(phi-search-failpart-face ((,class :inherit modus-theme-refine-red)))
- `(phi-search-match-face ((,class :inherit modus-theme-refine-cyan)))
- `(phi-search-selection-face ((,class :inherit (modus-theme-intense-green
bold))))
+ `(phi-replace-preview-face ((,class :inherit
modus-themes-intense-magenta)))
+ `(phi-search-failpart-face ((,class :inherit modus-themes-refine-red)))
+ `(phi-search-match-face ((,class :inherit modus-themes-refine-cyan)))
+ `(phi-search-selection-face ((,class :inherit (modus-themes-intense-green
bold))))
;;;;; pkgbuild-mode
- `(pkgbuild-error-face ((,class :inherit modus-theme-lang-error)))
+ `(pkgbuild-error-face ((,class :inherit modus-themes-lang-error)))
;;;;; pomidor
`(pomidor-break-face ((,class :foreground ,blue-alt-other)))
`(pomidor-overwork-face ((,class :foreground ,red-alt-other)))
- `(pomidor-skip-face ((,class :inherit modus-theme-slant :foreground
,fg-alt)))
+ `(pomidor-skip-face ((,class :inherit modus-themes-slant :foreground
,fg-alt)))
`(pomidor-work-face ((,class :foreground ,green-alt-other)))
;;;;; popup
`(popup-face ((,class :background ,bg-alt :foreground ,fg-main)))
- `(popup-isearch-match ((,class :inherit (modus-theme-refine-cyan bold))))
- `(popup-menu-mouse-face ((,class :inherit modus-theme-intense-blue)))
- `(popup-menu-selection-face ((,class :inherit (modus-theme-subtle-cyan
bold))))
+ `(popup-isearch-match ((,class :inherit (modus-themes-refine-cyan bold))))
+ `(popup-menu-mouse-face ((,class :inherit modus-themes-intense-blue)))
+ `(popup-menu-selection-face ((,class :inherit (modus-themes-subtle-cyan
bold))))
`(popup-scroll-bar-background-face ((,class :background ,bg-active)))
`(popup-scroll-bar-foreground-face ((,class :foreground ,fg-active)))
`(popup-summary-face ((,class :background ,bg-active :foreground
,fg-inactive)))
- `(popup-tip-face ((,class :inherit modus-theme-refine-yellow)))
+ `(popup-tip-face ((,class :inherit modus-themes-refine-yellow)))
;;;;; powerline
`(powerline-active0 ((,class :background ,bg-main :foreground ,blue-faint
:inverse-video t)))
`(powerline-active1 ((,class :background ,blue-nuanced-bg :foreground
,blue-nuanced-fg)))
@@ -5615,16 +5763,16 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(powerline-inactive2 ((,class :background ,bg-inactive :foreground
,fg-inactive)))
;;;;; powerline-evil
`(powerline-evil-base-face ((,class :background ,fg-main :foreground
,bg-main)))
- `(powerline-evil-emacs-face ((,class :inherit modus-theme-active-magenta)))
- `(powerline-evil-insert-face ((,class :inherit modus-theme-active-green)))
- `(powerline-evil-motion-face ((,class :inherit modus-theme-active-blue)))
+ `(powerline-evil-emacs-face ((,class :inherit
modus-themes-active-magenta)))
+ `(powerline-evil-insert-face ((,class :inherit modus-themes-active-green)))
+ `(powerline-evil-motion-face ((,class :inherit modus-themes-active-blue)))
`(powerline-evil-normal-face ((,class :background ,fg-alt :foreground
,bg-main)))
- `(powerline-evil-operator-face ((,class :inherit
modus-theme-active-yellow)))
- `(powerline-evil-replace-face ((,class :inherit modus-theme-active-red)))
- `(powerline-evil-visual-face ((,class :inherit modus-theme-active-cyan)))
+ `(powerline-evil-operator-face ((,class :inherit
modus-themes-active-yellow)))
+ `(powerline-evil-replace-face ((,class :inherit modus-themes-active-red)))
+ `(powerline-evil-visual-face ((,class :inherit modus-themes-active-cyan)))
;;;;; proced
- `(proced-mark ((,class :inherit modus-theme-mark-symbol)))
- `(proced-marked ((,class :inherit modus-theme-mark-alt)))
+ `(proced-mark ((,class :inherit modus-themes-mark-symbol)))
+ `(proced-marked ((,class :inherit modus-themes-mark-alt)))
`(proced-sort-header ((,class :inherit bold :foreground ,fg-special-calm
:underline t)))
;;;;; prodigy
`(prodigy-green-face ((,class :foreground ,green)))
@@ -5635,19 +5783,19 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(quick-peek-border-face ((,class :background ,fg-window-divider-inner
:height 1)))
`(quick-peek-padding-face ((,class :background ,bg-alt :height 0.15)))
;;;;; racket-mode
- `(racket-debug-break-face ((,class :inherit modus-theme-intense-red)))
+ `(racket-debug-break-face ((,class :inherit modus-themes-intense-red)))
`(racket-debug-locals-face ((,class :box (:line-width -1 :color nil)
:foreground ,green-alt-other)))
`(racket-debug-result-face ((,class :inherit bold :box (:line-width -1
:color nil)
:foreground ,green)))
`(racket-here-string-face ((,class :foreground ,blue-alt)))
`(racket-keyword-argument-face ((,class :foreground ,red-alt)))
- `(racket-logger-config-face ((,class :inherit modus-theme-slant
:foreground ,fg-alt)))
+ `(racket-logger-config-face ((,class :inherit modus-themes-slant
:foreground ,fg-alt)))
`(racket-logger-debug-face ((,class :foreground ,blue-alt-other)))
`(racket-logger-info-face ((,class :foreground ,fg-lang-note)))
- `(racket-logger-topic-face ((,class :inherit modus-theme-slant :foreground
,magenta)))
+ `(racket-logger-topic-face ((,class :inherit modus-themes-slant
:foreground ,magenta)))
`(racket-selfeval-face ((,class :foreground ,green-alt)))
- `(racket-xp-error-face ((,class :inherit modus-theme-lang-error)))
+ `(racket-xp-error-face ((,class :inherit modus-themes-lang-error)))
;;;;; rainbow-blocks
`(rainbow-blocks-depth-1-face ((,class :foreground ,magenta-alt-other)))
`(rainbow-blocks-depth-2-face ((,class :foreground ,blue)))
@@ -5687,8 +5835,8 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(rainbow-delimiters-depth-7-face ((,class :foreground ,red-intense)))
`(rainbow-delimiters-depth-8-face ((,class :foreground ,blue-intense)))
`(rainbow-delimiters-depth-9-face ((,class :foreground ,yellow-intense)))
- `(rainbow-delimiters-mismatched-face ((,class :inherit (bold
modus-theme-refine-yellow))))
- `(rainbow-delimiters-unmatched-face ((,class :inherit (bold
modus-theme-refine-red))))
+ `(rainbow-delimiters-mismatched-face ((,class :inherit (bold
modus-themes-refine-yellow))))
+ `(rainbow-delimiters-unmatched-face ((,class :inherit (bold
modus-themes-refine-red))))
;;;;; rcirc
`(rcirc-bright-nick ((,class :inherit bold :foreground ,magenta-alt)))
`(rcirc-dim-nick ((,class :inherit shadow)))
@@ -5696,7 +5844,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(rcirc-nick-in-message ((,class :foreground ,magenta-alt-other)))
`(rcirc-nick-in-message-full-line ((,class :inherit bold :foreground
,fg-special-mild)))
`(rcirc-other-nick ((,class :inherit bold :foreground ,fg-special-cold)))
- `(rcirc-prompt ((,class :inherit bold :foreground ,cyan-alt-other)))
+ `(rcirc-prompt ((,class :inherit comint-highlight-prompt)))
`(rcirc-server ((,class :foreground ,fg-unfocused)))
`(rcirc-timestamp ((,class :foreground ,blue-nuanced-fg)))
`(rcirc-url ((,class :foreground ,blue :underline t)))
@@ -5704,10 +5852,10 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(recursion-indicator-general ((,class :foreground ,blue-active)))
`(recursion-indicator-minibuffer ((,class :foreground ,red-active)))
;;;;; regexp-builder (re-builder)
- `(reb-match-0 ((,class :inherit modus-theme-refine-cyan)))
- `(reb-match-1 ((,class :inherit modus-theme-subtle-magenta)))
- `(reb-match-2 ((,class :inherit modus-theme-subtle-green)))
- `(reb-match-3 ((,class :inherit modus-theme-refine-yellow)))
+ `(reb-match-0 ((,class :inherit modus-themes-refine-cyan)))
+ `(reb-match-1 ((,class :inherit modus-themes-subtle-magenta)))
+ `(reb-match-2 ((,class :inherit modus-themes-subtle-green)))
+ `(reb-match-3 ((,class :inherit modus-themes-refine-yellow)))
`(reb-regexp-grouping-backslash ((,class :inherit
font-lock-regexp-grouping-backslash)))
`(reb-regexp-grouping-construct ((,class :inherit
font-lock-regexp-grouping-construct)))
;;;;; rg (rg.el)
@@ -5718,7 +5866,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(rg-filename-face ((,class :inherit bold :foreground ,fg-special-cold)))
`(rg-line-number-face ((,class :foreground ,fg-special-warm)))
`(rg-literal-face ((,class :foreground ,blue-alt)))
- `(rg-match-face ((,class :inherit modus-theme-special-calm)))
+ `(rg-match-face ((,class :inherit modus-themes-special-calm)))
`(rg-regexp-face ((,class :foreground ,magenta-active)))
`(rg-toggle-off-face ((,class :inherit bold :foreground ,fg-inactive)))
`(rg-toggle-on-face ((,class :inherit bold :foreground ,cyan-active)))
@@ -5727,7 +5875,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(ripgrep-context-face ((,class :foreground ,fg-unfocused)))
`(ripgrep-error-face ((,class :inherit bold :foreground ,red)))
`(ripgrep-hit-face ((,class :foreground ,cyan)))
- `(ripgrep-match-face ((,class :inherit modus-theme-special-calm)))
+ `(ripgrep-match-face ((,class :inherit modus-themes-special-calm)))
;;;;; rmail
`(rmail-header-name ((,class :foreground ,cyan-alt-other)))
`(rmail-highlight ((,class :inherit bold :foreground ,magenta-alt)))
@@ -5753,29 +5901,30 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(sallet-buffer-size ((,class :foreground ,fg-special-calm)))
`(sallet-buffer-special ((,class :foreground ,magenta-alt-other)))
`(sallet-flx-match ((,class ,@(modus-themes--extra-completions
- 'modus-theme-subtle-cyan
- 'modus-theme-refine-cyan
- 'modus-theme-nuanced-cyan
+ 'modus-themes-subtle-cyan
+ 'modus-themes-refine-cyan
+ 'modus-themes-nuanced-cyan
cyan-alt-other))))
`(sallet-recentf-buffer-name ((,class :foreground ,blue-nuanced-fg)))
`(sallet-recentf-file-path ((,class :foreground ,fg-special-mild)))
`(sallet-regexp-match ((,class ,@(modus-themes--extra-completions
- 'modus-theme-subtle-magenta
- 'modus-theme-refine-magenta
- 'modus-theme-nuanced-magenta
+ 'modus-themes-subtle-magenta
+ 'modus-themes-refine-magenta
+ 'modus-themes-nuanced-magenta
magenta-alt-other))))
`(sallet-source-header ((,class :inherit bold :foreground ,red-alt
,@(modus-themes--scale
modus-themes-scale-4))))
`(sallet-substring-match ((,class ,@(modus-themes--extra-completions
- 'modus-theme-subtle-blue
- 'modus-theme-refine-blue
- 'modus-theme-nuanced-blue
+ 'modus-themes-subtle-blue
+ 'modus-themes-refine-blue
+ 'modus-themes-nuanced-blue
blue-alt-other))))
;;;;; selectrum
-;; NOTE 2021-02-22: The `selectrum-primary-highlight' and
-;; `selectrum-secondary-highlight' are deprecated upstream in favour of
-;; their selectrum-prescient counterparts. We shall remove those faces
-;; from the themes once we are certain that they are no longer relevant.
+ ;; NOTE 2021-02-22: The `selectrum-primary-highlight' and
+ ;; `selectrum-secondary-highlight' are deprecated upstream in favour
+ ;; of their selectrum-prescient counterparts. We shall remove those
+ ;; faces from the themes once we are certain that they are no longer
+ ;; relevant.
`(selectrum-current-candidate
((,class :inherit bold :foreground ,fg-main
:background ,@(pcase modus-themes-completions
@@ -5791,6 +5940,10 @@ by virtue of calling either of
`modus-themes-load-operandi' and
,@(modus-themes--standard-completions
cyan-alt-other cyan-nuanced-bg
cyan-refine-bg cyan-refine-fg))))
+ `(selectrum-quick-keys-highlight
+ ((,class :inherit modus-themes-refine-red)))
+ `(selectrum-quick-keys-match
+ ((,class :inherit (bold modus-themes-intense-green))))
;;;;; selectrum-prescient
`(selectrum-prescient-primary-highlight
((,class :inherit bold
@@ -5804,40 +5957,37 @@ by virtue of calling either of
`modus-themes-load-operandi' and
cyan-refine-bg cyan-refine-fg))))
;;;;; semantic
`(semantic-complete-inline-face ((,class :foreground ,fg-special-warm
:underline t)))
- `(semantic-decoration-on-fileless-includes ((,class :inherit
modus-theme-refine-green)))
- `(semantic-decoration-on-private-members-face ((,class :inherit
modus-theme-refine-cyan)))
+ `(semantic-decoration-on-fileless-includes ((,class :inherit
modus-themes-refine-green)))
+ `(semantic-decoration-on-private-members-face ((,class :inherit
modus-themes-refine-cyan)))
`(semantic-decoration-on-protected-members-face ((,class :background
,bg-dim)))
- `(semantic-decoration-on-unknown-includes ((,class :inherit
modus-theme-refine-red)))
- `(semantic-decoration-on-unparsed-includes ((,class :inherit
modus-theme-refine-yellow)))
+ `(semantic-decoration-on-unknown-includes ((,class :inherit
modus-themes-refine-red)))
+ `(semantic-decoration-on-unparsed-includes ((,class :inherit
modus-themes-refine-yellow)))
`(semantic-highlight-edits-face ((,class :background ,bg-alt)))
`(semantic-highlight-func-current-tag-face ((,class :background ,bg-alt)))
- `(semantic-idle-symbol-highlight ((,class :inherit
modus-theme-special-mild)))
+ `(semantic-idle-symbol-highlight ((,class :inherit
modus-themes-special-mild)))
`(semantic-tag-boundary-face ((,class :overline ,blue-intense)))
`(semantic-unmatched-syntax-face ((,class :underline ,fg-lang-error)))
;;;;; sesman
`(sesman-browser-button-face ((,class :foreground ,blue-alt-other
:underline t)))
- `(sesman-browser-highligh-face ((,class :inherit modus-theme-subtle-blue)))
+ `(sesman-browser-highligh-face ((,class :inherit
modus-themes-subtle-blue)))
`(sesman-buffer-face ((,class :foreground ,magenta)))
`(sesman-directory-face ((,class :inherit bold :foreground ,blue)))
`(sesman-project-face ((,class :inherit bold :foreground
,magenta-alt-other)))
;;;;; shell-script-mode
`(sh-heredoc ((,class :foreground ,blue-alt)))
- `(sh-quoted-exec ((,class :inherit modus-theme-bold :foreground
,magenta-alt)))
+ `(sh-quoted-exec ((,class :inherit modus-themes-bold :foreground
,magenta-alt)))
;;;;; shortdoc
- `(shortdoc-heading ((,class :inherit modus-theme-pseudo-header)))
+ `(shortdoc-heading ((,class :inherit modus-themes-pseudo-header)))
`(shortdoc-section (())) ; remove the default's variable-pitch style
;;;;; show-paren-mode
`(show-paren-match ((,class ,@(modus-themes--paren bg-paren-match
bg-paren-match-intense)
:foreground ,fg-main)))
- `(show-paren-match-expression ((,class :inherit modus-theme-special-calm)))
- `(show-paren-mismatch ((,class :inherit modus-theme-intense-red)))
+ `(show-paren-match-expression ((,class :inherit
modus-themes-special-calm)))
+ `(show-paren-mismatch ((,class :inherit modus-themes-intense-red)))
;;;;; shr
- `(shr-abbreviation
- ((,(append '((supports :underline (:style wave))) class)
- :foreground ,fg-docstring :underline (:color ,fg-alt :style wave))
- (,class :foreground ,fg-docstring :underline t)))
- `(shr-selected-link ((,class :inherit modus-theme-subtle-cyan)))
+ `(shr-abbreviation ((,class :inherit modus-themes-lang-note)))
+ `(shr-selected-link ((,class :inherit modus-themes-subtle-red)))
;;;;; side-notes
`(side-notes ((,class :background ,bg-dim :foreground ,fg-dim)))
;;;;; sieve-mode
@@ -5862,94 +6012,94 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(sml/name-filling ((,class :foreground ,yellow-active)))
`(sml/not-modified ((,class :inherit sml/global)))
`(sml/numbers-separator ((,class :inherit sml/global)))
- `(sml/outside-modified ((,class :inherit modus-theme-intense-red)))
+ `(sml/outside-modified ((,class :inherit modus-themes-intense-red)))
`(sml/position-percentage ((,class :inherit sml/global)))
`(sml/prefix ((,class :foreground ,green-active)))
`(sml/process ((,class :inherit sml/prefix)))
`(sml/projectile ((,class :inherit sml/git)))
`(sml/read-only ((,class :inherit bold :foreground ,cyan-active)))
`(sml/remote ((,class :inherit sml/global)))
- `(sml/sudo ((,class :inherit modus-theme-subtle-red)))
+ `(sml/sudo ((,class :inherit modus-themes-subtle-red)))
`(sml/time ((,class :inherit sml/global)))
`(sml/vc ((,class :inherit sml/git)))
`(sml/vc-edited ((,class :inherit bold :foreground ,yellow-active)))
;;;;; smartparens
- `(sp-pair-overlay-face ((,class :inherit modus-theme-special-warm)))
- `(sp-show-pair-enclosing ((,class :inherit modus-theme-special-mild)))
+ `(sp-pair-overlay-face ((,class :inherit modus-themes-special-warm)))
+ `(sp-show-pair-enclosing ((,class :inherit modus-themes-special-mild)))
`(sp-show-pair-match-face ((,class ,@(modus-themes--paren bg-paren-match
bg-paren-match-intense)
:foreground ,fg-main)))
- `(sp-show-pair-mismatch-face ((,class :inherit modus-theme-intense-red)))
+ `(sp-show-pair-mismatch-face ((,class :inherit modus-themes-intense-red)))
`(sp-wrap-overlay-closing-pair ((,class :inherit sp-pair-overlay-face)))
`(sp-wrap-overlay-face ((,class :inherit sp-pair-overlay-face)))
`(sp-wrap-overlay-opening-pair ((,class :inherit sp-pair-overlay-face)))
`(sp-wrap-tag-overlay-face ((,class :inherit sp-pair-overlay-face)))
;;;;; smerge
- `(smerge-base ((,class :inherit modus-theme-diff-changed)))
- `(smerge-lower ((,class :inherit modus-theme-diff-added)))
- `(smerge-markers ((,class :background ,bg-diff-neutral-2 :foreground
,fg-diff-neutral-2)))
- `(smerge-refined-added ((,class :inherit modus-theme-diff-refine-added)))
+ `(smerge-base ((,class :inherit modus-themes-diff-changed)))
+ `(smerge-lower ((,class :inherit modus-themes-diff-added)))
+ `(smerge-markers ((,class :inherit modus-themes-diff-heading)))
+ `(smerge-refined-added ((,class :inherit modus-themes-diff-refine-added)))
`(smerge-refined-changed (()))
- `(smerge-refined-removed ((,class :inherit
modus-theme-diff-refine-removed)))
- `(smerge-upper ((,class :inherit modus-theme-diff-removed)))
+ `(smerge-refined-removed ((,class :inherit
modus-themes-diff-refine-removed)))
+ `(smerge-upper ((,class :inherit modus-themes-diff-removed)))
;;;;; solaire
`(solaire-default-face ((,class :inherit default :background ,bg-alt
:foreground ,fg-dim)))
`(solaire-line-number-face ((,class :inherit solaire-default-face
:foreground ,fg-unfocused)))
`(solaire-hl-line-face ((,class :background ,bg-active)))
`(solaire-org-hide-face ((,class :background ,bg-alt :foreground ,bg-alt)))
;;;;; spaceline
- `(spaceline-evil-emacs ((,class :inherit modus-theme-active-magenta)))
- `(spaceline-evil-insert ((,class :inherit modus-theme-active-green)))
- `(spaceline-evil-motion ((,class :inherit modus-theme-active-blue)))
+ `(spaceline-evil-emacs ((,class :inherit modus-themes-active-magenta)))
+ `(spaceline-evil-insert ((,class :inherit modus-themes-active-green)))
+ `(spaceline-evil-motion ((,class :inherit modus-themes-active-blue)))
`(spaceline-evil-normal ((,class :background ,fg-alt :foreground ,bg-alt)))
- `(spaceline-evil-replace ((,class :inherit modus-theme-active-red)))
- `(spaceline-evil-visual ((,class :inherit modus-theme-active-cyan)))
+ `(spaceline-evil-replace ((,class :inherit modus-themes-active-red)))
+ `(spaceline-evil-visual ((,class :inherit modus-themes-active-cyan)))
`(spaceline-flycheck-error ((,class :foreground ,red-active)))
`(spaceline-flycheck-info ((,class :foreground ,cyan-active)))
`(spaceline-flycheck-warning ((,class :foreground ,yellow-active)))
- `(spaceline-highlight-face ((,class :inherit modus-theme-fringe-blue)))
- `(spaceline-modified ((,class :inherit modus-theme-fringe-magenta)))
+ `(spaceline-highlight-face ((,class :inherit modus-themes-fringe-blue)))
+ `(spaceline-modified ((,class :inherit modus-themes-fringe-magenta)))
`(spaceline-python-venv ((,class :foreground ,magenta-active)))
- `(spaceline-read-only ((,class :inherit modus-theme-fringe-red)))
- `(spaceline-unmodified ((,class :inherit modus-theme-fringe-cyan)))
+ `(spaceline-read-only ((,class :inherit modus-themes-fringe-red)))
+ `(spaceline-unmodified ((,class :inherit modus-themes-fringe-cyan)))
;;;;; speedbar
`(speedbar-button-face ((,class :inherit button)))
`(speedbar-directory-face ((,class :inherit bold :foreground ,blue)))
`(speedbar-file-face ((,class :foreground ,fg-main)))
- `(speedbar-highlight-face ((,class :inherit modus-theme-subtle-blue)))
+ `(speedbar-highlight-face ((,class :inherit modus-themes-subtle-blue)))
`(speedbar-selected-face ((,class :inherit bold :foreground ,cyan)))
- `(speedbar-separator-face ((,class :inherit modus-theme-intense-neutral)))
+ `(speedbar-separator-face ((,class :inherit modus-themes-intense-neutral)))
`(speedbar-tag-face ((,class :foreground ,yellow-alt-other)))
;;;;; spell-fu
- `(spell-fu-incorrect-face ((,class :inherit modus-theme-lang-error)))
+ `(spell-fu-incorrect-face ((,class :inherit modus-themes-lang-error)))
;;;;; spray
`(spray-accent-face ((,class :foreground ,red-intense)))
`(spray-base-face ((,class :inherit default :foreground ,fg-special-cold)))
;;;;; stripes
- `(stripes ((,class :inherit modus-theme-hl-line)))
+ `(stripes ((,class :inherit modus-themes-hl-line)))
;;;;; success
`(suggest-heading ((,class :inherit bold :foreground ,yellow-alt-other)))
;;;;; switch-window
`(switch-window-background ((,class :background ,bg-dim)))
`(switch-window-label ((,class :height 3.0 :foreground ,blue-intense)))
;;;;; swiper
- `(swiper-background-match-face-1 ((,class :inherit
modus-theme-subtle-neutral)))
- `(swiper-background-match-face-2 ((,class :inherit
modus-theme-refine-cyan)))
- `(swiper-background-match-face-3 ((,class :inherit
modus-theme-refine-magenta)))
- `(swiper-background-match-face-4 ((,class :inherit
modus-theme-refine-yellow)))
- `(swiper-line-face ((,class :inherit modus-theme-special-cold)))
- `(swiper-match-face-1 ((,class :inherit (bold
modus-theme-intense-neutral))))
- `(swiper-match-face-2 ((,class :inherit (bold modus-theme-intense-green))))
- `(swiper-match-face-3 ((,class :inherit (bold modus-theme-intense-blue))))
- `(swiper-match-face-4 ((,class :inherit (bold modus-theme-intense-red))))
+ `(swiper-background-match-face-1 ((,class :inherit
modus-themes-subtle-neutral)))
+ `(swiper-background-match-face-2 ((,class :inherit
modus-themes-refine-cyan)))
+ `(swiper-background-match-face-3 ((,class :inherit
modus-themes-refine-magenta)))
+ `(swiper-background-match-face-4 ((,class :inherit
modus-themes-refine-yellow)))
+ `(swiper-line-face ((,class :inherit modus-themes-special-cold)))
+ `(swiper-match-face-1 ((,class :inherit (bold
modus-themes-intense-neutral))))
+ `(swiper-match-face-2 ((,class :inherit (bold
modus-themes-intense-green))))
+ `(swiper-match-face-3 ((,class :inherit (bold modus-themes-intense-blue))))
+ `(swiper-match-face-4 ((,class :inherit (bold modus-themes-intense-red))))
;;;;; swoop
`(swoop-face-header-format-line ((,class :inherit bold :foreground ,red-alt
,@(modus-themes--scale
modus-themes-scale-3))))
`(swoop-face-line-buffer-name ((,class :inherit bold :foreground ,blue-alt
,@(modus-themes--scale
modus-themes-scale-4))))
`(swoop-face-line-number ((,class :foreground ,fg-special-warm)))
- `(swoop-face-target-line ((,class :inherit modus-theme-intense-blue
:extend t)))
- `(swoop-face-target-words ((,class :inherit modus-theme-refine-cyan)))
+ `(swoop-face-target-line ((,class :inherit modus-themes-intense-blue
:extend t)))
+ `(swoop-face-target-words ((,class :inherit modus-themes-refine-cyan)))
;;;;; sx
`(sx-inbox-item-type ((,class :foreground ,magenta-alt-other)))
`(sx-inbox-item-type-unread ((,class :inherit (sx-inbox-item-type bold))))
@@ -5964,7 +6114,7 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(sx-question-list-score-upvoted ((,class :inherit (sx-question-list-score
bold))))
`(sx-question-list-unread-question ((,class :inherit bold :foreground
,fg-main)))
`(sx-question-mode-accepted ((,class :inherit bold :height 1.3 :foreground
,green)))
- `(sx-question-mode-closed ((,class :inherit modus-theme-active-yellow :box
(:line-width 2 :color nil))))
+ `(sx-question-mode-closed ((,class :inherit modus-themes-active-yellow
:box (:line-width 2 :color nil))))
`(sx-question-mode-closed-reason ((,class :box (:line-width 2 :color nil)
:foreground ,fg-main)))
`(sx-question-mode-content-face ((,class :background ,bg-dim)))
`(sx-question-mode-date ((,class :foreground ,blue)))
@@ -5979,15 +6129,15 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(sx-user-name ((,class :foreground ,blue-alt)))
`(sx-user-reputation ((,class :inherit shadow)))
;;;;; symbol-overlay
- `(symbol-overlay-default-face ((,class :inherit modus-theme-special-warm)))
- `(symbol-overlay-face-1 ((,class :inherit modus-theme-intense-blue)))
- `(symbol-overlay-face-2 ((,class :inherit modus-theme-refine-magenta)))
- `(symbol-overlay-face-3 ((,class :inherit modus-theme-intense-yellow)))
- `(symbol-overlay-face-4 ((,class :inherit modus-theme-intense-magenta)))
- `(symbol-overlay-face-5 ((,class :inherit modus-theme-intense-red)))
- `(symbol-overlay-face-6 ((,class :inherit modus-theme-refine-red)))
- `(symbol-overlay-face-7 ((,class :inherit modus-theme-intense-cyan)))
- `(symbol-overlay-face-8 ((,class :inherit modus-theme-refine-cyan)))
+ `(symbol-overlay-default-face ((,class :inherit
modus-themes-special-warm)))
+ `(symbol-overlay-face-1 ((,class :inherit modus-themes-intense-blue)))
+ `(symbol-overlay-face-2 ((,class :inherit modus-themes-refine-magenta)))
+ `(symbol-overlay-face-3 ((,class :inherit modus-themes-intense-yellow)))
+ `(symbol-overlay-face-4 ((,class :inherit modus-themes-intense-magenta)))
+ `(symbol-overlay-face-5 ((,class :inherit modus-themes-intense-red)))
+ `(symbol-overlay-face-6 ((,class :inherit modus-themes-refine-red)))
+ `(symbol-overlay-face-7 ((,class :inherit modus-themes-intense-cyan)))
+ `(symbol-overlay-face-8 ((,class :inherit modus-themes-refine-cyan)))
;;;;; syslog-mode
`(syslog-debug ((,class :inherit bold :foreground ,cyan-alt-other)))
`(syslog-error ((,class :inherit bold :foreground ,red)))
@@ -5998,6 +6148,23 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(syslog-ip ((,class :inherit bold :foreground ,fg-special-mild :underline
t)))
`(syslog-su ((,class :inherit bold :foreground ,red-alt)))
`(syslog-warn ((,class :inherit bold :foreground ,yellow)))
+;;;;; tab-bar-groups
+ `(tab-bar-groups-1 ((,class ,@(modus-themes--variable-pitch-ui)
:foreground ,blue-tab)))
+ `(tab-bar-groups-1-group-name ((,class :inherit tab-bar-groups-1
:inverse-video t)))
+ `(tab-bar-groups-2 ((,class ,@(modus-themes--variable-pitch-ui)
:foreground ,red-tab)))
+ `(tab-bar-groups-2-group-name ((,class :inherit tab-bar-groups-2
:inverse-video t)))
+ `(tab-bar-groups-3 ((,class ,@(modus-themes--variable-pitch-ui)
:foreground ,green-tab)))
+ `(tab-bar-groups-3-group-name ((,class :inherit tab-bar-groups-3
:inverse-video t)))
+ `(tab-bar-groups-4 ((,class ,@(modus-themes--variable-pitch-ui)
:foreground ,orange-tab)))
+ `(tab-bar-groups-4-group-name ((,class :inherit tab-bar-groups-4
:inverse-video t)))
+ `(tab-bar-groups-5 ((,class ,@(modus-themes--variable-pitch-ui)
:foreground ,purple-tab)))
+ `(tab-bar-groups-5-group-name ((,class :inherit tab-bar-groups-5
:inverse-video t)))
+ `(tab-bar-groups-6 ((,class ,@(modus-themes--variable-pitch-ui)
:foreground ,cyan-tab)))
+ `(tab-bar-groups-6-group-name ((,class :inherit tab-bar-groups-6
:inverse-video t)))
+ `(tab-bar-groups-7 ((,class ,@(modus-themes--variable-pitch-ui)
:foreground ,yellow-tab)))
+ `(tab-bar-groups-7-group-name ((,class :inherit tab-bar-groups-7
:inverse-video t)))
+ `(tab-bar-groups-8 ((,class ,@(modus-themes--variable-pitch-ui)
:foreground ,magenta-tab)))
+ `(tab-bar-groups-8-group-name ((,class :inherit tab-bar-groups-8
:inverse-video t)))
;;;;; tab-bar-mode
`(tab-bar ((,class ,@(modus-themes--variable-pitch-ui)
:background ,bg-tab-bar :foreground ,fg-main)))
@@ -6019,6 +6186,30 @@ by virtue of calling either of
`modus-themes-load-operandi' and
:background
,bg-tab-inactive-alt :foreground ,fg-main)))
;;;;; table (built-in table.el)
`(table-cell ((,class :background ,blue-nuanced-bg)))
+;;;;; telega
+ ;; FIXME 2021-03-28: Some aspects of `telega' are not fully
+ ;; supported or have not been tested thoroughly. Please understand
+ ;; that I do not use that service because it requires a smartphone
+ ;; and I have none. Help with testing is appreciated.
+ `(telega-button ((,class :box t :foreground ,blue)))
+ `(telega-button-active ((,class :box ,blue-intense-bg :background
,blue-intense-bg :foreground ,fg-main)))
+ `(telega-button-highlight ((,class :inherit modus-themes-subtle-magenta)))
+ `(telega-chat-prompt ((,class :inherit bold)))
+ `(telega-entity-type-code ((,class :inherit fixed-pitch)))
+ `(telega-entity-type-mention ((,class :foreground ,cyan)))
+ `(telega-entity-type-pre ((,class :inherit fixed-pitch)))
+ `(telega-msg-heading ((,class :background ,bg-alt)))
+ `(telega-msg-self-title ((,class :inherit bold)))
+ `(telega-root-heading ((,class :inherit modus-themes-subtle-neutral)))
+ `(telega-secret-title ((,class :foreground ,magenta-alt)))
+ `(telega-unmuted-count ((,class :foreground ,blue-alt-other)))
+ `(telega-user-online-status ((,class :foreground ,cyan-active)))
+ `(telega-username ((,class :foreground ,cyan-alt-other)))
+ `(telega-webpage-chat-link ((,class :background ,bg-alt)))
+ `(telega-webpage-fixed ((,class :inherit fixed-pitch :height 0.85)))
+ `(telega-webpage-header ((,class :inherit modus-themes-variable-pitch
:height 1.3)))
+ `(telega-webpage-preformatted ((,class :inherit fixed-pitch :background
,bg-alt)))
+ `(telega-webpage-subheader ((,class :inherit modus-themes-variable-pitch
:height 1.15)))
;;;;; telephone-line
`(telephone-line-accent-active ((,class :background ,fg-inactive
:foreground ,bg-inactive)))
`(telephone-line-accent-inactive ((,class :background ,bg-active
:foreground ,fg-active)))
@@ -6058,16 +6249,16 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(tomatinho-pause-face ((,class :foreground ,yellow-intense)))
`(tomatinho-reset-face ((,class :inherit shadow)))
;;;;; transient
- `(transient-active-infix ((,class :inherit modus-theme-special-mild)))
+ `(transient-active-infix ((,class :inherit modus-themes-special-mild)))
`(transient-amaranth ((,class :inherit bold :foreground ,yellow)))
`(transient-argument ((,class :inherit bold :foreground ,red-alt)))
`(transient-blue ((,class :inherit bold :foreground ,blue)))
- `(transient-disabled-suffix ((,class :inherit modus-theme-intense-red)))
- `(transient-enabled-suffix ((,class :inherit modus-theme-intense-green)))
+ `(transient-disabled-suffix ((,class :inherit modus-themes-intense-red)))
+ `(transient-enabled-suffix ((,class :inherit modus-themes-intense-green)))
`(transient-heading ((,class :inherit bold :foreground ,fg-main)))
`(transient-inactive-argument ((,class :inherit shadow)))
`(transient-inactive-value ((,class :inherit shadow)))
- `(transient-key ((,class :inherit bold :foreground ,blue)))
+ `(transient-key ((,class :inherit modus-themes-key-binding)))
`(transient-mismatched-key ((,class :underline t)))
`(transient-nonstandard-key ((,class :underline t)))
`(transient-pink ((,class :inherit bold :foreground ,magenta)))
@@ -6077,11 +6268,11 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(transient-unreachable-key ((,class :foreground ,fg-unfocused)))
`(transient-value ((,class :inherit bold :foreground ,magenta-alt-other)))
;;;;; trashed
- `(trashed-deleted ((,class :inherit modus-theme-mark-del)))
+ `(trashed-deleted ((,class :inherit modus-themes-mark-del)))
`(trashed-directory ((,class :foreground ,blue)))
- `(trashed-mark ((,class :inherit modus-theme-mark-symbol)))
- `(trashed-marked ((,class :inherit modus-theme-mark-alt)))
- `(trashed-restored ((,class :inherit modus-theme-mark-sel)))
+ `(trashed-mark ((,class :inherit modus-themes-mark-symbol)))
+ `(trashed-marked ((,class :inherit modus-themes-mark-alt)))
+ `(trashed-restored ((,class :inherit modus-themes-mark-sel)))
`(trashed-symlink ((,class :inherit button
,@(modus-themes--link-color
cyan-alt cyan-alt-faint))))
@@ -6091,16 +6282,16 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(treemacs-file-face ((,class :foreground ,fg-main)))
`(treemacs-fringe-indicator-face ((,class :foreground ,fg-main)))
`(treemacs-git-added-face ((,class :foreground ,green-intense)))
- `(treemacs-git-conflict-face ((,class :inherit (modus-theme-intense-red
bold))))
+ `(treemacs-git-conflict-face ((,class :inherit (modus-themes-intense-red
bold))))
`(treemacs-git-ignored-face ((,class :inherit shadow)))
`(treemacs-git-modified-face ((,class :foreground ,yellow-alt-other)))
`(treemacs-git-renamed-face ((,class :foreground ,cyan-alt-other)))
`(treemacs-git-unmodified-face ((,class :foreground ,fg-main)))
`(treemacs-git-untracked-face ((,class :foreground ,red-alt-other)))
- `(treemacs-help-column-face ((,class :inherit modus-theme-bold :foreground
,magenta-alt-other :underline t)))
+ `(treemacs-help-column-face ((,class :inherit modus-themes-bold
:foreground ,magenta-alt-other :underline t)))
`(treemacs-help-title-face ((,class :foreground ,blue-alt-other)))
- `(treemacs-on-failure-pulse-face ((,class :inherit
modus-theme-intense-red)))
- `(treemacs-on-success-pulse-face ((,class :inherit
modus-theme-intense-green)))
+ `(treemacs-on-failure-pulse-face ((,class :inherit
modus-themes-intense-red)))
+ `(treemacs-on-success-pulse-face ((,class :inherit
modus-themes-intense-green)))
`(treemacs-root-face ((,class :inherit bold :foreground ,blue-alt-other
:height 1.2 :underline t)))
`(treemacs-root-remote-disconnected-face ((,class :inherit
treemacs-root-remote-face :foreground ,yellow)))
`(treemacs-root-remote-face ((,class :inherit treemacs-root-face
:foreground ,magenta)))
@@ -6111,17 +6302,17 @@ by virtue of calling either of
`modus-themes-load-operandi' and
;;;;; tty-menu
`(tty-menu-disabled-face ((,class :background ,bg-alt :foreground
,fg-alt)))
`(tty-menu-enabled-face ((,class :inherit bold :background ,bg-alt
:foreground ,fg-main)))
- `(tty-menu-selected-face ((,class :inherit modus-theme-intense-blue)))
+ `(tty-menu-selected-face ((,class :inherit modus-themes-intense-blue)))
;;;;; tuareg
- `(caml-types-def-face ((,class :inherit modus-theme-subtle-red)))
- `(caml-types-expr-face ((,class :inherit modus-theme-subtle-green)))
- `(caml-types-occ-face ((,class :inherit modus-theme-subtle-green)))
- `(caml-types-scope-face ((,class :inherit modus-theme-subtle-blue)))
- `(caml-types-typed-face ((,class :inherit modus-theme-subtle-magenta)))
+ `(caml-types-def-face ((,class :inherit modus-themes-subtle-red)))
+ `(caml-types-expr-face ((,class :inherit modus-themes-subtle-green)))
+ `(caml-types-occ-face ((,class :inherit modus-themes-subtle-green)))
+ `(caml-types-scope-face ((,class :inherit modus-themes-subtle-blue)))
+ `(caml-types-typed-face ((,class :inherit modus-themes-subtle-magenta)))
`(tuareg-font-double-semicolon-face ((,class :inherit
font-lock-preprocessor-face)))
`(tuareg-font-lock-attribute-face ((,class :inherit
font-lock-function-name-face)))
`(tuareg-font-lock-constructor-face ((,class :foreground ,fg-main)))
- `(tuareg-font-lock-error-face ((,class :inherit (modus-theme-intense-red
bold))))
+ `(tuareg-font-lock-error-face ((,class :inherit (modus-themes-intense-red
bold))))
`(tuareg-font-lock-extension-node-face ((,class :background ,bg-alt
:foreground ,magenta)))
`(tuareg-font-lock-governing-face ((,class :inherit bold :foreground
,fg-main)))
`(tuareg-font-lock-infix-extension-node-face ((,class :inherit
font-lock-function-name-face)))
@@ -6136,9 +6327,9 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(tuareg-opam-error-face ((,class :inherit error)))
`(tuareg-opam-pkg-variable-name-face ((,class :inherit
font-lock-variable-name-face)))
;;;;; typescript
- `(typescript-jsdoc-tag ((,class :inherit modus-theme-slant :foreground
,fg-special-mild)))
- `(typescript-jsdoc-type ((,class :inherit modus-theme-slant :foreground
,fg-special-calm)))
- `(typescript-jsdoc-value ((,class :inherit modus-theme-slant :foreground
,fg-special-cold)))
+ `(typescript-jsdoc-tag ((,class :inherit (font-lock-builtin-face
font-lock-comment-face) :weight normal)))
+ `(typescript-jsdoc-type ((,class :inherit (font-lock-type-face
font-lock-comment-face) :weight normal)))
+ `(typescript-jsdoc-value ((,class :inherit (font-lock-constant-face
font-lock-comment-face) :weight normal)))
;;;;; undo-tree
`(undo-tree-visualizer-active-branch-face ((,class :inherit bold
:foreground ,fg-main)))
`(undo-tree-visualizer-current-face ((,class :foreground ,blue-intense)))
@@ -6155,26 +6346,31 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(vc-dir-status-ignored ((,class :foreground ,fg-unfocused)))
`(vc-dir-status-up-to-date ((,class :foreground ,cyan)))
`(vc-dir-status-warning ((,class :foreground ,red)))
- `(vc-conflict-state ((,class :inherit modus-theme-slant :foreground
,red-active)))
+ `(vc-conflict-state ((,class :inherit modus-themes-slant :foreground
,red-active)))
`(vc-edited-state ((,class :foreground ,yellow-active)))
`(vc-locally-added-state ((,class :foreground ,cyan-active)))
`(vc-locked-state ((,class :foreground ,blue-active)))
- `(vc-missing-state ((,class :inherit modus-theme-slant :foreground
,magenta-active)))
- `(vc-needs-update-state ((,class :inherit modus-theme-slant :foreground
,green-active)))
+ `(vc-missing-state ((,class :inherit modus-themes-slant :foreground
,magenta-active)))
+ `(vc-needs-update-state ((,class :inherit modus-themes-slant :foreground
,green-active)))
`(vc-removed-state ((,class :foreground ,red-active)))
`(vc-state-base ((,class :foreground ,fg-active)))
`(vc-up-to-date-state ((,class :foreground ,fg-special-cold)))
;;;;; vdiff
- `(vdiff-addition-face ((,class :inherit modus-theme-diff-added)))
- `(vdiff-change-face ((,class :inherit modus-theme-diff-changed)))
- `(vdiff-closed-fold-face ((,class :background ,bg-diff-neutral-1
:foreground ,fg-diff-neutral-1)))
- `(vdiff-refine-added ((,class :inherit modus-theme-diff-refine-added)))
- `(vdiff-refine-changed ((,class :inherit modus-theme-diff-refine-changed)))
- `(vdiff-subtraction-face ((,class :inherit modus-theme-diff-removed)))
- `(vdiff-target-face ((,class :inherit modus-theme-intense-blue)))
+ `(vdiff-addition-face ((,class :inherit modus-themes-diff-added)))
+ `(vdiff-change-face ((,class :inherit modus-themes-diff-changed)))
+ `(vdiff-closed-fold-face ((,class :inherit modus-themes-diff-heading)))
+ `(vdiff-refine-added ((,class :inherit modus-themes-diff-refine-added)))
+ `(vdiff-refine-changed ((,class :inherit
modus-themes-diff-refine-changed)))
+ `(vdiff-subtraction-face ((,class :inherit modus-themes-diff-removed)))
+ `(vdiff-target-face ((,class :inherit modus-themes-intense-blue)))
+;;;;; vertico
+ `(vertico-current ((,class :inherit bold :foreground ,fg-main
+ :background ,@(pcase modus-themes-completions
+ ('opinionated (list bg-active))
+ (_ (list bg-inactive))))))
;;;;; vimish-fold
`(vimish-fold-fringe ((,class :foreground ,cyan-active)))
- `(vimish-fold-mouse-face ((,class :inherit modus-theme-intense-blue)))
+ `(vimish-fold-mouse-face ((,class :inherit modus-themes-intense-blue)))
`(vimish-fold-overlay ((,class :background ,bg-alt :foreground
,fg-special-cold)))
;;;;; visible-mark
`(visible-mark-active ((,class :background ,blue-intense-bg)))
@@ -6183,12 +6379,12 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(visible-mark-forward-face1 ((,class :background ,magenta-intense-bg)))
`(visible-mark-forward-face2 ((,class :background ,green-intense-bg)))
;;;;; visual-regexp
- `(vr/group-0 ((,class :inherit modus-theme-intense-blue)))
- `(vr/group-1 ((,class :inherit modus-theme-intense-magenta)))
- `(vr/group-2 ((,class :inherit modus-theme-intense-green)))
- `(vr/match-0 ((,class :inherit modus-theme-refine-yellow)))
- `(vr/match-1 ((,class :inherit modus-theme-refine-yellow)))
- `(vr/match-separator-face ((,class :inherit (modus-theme-intense-neutral
bold))))
+ `(vr/group-0 ((,class :inherit modus-themes-intense-blue)))
+ `(vr/group-1 ((,class :inherit modus-themes-intense-magenta)))
+ `(vr/group-2 ((,class :inherit modus-themes-intense-green)))
+ `(vr/match-0 ((,class :inherit modus-themes-refine-yellow)))
+ `(vr/match-1 ((,class :inherit modus-themes-refine-yellow)))
+ `(vr/match-separator-face ((,class :inherit (modus-themes-intense-neutral
bold))))
;;;;; volatile-highlights
`(vhl/default-face ((,class :background ,bg-alt :foreground
,blue-nuanced-fg :extend t)))
;;;;; vterm
@@ -6232,9 +6428,9 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(web-mode-css-string-face ((,class :inherit web-mode-string-face)))
`(web-mode-css-variable-face ((,class :foreground ,fg-special-warm)))
`(web-mode-current-column-highlight-face ((,class :background ,bg-alt)))
- `(web-mode-current-element-highlight-face ((,class :inherit
modus-theme-special-mild)))
- `(web-mode-doctype-face ((,class :inherit modus-theme-slant :foreground
,fg-special-cold)))
- `(web-mode-error-face ((,class :inherit modus-theme-intense-red)))
+ `(web-mode-current-element-highlight-face ((,class :inherit
modus-themes-special-mild)))
+ `(web-mode-doctype-face ((,class :inherit modus-themes-slant :foreground
,fg-special-cold)))
+ `(web-mode-error-face ((,class :inherit modus-themes-intense-red)))
`(web-mode-filter-face ((,class :inherit font-lock-function-name-face)))
`(web-mode-folded-face ((,class :underline t)))
`(web-mode-function-call-face ((,class :inherit
font-lock-function-name-face)))
@@ -6280,44 +6476,44 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(web-mode-warning-face ((,class :inherit font-lock-warning-face)))
`(web-mode-whitespace-face ((,class :background ,bg-whitespace :foreground
,fg-whitespace)))
;;;;; wgrep
- `(wgrep-delete-face ((,class :inherit modus-theme-refine-yellow)))
- `(wgrep-done-face ((,class :inherit modus-theme-refine-blue)))
- `(wgrep-face ((,class :inherit modus-theme-refine-green)))
+ `(wgrep-delete-face ((,class :inherit modus-themes-refine-yellow)))
+ `(wgrep-done-face ((,class :inherit modus-themes-refine-blue)))
+ `(wgrep-face ((,class :inherit modus-themes-refine-green)))
`(wgrep-file-face ((,class :foreground ,fg-special-warm)))
- `(wgrep-reject-face ((,class :inherit (modus-theme-intense-red bold))))
+ `(wgrep-reject-face ((,class :inherit (modus-themes-intense-red bold))))
;;;;; which-function-mode
`(which-func ((,class :foreground ,magenta-active)))
;;;;; which-key
`(which-key-command-description-face ((,class :foreground ,fg-main)))
`(which-key-group-description-face ((,class :foreground ,magenta-alt)))
`(which-key-highlighted-command-face ((,class :foreground ,yellow
:underline t)))
- `(which-key-key-face ((,class :inherit bold :foreground ,blue-intense)))
+ `(which-key-key-face ((,class :inherit modus-themes-key-binding)))
`(which-key-local-map-description-face ((,class :foreground ,fg-main)))
`(which-key-note-face ((,class :foreground ,fg-special-warm)))
`(which-key-separator-face ((,class :inherit shadow)))
`(which-key-special-key-face ((,class :inherit bold :foreground
,orange-intense)))
;;;;; whitespace-mode
- `(whitespace-big-indent ((,class :inherit modus-theme-subtle-red)))
- `(whitespace-empty ((,class :inherit modus-theme-intense-magenta)))
+ `(whitespace-big-indent ((,class :inherit modus-themes-subtle-red)))
+ `(whitespace-empty ((,class :inherit modus-themes-intense-magenta)))
`(whitespace-hspace ((,class :background ,bg-whitespace :foreground
,fg-whitespace)))
`(whitespace-indentation ((,class :background ,bg-whitespace :foreground
,fg-whitespace)))
`(whitespace-line ((,class :background ,bg-alt)))
`(whitespace-newline ((,class :background ,bg-whitespace :foreground
,fg-whitespace)))
`(whitespace-space ((,class :background ,bg-whitespace :foreground
,fg-whitespace)))
- `(whitespace-space-after-tab ((,class :inherit
modus-theme-subtle-magenta)))
- `(whitespace-space-before-tab ((,class :inherit modus-theme-subtle-cyan)))
+ `(whitespace-space-after-tab ((,class :inherit
modus-themes-subtle-magenta)))
+ `(whitespace-space-before-tab ((,class :inherit modus-themes-subtle-cyan)))
`(whitespace-tab ((,class :background ,bg-whitespace :foreground
,fg-whitespace)))
- `(whitespace-trailing ((,class :inherit modus-theme-intense-red)))
+ `(whitespace-trailing ((,class :inherit modus-themes-intense-red)))
;;;;; window-divider-mode
`(window-divider ((,class :foreground ,fg-window-divider-inner)))
`(window-divider-first-pixel ((,class :foreground
,fg-window-divider-outer)))
`(window-divider-last-pixel ((,class :foreground
,fg-window-divider-outer)))
;;;;; winum
- `(winum-face ((,class :inherit modus-theme-bold :foreground ,cyan-active)))
+ `(winum-face ((,class :inherit modus-themes-bold :foreground
,cyan-active)))
;;;;; writegood-mode
`(writegood-duplicates-face ((,class :background ,bg-alt :foreground
,red-alt :underline t)))
- `(writegood-passive-voice-face ((,class :inherit
modus-theme-lang-warning)))
- `(writegood-weasels-face ((,class :inherit modus-theme-lang-error)))
+ `(writegood-passive-voice-face ((,class :inherit
modus-themes-lang-warning)))
+ `(writegood-weasels-face ((,class :inherit modus-themes-lang-error)))
;;;;; woman
`(woman-addition ((,class :foreground ,magenta-alt-other)))
`(woman-bold ((,class :inherit bold :foreground ,magenta)))
@@ -6333,18 +6529,18 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(xref-line-number ((,class :inherit shadow)))
`(xref-match ((,class :inherit match)))
;;;;; yaml-mode
- `(yaml-tab-face ((,class :inherit modus-theme-intense-red)))
+ `(yaml-tab-face ((,class :inherit modus-themes-intense-red)))
;;;;; yasnippet
`(yas-field-highlight-face ((,class :background ,bg-hl-alt-intense)))
;;;;; ztree
`(ztreep-arrow-face ((,class :foreground ,fg-inactive)))
`(ztreep-diff-header-face ((,class :inherit bold :height 1.2 :foreground
,fg-special-cold)))
- `(ztreep-diff-header-small-face ((,class :inherit bold :foreground
,fg-special-mild)))
- `(ztreep-diff-model-add-face ((,class :foreground ,green)))
+ `(ztreep-diff-header-small-face ((,class :foreground ,fg-main)))
+ `(ztreep-diff-model-add-face ((,class :foreground
,@(modus-themes--diff-deuteran blue green))))
`(ztreep-diff-model-diff-face ((,class :foreground ,red)))
`(ztreep-diff-model-ignored-face ((,class :inherit shadow :strike-through
t)))
`(ztreep-diff-model-normal-face ((,class :inherit shadow)))
- `(ztreep-expand-sign-face ((,class :foreground ,blue)))
+ `(ztreep-expand-sign-face ((,class :inherit ztreep-arrow-face)))
`(ztreep-header-face ((,class :inherit bold :height 1.2 :foreground
,fg-special-cold)))
`(ztreep-leaf-face ((,class :foreground ,cyan)))
`(ztreep-node-count-children-face ((,class :foreground ,fg-special-warm)))
@@ -6362,14 +6558,14 @@ by virtue of calling either of
`modus-themes-load-operandi' and
;;;; exwm
`(exwm-floating-border-color ,fg-window-divider-inner)
;;;; flymake fringe indicators
- `(flymake-error-bitmap '(flymake-double-exclamation-mark
modus-theme-fringe-red))
- `(flymake-warning-bitmap '(exclamation-mark modus-theme-fringe-yellow))
- `(flymake-note-bitmap '(exclamation-mark modus-theme-fringe-cyan))
+ `(flymake-error-bitmap '(flymake-double-exclamation-mark
modus-themes-fringe-red))
+ `(flymake-warning-bitmap '(exclamation-mark modus-themes-fringe-yellow))
+ `(flymake-note-bitmap '(exclamation-mark modus-themes-fringe-cyan))
;;;; ibuffer
- `(ibuffer-deletion-face 'modus-theme-mark-del)
- `(ibuffer-filter-group-name-face 'modus-theme-mark-symbol)
- `(ibuffer-marked-face 'modus-theme-mark-sel)
- `(ibuffer-title-face 'modus-theme-pseudo-header)
+ `(ibuffer-deletion-face 'modus-themes-mark-del)
+ `(ibuffer-filter-group-name-face 'modus-themes-mark-symbol)
+ `(ibuffer-marked-face 'modus-themes-mark-sel)
+ `(ibuffer-title-face 'modus-themes-pseudo-header)
;;;; highlight-tail
`(highlight-tail-colors
'((,green-subtle-bg . 0)
@@ -6425,24 +6621,24 @@ by virtue of calling either of
`modus-themes-load-operandi' and
`(xterm-color-names-bright ["gray35" ,red-alt ,green-alt ,yellow-alt
,blue-alt ,magenta-alt ,cyan-alt "white"])
(if (eq modus-themes-org-blocks 'rainbow)
`(org-src-block-faces ; TODO this list should be expanded
- `(("emacs-lisp" modus-theme-nuanced-magenta)
- ("elisp" modus-theme-nuanced-magenta)
- ("clojure" modus-theme-nuanced-magenta)
- ("clojurescript" modus-theme-nuanced-magenta)
- ("c" modus-theme-nuanced-blue)
- ("c++" modus-theme-nuanced-blue)
- ("sh" modus-theme-nuanced-green)
- ("shell" modus-theme-nuanced-green)
- ("html" modus-theme-nuanced-yellow)
- ("xml" modus-theme-nuanced-yellow)
- ("css" modus-theme-nuanced-red)
- ("scss" modus-theme-nuanced-red)
- ("python" modus-theme-nuanced-green)
- ("ipython" modus-theme-nuanced-magenta)
- ("r" modus-theme-nuanced-cyan)
- ("yaml" modus-theme-nuanced-cyan)
- ("conf" modus-theme-nuanced-cyan)
- ("docker" modus-theme-nuanced-cyan)))
+ `(("emacs-lisp" modus-themes-nuanced-magenta)
+ ("elisp" modus-themes-nuanced-magenta)
+ ("clojure" modus-themes-nuanced-magenta)
+ ("clojurescript" modus-themes-nuanced-magenta)
+ ("c" modus-themes-nuanced-blue)
+ ("c++" modus-themes-nuanced-blue)
+ ("sh" modus-themes-nuanced-green)
+ ("shell" modus-themes-nuanced-green)
+ ("html" modus-themes-nuanced-yellow)
+ ("xml" modus-themes-nuanced-yellow)
+ ("css" modus-themes-nuanced-red)
+ ("scss" modus-themes-nuanced-red)
+ ("python" modus-themes-nuanced-green)
+ ("ipython" modus-themes-nuanced-magenta)
+ ("r" modus-themes-nuanced-cyan)
+ ("yaml" modus-themes-nuanced-cyan)
+ ("conf" modus-themes-nuanced-cyan)
+ ("docker" modus-themes-nuanced-cyan)))
`(org-src-block-faces '())))
"Custom variables for `modus-themes-theme'.")
@@ -6453,4 +6649,11 @@ by virtue of calling either of
`modus-themes-load-operandi' and
(add-to-list 'custom-theme-load-path dir))))
(provide 'modus-themes)
+
+;; Local Variables:
+;; time-stamp-start: "Last-Modified:[ \t]+\\\\?[\"<]"
+;; time-stamp-end: "\\\\?[\">]"
+;; time-stamp-format: "%Y-%02m-%02d %02H:%02M:%02S %5z"
+;; End:
+
;;; modus-themes.el ends here
diff --git a/etc/themes/modus-vivendi-theme.el
b/etc/themes/modus-vivendi-theme.el
index 814f10d..ff59d30 100644
--- a/etc/themes/modus-vivendi-theme.el
+++ b/etc/themes/modus-vivendi-theme.el
@@ -4,7 +4,7 @@
;; Author: Protesilaos Stavrou <info@protesilaos.com>
;; URL: https://gitlab.com/protesilaos/modus-themes
-;; Version: 1.2.3
+;; Version: 1.3.2
;; Package-Requires: ((emacs "26.1"))
;; Keywords: faces, theme, accessibility
@@ -52,6 +52,9 @@
(eval-and-compile
(unless (and (fboundp 'require-theme)
+ load-file-name
+ (equal (file-name-directory load-file-name)
+ (expand-file-name "themes/" data-directory))
(require-theme 'modus-themes t))
(require 'modus-themes)))
diff --git a/leim/Makefile.in b/leim/Makefile.in
index c2f9cf5..2646abc 100644
--- a/leim/Makefile.in
+++ b/leim/Makefile.in
@@ -137,19 +137,23 @@ ${srcdir}/../lisp/language/pinyin.el:
${srcdir}/MISC-DIC/pinyin.map
$(AM_V_GEN)${RUN_EMACS} -l titdic-cnv -f pinyin-convert $< $@
-.PHONY: bootstrap-clean distclean maintainer-clean extraclean
+.PHONY: bootstrap-clean distclean maintainer-clean extraclean gen-clean
+## Perhaps this should run gen-clean.
bootstrap-clean:
rm -f ${TIT_MISC} ${leimdir}/leim-list.el
distclean:
rm -f Makefile
-maintainer-clean: distclean bootstrap-clean
+maintainer-clean: gen-clean distclean
-## We do not delete ja-dic, even in a bootstrap, because it rarely
-## changes and is slow to regenerate.
-extraclean: bootstrap-clean
+## ja-dic rarely changes and is slow to regenerate, and tends to be a
+## bottleneck in parallel builds.
+gen-clean:
+ rm -f ${TIT_MISC} ${leimdir}/leim-list.el
rm -rf ${leimdir}/ja-dic
+extraclean: maintainer-clean
+
### Makefile.in ends here
diff --git a/leim/leim-ext.el b/leim/leim-ext.el
index 687379d..904675c 100644
--- a/leim/leim-ext.el
+++ b/leim/leim-ext.el
@@ -1,4 +1,4 @@
-;; leim-ext.el -- extra leim configuration -*- lexical-binding: t; -*-
+;;; leim-ext.el --- extra leim configuration -*- lexical-binding: t; -*-
;; Copyright (C) 2004-2021 Free Software Foundation, Inc.
;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
diff --git a/lib-src/Makefile.in b/lib-src/Makefile.in
index 05eb524..923d0cf 100644
--- a/lib-src/Makefile.in
+++ b/lib-src/Makefile.in
@@ -189,6 +189,30 @@ LIB_WSOCK32=@LIB_WSOCK32@
## Extra libraries for etags
LIBS_ETAGS = $(LIB_CLOCK_GETTIME) $(LIB_GETRANDOM)
+HAVE_SECCOMP=@HAVE_SECCOMP@
+HAVE_LIBSECCOMP=@HAVE_LIBSECCOMP@
+LIBSECCOMP_LIBS=@LIBSECCOMP_LIBS@
+LIBSECCOMP_CFLAGS=@LIBSECCOMP_CFLAGS@
+
+# Currently, we can only generate seccomp filter files for x86-64.
+ifeq ($(HAVE_SECCOMP),yes)
+ifeq ($(HAVE_LIBSECCOMP),yes)
+ifeq ($(shell uname -m),x86_64)
+# We require SECCOMP_RET_KILL_PROCESS, which is only available in
+# Linux 4.14 and later.
+ifeq ($(shell { echo 4.14; uname -r | cut -d . -f 1-2; } | \
+ sort -C -t . -n -k 1,1 -k 2,2 && \
+ echo 1),1)
+SECCOMP_FILTER=1
+endif
+endif
+endif
+endif
+
+ifeq ($(SECCOMP_FILTER),1)
+DONT_INSTALL += seccomp-filter$(EXEEXT)
+endif
+
## Extra libraries to use when linking movemail.
LIBS_MOVE = $(LIBS_MAIL) $(KRB4LIB) $(DESLIB) $(KRB5LIB) $(CRYPTOLIB) \
$(COM_ERRLIB) $(LIBHESIOD) $(LIBRESOLV) $(LIB_WSOCK32) $(LIBS_ETAGS)
@@ -218,6 +242,10 @@ config_h = ../src/config.h $(srcdir)/../src/conf_post.h
all: ${EXE_FILES} ${SCRIPTS}
+ifeq ($(SECCOMP_FILTER),1)
+all: seccomp-filter.bpf seccomp-filter-exec.bpf
+endif
+
.PHONY: all need-blessmail maybe-blessmail
LOADLIBES = ../lib/libgnu.a $(LIBS_SYSTEM)
@@ -400,4 +428,15 @@ update-game-score${EXEEXT}: ${srcdir}/update-game-score.c
$(NTLIB) $(config_h)
emacsclient.res: ../nt/emacsclient.rc $(NTINC)/../icons/emacs.ico
$(AM_V_RC)$(WINDRES) -O coff --include-dir=$(NTINC)/.. -o $@ $<
+ifeq ($(SECCOMP_FILTER),1)
+seccomp-filter$(EXEEXT): $(srcdir)/seccomp-filter.c $(config_h)
+ $(AM_V_CCLD)$(CC) $(ALL_CFLAGS) $(LIBSECCOMP_CFLAGS) $< \
+ $(LIBSECCOMP_LIBS) -o $@
+
+seccomp-filter.bpf seccomp-filter.pfc seccomp-filter-exec.bpf
seccomp-filter-exec.pfc: seccomp-filter$(EXEEXT)
+ $(AM_V_GEN)./seccomp-filter$(EXEEXT) \
+ seccomp-filter.bpf seccomp-filter.pfc \
+ seccomp-filter-exec.bpf seccomp-filter-exec.pfc
+endif
+
## Makefile ends here.
diff --git a/lib-src/seccomp-filter.c b/lib-src/seccomp-filter.c
new file mode 100644
index 0000000..dc568e0
--- /dev/null
+++ b/lib-src/seccomp-filter.c
@@ -0,0 +1,370 @@
+/* Generate a Secure Computing filter definition file.
+
+Copyright (C) 2020-2021 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the
+Free Software Foundation, either version 3 of the License, or (at your
+option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see
+<https://www.gnu.org/licenses/>. */
+
+/* This program creates a small Secure Computing filter usable for a
+typical minimal Emacs sandbox. See the man page for `seccomp' for
+details about Secure Computing filters. This program requires the
+`libseccomp' library. However, the resulting filter file requires
+only a Linux kernel supporting the Secure Computing extension.
+
+Usage:
+
+ seccomp-filter out.bpf out.pfc out-exec.bpf out-exec.pfc
+
+This writes the raw `struct sock_filter' array to out.bpf and a
+human-readable representation to out.pfc. Additionally, it writes
+variants of those files that can be used to sandbox Emacs before
+'execve' to out-exec.bpf and out-exec.pfc. */
+
+#include "config.h"
+
+#include <assert.h>
+#include <errno.h>
+#include <limits.h>
+#include <stdarg.h>
+#include <stdbool.h>
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <time.h>
+
+#include <asm/prctl.h>
+#include <sys/ioctl.h>
+#include <sys/mman.h>
+#include <sys/prctl.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <linux/futex.h>
+#include <linux/filter.h>
+#include <linux/seccomp.h>
+#include <fcntl.h>
+#include <sched.h>
+#include <seccomp.h>
+#include <unistd.h>
+
+#include "verify.h"
+
+#ifndef ARCH_CET_STATUS
+#define ARCH_CET_STATUS 0x3001
+#endif
+
+static ATTRIBUTE_FORMAT_PRINTF (2, 3) _Noreturn void
+fail (int error, const char *format, ...)
+{
+ va_list ap;
+ va_start (ap, format);
+ if (error == 0)
+ {
+ vfprintf (stderr, format, ap);
+ fputc ('\n', stderr);
+ }
+ else
+ {
+ char buffer[1000];
+ vsnprintf (buffer, sizeof buffer, format, ap);
+ errno = error;
+ perror (buffer);
+ }
+ va_end (ap);
+ fflush (NULL);
+ exit (EXIT_FAILURE);
+}
+
+/* This binary is trivial, so we use a single global filter context
+ object that we release using `atexit'. */
+
+static scmp_filter_ctx ctx;
+
+static void
+release_context (void)
+{
+ seccomp_release (ctx);
+}
+
+/* Wrapper functions and macros for libseccomp functions. We exit
+ immediately upon any error to avoid error checking noise. */
+
+static void
+set_attribute (enum scmp_filter_attr attr, uint32_t value)
+{
+ int status = seccomp_attr_set (ctx, attr, value);
+ if (status < 0)
+ fail (-status, "seccomp_attr_set (ctx, %u, %u)", attr, value);
+}
+
+/* Like `seccomp_rule_add (ACTION, SYSCALL, ...)', except that you
+ don't have to specify the number of comparator arguments, and any
+ failure will exit the process. */
+
+#define RULE(action, syscall, ...) \
+ do \
+ { \
+ const struct scmp_arg_cmp arg_array[] = {__VA_ARGS__}; \
+ enum { arg_cnt = sizeof arg_array / sizeof *arg_array }; \
+ int status = seccomp_rule_add_array (ctx, (action), (syscall), \
+ arg_cnt, arg_array); \
+ if (status < 0) \
+ fail (-status, "seccomp_rule_add_array (%s, %s, %d, {%s})", \
+ #action, #syscall, arg_cnt, #__VA_ARGS__); \
+ } \
+ while (false)
+
+static void
+export_filter (const char *file,
+ int (*function) (const scmp_filter_ctx, int),
+ const char *name)
+{
+ int fd = TEMP_FAILURE_RETRY (
+ open (file, O_WRONLY | O_CREAT | O_TRUNC | O_BINARY | O_CLOEXEC,
+ 0644));
+ if (fd < 0)
+ fail (errno, "open %s", file);
+ int status = function (ctx, fd);
+ if (status < 0)
+ fail (-status, "%s", name);
+ if (close (fd) != 0)
+ fail (errno, "close");
+}
+
+#define EXPORT_FILTER(file, function) \
+ export_filter ((file), (function), #function)
+
+int
+main (int argc, char **argv)
+{
+ if (argc != 5)
+ fail (0, "usage: %s out.bpf out.pfc out-exec.bpf out-exec.pfc",
+ argv[0]);
+
+ /* Any unhandled syscall should abort the Emacs process. */
+ ctx = seccomp_init (SCMP_ACT_KILL_PROCESS);
+ if (ctx == NULL)
+ fail (0, "seccomp_init");
+ atexit (release_context);
+
+ /* We want to abort immediately if the architecture is unknown. */
+ set_attribute (SCMP_FLTATR_ACT_BADARCH, SCMP_ACT_KILL_PROCESS);
+ set_attribute (SCMP_FLTATR_CTL_NNP, 1);
+ set_attribute (SCMP_FLTATR_CTL_TSYNC, 1);
+
+ verify (CHAR_BIT == 8);
+ verify (sizeof (int) == 4 && INT_MIN == INT32_MIN
+ && INT_MAX == INT32_MAX);
+ verify (sizeof (long) == 8 && LONG_MIN == INT64_MIN
+ && LONG_MAX == INT64_MAX);
+ verify (sizeof (void *) == 8);
+ assert ((uintptr_t) NULL == 0);
+
+ /* Allow a clean exit. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (exit));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (exit_group));
+
+ /* Allow `mmap' and friends. This is necessary for dynamic loading,
+ reading the portable dump file, and thread creation. We don't
+ allow pages to be both writable and executable. */
+ verify (MAP_PRIVATE != 0);
+ verify (MAP_SHARED != 0);
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (mmap),
+ SCMP_A2_32 (SCMP_CMP_MASKED_EQ,
+ ~(PROT_NONE | PROT_READ | PROT_WRITE)),
+ /* Only support known flags. MAP_DENYWRITE is ignored, but
+ some versions of the dynamic loader still use it. Also
+ allow allocating thread stacks. */
+ SCMP_A3_32 (SCMP_CMP_MASKED_EQ,
+ ~(MAP_SHARED | MAP_PRIVATE | MAP_FILE
+ | MAP_ANONYMOUS | MAP_FIXED | MAP_DENYWRITE
+ | MAP_STACK | MAP_NORESERVE),
+ 0));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (mmap),
+ SCMP_A2_32 (SCMP_CMP_MASKED_EQ,
+ ~(PROT_NONE | PROT_READ | PROT_EXEC)),
+ /* Only support known flags. MAP_DENYWRITE is ignored, but
+ some versions of the dynamic loader still use it. */
+ SCMP_A3_32 (SCMP_CMP_MASKED_EQ,
+ ~(MAP_PRIVATE | MAP_ANONYMOUS | MAP_FIXED
+ | MAP_DENYWRITE),
+ 0));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (munmap));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (mprotect),
+ /* Don't allow making pages executable. */
+ SCMP_A2_32 (SCMP_CMP_MASKED_EQ,
+ ~(PROT_NONE | PROT_READ | PROT_WRITE), 0));
+
+ /* Futexes are used everywhere. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (futex),
+ SCMP_A1_32 (SCMP_CMP_EQ, FUTEX_WAKE_PRIVATE));
+
+ /* Allow basic dynamic memory management. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (brk));
+
+ /* Allow some status inquiries. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (uname));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (getuid));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (geteuid));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (getpid));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (getpgrp));
+
+ /* Allow operations on open file descriptors. File descriptors are
+ capabilities, and operating on them shouldn't cause security
+ issues. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (read));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (write));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (close));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (lseek));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (dup));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (dup2));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (fstat));
+
+ /* Allow read operations on the filesystem. If necessary, these
+ should be further restricted using mount namespaces. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (access));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (faccessat));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (stat));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (stat64));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (lstat));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (lstat64));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (fstatat64));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (newfstatat));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (readlink));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (readlinkat));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (getcwd));
+
+ /* Allow opening files, assuming they are only opened for
+ reading. */
+ verify (O_WRONLY != 0);
+ verify (O_RDWR != 0);
+ verify (O_CREAT != 0);
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (open),
+ SCMP_A1_32 (SCMP_CMP_MASKED_EQ,
+ ~(O_RDONLY | O_BINARY | O_CLOEXEC | O_PATH
+ | O_DIRECTORY | O_NOFOLLOW),
+ 0));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (openat),
+ SCMP_A2_32 (SCMP_CMP_MASKED_EQ,
+ ~(O_RDONLY | O_BINARY | O_CLOEXEC | O_PATH
+ | O_DIRECTORY | O_NOFOLLOW),
+ 0));
+
+ /* Allow `tcgetpgrp'. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (ioctl),
+ SCMP_A0_32 (SCMP_CMP_EQ, STDIN_FILENO),
+ SCMP_A1_32 (SCMP_CMP_EQ, TIOCGPGRP));
+
+ /* Allow reading (but not setting) file flags. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (fcntl),
+ SCMP_A1_32 (SCMP_CMP_EQ, F_GETFL));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (fcntl64),
+ SCMP_A1_32 (SCMP_CMP_EQ, F_GETFL));
+
+ /* Allow reading random numbers from the kernel. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (getrandom));
+
+ /* Changing the umask is uncritical. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (umask));
+
+ /* Allow creation of pipes. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (pipe));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (pipe2));
+
+ /* Allow reading (but not changing) resource limits. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (getrlimit));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (prlimit64),
+ SCMP_A0_32 (SCMP_CMP_EQ, 0) /* pid == 0 (current process) */,
+ SCMP_A2_64 (SCMP_CMP_EQ, 0) /* new_limit == NULL */);
+
+ /* Block changing resource limits, but don't crash. */
+ RULE (SCMP_ACT_ERRNO (EPERM), SCMP_SYS (prlimit64),
+ SCMP_A0_32 (SCMP_CMP_EQ, 0) /* pid == 0 (current process) */,
+ SCMP_A2_64 (SCMP_CMP_NE, 0) /* new_limit != NULL */);
+
+ /* Emacs installs signal handlers, which is harmless. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (sigaction));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (rt_sigaction));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (sigprocmask));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (rt_sigprocmask));
+
+ /* Allow reading the current time. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (clock_gettime),
+ SCMP_A0_32 (SCMP_CMP_EQ, CLOCK_REALTIME));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (time));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (gettimeofday));
+
+ /* Allow timer support. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (timer_create));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (timerfd_create));
+
+ /* Allow thread creation. See the NOTES section in the manual page
+ for the `clone' function. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (clone),
+ SCMP_A0_64 (SCMP_CMP_MASKED_EQ,
+ /* Flags needed to create threads. See
+ create_thread in libc. */
+ ~(CLONE_VM | CLONE_FS | CLONE_FILES
+ | CLONE_SYSVSEM | CLONE_SIGHAND | CLONE_THREAD
+ | CLONE_SETTLS | CLONE_PARENT_SETTID
+ | CLONE_CHILD_CLEARTID),
+ 0));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (sigaltstack));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (set_robust_list));
+
+ /* Allow setting the process name for new threads. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (prctl),
+ SCMP_A0_32 (SCMP_CMP_EQ, PR_SET_NAME));
+
+ /* Allow some event handling functions used by glib. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (eventfd));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (eventfd2));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (wait4));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (poll));
+
+ /* Don't allow creating sockets (network access would be extremely
+ dangerous), but also don't crash. */
+ RULE (SCMP_ACT_ERRNO (EACCES), SCMP_SYS (socket));
+
+ EXPORT_FILTER (argv[1], seccomp_export_bpf);
+ EXPORT_FILTER (argv[2], seccomp_export_pfc);
+
+ /* When applying a Seccomp filter before executing the Emacs binary
+ (e.g. using the `bwrap' program), we need to allow further system
+ calls. Firstly, the wrapper binary will need to `execve' the
+ Emacs binary. Furthermore, the C library requires some system
+ calls at startup time to set up thread-local storage. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (execve));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (set_tid_address));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (arch_prctl),
+ SCMP_A0_32 (SCMP_CMP_EQ, ARCH_SET_FS));
+ RULE (SCMP_ACT_ERRNO (EINVAL), SCMP_SYS (arch_prctl),
+ SCMP_A0_32 (SCMP_CMP_EQ, ARCH_CET_STATUS));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (statfs));
+
+ /* We want to allow starting the Emacs binary itself with the
+ --seccomp flag, so we need to allow the `prctl' and `seccomp'
+ system calls. */
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (prctl),
+ SCMP_A0_32 (SCMP_CMP_EQ, PR_SET_NO_NEW_PRIVS),
+ SCMP_A1_64 (SCMP_CMP_EQ, 1), SCMP_A2_64 (SCMP_CMP_EQ, 0),
+ SCMP_A3_64 (SCMP_CMP_EQ, 0), SCMP_A4_64 (SCMP_CMP_EQ, 0));
+ RULE (SCMP_ACT_ALLOW, SCMP_SYS (seccomp),
+ SCMP_A0_32 (SCMP_CMP_EQ, SECCOMP_SET_MODE_FILTER),
+ SCMP_A1_32 (SCMP_CMP_EQ, SECCOMP_FILTER_FLAG_TSYNC));
+
+ EXPORT_FILTER (argv[3], seccomp_export_bpf);
+ EXPORT_FILTER (argv[4], seccomp_export_pfc);
+}
diff --git a/lib/Makefile.in b/lib/Makefile.in
index 043ace2..68a0247 100644
--- a/lib/Makefile.in
+++ b/lib/Makefile.in
@@ -31,12 +31,18 @@ all:
-include ${top_builddir}/src/verbose.mk
+HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@
+
ALL_CFLAGS= \
$(C_SWITCH_SYSTEM) $(C_SWITCH_MACHINE) $(DEPFLAGS) \
$(GNULIB_WARN_CFLAGS) $(WERROR_CFLAGS) $(PROFILING_CFLAGS) $(CFLAGS) \
-I. -I../src -I$(srcdir) -I$(srcdir)/../src \
$(if $(patsubst e-%,,$(notdir $<)),,-Demacs)
+ifeq ($(HAVE_NATIVE_COMP),yes)
+ALL_CFLAGS += -DGL_COMPILE_CRYPTO_STREAM
+endif
+
SYSTEM_TYPE = @SYSTEM_TYPE@
ifeq ($(SYSTEM_TYPE),windows-nt)
include $(srcdir)/../nt/gnulib-cfg.mk
diff --git a/lib/af_alg.h b/lib/af_alg.h
new file mode 100644
index 0000000..4c5854c
--- /dev/null
+++ b/lib/af_alg.h
@@ -0,0 +1,115 @@
+/* af_alg.h - Compute message digests from file streams and buffers.
+ Copyright (C) 2018-2020 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 2, or (at your option) any
+ later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, see <https://www.gnu.org/licenses/>. */
+
+/* Written by Matteo Croce <mcroce@redhat.com>, 2018.
+ Documentation by Bruno Haible <bruno@clisp.org>, 2018. */
+
+/* Declare specific functions for computing message digests
+ using the Linux kernel crypto API, if available. This kernel API gives
+ access to specialized crypto instructions (that would also be available
+ in user space) or to crypto devices (not directly available in user space).
+
+ For a more complete set of facilities that use the Linux kernel crypto API,
+ look at libkcapi. */
+
+#ifndef AF_ALG_H
+# define AF_ALG_H 1
+
+# include <stdio.h>
+# include <errno.h>
+
+# ifdef __cplusplus
+extern "C" {
+# endif
+
+# if USE_LINUX_CRYPTO_API
+
+/* Compute a message digest of a memory region.
+
+ The memory region starts at BUFFER and is LEN bytes long.
+
+ ALG is the message digest algorithm; see the file /proc/crypto.
+
+ RESBLOCK points to a block of HASHLEN bytes, for the result.
+ HASHLEN must be the length of the message digest, in bytes, in particular:
+
+ alg | hashlen
+ -------+--------
+ md5 | 16
+ sha1 | 20
+ sha224 | 28
+ sha256 | 32
+ sha384 | 48
+ sha512 | 64
+
+ If successful, fill RESBLOCK and return 0.
+ Upon failure, return a negated error number. */
+int
+afalg_buffer (const char *buffer, size_t len, const char *alg,
+ void *resblock, ssize_t hashlen);
+
+/* Compute a message digest of data read from STREAM.
+
+ STREAM is an open file stream. The last operation on STREAM should
+ not be 'ungetc', and if STREAM is also open for writing it should
+ have been fflushed since its last write. Read from the current
+ position to the end of STREAM. Handle regular files efficiently.
+
+ ALG is the message digest algorithm; see the file /proc/crypto.
+
+ RESBLOCK points to a block of HASHLEN bytes, for the result.
+ HASHLEN must be the length of the message digest, in bytes, in particular:
+
+ alg | hashlen
+ -------+--------
+ md5 | 16
+ sha1 | 20
+ sha224 | 28
+ sha256 | 32
+ sha384 | 48
+ sha512 | 64
+
+ If successful, fill RESBLOCK and return 0.
+ Upon failure, return a negated error number.
+ Unless returning 0 or -EIO, restore STREAM's file position so that
+ the caller can fall back on some other method. */
+int
+afalg_stream (FILE *stream, const char *alg,
+ void *resblock, ssize_t hashlen);
+
+# else
+
+static inline int
+afalg_buffer (const char *buffer, size_t len, const char *alg,
+ void *resblock, ssize_t hashlen)
+{
+ return -EAFNOSUPPORT;
+}
+
+static inline int
+afalg_stream (FILE *stream, const char *alg,
+ void *resblock, ssize_t hashlen)
+{
+ return -EAFNOSUPPORT;
+}
+
+# endif
+
+# ifdef __cplusplus
+}
+# endif
+
+#endif /* AF_ALG_H */
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index 8ea2841..b970451 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -30,6 +30,13 @@ EXEEXT = @EXEEXT@
# limitation.
XARGS_LIMIT = @XARGS_LIMIT@
+HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@
+ifeq ($(HAVE_NATIVE_COMP),yes)
+ifndef NATIVE_FULL_AOT
+NATIVE_SKIP_NONDUMP = 1
+endif
+endif
+
-include ${top_builddir}/src/verbose.mk
FIND_DELETE = @FIND_DELETE@
@@ -82,8 +89,12 @@ COMPILE_FIRST = \
$(lisp)/emacs-lisp/macroexp.elc \
$(lisp)/emacs-lisp/cconv.elc \
$(lisp)/emacs-lisp/byte-opt.elc \
- $(lisp)/emacs-lisp/bytecomp.elc \
- $(lisp)/emacs-lisp/autoload.elc
+ $(lisp)/emacs-lisp/bytecomp.elc
+ifeq ($(HAVE_NATIVE_COMP),yes)
+COMPILE_FIRST += $(lisp)/emacs-lisp/comp.elc
+COMPILE_FIRST += $(lisp)/emacs-lisp/comp-cstr.elc
+endif
+COMPILE_FIRST += $(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 \
@@ -260,9 +271,15 @@ TAGS: ${ETAGS} ${tagsfiles}
THEFILE = no-such-file
.PHONY: $(THEFILE)c
$(THEFILE)c:
+ifeq ($(HAVE_NATIVE_COMP),yes)
+ $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \
+ -l comp -f byte-compile-refresh-preloaded \
+ -f batch-byte-native-compile-for-bootstrap $(THEFILE)
+else
$(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \
-l bytecomp -f byte-compile-refresh-preloaded \
-f batch-byte-compile $(THEFILE)
+endif
# Files MUST be compiled one by one. If we compile several files in a
# row (i.e., in the same instance of Emacs) we can't make sure that
@@ -275,8 +292,14 @@ $(THEFILE)c:
# An old-fashioned suffix rule, which, according to the GNU Make manual,
# cannot have prerequisites.
+ifeq ($(HAVE_NATIVE_COMP),yes)
+.el.elc:
+ $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \
+ -l comp -f batch-byte-native-compile-for-bootstrap $<
+else
.el.elc:
$(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $<
+endif
.PHONY: compile-first compile-main compile compile-always
@@ -294,7 +317,13 @@ compile-first: $(COMPILE_FIRST)
.PHONY: compile-targets
# TARGETS is set dynamically in the recursive call from 'compile-main'.
+# Do not build comp.el unless necessary not to exceed max-specpdl-size and
+# max-lisp-eval-depth in normal builds.
+ifneq ($(HAVE_NATIVE_COMP),yes)
+compile-targets: $(filter-out ./emacs-lisp/comp-cstr.elc,$(filter-out
./emacs-lisp/comp.elc,$(TARGETS)))
+else
compile-targets: $(TARGETS)
+endif
# Compile all the Elisp files that need it. Beware: it approximates
# 'no-byte-compile', so watch out for false-positives!
@@ -307,9 +336,11 @@ compile-main: gen-lisp compile-clean
GREP_OPTIONS= grep '^;.*[^a-zA-Z]no-byte-compile: *t' $$el >
/dev/null && \
continue; \
echo "$${el}c"; \
- done | xargs $(XARGS_LIMIT) echo) | \
- while read chunk; do \
- $(MAKE) compile-targets TARGETS="$$chunk"; \
+ done | xargs $(XARGS_LIMIT) echo) | \
+ while read chunk; do \
+ $(MAKE) compile-targets \
+ NATIVE_DISABLED=$(NATIVE_SKIP_NONDUMP) \
+ TARGETS="$$chunk"; \
done
.PHONY: compile-clean
@@ -449,8 +480,10 @@ maintainer-clean: distclean bootstrap-clean
rm -f TAGS
extraclean: bootstrap-clean distclean
- -for file in $(LOADDEFS); do rm -f $${file}~; done
+ -for file in $(loaddefs); do rm -f $${file}~; done
-rm -f $(lisp)/loaddefs.el~
+ -find $(lisp) -name '*~' $(FIND_DELETE)
+ -find $(lisp) -name '#*' $(FIND_DELETE)
.PHONY: check-declare
diff --git a/lisp/align.el b/lisp/align.el
index 7ae067f..a0b626a 100644
--- a/lisp/align.el
+++ b/lisp/align.el
@@ -1587,8 +1587,6 @@ aligner would have dealt with are."
(if report
(message "Aligning...done"))))
-;; Provide:
-
(provide 'align)
(run-hooks 'align-load-hook)
diff --git a/lisp/allout-widgets.el b/lisp/allout-widgets.el
index 931dfbc..0e12704 100644
--- a/lisp/allout-widgets.el
+++ b/lisp/allout-widgets.el
@@ -1,4 +1,4 @@
-;; allout-widgets.el --- Visually highlight allout outline structure. -*-
lexical-binding: t; -*-
+;;; allout-widgets.el --- Visually highlight allout outline structure. -*-
lexical-binding: t; -*-
;; Copyright (C) 2005-2021 Free Software Foundation, Inc.
@@ -2290,10 +2290,11 @@ The elements of LIST are not copied, just the list
structure itself."
(define-obsolete-function-alias 'allout-frame-property #'frame-parameter
"28.1")
-;;;_ : provide
(provide 'allout-widgets)
;;;_ . Local emacs vars.
;;;_ , Local variables:
;;;_ , allout-layout: (-1 : 0)
;;;_ , End:
+
+;;; allout-widgets.el ends here
diff --git a/lisp/allout.el b/lisp/allout.el
index f50f5fd..1605ce2 100644
--- a/lisp/allout.el
+++ b/lisp/allout.el
@@ -6457,7 +6457,6 @@ If BEG is bigger than END we return 0."
(isearch-repeat 'forward)
(isearch-mode t)))
-;;;_ #11 Provide
(provide 'allout)
;;;_* Local emacs vars.
diff --git a/lisp/array.el b/lisp/array.el
index cd8971b..6632da5 100644
--- a/lisp/array.el
+++ b/lisp/array.el
@@ -1,4 +1,4 @@
-;;; array.el --- array editing commands for GNU Emacs
+;;; array.el --- array editing commands for GNU Emacs -*- lexical-binding: t;
-*-
;; Copyright (C) 1987, 2000-2021 Free Software Foundation, Inc.
@@ -769,25 +769,25 @@ Return COLUMN."
(defvar array-mode-map
(let ((map (make-keymap)))
- (define-key map "\M-ad" 'array-display-local-variables)
- (define-key map "\M-am" 'array-make-template)
- (define-key map "\M-ae" 'array-expand-rows)
- (define-key map "\M-ar" 'array-reconfigure-rows)
- (define-key map "\M-a=" 'array-what-position)
- (define-key map "\M-ag" 'array-goto-cell)
- (define-key map "\M-af" 'array-fill-rectangle)
- (define-key map "\C-n" 'array-next-row)
- (define-key map "\C-p" 'array-previous-row)
- (define-key map "\C-f" 'array-forward-column)
- (define-key map "\C-b" 'array-backward-column)
- (define-key map "\M-n" 'array-copy-down)
- (define-key map "\M-p" 'array-copy-up)
- (define-key map "\M-f" 'array-copy-forward)
- (define-key map "\M-b" 'array-copy-backward)
- (define-key map "\M-\C-n" 'array-copy-row-down)
- (define-key map "\M-\C-p" 'array-copy-row-up)
- (define-key map "\M-\C-f" 'array-copy-column-forward)
- (define-key map "\M-\C-b" 'array-copy-column-backward)
+ (define-key map "\M-ad" #'array-display-local-variables)
+ (define-key map "\M-am" #'array-make-template)
+ (define-key map "\M-ae" #'array-expand-rows)
+ (define-key map "\M-ar" #'array-reconfigure-rows)
+ (define-key map "\M-a=" #'array-what-position)
+ (define-key map "\M-ag" #'array-goto-cell)
+ (define-key map "\M-af" #'array-fill-rectangle)
+ (define-key map "\C-n" #'array-next-row)
+ (define-key map "\C-p" #'array-previous-row)
+ (define-key map "\C-f" #'array-forward-column)
+ (define-key map "\C-b" #'array-backward-column)
+ (define-key map "\M-n" #'array-copy-down)
+ (define-key map "\M-p" #'array-copy-up)
+ (define-key map "\M-f" #'array-copy-forward)
+ (define-key map "\M-b" #'array-copy-backward)
+ (define-key map "\M-\C-n" #'array-copy-row-down)
+ (define-key map "\M-\C-p" #'array-copy-row-up)
+ (define-key map "\M-\C-f" #'array-copy-column-forward)
+ (define-key map "\M-\C-b" #'array-copy-column-backward)
map)
"Keymap used in array mode.")
@@ -815,17 +815,17 @@ in array mode may have different values assigned to the
variables.
The variables are:
Variables you assign:
- array-max-row: The number of rows in the array.
- array-max-column: The number of columns in the array.
- array-columns-per-line: The number of columns in the array
+ `array-max-row': The number of rows in the array.
+ `array-max-column': The number of columns in the array.
+ `array-columns-per-line': The number of columns in the array
per line of buffer.
- array-field-width: The width of each field, in characters.
- array-rows-numbered: A logical variable describing whether to ignore
+ `array-field-width': The width of each field, in characters.
+ `array-rows-numbered': A logical variable describing whether to ignore
row numbers in the buffer.
Variables which are calculated:
- array-line-length: The number of characters in a buffer line.
- array-lines-per-row: The number of buffer lines used to
+ `array-line-length': The number of characters in a buffer line.
+ `array-lines-per-row': The number of buffer lines used to
display each row.
The following commands are available (an asterisk indicates it may
diff --git a/lisp/autoarg.el b/lisp/autoarg.el
index c2cb0c7..7c2c6f1 100644
--- a/lisp/autoarg.el
+++ b/lisp/autoarg.el
@@ -107,7 +107,7 @@ then invokes the normal binding of \\[autoarg-terminate].
`C-u \\[autoarg-terminate]' invokes the normal binding of
\\[autoarg-terminate] four times.
\\{autoarg-mode-map}"
- nil " Aarg" autoarg-mode-map :global t :group 'keyboard)
+ :lighter" Aarg" :global t :group 'keyboard)
;;;###autoload
(define-minor-mode autoarg-kp-mode
@@ -118,7 +118,7 @@ This is similar to `autoarg-mode' but rebinds the keypad
keys
`kp-1' etc. to supply digit arguments.
\\{autoarg-kp-mode-map}"
- nil " Aakp" autoarg-kp-mode-map :global t :group 'keyboard
+ :lighter " Aakp" :global t :group 'keyboard
(if autoarg-kp-mode
(dotimes (i 10)
(let ((sym (intern (format "kp-%d" i))))
diff --git a/lisp/autorevert.el b/lisp/autorevert.el
index 57258f9..edd4c7e 100644
--- a/lisp/autorevert.el
+++ b/lisp/autorevert.el
@@ -227,10 +227,10 @@ modes, etc., of files. You may still sometimes want to
revert
them manually.
Use this option with care since it could lead to excessive auto-reverts.
-For more information, see Info node `(emacs)Autorevert'."
+For more information, see Info node `(emacs)Auto Revert'."
:group 'auto-revert
:type 'boolean
- :link '(info-link "(emacs)Autorevert"))
+ :link '(info-link "(emacs)Auto Revert"))
(defcustom global-auto-revert-ignore-modes ()
"List of major modes Global Auto-Revert Mode should not check."
@@ -937,7 +937,6 @@ the timer when no buffers need to be checked."
(cancel-timer auto-revert-timer))
(setq auto-revert-timer nil)))))
-;; The end:
(provide 'autorevert)
(run-hooks 'auto-revert-load-hook)
diff --git a/lisp/avoid.el b/lisp/avoid.el
index 3b3848e..d3afecf 100644
--- a/lisp/avoid.el
+++ b/lisp/avoid.el
@@ -1,4 +1,4 @@
-;;; avoid.el --- make mouse pointer stay out of the way of editing
+;;; avoid.el --- make mouse pointer stay out of the way of editing -*-
lexical-binding: t -*-
;; Copyright (C) 1993-1994, 2000-2021 Free Software Foundation, Inc.
@@ -80,7 +80,6 @@ use either \\[customize] or \\[mouse-avoidance-mode]."
:initialize 'custom-initialize-default
:type '(choice (const :tag "none" nil) (const banish) (const jump)
(const animate) (const exile) (const proteus))
- :group 'avoid
:require 'avoid
:version "20.3")
@@ -89,25 +88,21 @@ use either \\[customize] or \\[mouse-avoidance-mode]."
"Average distance that mouse will be moved when approached by cursor.
Only applies in Mouse Avoidance mode `jump' and its derivatives.
For best results make this larger than `mouse-avoidance-threshold'."
- :type 'integer
- :group 'avoid)
+ :type 'integer)
(defcustom mouse-avoidance-nudge-var 10
"Variability of `mouse-avoidance-nudge-dist' (which see)."
- :type 'integer
- :group 'avoid)
+ :type 'integer)
(defcustom mouse-avoidance-animation-delay .01
"Delay between animation steps, in seconds."
- :type 'number
- :group 'avoid)
+ :type 'number)
(defcustom mouse-avoidance-threshold 5
"Mouse-pointer's flight distance.
If the cursor gets closer than this, the mouse pointer will move away.
Only applies in Mouse Avoidance modes `animate' and `jump'."
- :type 'integer
- :group 'avoid)
+ :type 'integer)
(defcustom mouse-avoidance-banish-position '((frame-or-window . frame)
(side . right)
@@ -380,7 +375,7 @@ redefine this function to suit your own tastes."
(mouse-avoidance-nudge-mouse)
(if (not (eq (selected-frame) (car old-pos)))
;; This should never happen.
- (apply 'set-mouse-position old-pos)))))
+ (apply #'set-mouse-position old-pos)))))
;;;###autoload
(defun mouse-avoidance-mode (&optional mode)
diff --git a/lisp/bs.el b/lisp/bs.el
index 9ed0ee5..494bc42 100644
--- a/lisp/bs.el
+++ b/lisp/bs.el
@@ -120,8 +120,6 @@
;; can cycle through all file buffers and *scratch* although your current
;; configuration perhaps is "files" which ignores buffer *scratch*.
-;;; History:
-
;;; Code:
;; ----------------------------------------------------------------------
@@ -1506,7 +1504,6 @@ name of buffer configuration."
;; continue standard unloading
nil)
-;; Now provide feature bs
(provide 'bs)
;;; bs.el ends here
diff --git a/lisp/calc/calc-alg.el b/lisp/calc/calc-alg.el
index 1327cf0..162026d 100644
--- a/lisp/calc/calc-alg.el
+++ b/lisp/calc/calc-alg.el
@@ -444,12 +444,12 @@ Code can refer to the expression to simplify via lexical
variable `expr'
and should return the simplified expression to use (or nil)."
(declare (indent 1) (debug (sexp body)))
(cons 'progn
- (mapcar #'(lambda (func)
- `(put ',func 'math-simplify
- (nconc
- (get ',func 'math-simplify)
- (list
- #'(lambda (expr) ,@code)))))
+ (mapcar (lambda (func)
+ `(put ',func 'math-simplify
+ (nconc
+ (get ',func 'math-simplify)
+ (list
+ (lambda (expr) ,@code)))))
(if (symbolp funcs) (list funcs) funcs))))
(math-defsimplify (+ -)
diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el
index 24781ed..e85ecf0 100644
--- a/lisp/calc/calc-ext.el
+++ b/lisp/calc/calc-ext.el
@@ -2784,23 +2784,23 @@ If X is not an error form, return 1."
(declare (indent 1) (debug (sexp body)))
(setq math-integral-cache nil)
(cons 'progn
- (mapcar #'(lambda (func)
- `(put ',func 'math-integral
- (nconc
- (get ',func 'math-integral)
- (list
- #'(lambda (u) ,@code)))))
+ (mapcar (lambda (func)
+ `(put ',func 'math-integral
+ (nconc
+ (get ',func 'math-integral)
+ (list
+ (lambda (u) ,@code)))))
(if (symbolp funcs) (list funcs) funcs))))
(defmacro math-defintegral-2 (funcs &rest code)
(declare (indent 1) (debug (sexp body)))
(setq math-integral-cache nil)
(cons 'progn
- (mapcar #'(lambda (func)
- `(put ',func 'math-integral-2
- (nconc
- (get ',func 'math-integral-2)
- (list #'(lambda (u v) ,@code)))))
+ (mapcar (lambda (func)
+ `(put ',func 'math-integral-2
+ (nconc
+ (get ',func 'math-integral-2)
+ (list (lambda (u v) ,@code)))))
(if (symbolp funcs) (list funcs) funcs))))
(defvar var-IntegAfterRules 'calc-IntegAfterRules)
diff --git a/lisp/calc/calc-menu.el b/lisp/calc/calc-menu.el
index ac14e36..516f62d 100644
--- a/lisp/calc/calc-menu.el
+++ b/lisp/calc/calc-menu.el
@@ -1669,3 +1669,5 @@
["Quit" calc-quit]))
(provide 'calc-menu)
+
+;;; calc-menu.el ends here
diff --git a/lisp/calc/calc-nlfit.el b/lisp/calc/calc-nlfit.el
index 11867f1..f676b09 100644
--- a/lisp/calc/calc-nlfit.el
+++ b/lisp/calc/calc-nlfit.el
@@ -819,3 +819,5 @@
(calc-record traillist "parm")))))
(provide 'calc-nlfit)
+
+;;; calc-nlfit.el ends here
diff --git a/lisp/calc/calc-prog.el b/lisp/calc/calc-prog.el
index dd22145..4e27d76 100644
--- a/lisp/calc/calc-prog.el
+++ b/lisp/calc/calc-prog.el
@@ -1881,9 +1881,9 @@ Redefine the corresponding command."
(if (fboundp (setq chk (intern (concat "math-" qual-name))))
(append rest
(if is-rest
- `((mapcar #'(lambda (x)
- (or (,chk x)
- (math-reject-arg x ',qual)))
+ `((mapcar (lambda (x)
+ (or (,chk x)
+ (math-reject-arg x ',qual)))
,var))
`((or (,chk ,var)
(math-reject-arg ,var ',qual)))))
@@ -1894,9 +1894,9 @@ Redefine the corresponding command."
qual-name 1))))))
(append rest
(if is-rest
- `((mapcar #'(lambda (x)
- (and (,chk x)
- (math-reject-arg x ',qual)))
+ `((mapcar (lambda (x)
+ (and (,chk x)
+ (math-reject-arg x ',qual)))
,var))
`((and
(,chk ,var)
diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el
index ec09abb..1e7d5e7 100644
--- a/lisp/calc/calc.el
+++ b/lisp/calc/calc.el
@@ -483,6 +483,11 @@ current precision are displayed in scientific notation in
calc-mode.")
"Floating-point numbers with this negative exponent or lower are displayed
scientific notation in calc-mode.")
+(defvar calc-digit-after-point nil
+ "If t, display at least one digit after the decimal point, as in `12.0'.
+If nil, the decimal point may come last in a number, as in `12.'.
+This setting only applies to floats in normal display mode.")
+
(defvar calc-other-modes nil
"List of used-defined strings to append to Calculator mode line.")
@@ -3184,7 +3189,8 @@ the United States."
exp (- exp adj)))))
(setq str (int-to-string mant))
(let* ((len (length str))
- (dpos (+ exp len)))
+ (dpos (+ exp len))
+ (trailing-0 (and calc-digit-after-point "0")))
(if (and (eq fmt 'float)
(<= dpos (+ calc-internal-prec calc-display-sci-high))
(>= dpos (+ calc-display-sci-low 2)))
@@ -3194,9 +3200,11 @@ the United States."
(setq str (concat "0" point str)))
((and (<= exp 0) (> dpos 0))
(setq str (concat (substring str 0 dpos) point
- (substring str dpos))))
+ (substring str dpos)
+ (and (>= dpos len) trailing-0))))
((> exp 0)
- (setq str (concat str (make-string exp ?0) point)))
+ (setq str (concat str (make-string exp ?0)
+ point trailing-0)))
(t ; (< dpos 0)
(setq str (concat "0" point
(make-string (- dpos) ?0) str))))
diff --git a/lisp/calculator.el b/lisp/calculator.el
index 6dd8d9a..99c9b62 100644
--- a/lisp/calculator.el
+++ b/lisp/calculator.el
@@ -836,10 +836,11 @@ The result should not exceed the screen width."
"Convert the given STR to a number, according to the value of
`calculator-input-radix'."
(if calculator-input-radix
- (string-to-number str (cadr (assq calculator-input-radix
- '((bin 2) (oct 8) (hex 16)))))
- ;; Allow entry of "1.e3".
- (let ((str (replace-regexp-in-string (rx "." (any "eE")) "e" str)))
+ (string-to-number str (cadr (assq calculator-input-radix
+ '((bin 2) (oct 8) (hex 16)))))
+ ;; parse numbers similarly to calculators
+ ;; (see tests in test/lisp/calculator-tests.el)
+ (let ((str (replace-regexp-in-string "\\.\\([^0-9].*\\)?$" ".0\\1" str)))
(float (string-to-number str)))))
(defun calculator-push-curnum ()
diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el
index d9cd21e..6eb086a 100644
--- a/lisp/calendar/icalendar.el
+++ b/lisp/calendar/icalendar.el
@@ -105,10 +105,6 @@
;;; Code:
-(defconst icalendar-version "0.19"
- "Version number of icalendar.el.")
-(make-obsolete-variable 'icalendar-version nil "28.1")
-
;; ======================================================================
;; Customizables
;; ======================================================================
@@ -585,19 +581,19 @@ ALIST is a VTIMEZONE potentially containing historical
records."
(list
(car
(sort components
- #'(lambda (a b)
- (let* ((get-recent (lambda (n)
- (car
- (sort
- (delq nil
- (mapcar (lambda (p)
- (and (memq (car p)
'(DTSTART RDATE))
- (car (cddr p))))
- n))
- 'string-greaterp))))
- (a-recent (funcall get-recent (car (cddr a))))
- (b-recent (funcall get-recent (car (cddr b)))))
- (string-greaterp a-recent b-recent))))))))
+ (lambda (a b)
+ (let* ((get-recent (lambda (n)
+ (car
+ (sort
+ (delq nil
+ (mapcar (lambda (p)
+ (and (memq (car p)
'(DTSTART RDATE))
+ (car (cddr p))))
+ n))
+ 'string-greaterp))))
+ (a-recent (funcall get-recent (car (cddr a))))
+ (b-recent (funcall get-recent (car (cddr b)))))
+ (string-greaterp a-recent b-recent))))))))
(defun icalendar--convert-all-timezones (icalendar)
"Convert all timezones in the ICALENDAR into an alist.
@@ -2557,6 +2553,11 @@ the entry."
(or (icalendar--get-event-property event 'URL) "")
(or (icalendar--get-event-property event 'CLASS) "")))
+;; Obsolete
+
+(defconst icalendar-version "0.19" "Version number of icalendar.el.")
+(make-obsolete-variable 'icalendar-version 'emacs-version "28.1")
+
(provide 'icalendar)
;;; icalendar.el ends here
diff --git a/lisp/calendar/parse-time.el b/lisp/calendar/parse-time.el
index aa3236c..5a3d270 100644
--- a/lisp/calendar/parse-time.el
+++ b/lisp/calendar/parse-time.el
@@ -103,46 +103,46 @@ letters, digits, plus or minus signs or colons."
((4) parse-time-months)
((5) (100))
((2 1 0)
- ,#'(lambda () (and (stringp parse-time-elt)
- (= (length parse-time-elt) 8)
- (= (aref parse-time-elt 2) ?:)
- (= (aref parse-time-elt 5) ?:)))
+ ,(lambda () (and (stringp parse-time-elt)
+ (= (length parse-time-elt) 8)
+ (= (aref parse-time-elt 2) ?:)
+ (= (aref parse-time-elt 5) ?:)))
[0 2] [3 5] [6 8])
((8 7) parse-time-zoneinfo
- ,#'(lambda () (car parse-time-val))
- ,#'(lambda () (cadr parse-time-val)))
+ ,(lambda () (car parse-time-val))
+ ,(lambda () (cadr parse-time-val)))
((8)
- ,#'(lambda ()
- (and (stringp parse-time-elt)
- (= 5 (length parse-time-elt))
- (or (= (aref parse-time-elt 0) ?+)
- (= (aref parse-time-elt 0) ?-))))
- ,#'(lambda () (* 60 (+ (cl-parse-integer parse-time-elt :start 3 :end 5)
- (* 60 (cl-parse-integer parse-time-elt :start 1
:end 3)))
- (if (= (aref parse-time-elt 0) ?-) -1 1))))
+ ,(lambda ()
+ (and (stringp parse-time-elt)
+ (= 5 (length parse-time-elt))
+ (or (= (aref parse-time-elt 0) ?+)
+ (= (aref parse-time-elt 0) ?-))))
+ ,(lambda () (* 60 (+ (cl-parse-integer parse-time-elt :start 3 :end 5)
+ (* 60 (cl-parse-integer parse-time-elt :start 1 :end
3)))
+ (if (= (aref parse-time-elt 0) ?-) -1 1))))
((5 4 3)
- ,#'(lambda () (and (stringp parse-time-elt)
- (= (length parse-time-elt) 10)
- (= (aref parse-time-elt 4) ?-)
- (= (aref parse-time-elt 7) ?-)))
+ ,(lambda () (and (stringp parse-time-elt)
+ (= (length parse-time-elt) 10)
+ (= (aref parse-time-elt 4) ?-)
+ (= (aref parse-time-elt 7) ?-)))
[0 4] [5 7] [8 10])
((2 1 0)
- ,#'(lambda () (and (stringp parse-time-elt)
- (= (length parse-time-elt) 5)
- (= (aref parse-time-elt 2) ?:)))
- [0 2] [3 5] ,#'(lambda () 0))
+ ,(lambda () (and (stringp parse-time-elt)
+ (= (length parse-time-elt) 5)
+ (= (aref parse-time-elt 2) ?:)))
+ [0 2] [3 5] ,(lambda () 0))
((2 1 0)
- ,#'(lambda () (and (stringp parse-time-elt)
- (= (length parse-time-elt) 4)
- (= (aref parse-time-elt 1) ?:)))
- [0 1] [2 4] ,#'(lambda () 0))
+ ,(lambda () (and (stringp parse-time-elt)
+ (= (length parse-time-elt) 4)
+ (= (aref parse-time-elt 1) ?:)))
+ [0 1] [2 4] ,(lambda () 0))
((2 1 0)
- ,#'(lambda () (and (stringp parse-time-elt)
- (= (length parse-time-elt) 7)
- (= (aref parse-time-elt 1) ?:)))
+ ,(lambda () (and (stringp parse-time-elt)
+ (= (length parse-time-elt) 7)
+ (= (aref parse-time-elt 1) ?:)))
[0 1] [2 4] [5 7])
- ((5) (50 110) ,#'(lambda () (+ 1900 parse-time-elt)))
- ((5) (0 49) ,#'(lambda () (+ 2000 parse-time-elt))))
+ ((5) (50 110) ,(lambda () (+ 1900 parse-time-elt)))
+ ((5) (0 49) ,(lambda () (+ 2000 parse-time-elt))))
"(slots predicate extractor...)")
;;;###autoload(put 'parse-time-rules 'risky-local-variable t)
diff --git a/lisp/calendar/timeclock.el b/lisp/calendar/timeclock.el
index 0bbaa1e..4a4b65d 100644
--- a/lisp/calendar/timeclock.el
+++ b/lisp/calendar/timeclock.el
@@ -69,8 +69,6 @@
;; your average working time, and will make sure that the various
;; display functions return the correct value.
-;;; History:
-
;;; Code:
(require 'cl-lib)
diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el
index 4218b23..247f78e 100644
--- a/lisp/cedet/mode-local.el
+++ b/lisp/cedet/mode-local.el
@@ -91,13 +91,13 @@ MODES can be a symbol or a list of symbols.
FUNCTION does not have arguments."
(or (listp modes) (setq modes (list modes)))
(mode-local-map-file-buffers
- function #'(lambda ()
- (let ((mm (mode-local-equivalent-mode-p major-mode))
- (ans nil))
- (while (and (not ans) mm)
- (setq ans (memq (car mm) modes)
- mm (cdr mm)) )
- ans))))
+ function (lambda ()
+ (let ((mm (mode-local-equivalent-mode-p major-mode))
+ (ans nil))
+ (while (and (not ans) mm)
+ (setq ans (memq (car mm) modes)
+ mm (cdr mm)) )
+ ans))))
;;; Hook machinery
;;
@@ -323,14 +323,14 @@ Elements are (SYMBOL . PREVIOUS-VALUE), describing one
variable."
(dolist (mode modes)
(when (setq table (get mode 'mode-local-symbol-table))
(mapatoms
- #'(lambda (var)
- (when (get var 'mode-variable-flag)
- (let ((v (intern (symbol-name var))))
- ;; Save the current buffer-local value of the
- ;; mode-local variable.
- (and (local-variable-p v (current-buffer))
- (push (cons v (symbol-value v)) old-locals))
- (set (make-local-variable v) (symbol-value var)))))
+ (lambda (var)
+ (when (get var 'mode-variable-flag)
+ (let ((v (intern (symbol-name var))))
+ ;; Save the current buffer-local value of the
+ ;; mode-local variable.
+ (and (local-variable-p v (current-buffer))
+ (push (cons v (symbol-value v)) old-locals))
+ (set (make-local-variable v) (symbol-value var)))))
table)))
old-locals)))
@@ -348,9 +348,9 @@ If MODE is not specified it defaults to current
`major-mode'."
(while mode
(when (setq table (get mode 'mode-local-symbol-table))
(mapatoms
- #'(lambda (var)
- (when (get var 'mode-variable-flag)
- (kill-local-variable (intern (symbol-name var)))))
+ (lambda (var)
+ (when (get var 'mode-variable-flag)
+ (kill-local-variable (intern (symbol-name var)))))
table))
(setq mode (get-mode-local-parent mode)))))
@@ -428,7 +428,7 @@ Return the value of the last VAL."
;; Save mode bindings
(mode-local-bind (list ,@bl) '(mode-variable-flag t) ',mode)
;; Assign to local variables in all existing buffers in MODE
- (mode-local-map-mode-buffers #'(lambda () ,@sl) ',mode)
+ (mode-local-map-mode-buffers (lambda () ,@sl) ',mode)
;; Return the last value
,tmp)
)))
@@ -893,7 +893,7 @@ invoked interactively."
(interactive
(list (completing-read
"Mode: " obarray
- #'(lambda (s) (get s 'mode-local-symbol-table))
+ (lambda (s) (get s 'mode-local-symbol-table))
t (symbol-name major-mode))))
(when (setq mode (intern-soft mode))
(mode-local-describe-bindings-1 mode (called-interactively-p 'any))))
diff --git a/lisp/cedet/semantic.el b/lisp/cedet/semantic.el
index 15388f0..fb443fa 100644
--- a/lisp/cedet/semantic.el
+++ b/lisp/cedet/semantic.el
@@ -678,15 +678,15 @@ This function returns semantic tags without overlays."
(if tag
(if (car tag)
(setq tag (mapcar
- #'(lambda (tag)
- ;; Set the 'reparse-symbol property to
- ;; NONTERM unless it was already setup
- ;; by a tag expander
- (or (semantic--tag-get-property
- tag 'reparse-symbol)
- (semantic--tag-put-property
- tag 'reparse-symbol nonterm))
- tag)
+ (lambda (tag)
+ ;; Set the 'reparse-symbol property to
+ ;; NONTERM unless it was already setup
+ ;; by a tag expander
+ (or (semantic--tag-get-property
+ tag 'reparse-symbol)
+ (semantic--tag-put-property
+ tag 'reparse-symbol nonterm))
+ tag)
(semantic--tag-expand tag))
result (append result tag))
;; No error in this case, a purposeful nil means don't
diff --git a/lisp/cedet/semantic/bovine/c.el b/lisp/cedet/semantic/bovine/c.el
index 5712f9b..e7ecb61 100644
--- a/lisp/cedet/semantic/bovine/c.el
+++ b/lisp/cedet/semantic/bovine/c.el
@@ -2244,8 +2244,8 @@ actually in their parent which is not accessible.")
(if (obarrayp semantic-lex-spp-project-macro-symbol-obarray)
(let ((macros nil))
(mapatoms
- #'(lambda (symbol)
- (setq macros (cons symbol macros)))
+ (lambda (symbol)
+ (setq macros (cons symbol macros)))
semantic-lex-spp-project-macro-symbol-obarray)
(dolist (S macros)
(princ " ")
diff --git a/lisp/cedet/semantic/bovine/el.el b/lisp/cedet/semantic/bovine/el.el
index 1170e71..ebb2044 100644
--- a/lisp/cedet/semantic/bovine/el.el
+++ b/lisp/cedet/semantic/bovine/el.el
@@ -585,7 +585,7 @@ Overrides `semantic-nonterminal-static'."
;;; Context parsing
;;
-;; Emacs lisp is very different from C,C++ which most context parsing
+;; Emacs Lisp is very different from C,C++ which most context parsing
;; functions are written. Support them here.
(define-mode-local-override semantic-up-context emacs-lisp-mode
(&optional _point _bounds-type)
diff --git a/lisp/cedet/semantic/bovine/grammar.el
b/lisp/cedet/semantic/bovine/grammar.el
index e3df7b1..a2717d7 100644
--- a/lisp/cedet/semantic/bovine/grammar.el
+++ b/lisp/cedet/semantic/bovine/grammar.el
@@ -25,9 +25,8 @@
;;
;; Major mode for editing Bovine's input grammar (.by) files.
-;;; History:
-
;;; Code:
+
(require 'semantic)
(require 'semantic/grammar)
(require 'semantic/find)
@@ -476,7 +475,7 @@ Menu items are appended to the common grammar menu.")
(with-current-buffer (find-file-noselect infile)
(setq infile buffer-file-name)
(if outdir (setq default-directory outdir))
- (semantic-grammar-create-package nil t))
+ (semantic-grammar-create-package t t))
(error (message "%s" (error-message-string err)) nil)))
lang filename copyright-end)
(when (and packagename
diff --git a/lisp/cedet/semantic/db-ebrowse.el
b/lisp/cedet/semantic/db-ebrowse.el
index db37512..682a4cc 100644
--- a/lisp/cedet/semantic/db-ebrowse.el
+++ b/lisp/cedet/semantic/db-ebrowse.el
@@ -222,7 +222,7 @@ warn instead."
;JAVE this just instantiates a default empty ebrowse struct?
; how would new instances wind up here?
-; the ebrowse class isn't singleton, unlike the emacs lisp one
+; the ebrowse class isn't singleton, unlike the Emacs Lisp one
(defvar-mode-local c++-mode semanticdb-project-system-databases
()
"Search Ebrowse for symbols.")
@@ -274,7 +274,7 @@ For instance:
/home/<username>/.semanticdb/!usr!include!BROWSE"
(insert-file-contents B)
(let ((ans nil)
(efcn (symbol-function 'ebrowse-show-progress)))
- (fset 'ebrowse-show-progress #'(lambda (&rest _junk) nil))
+ (fset 'ebrowse-show-progress (lambda (&rest _junk) nil))
(unwind-protect ;; Protect against errors w/ ebrowse
(setq ans (list B (ebrowse-read)))
;; These items must always happen
diff --git a/lisp/cedet/semantic/db-global.el b/lisp/cedet/semantic/db-global.el
index 6bdc7b3..fad2448 100644
--- a/lisp/cedet/semantic/db-global.el
+++ b/lisp/cedet/semantic/db-global.el
@@ -56,7 +56,7 @@ values."
(interactive
(list (completing-read
"Enable in Mode: " obarray
- #'(lambda (s) (get s 'mode-local-symbol-table))
+ (lambda (s) (get s 'mode-local-symbol-table))
t (symbol-name major-mode))))
;; First, make sure the version is ok.
diff --git a/lisp/cedet/semantic/decorate/mode.el
b/lisp/cedet/semantic/decorate/mode.el
index 7895015..c6bf152 100644
--- a/lisp/cedet/semantic/decorate/mode.el
+++ b/lisp/cedet/semantic/decorate/mode.el
@@ -254,7 +254,7 @@ 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
+ :lighter nil
(if semantic-decoration-mode
(if (not (and (featurep 'semantic) (semantic-active-p)))
(progn
diff --git a/lisp/cedet/semantic/edit.el b/lisp/cedet/semantic/edit.el
index 0cca156..b2e5636 100644
--- a/lisp/cedet/semantic/edit.el
+++ b/lisp/cedet/semantic/edit.el
@@ -154,8 +154,8 @@ Optional argument BUFFER is the buffer to search for
changes in."
(when (overlay-get (car ol) 'semantic-change)
(setq ret (cons (car ol) ret)))
(setq ol (cdr ol)))
- (sort ret #'(lambda (a b) (< (overlay-start a)
- (overlay-start b)))))))
+ (sort ret (lambda (a b) (< (overlay-start a)
+ (overlay-start b)))))))
(defun semantic-edits-change-function-handle-changes (start end _length)
"Run whenever a buffer controlled by `semantic-mode' change.
diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el
index 2a3b0f5..4ad70ff 100644
--- a/lisp/cedet/semantic/fw.el
+++ b/lisp/cedet/semantic/fw.el
@@ -270,11 +270,11 @@ later installation should be done in MODE hook."
(mode-local-bind
;; Add the semantic- prefix to OVERLOAD short names.
(mapcar
- #'(lambda (e)
- (let ((name (symbol-name (car e))))
- (if (string-match "^semantic-" name)
- e
- (cons (intern (format "semantic-%s" name)) (cdr e)))))
+ (lambda (e)
+ (let ((name (symbol-name (car e))))
+ (if (string-match "^semantic-" name)
+ e
+ (cons (intern (format "semantic-%s" name)) (cdr e)))))
overrides)
(list 'constant-flag (not transient)
'override-flag t)))
diff --git a/lisp/cedet/semantic/grammar.el b/lisp/cedet/semantic/grammar.el
index 8d8faac..4c3bb6c 100644
--- a/lisp/cedet/semantic/grammar.el
+++ b/lisp/cedet/semantic/grammar.el
@@ -23,9 +23,6 @@
;;
;; Major mode framework for editing Semantic's input grammar files.
-;;; History:
-;;
-
;;; Code:
(require 'semantic)
@@ -34,7 +31,12 @@
(require 'semantic/format)
;; FIXME this is a generated file, but we need to load this file to
;; generate it!
-(require 'semantic/grammar-wy)
+;; We need `semantic/grammar-wy.el' but we're also needed to generate
+;; that file from `grammar.wy', so to break the dependency, we keep
+;; a bootstrap copy of `grammar-wy.el' in `grm-wy-boot.el'. See bug#16008.
+(eval-and-compile
+ (unless (require 'semantic/grammar-wy nil t)
+ (load "semantic/grm-wy-boot")))
(require 'semantic/idle)
(require 'help-fns)
(require 'semantic/analyze)
@@ -143,12 +145,12 @@ It ignores whitespaces, newlines and comments."
ARGS are ASSOC's key value list."
(let ((key t))
`(semantic-tag-make-plist
- ,@(mapcar #'(lambda (i)
- (prog1
- (if key
- (list 'quote i)
- i)
- (setq key (not key))))
+ ,@(mapcar (lambda (i)
+ (prog1
+ (if key
+ (list 'quote i)
+ i)
+ (setq key (not key))))
args))))
(defsubst semantic-grammar-quote-p (sym)
@@ -193,11 +195,11 @@ That is tag names plus names defined in tag attribute
`:rest'."
class (current-buffer))))
(apply #'append
(mapcar
- #'(lambda (tag)
- (mapcar
- #'intern
- (cons (semantic-tag-name tag)
- (semantic-tag-get-attribute tag :rest))))
+ (lambda (tag)
+ (mapcar
+ #'intern
+ (cons (semantic-tag-name tag)
+ (semantic-tag-get-attribute tag :rest))))
tags))))
(defsubst semantic-grammar-item-text (item)
@@ -298,9 +300,9 @@ foo.by it is foo-by."
That is an alist of (VALUE . TOKEN) where VALUE is the string value of
the keyword and TOKEN is the terminal symbol identifying the keyword."
(mapcar
- #'(lambda (key)
- (cons (semantic-tag-get-attribute key :value)
- (intern (semantic-tag-name key))))
+ (lambda (key)
+ (cons (semantic-tag-get-attribute key :value)
+ (intern (semantic-tag-name key))))
(semantic-find-tags-by-class 'keyword (current-buffer))))
(defun semantic-grammar-keyword-properties (keywords)
@@ -600,9 +602,6 @@ Typically a DEFINE expression should look like this:
;; PLEASE DO NOT MANUALLY EDIT THIS FILE! It is automatically
;; generated from the grammar file " gram ".
-;;; History:
-;;
-
;;; Code:
(require 'semantic/lex)
@@ -1069,7 +1068,7 @@ See also the variable `semantic-grammar-file-regexp'."
(setq semantic--grammar-macros-regexp-1
(concat "(\\s-*"
(regexp-opt
- (mapcar #'(lambda (e) (symbol-name (car e)))
+ (mapcar (lambda (e) (symbol-name (car e)))
semantic-grammar-macros)
t)
"\\>"))
@@ -1862,11 +1861,11 @@ Optional argument COLOR determines if color is added to
the text."
(setq label "Keyword: ")
(let (summary)
(semantic--find-tags-by-function
- #'(lambda (put)
- (unless summary
- (setq summary (cdr (assoc "summary"
- (semantic-tag-get-attribute
- put :value))))))
+ (lambda (put)
+ (unless summary
+ (setq summary (cdr (assoc "summary"
+ (semantic-tag-get-attribute
+ put :value))))))
;; Get `put' tag with TAG name.
(semantic-find-tags-by-name-regexp
(regexp-quote (semantic-tag-name tag))
diff --git a/lisp/cedet/semantic/grammar-wy.el
b/lisp/cedet/semantic/grm-wy-boot.el
similarity index 100%
rename from lisp/cedet/semantic/grammar-wy.el
rename to lisp/cedet/semantic/grm-wy-boot.el
diff --git a/lisp/cedet/semantic/idle.el b/lisp/cedet/semantic/idle.el
index b6633d7..b883573 100644
--- a/lisp/cedet/semantic/idle.el
+++ b/lisp/cedet/semantic/idle.el
@@ -171,7 +171,8 @@ date, and reparses while the user is idle (not typing.)
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
+non-nil if the minor mode is enabled."
+ :lighter nil
(if semantic-idle-scheduler-mode
(if (not (and (featurep 'semantic) (semantic-active-p)))
(progn
@@ -216,9 +217,9 @@ And also manages services that depend on tag values."
(let* ((inhibit-quit nil)
(buffers (delq (current-buffer)
(delq nil
- (mapcar #'(lambda (b)
- (and (buffer-file-name b)
- b))
+ (mapcar (lambda (b)
+ (and (buffer-file-name b)
+ b))
(buffer-list)))))
;; safe ;; This safe is not used, but could be.
others
@@ -356,9 +357,9 @@ Uses `semantic-idle-work-for-on-buffer' to do the work."
(cb (current-buffer))
(buffers (delq (current-buffer)
(delq nil
- (mapcar #'(lambda (b)
- (and (buffer-file-name b)
- b))
+ (mapcar (lambda (b)
+ (and (buffer-file-name b)
+ b))
(buffer-list)))))
safe) ;; errbuf
;; First, handle long tasks in the current buffer.
diff --git a/lisp/cedet/semantic/imenu.el b/lisp/cedet/semantic/imenu.el
index 2c5f10a..a5db85b 100644
--- a/lisp/cedet/semantic/imenu.el
+++ b/lisp/cedet/semantic/imenu.el
@@ -429,12 +429,12 @@ Optional argument PARENT is a tag parent of STREAM."
Clears all imenu menus that may be depending on the database."
(require 'semantic/db-mode)
(semantic-map-buffers
- #'(lambda ()
- ;; Set up semanticdb environment if enabled.
- (if (semanticdb-minor-mode-p)
- (semanticdb-semantic-init-hook-fcn))
- ;; Clear imenu cache to redraw the imenu.
- (semantic-imenu-flush-fcn))))
+ (lambda ()
+ ;; Set up semanticdb environment if enabled.
+ (if (semanticdb-minor-mode-p)
+ (semanticdb-semantic-init-hook-fcn))
+ ;; Clear imenu cache to redraw the imenu.
+ (semantic-imenu-flush-fcn))))
(add-hook 'semanticdb-mode-hook #'semantic-imenu-semanticdb-hook)
diff --git a/lisp/cedet/semantic/java.el b/lisp/cedet/semantic/java.el
index 8cadffa..f48b835 100644
--- a/lisp/cedet/semantic/java.el
+++ b/lisp/cedet/semantic/java.el
@@ -395,11 +395,11 @@ receives two arguments: the javadoc keyword and its
associated
removed from the result list."
(delq nil
(mapcar
- #'(lambda (k)
- (let* ((tag (semantic-java-doc-tag k))
- (plist (semantic-lex-keyword-get tag 'javadoc)))
- (if (or (not property) (plist-get plist property))
- (funcall fun k plist))))
+ (lambda (k)
+ (let* ((tag (semantic-java-doc-tag k))
+ (plist (semantic-lex-keyword-get tag 'javadoc)))
+ (if (or (not property) (plist-get plist property))
+ (funcall fun k plist))))
semantic-java-doc-line-tags)))
@@ -417,59 +417,59 @@ removed from the result list."
(or semantic-java-doc-with-name-tags
(setq semantic-java-doc-with-name-tags
(semantic-java-doc-keywords-map
- #'(lambda (k _p) k)
+ (lambda (k _p) k)
'with-name)))
(or semantic-java-doc-with-ref-tags
(setq semantic-java-doc-with-ref-tags
(semantic-java-doc-keywords-map
- #'(lambda (k _p) k)
+ (lambda (k _p) k)
'with-ref)))
(or semantic-java-doc-extra-type-tags
(setq semantic-java-doc-extra-type-tags
(semantic-java-doc-keywords-map
- #'(lambda (k p)
- (if (memq 'type (plist-get p 'usage))
- k))
+ (lambda (k p)
+ (if (memq 'type (plist-get p 'usage))
+ k))
'opt)))
(or semantic-java-doc-extra-function-tags
(setq semantic-java-doc-extra-function-tags
(semantic-java-doc-keywords-map
- #'(lambda (k p)
- (if (memq 'function (plist-get p 'usage))
- k))
+ (lambda (k p)
+ (if (memq 'function (plist-get p 'usage))
+ k))
'opt)))
(or semantic-java-doc-extra-variable-tags
(setq semantic-java-doc-extra-variable-tags
(semantic-java-doc-keywords-map
- #'(lambda (k p)
- (if (memq 'variable (plist-get p 'usage))
- k))
+ (lambda (k p)
+ (if (memq 'variable (plist-get p 'usage))
+ k))
'opt)))
(or semantic-java-doc-type-tags
(setq semantic-java-doc-type-tags
(semantic-java-doc-keywords-map
- #'(lambda (k p)
- (if (memq 'type (plist-get p 'usage))
- k)))))
+ (lambda (k p)
+ (if (memq 'type (plist-get p 'usage))
+ k)))))
(or semantic-java-doc-function-tags
(setq semantic-java-doc-function-tags
(semantic-java-doc-keywords-map
- #'(lambda (k p)
- (if (memq 'function (plist-get p 'usage))
- k)))))
+ (lambda (k p)
+ (if (memq 'function (plist-get p 'usage))
+ k)))))
(or semantic-java-doc-variable-tags
(setq semantic-java-doc-variable-tags
(semantic-java-doc-keywords-map
- #'(lambda (k p)
- (if (memq 'variable (plist-get p 'usage))
- k)))))
+ (lambda (k p)
+ (if (memq 'variable (plist-get p 'usage))
+ k)))))
)
diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el
index 0b24bd2..8073640 100644
--- a/lisp/cedet/semantic/lex-spp.el
+++ b/lisp/cedet/semantic/lex-spp.el
@@ -278,10 +278,10 @@ The return list is meant to be saved in a semanticdb
table."
(let (macros)
(when (obarrayp semantic-lex-spp-dynamic-macro-symbol-obarray)
(mapatoms
- #'(lambda (symbol)
- (setq macros (cons (cons (symbol-name symbol)
- (symbol-value symbol))
- macros)))
+ (lambda (symbol)
+ (setq macros (cons (cons (symbol-name symbol)
+ (symbol-value symbol))
+ macros)))
semantic-lex-spp-dynamic-macro-symbol-obarray))
macros))
@@ -291,18 +291,18 @@ The value of each symbol is the replacement stream."
(let (macros)
(when (obarrayp semantic-lex-spp-macro-symbol-obarray)
(mapatoms
- #'(lambda (symbol)
- (setq macros (cons symbol macros)))
+ (lambda (symbol)
+ (setq macros (cons symbol macros)))
semantic-lex-spp-macro-symbol-obarray))
(when (obarrayp semantic-lex-spp-project-macro-symbol-obarray)
(mapatoms
- #'(lambda (symbol)
- (setq macros (cons symbol macros)))
+ (lambda (symbol)
+ (setq macros (cons symbol macros)))
semantic-lex-spp-project-macro-symbol-obarray))
(when (obarrayp semantic-lex-spp-dynamic-macro-symbol-obarray)
(mapatoms
- #'(lambda (symbol)
- (setq macros (cons symbol macros)))
+ (lambda (symbol)
+ (setq macros (cons symbol macros)))
semantic-lex-spp-dynamic-macro-symbol-obarray))
macros))
diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el
index 121e5c3..69f20de 100644
--- a/lisp/cedet/semantic/lex.el
+++ b/lisp/cedet/semantic/lex.el
@@ -192,9 +192,9 @@ If optional PROPERTY is non-nil, call FUN only on every
symbol which
as a PROPERTY value. FUN receives a symbol as argument."
(if (obarrayp table)
(mapatoms
- #'(lambda (symbol)
- (if (or (null property) (get symbol property))
- (funcall fun symbol)))
+ (lambda (symbol)
+ (if (or (null property) (get symbol property))
+ (funcall fun symbol)))
table)))
;;; Lexical keyword table handling.
@@ -286,7 +286,7 @@ If optional PROPERTY is non-nil, return only keywords which
have a
PROPERTY set."
(let (keywords)
(semantic-lex-map-keywords
- #'(lambda (symbol) (setq keywords (cons symbol keywords)))
+ (lambda (symbol) (setq keywords (cons symbol keywords)))
property)
keywords))
@@ -462,7 +462,7 @@ If optional PROPERTY is non-nil, return only type symbols
which have
PROPERTY set."
(let (types)
(semantic-lex-map-types
- #'(lambda (symbol) (setq types (cons symbol types)))
+ (lambda (symbol) (setq types (cons symbol types)))
property)
types))
diff --git a/lisp/cedet/semantic/util-modes.el
b/lisp/cedet/semantic/util-modes.el
index a02d566..1068628 100644
--- a/lisp/cedet/semantic/util-modes.el
+++ b/lisp/cedet/semantic/util-modes.el
@@ -162,7 +162,7 @@ too an interactive function used to toggle the mode."
;; Update the minor mode format.
(semantic-mode-line-update)
;; Then turn MODE on or off in every Semantic enabled buffer.
- (semantic-map-buffers #'(lambda () (funcall mode arg))))
+ (semantic-map-buffers (lambda () (funcall mode arg))))
;;;;
;;;; Minor mode to highlight areas that a user edits.
diff --git a/lisp/cedet/semantic/wisent.el b/lisp/cedet/semantic/wisent.el
index f498e7e..f5f381d 100644
--- a/lisp/cedet/semantic/wisent.el
+++ b/lisp/cedet/semantic/wisent.el
@@ -22,13 +22,10 @@
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
-;;
+
;; Here are functions necessary to use the Wisent LALR parser from
;; Semantic environment.
-;;; History:
-;;
-
;;; Code:
(require 'semantic)
diff --git a/lisp/cedet/semantic/wisent/comp.el
b/lisp/cedet/semantic/wisent/comp.el
index 6addc13..a87ed51 100644
--- a/lisp/cedet/semantic/wisent/comp.el
+++ b/lisp/cedet/semantic/wisent/comp.el
@@ -35,9 +35,6 @@
;;
;; For more details on Wisent itself read the Wisent manual.
-;;; History:
-;;
-
;;; Code:
(require 'semantic/wisent)
(eval-when-compile (require 'cl-lib))
@@ -69,7 +66,7 @@
"Define a context NAME that will bind variables VARS."
(declare (indent 1))
(let* ((context (wisent-context-name name))
- (declarations (mapcar #'(lambda (v) (list 'defvar v)) vars)))
+ (declarations (mapcar (lambda (v) (list 'defvar v)) vars)))
`(progn
,@declarations
(eval-when-compile
@@ -3430,7 +3427,7 @@ where:
(if (wisent-automaton-p grammar)
grammar ;; Grammar already compiled just return it
(wisent-with-context compile-grammar
- (let* ((gc-cons-threshold 1000000))
+ (let* ((gc-cons-threshold (max gc-cons-threshold 1000000)))
(garbage-collect)
(setq wisent-new-log-flag t)
;; Parse input grammar
@@ -3488,11 +3485,11 @@ See also `wisent-compile-grammar' for more details on
AUTOMATON."
;; in local variable OBN.
,@(let (obcode)
(mapatoms
- #'(lambda (s)
- (setq obcode
- (cons `(fset (intern ,(symbol-name s) ,obn)
- #',(symbol-function s))
- obcode)))
+ (lambda (s)
+ (setq obcode
+ (cons `(fset (intern ,(symbol-name s) ,obn)
+ #',(symbol-function s))
+ obcode)))
obv)
obcode)
;; Generate code to create the automaton.
@@ -3504,18 +3501,18 @@ See also `wisent-compile-grammar' for more details on
AUTOMATON."
,@(mapcar
;; Use name `st' rather than `state' since `state' is
;; defined as dynbound in `semantic-actions' context above :-( !
- #'(lambda (st) ;; for each state
- `(list
- ,@(mapcar
- #'(lambda (tr) ;; for each transition
- (let ((k (car tr)) ; token
- (a (cdr tr))) ; action
- (if (and (symbolp a)
- (intern-soft (symbol-name a) obv))
- `(cons ,(if (symbolp k) `(quote ,k) k)
- (intern-soft ,(symbol-name a) ,obn))
- `(quote ,tr))))
- st)))
+ (lambda (st) ;; for each state
+ `(list
+ ,@(mapcar
+ (lambda (tr) ;; for each transition
+ (let ((k (car tr)) ; token
+ (a (cdr tr))) ; action
+ (if (and (symbolp a)
+ (intern-soft (symbol-name a) obv))
+ `(cons ,(if (symbolp k) `(quote ,k) k)
+ (intern-soft ,(symbol-name a) ,obn))
+ `(quote ,tr))))
+ st)))
(aref automaton 0)))
;; The code of the goto table is unchanged.
,(aref automaton 1)
diff --git a/lisp/cedet/semantic/wisent/grammar.el
b/lisp/cedet/semantic/wisent/grammar.el
index 819ebd5..c5e4554 100644
--- a/lisp/cedet/semantic/wisent/grammar.el
+++ b/lisp/cedet/semantic/wisent/grammar.el
@@ -198,10 +198,10 @@ See also the function `wisent-skip-token'."
(defun wisent-grammar-assocs ()
"Return associativity and precedence level definitions."
(mapcar
- #'(lambda (tag)
- (cons (intern (semantic-tag-name tag))
- (mapcar #'semantic-grammar-item-value
- (semantic-tag-get-attribute tag :value))))
+ (lambda (tag)
+ (cons (intern (semantic-tag-name tag))
+ (mapcar #'semantic-grammar-item-value
+ (semantic-tag-get-attribute tag :value))))
(semantic-find-tags-by-class 'assoc (current-buffer))))
(defun wisent-grammar-terminals ()
@@ -209,14 +209,14 @@ See also the function `wisent-skip-token'."
Keep order of declaration in the WY file without duplicates."
(let (terms)
(mapc
- #'(lambda (tag)
- (mapcar #'(lambda (name)
- (add-to-list 'terms (intern name)))
- (cons (semantic-tag-name tag)
- (semantic-tag-get-attribute tag :rest))))
+ (lambda (tag)
+ (mapcar (lambda (name)
+ (add-to-list 'terms (intern name)))
+ (cons (semantic-tag-name tag)
+ (semantic-tag-get-attribute tag :rest))))
(semantic--find-tags-by-function
- #'(lambda (tag)
- (memq (semantic-tag-class tag) '(token keyword)))
+ (lambda (tag)
+ (memq (semantic-tag-class tag) '(token keyword)))
(current-buffer)))
(nreverse terms)))
@@ -477,7 +477,7 @@ Menu items are appended to the common grammar menu.")
(condition-case err
(with-current-buffer (find-file-noselect infile)
(if outdir (setq default-directory outdir))
- (semantic-grammar-create-package nil t))
+ (semantic-grammar-create-package t t))
(error (message "%s" (error-message-string err)) nil)))
output-data)
(when (setq output-data (assoc packagename
wisent-make-parsers--parser-file-name))
diff --git a/lisp/cedet/semantic/wisent/java-tags.el
b/lisp/cedet/semantic/wisent/java-tags.el
index b4a87be..90dd40c 100644
--- a/lisp/cedet/semantic/wisent/java-tags.el
+++ b/lisp/cedet/semantic/wisent/java-tags.el
@@ -24,9 +24,6 @@
;;; Commentary:
;;
-;;; History:
-;;
-
;;; Code:
(require 'semantic/wisent)
diff --git a/lisp/cedet/semantic/wisent/wisent.el
b/lisp/cedet/semantic/wisent/wisent.el
index d205c0e..62d99ef 100644
--- a/lisp/cedet/semantic/wisent/wisent.el
+++ b/lisp/cedet/semantic/wisent/wisent.el
@@ -34,9 +34,6 @@
;;
;; For more details on Wisent itself read the Wisent manual.
-;;; History:
-;;
-
;;; Code:
(defgroup wisent nil
diff --git a/lisp/chistory.el b/lisp/chistory.el
index 589b5b5..95c1b49 100644
--- a/lisp/chistory.el
+++ b/lisp/chistory.el
@@ -1,4 +1,4 @@
-;;; chistory.el --- list command history
+;;; chistory.el --- list command history -*- lexical-binding: t -*-
;; Copyright (C) 1985, 2001-2021 Free Software Foundation, Inc.
@@ -71,8 +71,7 @@ If that function is given a list whose car is an element of
this list,
then it will return non-nil (indicating the list should be discarded from
the history).
Initially, all commands related to the command history are discarded."
- :type '(repeat symbol)
- :group 'chistory)
+ :type '(repeat symbol))
(defvar list-command-history-filter 'default-command-history-filter
"Predicate to test which commands should be excluded from the history
listing.
@@ -90,8 +89,7 @@ from the command history."
(defcustom list-command-history-max 32
"If non-nil, maximum length of the listing produced by
`list-command-history'."
- :type '(choice integer (const nil))
- :group 'chistory)
+ :type '(choice integer (const nil)))
;;;###autoload
(defun list-command-history ()
@@ -127,10 +125,10 @@ The buffer is left in Command History mode."
(let ((map (make-sparse-keymap)))
(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)
- (define-key map "\177" 'previous-line)
+ (define-key map "x" #'command-history-repeat)
+ (define-key map "\n" #'next-line)
+ (define-key map "\r" #'next-line)
+ (define-key map "\177" #'previous-line)
map)
"Keymap for `command-history-mode'.")
@@ -145,8 +143,7 @@ Keybindings:
(defcustom command-history-hook nil
"If non-nil, its value is called on entry to `command-history-mode'."
- :type 'hook
- :group 'chistory)
+ :type 'hook)
(defun command-history-revert (_ignore-auto _noconfirm)
(list-command-history))
@@ -165,7 +162,7 @@ The buffer for that command is the previous current buffer."
;;;###autoload
(defun command-history ()
- "Examine commands from `command-history' in a buffer.
+ "Examine commands from variable `command-history' in a buffer.
The number of commands listed is controlled by `list-command-history-max'.
The command history is filtered by `list-command-history-filter' if non-nil.
Use \\<command-history-map>\\[command-history-repeat] to repeat the command on
the current line.
diff --git a/lisp/cmuscheme.el b/lisp/cmuscheme.el
index d43cdb1..18087da 100644
--- a/lisp/cmuscheme.el
+++ b/lisp/cmuscheme.el
@@ -1,7 +1,6 @@
-;;; cmuscheme.el --- Scheme process in a buffer. Adapted from tea.el
+;;; cmuscheme.el --- Scheme process in a buffer. Adapted from tea.el -*-
lexical-binding: t -*-
-;; Copyright (C) 1988, 1994, 1997, 2001-2021 Free Software Foundation,
-;; Inc.
+;; Copyright (C) 1988-2021 Free Software Foundation, Inc.
;; Author: Olin Shivers <olin.shivers@cs.cmu.edu>
;; Maintainer: emacs-devel@gnu.org
@@ -26,20 +25,18 @@
;; This is a customization of comint-mode (see comint.el)
;;
-;; Written by Olin Shivers (olin.shivers@cs.cmu.edu). With bits and pieces
+;; Written by Olin Shivers (olin.shivers@cs.cmu.edu). With bits and pieces
;; lifted from scheme.el, shell.el, clisp.el, newclisp.el, cobol.el, et al..
;; 8/88
;;
;; Please send me bug reports, bug fixes, and extensions, so that I can
;; merge them into the master source.
;;
-;; The changelog is at the end of this file.
-;;
;; NOTE: MIT Cscheme, when invoked with the -emacs flag, has a special user
;; interface that communicates process state back to the superior emacs by
-;; outputting special control sequences. The Emacs package, xscheme.el, has
+;; outputting special control sequences. The Emacs package, xscheme.el, has
;; lots and lots of special purpose code to read these control sequences, and
-;; so is very tightly integrated with the cscheme process. The cscheme
+;; so is very tightly integrated with the cscheme process. The cscheme
;; interrupt handler and debugger read single character commands in cbreak
;; mode; when this happens, xscheme.el switches to special keymaps that bind
;; the single letter command keys to emacs functions that directly send the
@@ -49,18 +46,18 @@
;;
;; Here's a summary of the pros and cons, as I see them.
;; xscheme: Tightly integrated with inferior cscheme process! A few commands
-;; not in cmuscheme. But. Integration is a bit of a hack. Input
-;; history only keeps the immediately prior input. Bizarre
+;; not in cmuscheme. But. Integration is a bit of a hack. Input
+;; history only keeps the immediately prior input. Bizarre
;; keybindings.
;;
;; cmuscheme: Not tightly integrated with inferior cscheme process. But.
;; Carefully integrated functionality with the entire suite of
-;; comint-derived CMU process modes. Keybindings reminiscent of
-;; Zwei and Hemlock. Good input history. A few commands not in
+;; comint-derived CMU process modes. Keybindings reminiscent of
+;; Zwei and Hemlock. Good input history. A few commands not in
;; xscheme.
;;
-;; It's a tradeoff. Pay your money; take your choice. If you use a Scheme
-;; that isn't Cscheme, of course, there isn't a choice. Xscheme.el is *very*
+;; It's a tradeoff. Pay your money; take your choice. If you use a Scheme
+;; that isn't Cscheme, of course, there isn't a choice. Xscheme.el is *very*
;; Cscheme-specific; you must use cmuscheme.el. Interested parties are
;; invited to port xscheme functionality on top of comint mode...
@@ -70,18 +67,18 @@
;; Created.
;;
;; 2/15/89 Olin
-;; Removed -emacs flag from process invocation. It's only useful for
+;; Removed -emacs flag from process invocation. It's only useful for
;; cscheme, and makes cscheme assume it's running under xscheme.el,
-;; which messes things up royally. A bug.
+;; which messes things up royally. A bug.
;;
;; 5/22/90 Olin
;; - Upgraded to use comint-send-string and comint-send-region.
;; - run-scheme now offers to let you edit the command line if
-;; you invoke it with a prefix-arg. M-x scheme is redundant, and
+;; you invoke it with a prefix-arg. M-x scheme is redundant, and
;; has been removed.
;; - Explicit references to process "scheme" have been replaced with
-;; (scheme-proc). This allows better handling of multiple process bufs.
-;; - Added scheme-send-last-sexp, bound to C-x C-e. A gnu convention.
+;; (scheme-proc). This allows better handling of multiple process bufs.
+;; - Added scheme-send-last-sexp, bound to C-x C-e. A gnu convention.
;; - Have not added process query facility a la cmulisp.el's lisp-show-arglist
;; and friends, but interested hackers might find a useful application
;; of this facility.
@@ -95,42 +92,37 @@
(require 'scheme)
(require 'comint)
-
(defgroup cmuscheme nil
"Run a scheme process in a buffer."
:group 'scheme)
-;;; INFERIOR SCHEME MODE STUFF
-;;;============================================================================
-
(defcustom inferior-scheme-mode-hook nil
"Hook for customizing inferior-scheme mode."
- :type 'hook
- :group 'cmuscheme)
+ :type 'hook)
(defvar inferior-scheme-mode-map
(let ((m (make-sparse-keymap)))
- (define-key m "\M-\C-x" 'scheme-send-definition) ;gnu convention
- (define-key m "\C-x\C-e" 'scheme-send-last-sexp)
- (define-key m "\C-c\C-l" 'scheme-load-file)
- (define-key m "\C-c\C-k" 'scheme-compile-file)
+ (define-key m "\M-\C-x" #'scheme-send-definition) ;gnu convention
+ (define-key m "\C-x\C-e" #'scheme-send-last-sexp)
+ (define-key m "\C-c\C-l" #'scheme-load-file)
+ (define-key m "\C-c\C-k" #'scheme-compile-file)
(scheme-mode-commands m)
m))
;; Install the process communication commands in the scheme-mode keymap.
-(define-key scheme-mode-map "\M-\C-x" 'scheme-send-definition);gnu convention
-(define-key scheme-mode-map "\C-x\C-e" 'scheme-send-last-sexp);gnu convention
-(define-key scheme-mode-map "\C-c\C-e" 'scheme-send-definition)
-(define-key scheme-mode-map "\C-c\M-e" 'scheme-send-definition-and-go)
-(define-key scheme-mode-map "\C-c\C-r" 'scheme-send-region)
-(define-key scheme-mode-map "\C-c\M-r" 'scheme-send-region-and-go)
-(define-key scheme-mode-map "\C-c\M-c" 'scheme-compile-definition)
-(define-key scheme-mode-map "\C-c\C-c" 'scheme-compile-definition-and-go)
-(define-key scheme-mode-map "\C-c\C-t" 'scheme-trace-procedure)
-(define-key scheme-mode-map "\C-c\C-x" 'scheme-expand-current-form)
-(define-key scheme-mode-map "\C-c\C-z" 'switch-to-scheme)
-(define-key scheme-mode-map "\C-c\C-l" 'scheme-load-file)
-(define-key scheme-mode-map "\C-c\C-k" 'scheme-compile-file) ;k for "kompile"
+(define-key scheme-mode-map "\M-\C-x" #'scheme-send-definition);gnu convention
+(define-key scheme-mode-map "\C-x\C-e" #'scheme-send-last-sexp);gnu convention
+(define-key scheme-mode-map "\C-c\C-e" #'scheme-send-definition)
+(define-key scheme-mode-map "\C-c\M-e" #'scheme-send-definition-and-go)
+(define-key scheme-mode-map "\C-c\C-r" #'scheme-send-region)
+(define-key scheme-mode-map "\C-c\M-r" #'scheme-send-region-and-go)
+(define-key scheme-mode-map "\C-c\M-c" #'scheme-compile-definition)
+(define-key scheme-mode-map "\C-c\C-c" #'scheme-compile-definition-and-go)
+(define-key scheme-mode-map "\C-c\C-t" #'scheme-trace-procedure)
+(define-key scheme-mode-map "\C-c\C-x" #'scheme-expand-current-form)
+(define-key scheme-mode-map "\C-c\C-z" #'switch-to-scheme)
+(define-key scheme-mode-map "\C-c\C-l" #'scheme-load-file)
+(define-key scheme-mode-map "\C-c\C-k" #'scheme-compile-file) ;k for "kompile"
(let ((map (lookup-key scheme-mode-map [menu-bar scheme])))
(define-key map [separator-eval] '("--"))
@@ -157,8 +149,7 @@
(define-key map [send-region]
'("Evaluate Region" . scheme-send-region))
(define-key map [send-sexp]
- '("Evaluate Last S-expression" . scheme-send-last-sexp))
- )
+ '("Evaluate Last S-expression" . scheme-send-last-sexp)))
(defvar scheme-buffer)
@@ -209,8 +200,7 @@ to continue it."
(defcustom inferior-scheme-filter-regexp "\\`\\s *\\S ?\\S ?\\s *\\'"
"Input matching this regexp are not saved on the history list.
Defaults to a regexp ignoring all inputs of 0, 1, or 2 letters."
- :type 'regexp
- :group 'cmuscheme)
+ :type 'regexp)
(defun scheme-input-filter (str)
"Don't save anything matching `inferior-scheme-filter-regexp'."
@@ -242,7 +232,7 @@ is run).
scheme-program-name)))
(if (not (comint-check-proc "*scheme*"))
(let ((cmdlist (split-string-and-unquote cmd)))
- (set-buffer (apply 'make-comint "scheme" (car cmdlist)
+ (set-buffer (apply #'make-comint "scheme" (car cmdlist)
(scheme-start-file (car cmdlist)) (cdr cmdlist)))
(inferior-scheme-mode)))
(setq scheme-program-name cmd)
@@ -282,8 +272,7 @@ in this order. Return nil if no start file found."
(defcustom scheme-compile-exp-command "(compile '%s)"
"Template for issuing commands to compile arbitrary Scheme expressions."
- :type 'string
- :group 'cmuscheme)
+ :type 'string)
(defun scheme-compile-region (start end)
"Compile the current region in the inferior Scheme process.
@@ -311,15 +300,12 @@ For PLT-Scheme, e.g., one should use
(setq scheme-trace-command \"(begin (require (lib \\\"trace.ss\\\")) (trace
%s))\")
For Scheme 48 and Scsh use \",trace %s\"."
- :type 'string
- :group 'cmuscheme)
+ :type 'string)
(defcustom scheme-untrace-command "(untrace %s)"
"Template for switching off tracing of a Scheme procedure.
Scheme 48 and Scsh users should set this variable to \",untrace %s\"."
-
- :type 'string
- :group 'cmuscheme)
+ :type 'string)
(defun scheme-trace-procedure (proc &optional untrace)
"Trace procedure PROC in the inferior Scheme process.
@@ -341,8 +327,7 @@ With a prefix argument switch off tracing of procedure
PROC."
(defcustom scheme-macro-expand-command "(expand %s)"
"Template for macro-expanding a Scheme form.
For Scheme 48 and Scsh use \",expand %s\"."
- :type 'string
- :group 'cmuscheme)
+ :type 'string)
(defun scheme-expand-current-form ()
"Macro-expand the form at point in the inferior Scheme process."
@@ -410,8 +395,7 @@ Then switch to the process buffer."
If it's loaded into a buffer that is in one of these major modes, it's
considered a scheme source file by `scheme-load-file' and
`scheme-compile-file'.
Used by these commands to determine defaults."
- :type '(repeat function)
- :group 'cmuscheme)
+ :type '(repeat function))
(defvar scheme-prev-l/c-dir/file nil
"Caches the last (directory . file) pair.
@@ -514,8 +498,7 @@ command to run."
(defcustom cmuscheme-load-hook nil
"This hook is run when cmuscheme is loaded in.
This is a good place to put keybindings."
- :type 'hook
- :group 'cmuscheme)
+ :type 'hook)
(make-obsolete-variable 'cmuscheme-load-hook
"use `with-eval-after-load' instead." "28.1")
diff --git a/lisp/comint.el b/lisp/comint.el
index b04d404..ef34174 100644
--- a/lisp/comint.el
+++ b/lisp/comint.el
@@ -1627,7 +1627,6 @@ or to the last history element for a backward search."
(if isearch-forward
(comint-goto-input (1- (ring-length comint-input-ring)))
(comint-goto-input nil))
- (setq isearch-success t)
(goto-char (if isearch-forward (comint-line-beginning-position)
(point-max))))
(defun comint-history-isearch-push-state ()
@@ -1798,6 +1797,10 @@ Ignore duplicates if `comint-input-ignoredups' is
non-nil."
(min size (- comint-input-ring-size size)))))
(ring-insert comint-input-ring cmd)))
+(defconst comint--prompt-rear-nonsticky
+ '(field inhibit-line-move-field-capture read-only font-lock-face)
+ "Text properties we set on the prompt and don't want to leak past it.")
+
(defun comint-send-input (&optional no-newline artificial)
"Send input to process.
After the process output mark, sends all text from the process mark to
@@ -1917,7 +1920,8 @@ Similarly for Soar, Scheme, etc."
(unless (or no-newline comint-use-prompt-regexp)
;; Cover the terminating newline
(add-text-properties end (1+ end)
- '(rear-nonsticky t
+ `(rear-nonsticky
+ ,comint--prompt-rear-nonsticky
field boundary
inhibit-line-move-field-capture t)))))
@@ -2124,9 +2128,10 @@ Make backspaces delete the previous character."
(unless comint-use-prompt-regexp
(with-silent-modifications
(add-text-properties comint-last-output-start (point)
- '(front-sticky
+ `(rear-nonsticky
+ ,comint--prompt-rear-nonsticky
+ front-sticky
(field inhibit-line-move-field-capture)
- rear-nonsticky t
field output
inhibit-line-move-field-capture t))))
@@ -2155,7 +2160,9 @@ Make backspaces delete the previous character."
(font-lock-prepend-text-property prompt-start (point)
'font-lock-face
'comint-highlight-prompt)
- (add-text-properties prompt-start (point) '(rear-nonsticky t)))
+ (add-text-properties prompt-start (point)
+ `(rear-nonsticky
+ ,comint--prompt-rear-nonsticky)))
(goto-char saved-point)))))))
(defun comint-preinput-scroll-to-bottom ()
@@ -2251,23 +2258,23 @@ This function could be on
`comint-output-filter-functions' or bound to a key."
(let ((inhibit-read-only t))
(delete-region (point-min) (point)))))
-(defun comint-strip-ctrl-m (&optional _string)
+(defun comint-strip-ctrl-m (&optional _string interactive)
"Strip trailing `^M' characters from the current output group.
This function could be on `comint-output-filter-functions' or bound to a key."
- (interactive)
+ (interactive (list nil t))
(let ((process (get-buffer-process (current-buffer))))
(if (not process)
;; This function may be used in
;; `comint-output-filter-functions', and in that case, if
;; there's no process, then we should do nothing. If
;; interactive, report an error.
- (when (called-interactively-p 'interactive)
+ (when interactive
(error "No process in the current buffer"))
(let ((pmark (process-mark process)))
(save-excursion
(condition-case nil
(goto-char
- (if (called-interactively-p 'interactive)
+ (if interactive
comint-last-input-end comint-last-output-start))
(error nil))
(while (re-search-forward "\r+$" pmark t)
diff --git a/lisp/cus-dep.el b/lisp/cus-dep.el
index f0b108b..31a8960 100644
--- a/lisp/cus-dep.el
+++ b/lisp/cus-dep.el
@@ -1,4 +1,4 @@
-;;; cus-dep.el --- find customization dependencies
+;;; cus-dep.el --- find customization dependencies -*- lexical-binding: t; -*-
;;
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
;;
@@ -109,6 +109,7 @@ Usage: emacs -batch -l ./cus-dep.el -f
custom-make-dependencies DIRS"
(string-match "\\`\\(.*\\)\\.el\\'" file)
(let ((name (or generated-autoload-load-name ; see bug#5277
(file-name-nondirectory (match-string 1 file))))
+ (load-true-file-name file)
(load-file-name file))
(if (save-excursion
(re-search-forward
@@ -131,7 +132,7 @@ Usage: emacs -batch -l ./cus-dep.el -f
custom-make-dependencies DIRS"
'custom-where name)
;; Eval to get the 'custom-group, -tag,
;; -version, group-documentation etc properties.
- (eval expr))
+ (eval expr t))
;; Eval failed for some reason. Eg maybe the
;; defcustom uses something defined earlier
;; in the file (we haven't loaded the file).
@@ -163,7 +164,7 @@ Usage: emacs -batch -l ./cus-dep.el -f
custom-make-dependencies DIRS"
(let ((members (get symbol 'custom-group))
where found)
(when members
- (dolist (member (mapcar 'car members))
+ (dolist (member (mapcar #'car members))
(setq where (get member 'custom-where))
(unless (or (null where)
(member where found))
diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el
index dde6e89..7627930 100644
--- a/lisp/cus-edit.el
+++ b/lisp/cus-edit.el
@@ -5155,8 +5155,6 @@ if that value is non-nil."
(put 'Custom-mode 'mode-class 'special)
-;;; The End.
-
(provide 'cus-edit)
;;; cus-edit.el ends here
diff --git a/lisp/cus-face.el b/lisp/cus-face.el
index 21fe89c..6c0052b 100644
--- a/lisp/cus-face.el
+++ b/lisp/cus-face.el
@@ -395,8 +395,6 @@ This means reset FACE to its value in FROM-THEME."
(define-obsolete-function-alias 'custom-facep #'facep "28.1")
-;;; The End.
-
(provide 'cus-face)
;;; cus-face.el ends here
diff --git a/lisp/cus-theme.el b/lisp/cus-theme.el
index a702fed..13fb9f3 100644
--- a/lisp/cus-theme.el
+++ b/lisp/cus-theme.el
@@ -1,7 +1,7 @@
-;;; cus-theme.el -- custom theme creation user interface -*- lexical-binding:
t -*-
-;;
+;;; cus-theme.el --- custom theme creation user interface -*-
lexical-binding: t -*-
+
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
-;;
+
;; Author: Alex Schroeder <alex@gnu.org>
;; Maintainer: emacs-devel@gnu.org
;; Keywords: help, faces
diff --git a/lisp/custom.el b/lisp/custom.el
index 85e5d65..614f8cf 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -117,9 +117,10 @@ For the standard setting, use `set-default'."
(set-default symbol (eval exp)))))))
(defvar custom-delayed-init-variables nil
- "List of variables whose initialization is pending.")
+ "List of variables whose initialization is pending until startup.
+Once this list has been processed, this var is set to a non-list value.")
-(defun custom-initialize-delay (symbol _value)
+(defun custom-initialize-delay (symbol value)
"Delay initialization of SYMBOL to the next Emacs start.
This is used in files that are preloaded (or for autoloaded
variables), so that the initialization is done in the run-time
@@ -133,7 +134,11 @@ the :set function."
;; This seemed to be at least as good as setting it to an arbitrary
;; value like nil (evaluating `value' is not an option because it
;; may have undesirable side-effects).
- (push symbol custom-delayed-init-variables))
+ (if (listp custom-delayed-init-variables)
+ (push symbol custom-delayed-init-variables)
+ ;; In case this is called after startup, there is no "later" to which to
+ ;; delay it, so initialize it "normally" (bug#47072).
+ (custom-initialize-reset symbol value)))
(defun custom-declare-variable (symbol default doc &rest args)
"Like `defcustom', but SYMBOL and DEFAULT are evaluated as normal arguments.
@@ -1623,8 +1628,6 @@ If a choice with the same tag already exists, no action
is taken."
(put variable 'custom-type
(append choices (list choice))))))
-;;; The End.
-
(provide 'custom)
;;; custom.el ends here
diff --git a/lisp/dframe.el b/lisp/dframe.el
index e61d2ea..1ddf11a 100644
--- a/lisp/dframe.el
+++ b/lisp/dframe.el
@@ -1,4 +1,4 @@
-;;; dframe --- dedicate frame support modes -*- lexical-binding:t -*-
+;;; dframe.el --- dedicate frame support modes -*- lexical-binding:t -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
@@ -828,7 +828,7 @@ the mode-line."
(defvar dframe-version "1.3"
"The current version of the dedicated frame library.")
-(make-obsolete-variable 'dframe-version nil "28.1")
+(make-obsolete-variable 'dframe-version 'emacs-version "28.1")
(provide 'dframe)
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index d5f4910..8fe612f 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -2980,7 +2980,7 @@ a file name. Otherwise, it searches the whole buffer
without restrictions."
When on, Isearch skips matches outside file names using the predicate
`dired-isearch-filter-filenames' that matches only at file names.
When off, it uses the original predicate."
- nil nil nil
+ :lighter nil
(if dired-isearch-filenames-mode
(add-function :before-while (local 'isearch-filter-predicate)
#'dired-isearch-filter-filenames
diff --git a/lisp/dirtrack.el b/lisp/dirtrack.el
index 795f1dd..be8db75 100644
--- a/lisp/dirtrack.el
+++ b/lisp/dirtrack.el
@@ -1,4 +1,4 @@
-;;; dirtrack.el --- Directory Tracking by watching the prompt
+;;; dirtrack.el --- Directory Tracking by watching the prompt -*-
lexical-binding: t -*-
;; Copyright (C) 1996, 2001-2021 Free Software Foundation, Inc.
@@ -77,7 +77,7 @@
;; Running under tcsh:
;; (setq-default dirtrack-list '("^%E \\([^ ]+\\)" 1))
;;
-;; It might be worth mentioning in your file that emacs sources start up
+;; It might be worth mentioning in your file that Emacs sources start up
;; files of the form: ~/.emacs_<SHELL> where <SHELL> is the name of the
;; shell. So for example, I have the following in ~/.emacs_tcsh:
;;
@@ -123,7 +123,6 @@
"List for directory tracking.
First item is a regexp that describes where to find the path in a prompt.
Second is a number, the regexp group to match."
- :group 'dirtrack
:type '(sexp (regexp :tag "Prompt Expression")
(integer :tag "Regexp Group"))
:version "24.1")
@@ -132,12 +131,10 @@ Second is a number, the regexp group to match."
(defcustom dirtrack-debug nil
"If non-nil, the function `dirtrack' will report debugging info."
- :group 'dirtrack
:type 'boolean)
(defcustom dirtrack-debug-buffer "*Directory Tracking Log*"
"Buffer in which to write directory tracking debug information."
- :group 'dirtrack
:type 'string)
(defcustom dirtrack-directory-function
@@ -145,19 +142,16 @@ Second is a number, the regexp group to match."
'dirtrack-windows-directory-function
'file-name-as-directory)
"Function to apply to the prompt directory for comparison purposes."
- :group 'dirtrack
:type 'function)
(defcustom dirtrack-canonicalize-function
(if (memq system-type '(ms-dos windows-nt cygwin))
'downcase 'identity)
"Function to apply to the default directory for comparison purposes."
- :group 'dirtrack
:type 'function)
(defcustom dirtrack-directory-change-hook nil
"Hook that is called when a directory change is made."
- :group 'dirtrack
:type 'hook)
@@ -190,7 +184,7 @@ working directory at all times, and that you set the
variable
This is an alternative to `shell-dirtrack-mode', which works by
tracking `cd' and similar commands which change the shell working
directory."
- nil nil nil
+ :lighter nil
(if dirtrack-mode
(add-hook 'comint-preoutput-filter-functions 'dirtrack nil t)
(remove-hook 'comint-preoutput-filter-functions 'dirtrack t)))
@@ -198,7 +192,7 @@ directory."
(define-minor-mode dirtrack-debug-mode
"Toggle Dirtrack debugging."
- nil nil nil
+ :lighter nil
(if dirtrack-debug-mode
(display-buffer (get-buffer-create dirtrack-debug-buffer))))
diff --git a/lisp/doc-view.el b/lisp/doc-view.el
index cef0900..0ae2293 100644
--- a/lisp/doc-view.el
+++ b/lisp/doc-view.el
@@ -1802,11 +1802,6 @@ If BACKWARD is non-nil, jump to the previous match."
(remove-overlays (point-min) (point-max) 'doc-view t)
(if (consp image-mode-winprops-alist) (setq image-mode-winprops-alist nil)))
-(defun doc-view-intersection (l1 l2)
- (let ((l ()))
- (dolist (x l1) (if (memq x l2) (push x l)))
- l))
-
(defun doc-view-set-doc-type ()
"Figure out the current document type (`doc-view-doc-type')."
(let ((name-types
@@ -1841,7 +1836,7 @@ If BACKWARD is non-nil, jump to the previous match."
((looking-at "AT&TFORM") '(djvu))))))
(setq-local
doc-view-doc-type
- (car (or (doc-view-intersection name-types content-types)
+ (car (or (nreverse (seq-intersection name-types content-types #'eq))
(when (and name-types content-types)
(error "Conflicting types: name says %s but content says %s"
name-types content-types))
@@ -2146,6 +2141,12 @@ See the command `doc-view-mode' for more information on
this mode."
(add-hook 'bookmark-after-jump-hook show-fn-sym)
(bookmark-default-handler bmk)))
+;; Obsolete.
+
+(defun doc-view-intersection (l1 l2)
+ (declare (obsolete seq-intersection "28.1"))
+ (nreverse (seq-intersection l1 l2 #'eq)))
+
(provide 'doc-view)
;; Local Variables:
diff --git a/lisp/dos-w32.el b/lisp/dos-w32.el
index cf75321..45daaad 100644
--- a/lisp/dos-w32.el
+++ b/lisp/dos-w32.el
@@ -1,4 +1,4 @@
-;; dos-w32.el --- Functions shared among MS-DOS and W32 (NT/95) platforms -*-
lexical-binding: t; -*-
+;;; dos-w32.el --- Functions shared among MS-DOS and W32 (NT/95) platforms
-*- lexical-binding: t; -*-
;; Copyright (C) 1996, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/double.el b/lisp/double.el
index 7bc8d92..f9227a8 100644
--- a/lisp/double.el
+++ b/lisp/double.el
@@ -1,4 +1,4 @@
-;;; double.el --- support for keyboard remapping with double clicking
+;;; double.el --- support for keyboard remapping with double clicking -*-
lexical-binding: t -*-
;; Copyright (C) 1994, 1997-1998, 2001-2021 Free Software Foundation,
;; Inc.
@@ -67,7 +67,6 @@ Each entry is a list with three elements:
1. The key activating the translation.
2. The string to be inserted when the key is pressed once.
3. The string to be inserted when the key is pressed twice."
- :group 'double
:type '(repeat (list (character :tag "Key")
(string :tag "Once")
(string :tag "Twice"))))
@@ -76,7 +75,6 @@ Each entry is a list with three elements:
"Non-nil means that Double mode mapping only works for prefix keys.
That is, for any key `X' in `double-map', `X' alone will be mapped
but not `C-u X' or `ESC X' since the X is not the prefix key."
- :group 'double
:type 'boolean)
;;; Read Event
diff --git a/lisp/dynamic-setting.el b/lisp/dynamic-setting.el
index d6952ed..6b037aa 100644
--- a/lisp/dynamic-setting.el
+++ b/lisp/dynamic-setting.el
@@ -1,4 +1,4 @@
-;;; dynamic-setting.el --- Support dynamic changes
+;;; dynamic-setting.el --- Support dynamic changes -*- lexical-binding: t -*-
;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
@@ -24,8 +24,8 @@
;;; Commentary:
-;; This file provides the lisp part of the GConf and XSetting code in
-;; xsetting.c. But it is nothing that prevents it from being used by
+;; This file provides the Lisp part of the GConf and XSetting code in
+;; xsetting.c. But there is nothing that prevents it from being used by
;; other configuration schemes.
;;; Code:
@@ -91,4 +91,7 @@ Changes can be
((eq type 'tool-bar-style) (force-mode-line-update t)))))
(define-key special-event-map [config-changed-event]
- 'dynamic-setting-handle-config-changed-event)
+ #'dynamic-setting-handle-config-changed-event)
+
+(provide 'dynamic-setting)
+;;; dynamic-setting.el ends here
diff --git a/lisp/ebuff-menu.el b/lisp/ebuff-menu.el
index fb73b2d..7fecf1a 100644
--- a/lisp/ebuff-menu.el
+++ b/lisp/ebuff-menu.el
@@ -1,4 +1,4 @@
-;;; ebuff-menu.el --- electric-buffer-list mode
+;;; ebuff-menu.el --- electric-buffer-list mode -*- lexical-binding: t -*-
;; Copyright (C) 1985-1986, 1994, 2001-2021 Free Software Foundation,
;; Inc.
@@ -34,55 +34,53 @@
(defvar electric-buffer-menu-mode-map
(let ((map (make-keymap)))
- (fillarray (car (cdr map)) 'Electric-buffer-menu-undefined)
+ (fillarray (car (cdr map)) #'Electric-buffer-menu-undefined)
(define-key map "\e" nil)
- (define-key map "\C-z" 'suspend-frame)
- (define-key map "v" 'Electric-buffer-menu-mode-view-buffer)
- (define-key map (char-to-string help-char) 'Helper-help)
- (define-key map "?" 'Helper-describe-bindings)
+ (define-key map "\C-z" #'suspend-frame)
+ (define-key map "v" #'Electric-buffer-menu-mode-view-buffer)
+ (define-key map (char-to-string help-char) #'Helper-help)
+ (define-key map "?" #'Helper-describe-bindings)
(define-key map "\C-c" nil)
- (define-key map "\C-c\C-c" 'Electric-buffer-menu-quit)
- (define-key map "\C-]" 'Electric-buffer-menu-quit)
- (define-key map "q" 'Electric-buffer-menu-quit)
- (define-key map " " 'Electric-buffer-menu-select)
- (define-key map "\C-m" 'Electric-buffer-menu-select)
- (define-key map "\C-l" 'recenter)
- (define-key map "s" 'Buffer-menu-save)
- (define-key map "d" 'Buffer-menu-delete)
- (define-key map "k" 'Buffer-menu-delete)
- (define-key map "\C-d" 'Buffer-menu-delete-backwards)
- ;; (define-key map "\C-k" 'Buffer-menu-delete)
- (define-key map "\177" 'Buffer-menu-backup-unmark)
- (define-key map "~" 'Buffer-menu-not-modified)
- (define-key map "u" 'Buffer-menu-unmark)
- (define-key map "\M-\177" 'Buffer-menu-unmark-all-buffers)
- (define-key map "U" 'Buffer-menu-unmark-all)
- (let ((i ?0))
- (while (<= i ?9)
- (define-key map (char-to-string i) 'digit-argument)
- (define-key map (concat "\e" (char-to-string i)) 'digit-argument)
- (setq i (1+ i))))
- (define-key map "-" 'negative-argument)
- (define-key map "\e-" 'negative-argument)
- (define-key map "m" 'Buffer-menu-mark)
- (define-key map "\C-u" 'universal-argument)
- (define-key map "\C-p" 'previous-line)
- (define-key map "\C-n" 'next-line)
- (define-key map "p" 'previous-line)
- (define-key map "n" 'next-line)
- (define-key map "\C-v" 'scroll-up-command)
- (define-key map "\ev" 'scroll-down-command)
- (define-key map ">" 'scroll-right)
- (define-key map "<" 'scroll-left)
- (define-key map "\e\C-v" 'scroll-other-window)
- (define-key map "\e>" 'end-of-buffer)
- (define-key map "\e<" 'beginning-of-buffer)
+ (define-key map "\C-c\C-c" #'Electric-buffer-menu-quit)
+ (define-key map "\C-]" #'Electric-buffer-menu-quit)
+ (define-key map "q" #'Electric-buffer-menu-quit)
+ (define-key map " " #'Electric-buffer-menu-select)
+ (define-key map "\C-m" #'Electric-buffer-menu-select)
+ (define-key map "\C-l" #'recenter)
+ (define-key map "s" #'Buffer-menu-save)
+ (define-key map "d" #'Buffer-menu-delete)
+ (define-key map "k" #'Buffer-menu-delete)
+ (define-key map "\C-d" #'Buffer-menu-delete-backwards)
+ ;; (define-key map "\C-k" #'Buffer-menu-delete)
+ (define-key map "\177" #'Buffer-menu-backup-unmark)
+ (define-key map "~" #'Buffer-menu-not-modified)
+ (define-key map "u" #'Buffer-menu-unmark)
+ (define-key map "\M-\177" #'Buffer-menu-unmark-all-buffers)
+ (define-key map "U" #'Buffer-menu-unmark-all)
+ (dotimes (i 10)
+ (define-key map (char-to-string i) #'digit-argument)
+ (define-key map (concat "\e" (char-to-string i)) #'digit-argument))
+ (define-key map "-" #'negative-argument)
+ (define-key map "\e-" #'negative-argument)
+ (define-key map "m" #'Buffer-menu-mark)
+ (define-key map "\C-u" #'universal-argument)
+ (define-key map "\C-p" #'previous-line)
+ (define-key map "\C-n" #'next-line)
+ (define-key map "p" #'previous-line)
+ (define-key map "n" #'next-line)
+ (define-key map "\C-v" #'scroll-up-command)
+ (define-key map "\ev" #'scroll-down-command)
+ (define-key map ">" #'scroll-right)
+ (define-key map "<" #'scroll-left)
+ (define-key map "\e\C-v" #'scroll-other-window)
+ (define-key map "\e>" #'end-of-buffer)
+ (define-key map "\e<" #'beginning-of-buffer)
(define-key map "\e\e" nil)
- (define-key map "\e\e\e" 'Electric-buffer-menu-quit)
+ (define-key map "\e\e\e" #'Electric-buffer-menu-quit)
;; This binding prevents the "escape => ESC" function-key-map mapping from
;; kicking in!
- ;; (define-key map [escape escape escape] 'Electric-buffer-menu-quit)
- (define-key map [mouse-2] 'Electric-buffer-menu-mouse-select)
+ ;; (define-key map [escape escape escape] #'Electric-buffer-menu-quit)
+ (define-key map [mouse-2] #'Electric-buffer-menu-mouse-select)
map))
(put 'Electric-buffer-menu-quit :advertised-binding "\C-c\C-c")
@@ -205,7 +203,7 @@ See the documentation of `electric-buffer-list' for
details."
(setq-local Helper-return-blurb "return to buffer editing"))
(define-obsolete-function-alias 'Electric-buffer-menu-mode
- 'electric-buffer-menu-mode "24.3")
+ #'electric-buffer-menu-mode "24.3")
;; generally the same as Buffer-menu-mode-map
;; (except we don't indirect to global-map)
diff --git a/lisp/echistory.el b/lisp/echistory.el
index 8f787e7..15679b1 100644
--- a/lisp/echistory.el
+++ b/lisp/echistory.el
@@ -1,4 +1,4 @@
-;;; echistory.el --- Electric Command History Mode
+;;; echistory.el --- Electric Command History Mode -*- lexical-binding: t -*-
;; Copyright (C) 1985, 2001-2021 Free Software Foundation, Inc.
@@ -44,44 +44,43 @@ With prefix arg NOCONFIRM, execute current line as-is
without editing."
(defvar electric-history-map
(let ((map (make-sparse-keymap)))
- (define-key map [t] 'Electric-history-undefined)
+ (define-key map [t] #'Electric-history-undefined)
(define-key map "\e" (make-sparse-keymap))
- (define-key map [?\e t] 'Electric-history-undefined)
- (define-key map "\C-u" 'universal-argument)
- (define-key map " " 'Electric-command-history-redo-expression)
- (define-key map "!" 'Electric-command-history-redo-expression)
- (define-key map "\e\C-x" 'eval-sexp)
- (define-key map "\e\C-d" 'down-list)
- (define-key map "\e\C-u" 'backward-up-list)
- (define-key map "\e\C-b" 'backward-sexp)
- (define-key map "\e\C-f" 'forward-sexp)
- (define-key map "\e\C-a" 'beginning-of-defun)
- (define-key map "\e\C-e" 'end-of-defun)
- (define-key map "\e\C-n" 'forward-list)
- (define-key map "\e\C-p" 'backward-list)
- (define-key map "q" 'Electric-history-quit)
+ (define-key map [?\e t] #'Electric-history-undefined)
+ (define-key map "\C-u" #'universal-argument)
+ (define-key map " " #'Electric-command-history-redo-expression)
+ (define-key map "!" #'Electric-command-history-redo-expression)
+ (define-key map "\e\C-d" #'down-list)
+ (define-key map "\e\C-u" #'backward-up-list)
+ (define-key map "\e\C-b" #'backward-sexp)
+ (define-key map "\e\C-f" #'forward-sexp)
+ (define-key map "\e\C-a" #'beginning-of-defun)
+ (define-key map "\e\C-e" #'end-of-defun)
+ (define-key map "\e\C-n" #'forward-list)
+ (define-key map "\e\C-p" #'backward-list)
+ (define-key map "q" #'Electric-history-quit)
(define-key map "\C-c" nil)
- (define-key map "\C-c\C-c" 'Electric-history-quit)
- (define-key map "\C-]" 'Electric-history-quit)
- (define-key map "\C-z" 'suspend-frame)
- (define-key map (char-to-string help-char) 'Helper-help)
- (define-key map "?" 'Helper-describe-bindings)
- (define-key map "\e>" 'end-of-buffer)
- (define-key map "\e<" 'beginning-of-buffer)
- (define-key map "\n" 'next-line)
- (define-key map "\r" 'next-line)
- (define-key map "\177" 'previous-line)
- (define-key map "\C-n" 'next-line)
- (define-key map "\C-p" 'previous-line)
- (define-key map "\ev" 'scroll-down)
- (define-key map "\C-v" 'scroll-up)
- (define-key map [home] 'beginning-of-buffer)
- (define-key map [down] 'next-line)
- (define-key map [up] 'previous-line)
- (define-key map [prior] 'scroll-down)
- (define-key map [next] 'scroll-up)
- (define-key map "\C-l" 'recenter)
- (define-key map "\e\C-v" 'scroll-other-window)
+ (define-key map "\C-c\C-c" #'Electric-history-quit)
+ (define-key map "\C-]" #'Electric-history-quit)
+ (define-key map "\C-z" #'suspend-frame)
+ (define-key map (char-to-string help-char) #'Helper-help)
+ (define-key map "?" #'Helper-describe-bindings)
+ (define-key map "\e>" #'end-of-buffer)
+ (define-key map "\e<" #'beginning-of-buffer)
+ (define-key map "\n" #'next-line)
+ (define-key map "\r" #'next-line)
+ (define-key map "\177" #'previous-line)
+ (define-key map "\C-n" #'next-line)
+ (define-key map "\C-p" #'previous-line)
+ (define-key map "\ev" #'scroll-down)
+ (define-key map "\C-v" #'scroll-up)
+ (define-key map [home] #'beginning-of-buffer)
+ (define-key map [down] #'next-line)
+ (define-key map [up] #'previous-line)
+ (define-key map [prior] #'scroll-down)
+ (define-key map [next] #'scroll-up)
+ (define-key map "\C-l" #'recenter)
+ (define-key map "\e\C-v" #'scroll-other-window)
map)
"Keymap for Electric Command History mode.")
@@ -141,7 +140,9 @@ The Command History listing is recomputed each time this
mode is invoked."
(defun Electric-history-undefined ()
(interactive)
(ding)
- (message "%s" (substitute-command-keys "Type \\[Helper-help] for help, ? for
commands, C-c C-c to quit, Space to execute"))
+ (message "%s" (substitute-command-keys "Type \\[Helper-help] for help, \
+\\[Helper-describe-bindings] for commands, \\[Electric-history-quit] to quit, \
+\\[Electric-command-history-redo-expression] to execute"))
(sit-for 4))
(defun Electric-history-quit ()
diff --git a/lisp/edmacro.el b/lisp/edmacro.el
index 3d7db44..84de69a 100644
--- a/lisp/edmacro.el
+++ b/lisp/edmacro.el
@@ -1,4 +1,4 @@
-;;; edmacro.el --- keyboard macro editor
+;;; edmacro.el --- keyboard macro editor -*- lexical-binding: t; -*-
;; Copyright (C) 1993-1994, 2001-2021 Free Software Foundation, Inc.
@@ -74,8 +74,8 @@ Default nil means to write characters above \\177 in octal
notation."
(defvar edmacro-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-c\C-c" 'edmacro-finish-edit)
- (define-key map "\C-c\C-q" 'edmacro-insert-key)
+ (define-key map "\C-c\C-c" #'edmacro-finish-edit)
+ (define-key map "\C-c\C-q" #'edmacro-insert-key)
map))
(defvar edmacro-store-hook)
@@ -177,8 +177,8 @@ With a prefix argument, format the macro in a more concise
way."
(set-buffer-modified-p nil))
(run-hooks 'edmacro-format-hook)))))
-;;; The next two commands are provided for convenience and backward
-;;; compatibility.
+;; The next two commands are provided for convenience and backward
+;; compatibility.
;;;###autoload
(defun edit-last-kbd-macro (&optional prefix)
@@ -237,8 +237,7 @@ or nil, use a compact 80-column format."
((looking-at "Command:[ \t]*\\([^ \t\n]*\\)[ \t]*$")
(when edmacro-store-hook
(error "\"Command\" line not allowed in this context"))
- (let ((str (buffer-substring (match-beginning 1)
- (match-end 1))))
+ (let ((str (match-string 1)))
(unless (equal str "")
(setq cmd (and (not (equal str "none"))
(intern str)))
@@ -253,8 +252,7 @@ or nil, use a compact 80-column format."
(when edmacro-store-hook
(error "\"Key\" line not allowed in this context"))
(let ((key (edmacro-parse-keys
- (buffer-substring (match-beginning 1)
- (match-end 1)))))
+ (match-string 1))))
(unless (equal key "")
(if (equal key "none")
(setq no-keys t)
@@ -274,16 +272,14 @@ or nil, use a compact 80-column format."
((looking-at "Counter:[ \t]*\\([^ \t\n]*\\)[ \t]*$")
(when edmacro-store-hook
(error "\"Counter\" line not allowed in this context"))
- (let ((str (buffer-substring (match-beginning 1)
- (match-end 1))))
+ (let ((str (match-string 1)))
(unless (equal str "")
(setq mac-counter (string-to-number str))))
t)
((looking-at "Format:[ \t]*\"\\([^\n]*\\)\"[ \t]*$")
(when edmacro-store-hook
(error "\"Format\" line not allowed in this context"))
- (let ((str (buffer-substring (match-beginning 1)
- (match-end 1))))
+ (let ((str (match-string 1)))
(unless (equal str "")
(setq mac-format str)))
t)
@@ -475,7 +471,7 @@ doubt, use whitespace."
(and (not (memq (aref rest-mac i) pkeys))
(prog1 (vconcat "C-u " (cl-subseq rest-mac 1 i) "
")
(cl-callf cl-subseq rest-mac i)))))))
- (bind-len (apply 'max 1
+ (bind-len (apply #'max 1
(cl-loop for map in maps
for b = (lookup-key map rest-mac)
when b collect b)))
@@ -506,7 +502,7 @@ doubt, use whitespace."
finally return i))
desc)
(if (stringp bind) (setq bind nil))
- (cond ((and (eq bind 'self-insert-command) (not prefix)
+ (cond ((and (eq bind #'self-insert-command) (not prefix)
(> text 1) (integerp first)
(> first 32) (<= first maxkey) (/= first 92)
(progn
@@ -520,11 +516,11 @@ doubt, use whitespace."
desc))))
(when (or (string-match "^\\^.$" desc)
(member desc res-words))
- (setq desc (mapconcat 'char-to-string desc " ")))
+ (setq desc (mapconcat #'char-to-string desc " ")))
(when verbose
(setq bind (format "%s * %d" bind text)))
(setq bind-len text))
- ((and (eq bind 'execute-extended-command)
+ ((and (eq bind #'execute-extended-command)
(> text bind-len)
(memq (aref rest-mac text) '(return 13))
(progn
@@ -667,10 +663,8 @@ This function assumes that the events can be stored in a
string."
(substring word 2 -2) "\r")))
((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word)
(progn
- (setq word (concat (substring word (match-beginning 1)
- (match-end 1))
- (substring word (match-beginning 3)
- (match-end 3))))
+ (setq word (concat (match-string 1 word)
+ (match-string 3 word)))
(not (string-match
"\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$"
word))))
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el
index b9a3a32..dc8636f 100644
--- a/lisp/emacs-lisp/advice.el
+++ b/lisp/emacs-lisp/advice.el
@@ -2051,6 +2051,8 @@ in that CLASS."
function class name)))
(error "ad-remove-advice: `%s' is not advised" function)))
+(declare-function comp-subr-trampoline-install "comp")
+
;;;###autoload
(defun ad-add-advice (function advice class position)
"Add a piece of ADVICE to FUNCTION's list of advices in CLASS.
@@ -2074,6 +2076,9 @@ mapped to the closest extremal position).
If FUNCTION was not advised already, its advice info will be
initialized. Redefining a piece of advice whose name is part of
the cache-id will clear the cache."
+ (when (and (featurep 'nativecomp)
+ (subr-primitive-p (symbol-function function)))
+ (comp-subr-trampoline-install function))
(cond ((not (ad-is-advised function))
(ad-initialize-advice-info function)
(ad-set-advice-info-field
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el
index ae17039..b45984b 100644
--- a/lisp/emacs-lisp/autoload.el
+++ b/lisp/emacs-lisp/autoload.el
@@ -170,7 +170,9 @@ expression, in which case we want to handle forms
differently."
define-inline cl-defun cl-defmacro cl-defgeneric
cl-defstruct pcase-defmacro))
(macrop car)
- (setq expand (let ((load-file-name file)) (macroexpand form)))
+ (setq expand (let ((load-true-file-name file)
+ (load-file-name file))
+ (macroexpand form)))
(memq (car expand) '(progn prog1 defalias)))
(make-autoload expand file 'expansion)) ;Recurse on the expansion.
diff --git a/lisp/emacs-lisp/avl-tree.el b/lisp/emacs-lisp/avl-tree.el
index 75c7322..4382985 100644
--- a/lisp/emacs-lisp/avl-tree.el
+++ b/lisp/emacs-lisp/avl-tree.el
@@ -74,7 +74,7 @@
cmpfun)
(defmacro avl-tree--root (tree)
- ;; Return the root node for an AVL tree. INTERNAL USE ONLY.
+ "Return the root node for an AVL TREE. INTERNAL USE ONLY."
`(avl-tree--node-left (avl-tree--dummyroot ,tree)))
;; ----------------------------------------------------------------
@@ -117,11 +117,11 @@ NODE is the node, and BRANCH is the branch.
`(- 1 ,dir))
(defmacro avl-tree--dir-to-sign (dir)
- "Convert direction (0,1) to sign factor (-1,+1)."
+ "Convert direction DIR (0,1) to sign factor (-1,+1)."
`(1- (* 2 ,dir)))
(defmacro avl-tree--sign-to-dir (dir)
- "Convert sign factor (-x,+x) to direction (0,1)."
+ "Convert sign factor in DIR (-x,+x) to direction (0,1)."
`(if (< ,dir 0) 0 1))
@@ -129,7 +129,7 @@ NODE is the node, and BRANCH is the branch.
;; Deleting data
(defun avl-tree--del-balance (node branch dir)
- "Rebalance a tree after deleting a node.
+ "Rebalance a tree after deleting a NODE.
The deletion was done from the left (DIR=0) or right (DIR=1) sub-tree
of the left (BRANCH=0) or right (BRANCH=1) child of NODE.
Return t if the height of the tree has shrunk."
@@ -247,9 +247,9 @@ the related data."
;; Entering data
(defun avl-tree--enter-balance (node branch dir)
- "Rebalance tree after an insertion
-into the left (DIR=0) or right (DIR=1) sub-tree of the
-left (BRANCH=0) or right (BRANCH=1) child of NODE.
+ "Rebalance tree after insertion of NODE.
+NODE was inserted into the left (DIR=0) or right (DIR=1) sub-tree
+of the left (BRANCH=0) or right (BRANCH=1) child of NODE.
Return t if the height of the tree has grown."
(let ((br (avl-tree--node-branch node branch))
;; opposite direction: 0,1 -> 1,0
@@ -337,7 +337,7 @@ inserted data."
))))
(defun avl-tree--check (tree)
- "Check the tree's balance."
+ "Check the balance of TREE."
(avl-tree--check-node (avl-tree--root tree)))
(defun avl-tree--check-node (node)
(if (null node) 0
@@ -379,7 +379,8 @@ itself."
;;; INTERNAL USE ONLY
(defun avl-tree--do-copy (root)
- "Copy the AVL tree with ROOT as root. Highly recursive."
+ "Copy the AVL tree wiath ROOT as root.
+This function is highly recursive."
(if (null root)
nil
(avl-tree--node-create
@@ -405,8 +406,9 @@ itself."
\n(fn OBJ)")
(defun avl-tree--stack-repopulate (stack)
- ;; Recursively push children of the node at the head of STACK onto the
- ;; front of the STACK, until a leaf is reached.
+ "Recursively push children of STACK onto the front.
+This pushes the children of the node at the head of STACK onto
+the front of STACK, until a leaf node is reached."
(let ((node (car (avl-tree--stack-store stack)))
(dir (if (avl-tree--stack-reverse stack) 1 0)))
(when node ; check for empty stack
@@ -429,7 +431,7 @@ and returns non-nil if A is less than B, and nil otherwise.
\n(fn TREE)")
(defun avl-tree-empty (tree)
- "Return t if AVL tree TREE is empty, otherwise return nil."
+ "Return t if AVL TREE is empty, otherwise return nil."
(null (avl-tree--root tree)))
(defun avl-tree-enter (tree data &optional updatefun)
@@ -451,7 +453,7 @@ Returns the new data."
0 data updatefun)))
(defun avl-tree-delete (tree data &optional test nilflag)
- "Delete the element matching DATA from the AVL tree TREE.
+ "Delete the element matching DATA from the AVL TREE.
Matching uses the comparison function previously specified in
`avl-tree-create' when TREE was created.
@@ -473,7 +475,7 @@ value is non-nil."
(defun avl-tree-member (tree data &optional nilflag)
- "Return the element in the AVL tree TREE which matches DATA.
+ "Return the element in the AVL TREE which matches DATA.
Matching uses the comparison function previously specified in
`avl-tree-create' when TREE was created.
@@ -496,7 +498,7 @@ for you.)"
(defun avl-tree-member-p (tree data)
- "Return t if an element matching DATA exists in the AVL tree TREE.
+ "Return t if an element matching DATA exists in the AVL TREE.
Otherwise return nil. Matching uses the comparison function
previously specified in `avl-tree-create' when TREE was created."
(let ((flag '(nil)))
@@ -504,13 +506,13 @@ previously specified in `avl-tree-create' when TREE was
created."
(defun avl-tree-map (fun tree &optional reverse)
- "Modify all elements in the AVL tree TREE by applying FUNCTION.
+ "Modify all elements in the AVL TREE by applying function FUN.
-Each element is replaced by the return value of FUNCTION applied
-to that element.
+Each element is replaced by the return value of FUN applied to
+that element.
-FUNCTION is applied to the elements in ascending order, or
-descending order if REVERSE is non-nil."
+FUN is applied to the elements in ascending order, or descending
+order if REVERSE is non-nil."
(avl-tree--mapc
(lambda (node)
(setf (avl-tree--node-data node)
@@ -520,8 +522,7 @@ descending order if REVERSE is non-nil."
(defun avl-tree-mapc (fun tree &optional reverse)
- "Apply FUNCTION to all elements in AVL tree TREE,
-for side-effect only.
+ "Apply function FUN to all elements in AVL TREE, for side-effect only.
FUNCTION is applied to the elements in ascending order, or
descending order if REVERSE is non-nil."
@@ -534,8 +535,7 @@ descending order if REVERSE is non-nil."
(defun avl-tree-mapf
(fun combinator tree &optional reverse)
- "Apply FUNCTION to all elements in AVL tree TREE,
-and combine the results using COMBINATOR.
+ "Apply FUN to all elements in AVL TREE, combine results using COMBINATOR.
The FUNCTION is applied and the results are combined in ascending
order, or descending order if REVERSE is non-nil."
@@ -553,8 +553,7 @@ order, or descending order if REVERSE is non-nil."
(defun avl-tree-mapcar (fun tree &optional reverse)
- "Apply function FUN to all elements in AVL tree TREE,
-and make a list of the results.
+ "Apply FUN to all elements in AVL TREE, and make a list of the results.
The function is applied and the list constructed in ascending
order, or descending order if REVERSE is non-nil.
@@ -586,7 +585,7 @@ is more efficient."
(avl-tree--node-data node))))
(defun avl-tree-copy (tree)
- "Return a copy of the AVL tree TREE."
+ "Return a copy of the AVL TREE."
(let ((new-tree (avl-tree-create (avl-tree--cmpfun tree))))
(setf (avl-tree--root new-tree) (avl-tree--do-copy (avl-tree--root tree)))
new-tree))
@@ -608,13 +607,12 @@ is more efficient."
treesize))
(defun avl-tree-clear (tree)
- "Clear the AVL tree TREE."
+ "Clear the AVL TREE."
(setf (avl-tree--root tree) nil))
(defun avl-tree-stack (tree &optional reverse)
- "Return an object that behaves like a sorted stack
-of all elements of TREE.
+ "Return an object that behaves like a sorted stack of all elements of TREE.
If REVERSE is non-nil, the stack is sorted in reverse order.
\(See also `avl-tree-stack-pop').
@@ -655,8 +653,7 @@ a null element stored in the AVL tree.)"
(defun avl-tree-stack-first (avl-tree-stack &optional nilflag)
- "Return the first element of AVL-TREE-STACK, without removing it
-from the stack.
+ "Return the first element of AVL-TREE-STACK, without removing it from stack.
Returns nil if the stack is empty, or NILFLAG if specified.
\(The latter allows an empty stack to be distinguished from
diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el
index 9899496..247fb91 100644
--- a/lisp/emacs-lisp/bindat.el
+++ b/lisp/emacs-lisp/bindat.el
@@ -167,7 +167,7 @@
(defun bindat--unpack-strz (len)
(let ((i 0) s)
- (while (and (< i len) (/= (aref bindat-raw (+ bindat-idx i)) 0))
+ (while (and (if len (< i len) t) (/= (aref bindat-raw (+ bindat-idx i)) 0))
(setq i (1+ i)))
(setq s (substring bindat-raw bindat-idx (+ bindat-idx i)))
(setq bindat-idx (+ bindat-idx len))
@@ -439,6 +439,12 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(aset bindat-raw (+ bindat-idx i) (aref v i)))
(setq bindat-idx (+ bindat-idx len)))
+(defun bindat--pack-strz (v)
+ (let ((len (length v)))
+ (dotimes (i len)
+ (aset bindat-raw (+ bindat-idx i) (aref v i)))
+ (setq bindat-idx (+ bindat-idx len 1))))
+
(defun bindat--pack-bits (len v)
(let ((bnum (1- (* 8 len))) j m)
(while (>= bnum 0)
@@ -677,14 +683,23 @@ is the name of a variable that will hold the value we
need to pack.")
(`(length . ,_) `(cl-incf bindat-idx ,len))
(`(pack . ,args) `(bindat--pack-str ,len . ,args))))
-(cl-defmethod bindat--type (op (_ (eql strz)) len)
+(cl-defmethod bindat--type (op (_ (eql strz)) &optional len)
(bindat--pcase op
('unpack `(bindat--unpack-strz ,len))
- (`(length . ,_) `(cl-incf bindat-idx ,len))
- ;; Here we don't add the terminating zero because we rely
- ;; on the fact that `bindat-raw' was presumably initialized with
- ;; all-zeroes before we started.
- (`(pack . ,args) `(bindat--pack-str ,len . ,args))))
+ (`(length ,val)
+ `(cl-incf bindat-idx ,(cond
+ ((null len) `(length ,val))
+ ((numberp len) len)
+ (t `(or ,len (length ,val))))))
+ (`(pack . ,args)
+ (macroexp-let2 nil len len
+ `(if ,len
+ ;; Same as non-zero terminated strings since we don't actually add
+ ;; the terminating zero anyway (because we rely on the fact that
+ ;; `bindat-raw' was presumably initialized with all-zeroes before
+ ;; we started).
+ (bindat--pack-str ,len . ,args)
+ (bindat--pack-strz . ,args))))))
(cl-defmethod bindat--type (op (_ (eql bits)) len)
(bindat--pcase op
@@ -812,7 +827,7 @@ is the name of a variable that will hold the value we need
to pack.")
'(&or ["uint" def-form]
["uintr" def-form]
["str" def-form]
- ["strz" def-form]
+ ["strz" &optional def-form]
["bits" def-form]
["fill" def-form]
["align" def-form]
@@ -832,7 +847,7 @@ TYPE is a Bindat type expression. It can take the
following forms:
uint BITLEN - Big-endian unsigned integer
uintr BITLEN - Little-endian unsigned integer
str LEN - Byte string
- strz LEN - Zero-terminated byte-string
+ strz [LEN] - Zero-terminated byte-string
bits LEN - Bit vector (LEN is counted in bytes)
fill LEN - Just a filler
align LEN - Fill up to the next multiple of LEN bytes
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index db8d825..33b4d4b 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -528,8 +528,14 @@ Same format as `byte-optimize--lexvars', with shared
structure and contents.")
`(condition-case ,var ;Not evaluated.
,(byte-optimize-form exp for-effect)
,@(mapcar (lambda (clause)
- `(,(car clause)
- ,@(byte-optimize-body (cdr clause) for-effect)))
+ (let ((byte-optimize--lexvars
+ (and lexical-binding
+ (if var
+ (cons (list var t)
+ byte-optimize--lexvars)
+ byte-optimize--lexvars))))
+ (cons (car clause)
+ (byte-optimize-body (cdr clause) for-effect))))
clauses))))
(`(unwind-protect ,exp . ,exps)
@@ -1318,7 +1324,7 @@ Same format as `byte-optimize--lexvars', with shared
structure and contents.")
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-byte-code make-list make-string make-symbol marker-buffer max
+ make-byte-code make-list make-string make-symbol mark marker-buffer max
member memq memql min minibuffer-selected-window minibuffer-window
mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string
parse-colon-path plist-get plist-member
@@ -1368,7 +1374,7 @@ Same format as `byte-optimize--lexvars', with shared
structure and contents.")
invocation-directory invocation-name
keymapp keywordp
list listp
- make-marker mark mark-marker markerp max-char
+ make-marker mark-marker markerp max-char
memory-limit
mouse-movement-p
natnump nlistp not null number-or-marker-p numberp
@@ -2350,6 +2356,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to
be of no importance."
;;
(eval-when-compile
(or (byte-code-function-p (symbol-function 'byte-optimize-form))
+ (subr-native-elisp-p (symbol-function 'byte-optimize-form))
(assq 'byte-code (symbol-function 'byte-optimize-form))
(let ((byte-optimize nil)
(byte-compile-warnings nil))
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 119d397..aca5dcb 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -146,6 +146,11 @@ The return value of this function is not used."
(list 'function-put (list 'quote f)
''lisp-indent-function (list 'quote val))))
+(defalias 'byte-run--set-speed
+ #'(lambda (f _args val)
+ (list 'function-put (list 'quote f)
+ ''speed (list 'quote val))))
+
(defalias 'byte-run--set-completion
#'(lambda (f _args val)
(list 'function-put (list 'quote f)
@@ -173,6 +178,7 @@ If `error-free', drop calls even if
`byte-compile-delete-errors' is nil.")
(list 'compiler-macro #'byte-run--set-compiler-macro)
(list 'doc-string #'byte-run--set-doc-string)
(list 'indent #'byte-run--set-indent)
+ (list 'speed #'byte-run--set-speed)
(list 'completion #'byte-run--set-completion)
(list 'modes #'byte-run--set-modes))
"List associating function properties to their macro expansion.
@@ -381,6 +387,10 @@ You don't need this. (See bytecomp.el commentary for more
details.)
`(prog1
(defun ,name ,arglist ,@body)
(eval-and-compile
+ ;; Never native-compile defsubsts as we need the byte
+ ;; definition in `byte-compile-unfold-bcf' to perform the
+ ;; inlining (Bug#42664, Bug#43280, Bug#44209).
+ ,(byte-run--set-speed name nil -1)
(put ',name 'byte-optimizer 'byte-compile-inline-expand))))
(defvar advertised-signature-table (make-hash-table :test 'eq :weakness 'key))
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 0babbbb..9be54ca 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -577,6 +577,50 @@ Each element is (INDEX . VALUE)")
(defvar byte-compile-depth 0 "Current depth of execution stack.")
(defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.")
+;; The following is used by comp.el to spill data out of here.
+;;
+;; Spilling is done in 3 places:
+;;
+;; - `byte-compile-lapcode' to obtain the map bytecode -> LAP for any
+;; code assembled.
+;;
+;; - `byte-compile-lambda' to obtain arglist doc and interactive spec
+;; af any lambda compiled (including anonymous).
+;;
+;; - `byte-compile-file-form-defmumble' to obtain the list of
+;; top-level forms as they would be outputted in the .elc file.
+;;
+
+(cl-defstruct byte-to-native-lambda
+ byte-func lap)
+
+;; Top level forms:
+(cl-defstruct byte-to-native-func-def
+ "Named function defined at top-level."
+ name c-name byte-func)
+(cl-defstruct byte-to-native-top-level
+ "All other top-level forms."
+ form lexical)
+
+(defvar byte-native-compiling nil
+ "Non nil while native compiling.")
+(defvar byte-native-qualities nil
+ "To spill default qualities from the compiled file.")
+(defvar byte-native-for-bootstrap nil
+ "Non nil while compiling for bootstrap."
+ ;; During bootstrap we produce both the .eln and the .elc together.
+ ;; Because the make target is the later this has to be produced as
+ ;; last to be resilient against build interruptions.
+)
+(defvar byte-to-native-lambdas-h nil
+ "Hash byte-code -> byte-to-native-lambda.")
+(defvar byte-to-native-top-level-forms nil
+ "List of top level forms.")
+(defvar byte-to-native-output-file nil
+ "Temporary file containing the byte-compilation output.")
+(defvar byte-to-native-plist-environment nil
+ "To spill `overriding-plist-environment'.")
+
;;; The byte codes; this information is duplicated in bytecomp.c
@@ -973,7 +1017,12 @@ CONST2 may be evaluated multiple times."
;; it within 2 bytes in the byte string).
(puthash value pc hash-table))
hash-table))
- (apply 'unibyte-string (nreverse bytes))))
+ (let ((bytecode (apply 'unibyte-string (nreverse bytes))))
+ (when byte-native-compiling
+ ;; Spill LAP for the native compiler here.
+ (puthash bytecode (make-byte-to-native-lambda :lap lap)
+ byte-to-native-lambdas-h))
+ bytecode)))
;;; compile-time evaluation
@@ -1702,7 +1751,11 @@ It is too wide if it has any lines longer than the
largest of
;; cause macro calls in B to think they come from A.
(current-load-list (list nil))
)
- ,@body))
+ (prog1
+ (progn ,@body)
+ (when byte-native-compiling
+ (setq byte-to-native-plist-environment
+ overriding-plist-environment)))))
(defmacro displaying-byte-compile-warnings (&rest body)
(declare (debug t))
@@ -2018,15 +2071,16 @@ See also `emacs-lisp-byte-compile-and-load'."
(insert "\n") ; aaah, unix.
(cond
((null target-file) nil) ;We only wanted the warnings!
- ((and (file-writable-p target-file)
- ;; We attempt to create a temporary file in the
- ;; target directory, so the target directory must be
- ;; writable.
- (file-writable-p
- (file-name-directory
- ;; Need to expand in case TARGET-FILE doesn't
- ;; include a directory (Bug#45287).
- (expand-file-name target-file))))
+ ((or byte-native-compiling
+ (and (file-writable-p target-file)
+ ;; We attempt to create a temporary file in the
+ ;; target directory, so the target directory must be
+ ;; writable.
+ (file-writable-p
+ (file-name-directory
+ ;; Need to expand in case TARGET-FILE doesn't
+ ;; include a directory (Bug#45287).
+ (expand-file-name target-file)))))
;; We must disable any code conversion here.
(let* ((coding-system-for-write 'no-conversion)
;; Write to a tempfile so that if another Emacs
@@ -2034,7 +2088,8 @@ See also `emacs-lisp-byte-compile-and-load'."
;; parallel bootstrap), it does not risk getting a
;; half-finished file. (Bug#4196)
(tempfile
- (make-temp-file (expand-file-name target-file)))
+ (make-temp-file (when (file-writable-p target-file)
+ (expand-file-name target-file))))
(default-modes (default-file-modes))
(temp-modes (logand default-modes #o600))
(desired-modes (logand default-modes #o666))
@@ -2053,8 +2108,16 @@ See also `emacs-lisp-byte-compile-and-load'."
;; emacs-lisp files in the build tree are
;; recompiled). Previously this was accomplished by
;; deleting target-file before writing it.
- (rename-file tempfile target-file t))
- (or noninteractive (message "Wrote %s" target-file)))
+ (if byte-native-compiling
+ (if byte-native-for-bootstrap
+ ;; Defer elc final renaming.
+ (setf byte-to-native-output-file
+ (cons tempfile target-file))
+ (delete-file tempfile))
+ (rename-file tempfile target-file t)))
+ (or noninteractive
+ byte-native-compiling
+ (message "Wrote %s" target-file)))
((file-writable-p target-file)
;; In case the target directory isn't writable (see e.g.
Bug#44631),
;; try writing to the output file directly. We must disable any
@@ -2174,6 +2237,17 @@ With argument ARG, insert value in current buffer after
the form."
(setq byte-compile-unresolved-functions nil)
(setq byte-compile-noruntime-functions nil)
(setq byte-compile-new-defuns nil)
+ (when byte-native-compiling
+ (defvar comp-speed)
+ (push `(comp-speed . ,comp-speed) byte-native-qualities)
+ (defvar comp-debug)
+ (push `(comp-debug . ,comp-debug) byte-native-qualities)
+ (defvar comp-native-driver-options)
+ (push `(comp-native-driver-options . ,comp-native-driver-options)
+ byte-native-qualities)
+ (defvar no-native-compile)
+ (push `(no-native-compile . ,no-native-compile)
+ byte-native-qualities))
;; Compile the forms from the input buffer.
(while (progn
@@ -2246,6 +2320,10 @@ Call from the source buffer."
;; defalias calls are output directly by byte-compile-file-form-defmumble;
;; it does not pay to first build the defalias in defmumble and then parse
;; it here.
+ (when byte-native-compiling
+ ;; Spill output for the native compiler here
+ (push (make-byte-to-native-top-level :form form :lexical lexical-binding)
+ byte-to-native-top-level-forms))
(let ((print-escape-newlines t)
(print-length nil)
(print-level nil)
@@ -2689,6 +2767,15 @@ not to take responsibility for the actual compilation of
the code."
;; If there's no doc string, provide -1 as the "doc string
;; index" so that no element will be treated as a doc string.
(if (not (stringp (documentation code t))) -1 4)))
+ (when byte-native-compiling
+ ;; Spill output for the native compiler here.
+ (push (if macro
+ (make-byte-to-native-top-level
+ :form `(defalias ',name '(macro . ,code) nil)
+ :lexical lexical-binding)
+ (make-byte-to-native-func-def :name name
+ :byte-func code))
+ byte-to-native-top-level-forms))
;; Output the form by hand, that's much simpler than having
;; b-c-output-file-form analyze the defalias.
(byte-compile-output-docform
@@ -2966,30 +3053,37 @@ for symbols generated by the byte compiler itself."
reserved-csts)))
;; Build the actual byte-coded function.
(cl-assert (eq 'byte-code (car-safe compiled)))
- (apply #'make-byte-code
- (if lexical-binding
- (byte-compile-make-args-desc arglist)
- arglist)
- (append
- ;; byte-string, constants-vector, stack depth
- (cdr compiled)
- ;; optionally, the doc string.
- (cond ((and lexical-binding arglist)
- ;; byte-compile-make-args-desc lost the args's names,
- ;; so preserve them in the docstring.
- (list (help-add-fundoc-usage doc arglist)))
- ((or doc int)
- (list doc)))
- ;; optionally, the interactive spec (and the modes the
- ;; command applies to).
- (cond
- ;; We have some command modes, so use the vector form.
- (command-modes
- (list (vector (nth 1 int) command-modes)))
- ;; No command modes, use the simple form with just the
- ;; interactive spec.
- (int
- (list (nth 1 int)))))))))
+ (let ((out
+ (apply #'make-byte-code
+ (if lexical-binding
+ (byte-compile-make-args-desc arglist)
+ arglist)
+ (append
+ ;; byte-string, constants-vector, stack depth
+ (cdr compiled)
+ ;; optionally, the doc string.
+ (cond ((and lexical-binding arglist)
+ ;; byte-compile-make-args-desc lost the args's
names,
+ ;; so preserve them in the docstring.
+ (list (help-add-fundoc-usage doc arglist)))
+ ((or doc int)
+ (list doc)))
+ ;; optionally, the interactive spec (and the modes the
+ ;; command applies to).
+ (cond
+ ;; We have some command modes, so use the vector form.
+ (command-modes
+ (list (vector (nth 1 int) command-modes)))
+ ;; No command modes, use the simple form with just the
+ ;; interactive spec.
+ (int
+ (list (nth 1 int))))))))
+ (when byte-native-compiling
+ (setf (byte-to-native-lambda-byte-func
+ (gethash (cadr compiled)
+ byte-to-native-lambdas-h))
+ out))
+ out))))
(defvar byte-compile-reserved-constants 0)
@@ -4621,10 +4715,15 @@ binding slots have been popped."
(defun byte-compile-condition-case (form)
(let* ((var (nth 1 form))
(body (nth 2 form))
+ (handlers (nthcdr 3 form))
(depth byte-compile-depth)
+ (success-handler (assq :success handlers))
+ (failure-handlers (if success-handler
+ (remq success-handler handlers)
+ handlers))
(clauses (mapcar (lambda (clause)
(cons (byte-compile-make-tag) clause))
- (nthcdr 3 form)))
+ failure-handlers))
(endtag (byte-compile-make-tag)))
(byte-compile-set-symbol-position 'condition-case)
(unless (symbolp var)
@@ -4650,30 +4749,40 @@ binding slots have been popped."
(byte-compile-form body) ;; byte-compile--for-effect
(dolist (_ clauses) (byte-compile-out 'byte-pophandler))
- (byte-compile-goto 'byte-goto endtag)
- (while clauses
- (let ((clause (pop clauses))
- (byte-compile-bound-variables byte-compile-bound-variables)
- (byte-compile--lexical-environment
- byte-compile--lexical-environment))
- (setq byte-compile-depth (1+ depth))
- (byte-compile-out-tag (pop clause))
- (dolist (_ clauses) (byte-compile-out 'byte-pophandler))
- (cond
- ((null var) (byte-compile-discard))
- (lexical-binding
- (push (cons var (1- byte-compile-depth))
- byte-compile--lexical-environment))
- (t (byte-compile-dynamic-variable-bind var)))
- (byte-compile-body (cdr clause)) ;; byte-compile--for-effect
- (cond
- ((null var) nil)
- (lexical-binding (byte-compile-discard 1 'preserve-tos))
- (t (byte-compile-out 'byte-unbind 1)))
- (byte-compile-goto 'byte-goto endtag)))
+ (let ((compile-handler-body
+ (lambda (body)
+ (let ((byte-compile-bound-variables byte-compile-bound-variables)
+ (byte-compile--lexical-environment
+ byte-compile--lexical-environment))
+ (cond
+ ((null var) (byte-compile-discard))
+ (lexical-binding
+ (push (cons var (1- byte-compile-depth))
+ byte-compile--lexical-environment))
+ (t (byte-compile-dynamic-variable-bind var)))
- (byte-compile-out-tag endtag)))
+ (byte-compile-body body) ;; byte-compile--for-effect
+
+ (cond
+ ((null var))
+ (lexical-binding (byte-compile-discard 1 'preserve-tos))
+ (t (byte-compile-out 'byte-unbind 1)))))))
+
+ (when success-handler
+ (funcall compile-handler-body (cdr success-handler)))
+
+ (byte-compile-goto 'byte-goto endtag)
+
+ (while clauses
+ (let ((clause (pop clauses)))
+ (setq byte-compile-depth (1+ depth))
+ (byte-compile-out-tag (pop clause))
+ (dolist (_ clauses) (byte-compile-out 'byte-pophandler))
+ (funcall compile-handler-body (cdr clause))
+ (byte-compile-goto 'byte-goto endtag)))
+
+ (byte-compile-out-tag endtag))))
(defun byte-compile-save-excursion (form)
(if (and (eq 'set-buffer (car-safe (car-safe (cdr form))))
@@ -5217,7 +5326,7 @@ Use with caution."
;; so it can cause recompilation to fail.
(not (member (file-name-nondirectory f)
'("pcase.el" "bytecomp.el" "macroexp.el"
- "cconv.el" "byte-opt.el"))))
+ "cconv.el" "byte-opt.el" "comp.el"))))
(message "Reloading stale %s" (file-name-nondirectory f))
(condition-case nil
(load f 'noerror nil 'nosuffix)
@@ -5298,13 +5407,15 @@ and corresponding effects."
;;
(eval-when-compile
(or (byte-code-function-p (symbol-function 'byte-compile-form))
+ (subr-native-elisp-p (symbol-function 'byte-compile-form))
(assq 'byte-code (symbol-function 'byte-compile-form))
(let ((byte-optimize nil) ; do it fast
(byte-compile-warnings nil))
(mapc (lambda (x)
- (or noninteractive (message "compiling %s..." x))
- (byte-compile x)
- (or noninteractive (message "compiling %s...done" x)))
+ (unless (subr-native-elisp-p x)
+ (or noninteractive (message "compiling %s..." x))
+ (byte-compile x)
+ (or noninteractive (message "compiling %s...done" x))))
'(byte-compile-normal-call
byte-compile-form
byte-compile-body
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index afaa13a..f663710 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -1,4 +1,4 @@
-;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*-
lexical-binding: t -*-
+;;; cconv.el --- Closure conversion for statically scoped Emacs Lisp. -*-
lexical-binding: t -*-
;; Copyright (C) 2011-2021 Free Software Foundation, Inc.
@@ -498,7 +498,7 @@ places where they originally did not directly appear."
(let* ((class (and var (cconv--var-classification (list var) form)))
(newenv
(cond ((eq class :captured+mutated)
- (cons `(,var . (car-save ,var)) env))
+ (cons `(,var . (car-safe ,var)) env))
((assq var env) (cons `(,var) env))
(t env)))
(msg (when (eq class :unused)
diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el
index 7c2b23b..bec4ad9 100644
--- a/lisp/emacs-lisp/check-declare.el
+++ b/lisp/emacs-lisp/check-declare.el
@@ -328,4 +328,4 @@ Returns non-nil if any false statements are found."
(provide 'check-declare)
-;;; check-declare.el ends here.
+;;; check-declare.el ends here
diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el
index 6285166..00cc777 100644
--- a/lisp/emacs-lisp/checkdoc.el
+++ b/lisp/emacs-lisp/checkdoc.el
@@ -160,9 +160,6 @@
;; not specifically docstring related. Would this even be useful?
;;; Code:
-(defvar checkdoc-version "0.6.2"
- "Release version of checkdoc you are currently running.")
-(make-obsolete-variable 'checkdoc-version nil "28.1")
(require 'cl-lib)
(require 'help-mode) ;; for help-xref-info-regexp
@@ -1245,7 +1242,7 @@ bound to
\\<checkdoc-minor-mode-map>\\[checkdoc-eval-defun] and `checkdoc-eval-c
checking of documentation strings.
\\{checkdoc-minor-mode-map}"
- nil checkdoc-minor-mode-string nil
+ :lighter checkdoc-minor-mode-string
:group 'checkdoc)
;;; Subst utils
@@ -2709,6 +2706,12 @@ function called to create the messages."
(custom-add-option 'emacs-lisp-mode-hook 'checkdoc-minor-mode)
+;; Obsolete
+
+(defvar checkdoc-version "0.6.2"
+ "Release version of checkdoc you are currently running.")
+(make-obsolete-variable 'checkdoc-version 'emacs-version "28.1")
+
(provide 'checkdoc)
;;; checkdoc.el ends here
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index f5b8c7b..31aa0cb 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -438,7 +438,7 @@ Presumes point is at the end of the `cl-defmethod' symbol."
;;;###autoload
(defmacro cl-defmethod (name args &rest body)
"Define a new method for generic function NAME.
-This it defines an implementation of NAME to use for invocations
+This defines an implementation of NAME to use for invocations
of specific types of arguments.
ARGS is a list of dispatch arguments (see `cl-defun'), but where
diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el
index 7d0bfc8..c88e15d 100644
--- a/lisp/emacs-lisp/cl-indent.el
+++ b/lisp/emacs-lisp/cl-indent.el
@@ -27,7 +27,7 @@
;; This package supplies a single entry point, common-lisp-indent-function,
;; which performs indentation in the preferred style for Common Lisp code.
-;; It is also a suitable function for indenting Emacs lisp code.
+;; It is also a suitable function for indenting Emacs Lisp code.
;;
;; To enable it:
;;
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 27ed07b..d7e6c30 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2141,6 +2141,15 @@ Like `cl-flet' but the definitions can refer to previous
ones.
;; tail-called any more.
(not (memq var shadowings)))))
`(,(car exp) ,bindings . ,(funcall opt-exps exps)))
+ ((and `(condition-case ,err-var ,bodyform . ,handlers)
+ (guard (not (eq err-var var))))
+ `(condition-case ,err-var
+ ,(if (assq :success handlers)
+ bodyform
+ `(progn (setq ,retvar ,bodyform) nil))
+ . ,(mapcar (lambda (h)
+ (cons (car h) (funcall opt-exps (cdr h))))
+ handlers)))
('nil nil) ;No need to set `retvar' to return nil.
(_ `(progn (setq ,retvar ,exp) nil))))))
@@ -2468,6 +2477,14 @@ values. For compatibility, (cl-values A B C) is a
synonym for (list A B C).
(defmacro cl-the (type form)
"Return FORM. If type-checking is enabled, assert that it is of TYPE."
(declare (indent 1) (debug (cl-type-spec form)))
+ ;; When native compiling possibly add the appropriate type hint.
+ (when (and (boundp 'byte-native-compiling)
+ byte-native-compiling)
+ (setf form
+ (cl-case type
+ (fixnum `(comp-hint-fixnum ,form))
+ (cons `(comp-hint-cons ,form))
+ (otherwise form))))
(if (not (or (not (macroexp-compiling-p))
(< cl--optimize-speed 3)
(= cl--optimize-safety 3)))
@@ -2478,6 +2495,28 @@ values. For compatibility, (cl-values A B C) is a
synonym for (list A B C).
(list ',type ,temp ',form)))
,temp))))
+;;;###autoload
+(or (assq 'cl-optimize defun-declarations-alist)
+ (let ((x (list 'cl-optimize #'cl--optimize)))
+ (push x macro-declarations-alist)
+ (push x defun-declarations-alist)))
+
+(defun cl--optimize (f _args &rest qualities)
+ "Serve 'cl-optimize' in function declarations.
+Example:
+(defun foo (x)
+ (declare (cl-optimize (speed 3) (safety 0)))
+ x)"
+ ;; FIXME this should make use of `cl--declare-stack' but I suspect
+ ;; this mechanism should be reviewed first.
+ (cl-loop for (qly val) in qualities
+ do (cl-ecase qly
+ (speed
+ (setf cl--optimize-speed val)
+ (byte-run--set-speed f nil val))
+ (safety
+ (setf cl--optimize-safety val)))))
+
(defvar cl--proclaim-history t) ; for future compilers
(defvar cl--declare-stack t) ; for future compilers
@@ -3547,6 +3586,10 @@ The type name can then be used in `cl-typecase',
`cl-check-type', etc."
(cl-function (lambda (&cl-defs ('*) ,@arglist) ,@body)))))
(cl-deftype extended-char () '(and character (not base-char)))
+;; Define fixnum so `cl-typep' recognize it and the type check emitted
+;; by `cl-the' is effective.
+(cl-deftype fixnum () 'fixnump)
+(cl-deftype bignum () 'bignump)
;;; Additional functions that we can now define because we've defined
;;; `cl-defsubst' and `cl-typep'.
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
new file mode 100644
index 0000000..73b78a3
--- /dev/null
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -0,0 +1,1192 @@
+;;; comp-cstr.el --- native compiler constraint library -*- lexical-binding: t
-*-
+
+;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
+
+;; Author: Andrea Corallo <akrl@sdf.com>
+;; Keywords: lisp
+;; Package: emacs
+
+;; 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:
+
+;; Constraint library in use by the native compiler.
+
+;; In LIMPLE each non immediate value is represented by a `comp-mvar'.
+;; The part concerning the set of all values the `comp-mvar' can
+;; assume is described into its constraint `comp-cstr'. Each
+;; constraint consists in a triplet: type-set, value-set, range-set.
+;; This file provide set operations between constraints (union
+;; intersection and negation) plus routines to convert from and to a
+;; CL like type specifier.
+
+;;; Code:
+
+(require 'cl-lib)
+
+(defconst comp--typeof-types (mapcar (lambda (x)
+ (append x '(t)))
+ cl--typeof-types)
+ ;; TODO can we just add t in `cl--typeof-types'?
+ "Like `cl--typeof-types' but with t as common supertype.")
+
+(defconst comp--all-builtin-types
+ (append cl--all-builtin-types '(t))
+ "Likewise like `cl--all-builtin-types' but with t as common supertype.")
+
+(cl-defstruct (comp-cstr (:constructor comp-type-to-cstr
+ (type &aux
+ (null (eq type 'null))
+ (integer (eq type 'integer))
+ (typeset (if (or null integer)
+ nil
+ (list type)))
+ (valset (when null
+ '(nil)))
+ (range (when integer
+ '((- . +))))))
+ (:constructor comp-value-to-cstr
+ (value &aux
+ (integer (integerp value))
+ (valset (unless integer
+ (list value)))
+ (range (when integer
+ `((,value . ,value))))
+ (typeset ())))
+ (:constructor comp-irange-to-cstr
+ (irange &aux
+ (range (list irange))
+ (typeset ())))
+ (:copier comp-cstr-shallow-copy))
+ "Internal representation of a type/value constraint."
+ (typeset '(t) :type list
+ :documentation "List of possible types the mvar can assume.
+Each element cannot be a subtype of any other element of this slot.")
+ (valset () :type list
+ :documentation "List of possible values the mvar can assume.
+Integer values are handled in the `range' slot.")
+ (range () :type list
+ :documentation "Integer interval.")
+ (neg nil :type boolean
+ :documentation "Non-nil if the constraint is negated"))
+
+(cl-defstruct comp-cstr-f
+ "Internal constraint representation for a function."
+ (args () :type list
+ :documentation "List of `comp-cstr' for its arguments.")
+ (ret nil :type (or comp-cstr comp-cstr-f)
+ :documentation "Returned value."))
+
+(cl-defstruct comp-cstr-ctxt
+ (union-typesets-mem (make-hash-table :test #'equal) :type hash-table
+ :documentation "Serve memoization for
+`comp-union-typesets'.")
+ ;; TODO we should be able to just cons hash this.
+ (common-supertype-mem (make-hash-table :test #'equal) :type hash-table
+ :documentation "Serve memoization for
+`comp-common-supertype'.")
+ (subtype-p-mem (make-hash-table :test #'equal) :type hash-table
+ :documentation "Serve memoization for
+`comp-subtype-p-mem'.")
+ (union-1-mem-no-range (make-hash-table :test #'equal) :type hash-table
+ :documentation "Serve memoization for
+`comp-cstr-union-1'.")
+ (union-1-mem-range (make-hash-table :test #'equal) :type hash-table
+ :documentation "Serve memoization for
+`comp-cstr-union-1'.")
+ (intersection-mem (make-hash-table :test #'equal) :type hash-table
+ :documentation "Serve memoization for
+`intersection-mem'."))
+
+(defmacro with-comp-cstr-accessors (&rest body)
+ "Define some quick accessor to reduce code vergosity in BODY."
+ (declare (debug (form body))
+ (indent defun))
+ `(cl-macrolet ((typeset (x)
+ `(comp-cstr-typeset ,x))
+ (valset (x)
+ `(comp-cstr-valset ,x))
+ (range (x)
+ `(comp-cstr-range ,x))
+ (neg (x)
+ `(comp-cstr-neg ,x)))
+ ,@body))
+
+(defun comp-cstr-copy (cstr)
+ "Return a deep copy of CSTR."
+ (with-comp-cstr-accessors
+ (make-comp-cstr :typeset (copy-sequence (typeset cstr))
+ :valset (copy-sequence (valset cstr))
+ :range (copy-tree (range cstr))
+ :neg (neg cstr))))
+
+(defsubst comp-cstr-empty-p (cstr)
+ "Return t if CSTR is equivalent to the `nil' type specifier or nil
otherwise."
+ (with-comp-cstr-accessors
+ (and (null (typeset cstr))
+ (null (valset cstr))
+ (null (range cstr))
+ (null (neg cstr)))))
+
+(defsubst comp-cstr-null-p (cstr)
+ "Return t if CSTR is equivalent to the `null' type specifier, nil otherwise."
+ (with-comp-cstr-accessors
+ (and (null (typeset cstr))
+ (null (range cstr))
+ (null (neg cstr))
+ (equal (valset cstr) '(nil)))))
+
+(defun comp-cstrs-homogeneous (cstrs)
+ "Check if constraints CSTRS are all homogeneously negated or non-negated.
+Return `pos' if they are all positive, `neg' if they are all
+negated or nil othewise."
+ (cl-loop
+ for cstr in cstrs
+ unless (comp-cstr-neg cstr)
+ count t into n-pos
+ else
+ count t into n-neg
+ finally
+ (cond
+ ((zerop n-neg) (cl-return 'pos))
+ ((zerop n-pos) (cl-return 'neg)))))
+
+(defun comp-split-pos-neg (cstrs)
+ "Split constraints CSTRS into non-negated and negated.
+Return them as multiple value."
+ (cl-loop
+ for cstr in cstrs
+ if (comp-cstr-neg cstr)
+ collect cstr into negatives
+ else
+ collect cstr into positives
+ finally return (cl-values positives negatives)))
+
+;; So we can load comp-cstr.el and comp.el in non native compiled
+;; builds.
+(defvar comp-ctxt nil)
+
+(defvar comp-cstr-one (comp-value-to-cstr 1)
+ "Represent the integer immediate one.")
+
+(defvar comp-cstr-t (comp-type-to-cstr t)
+ "Represent the superclass t.")
+
+
+;;; Value handling.
+
+(defun comp-normalize-valset (valset)
+ "Sort and remove duplicates from VALSET then return it."
+ (cl-remove-duplicates
+ (cl-sort valset (lambda (x y)
+ ;; We might want to use `sxhash-eql' for speed but
+ ;; this is safer to keep tests stable.
+ (< (sxhash-equal x)
+ (sxhash-equal y))))
+ :test #'eq))
+
+(defun comp-union-valsets (&rest valsets)
+ "Union values present into VALSETS."
+ (comp-normalize-valset (cl-reduce #'cl-union valsets)))
+
+(defun comp-intersection-valsets (&rest valsets)
+ "Union values present into VALSETS."
+ (comp-normalize-valset (cl-reduce #'cl-intersection valsets)))
+
+
+;;; Type handling.
+
+(defun comp-normalize-typeset (typeset)
+ "Sort TYPESET and return it."
+ (cl-sort (cl-remove-duplicates typeset)
+ (lambda (x y)
+ (string-lessp (symbol-name x)
+ (symbol-name y)))))
+
+(defun comp-supertypes (type)
+ "Return a list of pairs (supertype . hierarchy-level) for TYPE."
+ (cl-loop
+ named outer
+ with found = nil
+ for l in comp--typeof-types
+ do (cl-loop
+ for x in l
+ for i from (length l) downto 0
+ when (eq type x)
+ do (setf found t)
+ when found
+ collect `(,x . ,i) into res
+ finally (when found
+ (cl-return-from outer res)))))
+
+(defun comp-common-supertype-2 (type1 type2)
+ "Return the first common supertype of TYPE1 TYPE2."
+ (when-let ((types (cl-intersection
+ (comp-supertypes type1)
+ (comp-supertypes type2)
+ :key #'car)))
+ (car (cl-reduce (lambda (x y)
+ (if (> (cdr x) (cdr y)) x y))
+ types))))
+
+(defun comp-common-supertype (&rest types)
+ "Return the first common supertype of TYPES."
+ (or (gethash types (comp-cstr-ctxt-common-supertype-mem comp-ctxt))
+ (puthash types
+ (cl-reduce #'comp-common-supertype-2 types)
+ (comp-cstr-ctxt-common-supertype-mem comp-ctxt))))
+
+(defsubst comp-subtype-p (type1 type2)
+ "Return t if TYPE1 is a subtype of TYPE2 or nil otherwise."
+ (let ((types (cons type1 type2)))
+ (or (gethash types (comp-cstr-ctxt-subtype-p-mem comp-ctxt))
+ (puthash types
+ (eq (comp-common-supertype-2 type1 type2) type2)
+ (comp-cstr-ctxt-subtype-p-mem comp-ctxt)))))
+
+(defun comp-union-typesets (&rest typesets)
+ "Union types present into TYPESETS."
+ (or (gethash typesets (comp-cstr-ctxt-union-typesets-mem comp-ctxt))
+ (puthash typesets
+ (cl-loop
+ with types = (apply #'append typesets)
+ with res = '()
+ for lane in comp--typeof-types
+ do (cl-loop
+ with last = nil
+ for x in lane
+ when (memq x types)
+ do (setf last x)
+ finally (when last
+ (push last res)))
+ finally return (comp-normalize-typeset res))
+ (comp-cstr-ctxt-union-typesets-mem comp-ctxt))))
+
+(defun comp-intersect-two-typesets (t1 t2)
+ "Intersect typesets T1 and T2."
+ (with-comp-cstr-accessors
+ (cl-loop
+ for types in (list t1 t2)
+ for other-types in (list t2 t1)
+ append
+ (cl-loop
+ for type in types
+ when (cl-some (lambda (x)
+ (comp-subtype-p type x))
+ other-types)
+ collect type))))
+
+(defun comp-intersect-typesets (&rest typesets)
+ "Intersect types present into TYPESETS."
+ (unless (cl-some #'null typesets)
+ (if (length= typesets 1)
+ (car typesets)
+ (comp-normalize-typeset
+ (cl-reduce #'comp-intersect-two-typesets typesets)))))
+
+
+;;; Integer range handling
+
+(defsubst comp-star-or-num-p (x)
+ (or (numberp x) (eq '* x)))
+
+(defsubst comp-range-1+ (x)
+ (if (symbolp x)
+ x
+ (1+ x)))
+
+(defsubst comp-range-1- (x)
+ (if (symbolp x)
+ x
+ (1- x)))
+
+(defsubst comp-range-+ (x y)
+ (pcase (cons x y)
+ ((or '(+ . -) '(- . +)) '??)
+ ((or `(- . ,_) `(,_ . -)) '-)
+ ((or `(+ . ,_) `(,_ . +)) '+)
+ (_ (+ x y))))
+
+(defsubst comp-range-- (x y)
+ (pcase (cons x y)
+ ((or '(+ . +) '(- . -)) '??)
+ ('(+ . -) '+)
+ ('(- . +) '-)
+ ((or `(+ . ,_) `(,_ . -)) '+)
+ ((or `(- . ,_) `(,_ . +)) '-)
+ (_ (- x y))))
+
+(defsubst comp-range-< (x y)
+ (cond
+ ((eq x '+) nil)
+ ((eq x '-) t)
+ ((eq y '+) t)
+ ((eq y '-) nil)
+ (t (< x y))))
+
+(defsubst comp-cstr-smallest-in-range (range)
+ "Smallest entry in RANGE."
+ (caar range))
+
+(defsubst comp-cstr-greatest-in-range (range)
+ "Greater entry in RANGE."
+ (cdar (last range)))
+
+(defun comp-range-union (&rest ranges)
+ "Combine integer intervals RANGES by union set operation."
+ (cl-loop
+ with all-ranges = (apply #'append ranges)
+ with lows = (mapcar (lambda (x)
+ (cons (comp-range-1- (car x)) 'l))
+ all-ranges)
+ with highs = (mapcar (lambda (x)
+ (cons (cdr x) 'h))
+ all-ranges)
+ with nest = 0
+ with low = nil
+ with res = ()
+ for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car)
+ if (eq x 'l)
+ do
+ (when (zerop nest)
+ (setf low i))
+ (cl-incf nest)
+ else
+ do
+ (when (= nest 1)
+ (push `(,(comp-range-1+ low) . ,i) res))
+ (cl-decf nest)
+ finally return (reverse res)))
+
+(defun comp-range-intersection (&rest ranges)
+ "Combine integer intervals RANGES by intersecting."
+ (cl-loop
+ with all-ranges = (apply #'append ranges)
+ with n-ranges = (length ranges)
+ with lows = (mapcar (lambda (x)
+ (cons (car x) 'l))
+ all-ranges)
+ with highs = (mapcar (lambda (x)
+ (cons (cdr x) 'h))
+ all-ranges)
+ with nest = 0
+ with low = nil
+ with res = ()
+ for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car)
+ initially (when (cl-some #'null ranges)
+ ;; Intersecting with a null range always results in a
+ ;; null range.
+ (cl-return '()))
+ if (eq x 'l)
+ do
+ (cl-incf nest)
+ (when (= nest n-ranges)
+ (setf low i))
+ else
+ do
+ (when (= nest n-ranges)
+ (push `(,low . ,i)
+ res))
+ (cl-decf nest)
+ finally return (reverse res)))
+
+(defun comp-range-negation (range)
+ "Negate range RANGE."
+ (if (null range)
+ '((- . +))
+ (cl-loop
+ with res = ()
+ with last-h = '-
+ for (l . h) in range
+ unless (eq l '-)
+ do (push `(,(comp-range-1+ last-h) . ,(1- l)) res)
+ do (setf last-h h)
+ finally
+ (unless (eq '+ last-h)
+ (push `(,(1+ last-h) . +) res))
+ (cl-return (reverse res)))))
+
+(defsubst comp-cstr-set-cmp-range (dst old-dst ext-range)
+ "Support range comparison functions."
+ (with-comp-cstr-accessors
+ (if ext-range
+ (setf (typeset dst) (when (cl-some (lambda (x)
+ (comp-subtype-p 'float x))
+ (typeset old-dst))
+ '(float))
+ (valset dst) ()
+ (range dst) (if (range old-dst)
+ (comp-range-intersection (range old-dst)
+ ext-range)
+ ext-range)
+ (neg dst) nil)
+ (setf (typeset dst) (typeset old-dst)
+ (valset dst) (valset old-dst)
+ (range dst) (range old-dst)
+ (neg dst) (neg old-dst)))))
+
+(defmacro comp-cstr-set-range-for-arithm (dst src1 src2 &rest range-body)
+ ;; Prevent some code duplication for `comp-cstr-add-2'
+ ;; `comp-cstr-sub-2'.
+ (declare (debug (range-body))
+ (indent defun))
+ `(with-comp-cstr-accessors
+ (when-let ((r1 (range ,src1))
+ (r2 (range ,src2)))
+ (let* ((l1 (comp-cstr-smallest-in-range r1))
+ (l2 (comp-cstr-smallest-in-range r2))
+ (h1 (comp-cstr-greatest-in-range r1))
+ (h2 (comp-cstr-greatest-in-range r2)))
+ (setf (typeset ,dst) (when (cl-some (lambda (x)
+ (comp-subtype-p 'float x))
+ (append (typeset src1)
+ (typeset src2)))
+ '(float))
+ (range ,dst) ,@range-body)))))
+
+(defun comp-cstr-add-2 (dst src1 src2)
+ "Sum SRC1 and SRC2 into DST."
+ (comp-cstr-set-range-for-arithm dst src1 src2
+ `((,(comp-range-+ l1 l2) . ,(comp-range-+ h1 h2)))))
+
+(defun comp-cstr-sub-2 (dst src1 src2)
+ "Subtract SRC1 and SRC2 into DST."
+ (comp-cstr-set-range-for-arithm dst src1 src2
+ (let ((l (comp-range-- l1 h2))
+ (h (comp-range-- h1 l2)))
+ (if (or (eq l '??) (eq h '??))
+ '((- . +))
+ `((,l . ,h))))))
+
+
+;;; Union specific code.
+
+(defun comp-cstr-union-homogeneous-no-range (dst &rest srcs)
+ "As `comp-cstr-union' but escluding the irange component.
+All SRCS constraints must be homogeneously negated or non-negated."
+
+ ;; Type propagation.
+ (setf (comp-cstr-typeset dst)
+ (apply #'comp-union-typesets (mapcar #'comp-cstr-typeset srcs)))
+
+ ;; Value propagation.
+ (setf (comp-cstr-valset dst)
+ (comp-normalize-valset
+ (cl-loop
+ with values = (mapcar #'comp-cstr-valset srcs)
+ ;; TODO sort.
+ for v in (cl-remove-duplicates (apply #'append values)
+ :test #'equal)
+ ;; We propagate only values those types are not already
+ ;; into typeset.
+ when (cl-notany (lambda (x)
+ (comp-subtype-p (type-of v) x))
+ (comp-cstr-typeset dst))
+ collect v)))
+
+ dst)
+
+(defun comp-cstr-union-homogeneous (range dst &rest srcs)
+ "Combine SRCS by union set operation setting the result in DST.
+Do range propagation when RANGE is non-nil.
+All SRCS constraints must be homogeneously negated or non-negated.
+DST is returned."
+ (apply #'comp-cstr-union-homogeneous-no-range dst srcs)
+ ;; Range propagation.
+ (setf (comp-cstr-neg dst)
+ (when srcs
+ (comp-cstr-neg (car srcs)))
+
+ (comp-cstr-range dst)
+ (when (cl-notany (lambda (x)
+ (comp-subtype-p 'integer x))
+ (comp-cstr-typeset dst))
+ (if range
+ (apply #'comp-range-union
+ (mapcar #'comp-cstr-range srcs))
+ '((- . +)))))
+ dst)
+
+(cl-defun comp-cstr-union-1-no-mem (range &rest srcs)
+ "Combine SRCS by union set operation setting the result in DST.
+Do range propagation when RANGE is non-nil.
+Non memoized version of `comp-cstr-union-1'.
+DST is returned."
+ (with-comp-cstr-accessors
+ (let ((dst (make-comp-cstr)))
+ (cl-flet ((give-up ()
+ (setf (typeset dst) '(t)
+ (valset dst) ()
+ (range dst) ()
+ (neg dst) nil)
+ (cl-return-from comp-cstr-union-1-no-mem dst)))
+
+ ;; Check first if we are in the simple case of all input non-negate
+ ;; or negated so we don't have to cons.
+ (when-let ((res (comp-cstrs-homogeneous srcs)))
+ (apply #'comp-cstr-union-homogeneous range dst srcs)
+ (cl-return-from comp-cstr-union-1-no-mem dst))
+
+ ;; Some are negated and some are not
+ (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs)
+ (let* ((pos (apply #'comp-cstr-union-homogeneous range
+ (make-comp-cstr) positives))
+ ;; We'll always use neg as result as this is almost
+ ;; always necessary for describing open intervals
+ ;; resulting from negated constraints.
+ (neg (apply #'comp-cstr-union-homogeneous range
+ (make-comp-cstr :neg t) negatives)))
+ ;; Type propagation.
+ (when (and (typeset pos)
+ ;; When every pos type is a subtype of some neg ones.
+ (cl-every (lambda (x)
+ (cl-some (lambda (y)
+ (comp-subtype-p x y))
+ (append (typeset neg)
+ (when (range neg)
+ '(integer)))))
+ (typeset pos)))
+ ;; This is a conservative choice, ATM we can't represent such
+ ;; a disjoint set of types unless we decide to add a new slot
+ ;; into `comp-cstr' or adopt something like
+ ;; `intersection-type' `union-type' in SBCL. Keep it
+ ;; "simple" for now.
+ (give-up))
+
+ ;; When every neg type is a subtype of some pos one.
+ ;; In case return pos.
+ (when (and (typeset neg)
+ (cl-every (lambda (x)
+ (cl-some (lambda (y)
+ (comp-subtype-p x y))
+ (append (typeset pos)
+ (when (range pos)
+ '(integer)))))
+ (typeset neg)))
+ (setf (typeset dst) (typeset pos)
+ (valset dst) (valset pos)
+ (range dst) (range pos)
+ (neg dst) nil)
+ (cl-return-from comp-cstr-union-1-no-mem dst))
+
+ ;; Verify disjoint condition between positive types and
+ ;; negative types coming from values, in case give-up.
+ (let ((neg-value-types (nconc (mapcar #'type-of (valset neg))
+ (when (range neg)
+ '(integer)))))
+ (when (cl-some (lambda (x)
+ (cl-some (lambda (y)
+ (and (not (eq y x))
+ (comp-subtype-p y x)))
+ neg-value-types))
+ (typeset pos))
+ (give-up)))
+
+ ;; Value propagation.
+ (cond
+ ((and (valset pos) (valset neg)
+ (equal (comp-union-valsets (valset pos) (valset neg))
+ (valset pos)))
+ ;; Pos is a superset of neg.
+ (give-up))
+ ((cl-some (lambda (x)
+ (cl-some (lambda (y)
+ (comp-subtype-p y x))
+ (mapcar #'type-of (valset pos))))
+ (typeset neg))
+ (give-up))
+ (t
+ ;; pos is a subset or eq to neg
+ (setf (valset neg)
+ (cl-nset-difference (valset neg) (valset pos)))))
+
+ ;; Range propagation
+ (when range
+ ;; Handle apart (or (integer 1 1) (not (integer 1 1)))
+ ;; like cases.
+ (if (and (range pos) (range neg)
+ (equal (range pos) (range neg)))
+ (give-up)
+ (setf (range neg)
+ (comp-range-negation
+ (comp-range-union
+ (comp-range-negation (range neg))
+ (range pos))))))
+
+ (if (comp-cstr-empty-p neg)
+ (setf (typeset dst) (typeset pos)
+ (valset dst) (valset pos)
+ (range dst) (range pos)
+ (neg dst) nil)
+ (setf (typeset dst) (typeset neg)
+ (valset dst) (valset neg)
+ (range dst) (range neg)
+ (neg dst) (neg neg)))))
+
+ ;; (not null) => t
+ (when (and (neg dst)
+ (null (typeset dst))
+ (null (valset dst))
+ (null (range dst)))
+ (give-up)))
+
+ dst)))
+
+(defun comp-cstr-union-1 (range dst &rest srcs)
+ "Combine SRCS by union set operation setting the result in DST.
+Do range propagation when RANGE is non-nil.
+DST is returned."
+ (with-comp-cstr-accessors
+ (let* ((mem-h (if range
+ (comp-cstr-ctxt-union-1-mem-range comp-ctxt)
+ (comp-cstr-ctxt-union-1-mem-no-range comp-ctxt)))
+ (res (or (gethash srcs mem-h)
+ (puthash
+ (mapcar #'comp-cstr-copy srcs)
+ (apply #'comp-cstr-union-1-no-mem range srcs)
+ mem-h))))
+ (setf (typeset dst) (typeset res)
+ (valset dst) (valset res)
+ (range dst) (range res)
+ (neg dst) (neg res))
+ res)))
+
+(cl-defun comp-cstr-intersection-homogeneous (dst &rest srcs)
+ "Combine SRCS by intersection set operation setting the result in DST.
+All SRCS constraints must be homogeneously negated or non-negated.
+DST is returned."
+
+ (with-comp-cstr-accessors
+ (when (cl-some #'comp-cstr-empty-p srcs)
+ (setf (valset dst) nil
+ (range dst) nil
+ (typeset dst) nil)
+ (cl-return-from comp-cstr-intersection-homogeneous dst))
+
+ (setf (neg dst) (when srcs
+ (neg (car srcs))))
+
+ ;; Type propagation.
+ (setf (typeset dst)
+ (apply #'comp-intersect-typesets
+ (mapcar #'comp-cstr-typeset srcs)))
+
+ ;; Value propagation.
+ (setf (valset dst)
+ (comp-normalize-valset
+ (cl-loop
+ for src in srcs
+ append
+ (cl-loop
+ for val in (valset src)
+ ;; If (member value) is subtypep of all other sources then
+ ;; is good to be colleted.
+ when (cl-every (lambda (s)
+ (or (memql val (valset s))
+ (cl-some (lambda (type)
+ (cl-typep val type))
+ (typeset s))))
+ (remq src srcs))
+ collect val))))
+
+ ;; Range propagation.
+ (setf (range dst)
+ ;; Do range propagation only if the destination typeset
+ ;; doesn't cover it already.
+ (unless (cl-some (lambda (type)
+ (comp-subtype-p 'integer type))
+ (typeset dst))
+ (apply #'comp-range-intersection
+ (cl-loop
+ for src in srcs
+ ;; Collect effective ranges.
+ collect (or (range src)
+ (when (cl-some (lambda (s)
+ (comp-subtype-p 'integer s))
+ (typeset src))
+ '((- . +))))))))
+
+ dst))
+
+(cl-defun comp-cstr-intersection-no-mem (&rest srcs)
+ "Combine SRCS by intersection set operation.
+Non memoized version of `comp-cstr-intersection-no-mem'."
+ (let ((dst (make-comp-cstr)))
+ (with-comp-cstr-accessors
+ (cl-flet ((return-empty ()
+ (setf (typeset dst) ()
+ (valset dst) ()
+ (range dst) ()
+ (neg dst) nil)
+ (cl-return-from comp-cstr-intersection-no-mem
dst)))
+ (when-let ((res (comp-cstrs-homogeneous srcs)))
+ (if (eq res 'neg)
+ (apply #'comp-cstr-union-homogeneous t dst srcs)
+ (apply #'comp-cstr-intersection-homogeneous dst srcs))
+ (cl-return-from comp-cstr-intersection-no-mem dst))
+
+ ;; Some are negated and some are not
+ (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs)
+ (let* ((pos (apply #'comp-cstr-intersection-homogeneous
+ (make-comp-cstr) positives))
+ (neg (apply #'comp-cstr-intersection-homogeneous
+ (make-comp-cstr) negatives)))
+
+ ;; In case pos is not relevant return directly the content
+ ;; of neg.
+ (when (equal (typeset pos) '(t))
+ (setf (typeset dst) (typeset neg)
+ (valset dst) (valset neg)
+ (range dst) (range neg)
+ (neg dst) t)
+
+ ;; (not t) => nil
+ (when (and (null (valset dst))
+ (null (range dst))
+ (neg dst)
+ (equal '(t) (typeset dst)))
+ (setf (typeset dst) ()
+ (neg dst) nil))
+
+ (cl-return-from comp-cstr-intersection-no-mem dst))
+
+ (when (cl-some
+ (lambda (ty)
+ (memq ty (typeset neg)))
+ (typeset pos))
+ (return-empty))
+
+ ;; Some negated types are subtypes of some non-negated one.
+ ;; Transform the corresponding set of types from neg to pos.
+ (cl-loop
+ for neg-type in (typeset neg)
+ do (cl-loop
+ for pos-type in (copy-sequence (typeset pos))
+ when (and (not (eq neg-type pos-type))
+ (comp-subtype-p neg-type pos-type))
+ do (cl-loop
+ with found
+ for (type . _) in (comp-supertypes neg-type)
+ when found
+ collect type into res
+ when (eq type pos-type)
+ do (setf (typeset pos) (cl-union (typeset pos) res))
+ (cl-return)
+ when (eq type neg-type)
+ do (setf found t))))
+
+ (setf (range pos)
+ (comp-range-intersection (range pos)
+ (comp-range-negation (range neg)))
+ (valset pos)
+ (cl-set-difference (valset pos) (valset neg)))
+
+ ;; Return a non negated form.
+ (setf (typeset dst) (typeset pos)
+ (valset dst) (valset pos)
+ (range dst) (range pos)
+ (neg dst) nil)))
+ dst))))
+
+
+;;; Entry points.
+
+(defun comp-cstr-imm-vld-p (cstr)
+ "Return t if one and only one immediate value can be extracted from CSTR."
+ (with-comp-cstr-accessors
+ (when (and (null (typeset cstr))
+ (null (neg cstr)))
+ (let* ((v (valset cstr))
+ (r (range cstr))
+ (valset-len (length v))
+ (range-len (length r)))
+ (if (and (= valset-len 1)
+ (= range-len 0))
+ t
+ (when (and (= valset-len 0)
+ (= range-len 1))
+ (let* ((low (caar r))
+ (high (cdar r)))
+ (and (integerp low)
+ (integerp high)
+ (= low high)))))))))
+
+(defun comp-cstr-imm (cstr)
+ "Return the immediate value of CSTR.
+`comp-cstr-imm-vld-p' *must* be satisfied before calling
+`comp-cstr-imm'."
+ (declare (gv-setter
+ (lambda (val)
+ `(with-comp-cstr-accessors
+ (if (integerp ,val)
+ (setf (typeset ,cstr) nil
+ (range ,cstr) (list (cons ,val ,val)))
+ (setf (typeset ,cstr) nil
+ (valset ,cstr) (list ,val)))))))
+ (with-comp-cstr-accessors
+ (let ((v (valset cstr)))
+ (if (length= v 1)
+ (car v)
+ (caar (range cstr))))))
+
+(defun comp-cstr-fixnum-p (cstr)
+ "Return t if CSTR is certainly a fixnum."
+ (with-comp-cstr-accessors
+ (when (null (neg cstr))
+ (when-let (range (range cstr))
+ (let* ((low (caar range))
+ (high (cdar (last range))))
+ (unless (or (eq low '-)
+ (< low most-negative-fixnum)
+ (eq high '+)
+ (> high most-positive-fixnum))
+ t))))))
+
+(defun comp-cstr-symbol-p (cstr)
+ "Return t if CSTR is certainly a symbol."
+ (with-comp-cstr-accessors
+ (and (null (range cstr))
+ (null (neg cstr))
+ (or (and (null (valset cstr))
+ (equal (typeset cstr) '(symbol)))
+ (and (or (null (typeset cstr))
+ (equal (typeset cstr) '(symbol)))
+ (cl-every #'symbolp (valset cstr)))))))
+
+(defsubst comp-cstr-cons-p (cstr)
+ "Return t if CSTR is certainly a cons."
+ (with-comp-cstr-accessors
+ (and (null (valset cstr))
+ (null (range cstr))
+ (null (neg cstr))
+ (equal (typeset cstr) '(cons)))))
+
+(defun comp-cstr-= (dst op1 op2)
+ "Constraint OP1 being = OP2 setting the result into DST."
+ (with-comp-cstr-accessors
+ (cl-flet ((relax-cstr (cstr)
+ (setf cstr (comp-cstr-shallow-copy cstr))
+ ;; If can be any float extend it to all integers.
+ (when (memq 'float (typeset cstr))
+ (setf (range cstr) '((- . +))))
+ ;; For each float value that can be represented
+ ;; precisely as an integer add the integer as well.
+ (cl-loop
+ for v in (valset cstr)
+ do
+ (when-let* ((ok (floatp v))
+ (truncated (ignore-error overflow-error
+ (truncate v)))
+ (ok (= v truncated)))
+ (push (cons truncated truncated) (range cstr))))
+ (cl-loop
+ with vals-to-add
+ for (l . h) in (range cstr)
+ ;; If an integer range reduces to single value add
+ ;; its float value too.
+ if (eql l h)
+ do (push (float l) vals-to-add)
+ ;; Otherwise can be any float.
+ else
+ do (cl-pushnew 'float (typeset cstr))
+ (cl-return cstr)
+ finally (setf (valset cstr)
+ (append vals-to-add (valset cstr))))
+ (when (memql 0.0 (valset cstr))
+ (cl-pushnew -0.0 (valset cstr)))
+ (when (memql -0.0 (valset cstr))
+ (cl-pushnew 0.0 (valset cstr)))
+ cstr))
+ (comp-cstr-intersection dst (relax-cstr op1) (relax-cstr op2)))))
+
+(defun comp-cstr-> (dst old-dst src)
+ "Constraint DST being > than SRC.
+SRC can be either a comp-cstr or an integer."
+ (with-comp-cstr-accessors
+ (let ((ext-range
+ (if (integerp src)
+ `((,(1+ src) . +))
+ (when-let* ((range (range src))
+ (low (comp-cstr-smallest-in-range range))
+ (okay (integerp low)))
+ `((,(1+ low) . +))))))
+ (comp-cstr-set-cmp-range dst old-dst ext-range))))
+
+(defun comp-cstr->= (dst old-dst src)
+ "Constraint DST being >= than SRC.
+SRC can be either a comp-cstr or an integer."
+ (with-comp-cstr-accessors
+ (let ((ext-range
+ (if (integerp src)
+ `((,src . +))
+ (when-let* ((range (range src))
+ (low (comp-cstr-smallest-in-range range))
+ (okay (integerp low)))
+ `((,low . +))))))
+ (comp-cstr-set-cmp-range dst old-dst ext-range))))
+
+(defun comp-cstr-< (dst old-dst src)
+ "Constraint DST being < than SRC.
+SRC can be either a comp-cstr or an integer."
+ (with-comp-cstr-accessors
+ (let ((ext-range
+ (if (integerp src)
+ `((- . ,(1- src)))
+ (when-let* ((range (range src))
+ (low (comp-cstr-greatest-in-range range))
+ (okay (integerp low)))
+ `((- . ,(1- low)))))))
+ (comp-cstr-set-cmp-range dst old-dst ext-range))))
+
+(defun comp-cstr-<= (dst old-dst src)
+ "Constraint DST being > than SRC.
+SRC can be either a comp-cstr or an integer."
+ (with-comp-cstr-accessors
+ (let ((ext-range
+ (if (integerp src)
+ `((- . ,src))
+ (when-let* ((range (range src))
+ (low (comp-cstr-greatest-in-range range))
+ (okay (integerp low)))
+ `((- . ,low))))))
+ (comp-cstr-set-cmp-range dst old-dst ext-range))))
+
+(defun comp-cstr-add (dst srcs)
+ "Sum SRCS into DST."
+ (comp-cstr-add-2 dst (cl-first srcs) (cl-second srcs))
+ (cl-loop
+ for src in (nthcdr 2 srcs)
+ do (comp-cstr-add-2 dst dst src)))
+
+(defun comp-cstr-sub (dst srcs)
+ "Subtract SRCS into DST."
+ (comp-cstr-sub-2 dst (cl-first srcs) (cl-second srcs))
+ (cl-loop
+ for src in (nthcdr 2 srcs)
+ do (comp-cstr-sub-2 dst dst src)))
+
+(defun comp-cstr-union-no-range (dst &rest srcs)
+ "Combine SRCS by union set operation setting the result in DST.
+Do not propagate the range component.
+DST is returned."
+ (apply #'comp-cstr-union-1 nil dst srcs))
+
+(defun comp-cstr-union (dst &rest srcs)
+ "Combine SRCS by union set operation setting the result in DST.
+DST is returned."
+ (apply #'comp-cstr-union-1 t dst srcs))
+
+(defun comp-cstr-union-make (&rest srcs)
+ "Combine SRCS by union set operation and return a new constraint."
+ (apply #'comp-cstr-union (make-comp-cstr) srcs))
+
+(defun comp-cstr-intersection (dst &rest srcs)
+ "Combine SRCS by intersection set operation setting the result in DST.
+DST is returned."
+ (with-comp-cstr-accessors
+ (let* ((mem-h (comp-cstr-ctxt-intersection-mem comp-ctxt))
+ (res (or (gethash srcs mem-h)
+ (puthash
+ (mapcar #'comp-cstr-copy srcs)
+ (apply #'comp-cstr-intersection-no-mem srcs)
+ mem-h))))
+ (setf (typeset dst) (typeset res)
+ (valset dst) (valset res)
+ (range dst) (range res)
+ (neg dst) (neg res))
+ res)))
+
+(defun comp-cstr-intersection-no-hashcons (dst &rest srcs)
+ "Combine SRCS by intersection set operation setting the result in DST.
+Non hash consed values are not propagated as values but rather
+promoted to their types.
+DST is returned."
+ (with-comp-cstr-accessors
+ (apply #'comp-cstr-intersection dst srcs)
+ (if (and (neg dst)
+ (valset dst)
+ (cl-notevery #'symbolp (valset dst)))
+ (setf (valset dst) ()
+ (typeset dst) '(t)
+ (range dst) ()
+ (neg dst) nil)
+ (let (strip-values strip-types)
+ (cl-loop for v in (valset dst)
+ unless (symbolp v)
+ do (push v strip-values)
+ (push (type-of v) strip-types))
+ (when strip-values
+ (setf (typeset dst) (comp-union-typesets (typeset dst) strip-types)
+ (valset dst) (cl-set-difference (valset dst) strip-values)))
+ (cl-loop for (l . h) in (range dst)
+ when (or (bignump l) (bignump h))
+ do (setf (range dst) '((- . +)))
+ (cl-return))))
+ dst))
+
+(defun comp-cstr-intersection-make (&rest srcs)
+ "Combine SRCS by intersection set operation and return a new constraint."
+ (apply #'comp-cstr-intersection (make-comp-cstr) srcs))
+
+(defun comp-cstr-negation (dst src)
+ "Negate SRC setting the result in DST.
+DST is returned."
+ (with-comp-cstr-accessors
+ (cond
+ ((and (null (valset src))
+ (null (range src))
+ (null (neg src))
+ (equal (typeset src) '(t)))
+ (setf (typeset dst) ()
+ (valset dst) ()
+ (range dst) nil
+ (neg dst) nil))
+ ((and (null (valset src))
+ (null (range src))
+ (null (neg src))
+ (null (typeset src)))
+ (setf (typeset dst) '(t)
+ (valset dst) ()
+ (range dst) nil
+ (neg dst) nil))
+ (t (setf (typeset dst) (typeset src)
+ (valset dst) (valset src)
+ (range dst) (range src)
+ (neg dst) (not (neg src)))))
+ dst))
+
+(defun comp-cstr-value-negation (dst src)
+ "Negate values in SRC setting the result in DST.
+DST is returned."
+ (with-comp-cstr-accessors
+ (if (or (valset src) (range src))
+ (setf (typeset dst) ()
+ (valset dst) (valset src)
+ (range dst) (range src)
+ (neg dst) (not (neg src)))
+ (setf (typeset dst) (typeset src)
+ (valset dst) ()
+ (range dst) ()))
+ dst))
+
+(defun comp-cstr-negation-make (src)
+ "Negate SRC and return a new constraint."
+ (comp-cstr-negation (make-comp-cstr) src))
+
+(defun comp-type-spec-to-cstr (type-spec &optional fn)
+ "Convert a type specifier TYPE-SPEC into a `comp-cstr'.
+FN non-nil indicates we are parsing a function lambda list."
+ (pcase type-spec
+ ((and (or '&optional '&rest) x)
+ (if fn
+ x
+ (error "Invalid `%s` in type specifier" x)))
+ ('nil
+ (make-comp-cstr :typeset ()))
+ ('fixnum
+ (comp-irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum)))
+ ('boolean
+ (comp-type-spec-to-cstr '(member t nil)))
+ ('integer
+ (comp-irange-to-cstr '(- . +)))
+ ('null (comp-value-to-cstr nil))
+ ((pred atom)
+ (comp-type-to-cstr type-spec))
+ (`(or . ,rest)
+ (apply #'comp-cstr-union-make
+ (mapcar #'comp-type-spec-to-cstr rest)))
+ (`(and . ,rest)
+ (apply #'comp-cstr-intersection-make
+ (mapcar #'comp-type-spec-to-cstr rest)))
+ (`(not ,cstr)
+ (comp-cstr-negation-make (comp-type-spec-to-cstr cstr)))
+ (`(integer ,(and (pred integerp) l) ,(and (pred integerp) h))
+ (comp-irange-to-cstr `(,l . ,h)))
+ (`(integer * ,(and (pred integerp) h))
+ (comp-irange-to-cstr `(- . ,h)))
+ (`(integer ,(and (pred integerp) l) *)
+ (comp-irange-to-cstr `(,l . +)))
+ (`(float ,(pred comp-star-or-num-p) ,(pred comp-star-or-num-p))
+ ;; No float range support :/
+ (comp-type-to-cstr 'float))
+ (`(member . ,rest)
+ (apply #'comp-cstr-union-make (mapcar #'comp-value-to-cstr rest)))
+ (`(function ,args ,ret)
+ (make-comp-cstr-f
+ :args (mapcar (lambda (x)
+ (comp-type-spec-to-cstr x t))
+ args)
+ :ret (comp-type-spec-to-cstr ret)))
+ (_ (error "Invalid type specifier"))))
+
+(defun comp-cstr-to-type-spec (cstr)
+ "Given CSTR return its type specifier."
+ (let ((valset (comp-cstr-valset cstr))
+ (typeset (comp-cstr-typeset cstr))
+ (range (comp-cstr-range cstr))
+ (negated (comp-cstr-neg cstr)))
+
+ (when valset
+ (when (memq nil valset)
+ (if (memq t valset)
+ (progn
+ ;; t and nil are values, convert into `boolean'.
+ (push 'boolean typeset)
+ (setf valset (remove t (remove nil valset))))
+ ;; Only nil is a value, convert it into a `null' type specifier.
+ (setf valset (remove nil valset))
+ (push 'null typeset))))
+
+ ;; Form proper integer type specifiers.
+ (setf range (cl-loop for (l . h) in range
+ for low = (if (integerp l) l '*)
+ for high = (if (integerp h) h '*)
+ if (and (eq low '*) (eq high '*))
+ collect 'integer
+ else
+ collect `(integer ,low , high))
+ valset (cl-remove-duplicates valset))
+
+ ;; Form the final type specifier.
+ (let* ((types-ints (append typeset range))
+ (res (cond
+ ((and types-ints valset)
+ `((member ,@valset) ,@types-ints))
+ (types-ints types-ints)
+ (valset `(member ,@valset))
+ (t
+ ;; Empty type specifier
+ nil)))
+ (final
+ (pcase res
+ ((or `(member . ,rest)
+ `(integer ,(pred comp-star-or-num-p)
+ ,(pred comp-star-or-num-p)))
+ (if rest
+ res
+ (car res)))
+ ((pred atom) res)
+ (`(,_first . ,rest)
+ (if rest
+ `(or ,@res)
+ (car res))))))
+ (if negated
+ `(not ,final)
+ final))))
+
+(provide 'comp-cstr)
+
+;;; comp-cstr.el ends here
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
new file mode 100644
index 0000000..0ebaccb
--- /dev/null
+++ b/lisp/emacs-lisp/comp.el
@@ -0,0 +1,4210 @@
+;;; comp.el --- compilation of Lisp code into native code -*- lexical-binding:
t -*-
+
+;; Copyright (C) 2019-2021 Free Software Foundation, Inc.
+
+;; Author: Andrea Corallo <akrl@sdf.com>
+;; Keywords: lisp
+;; Package: emacs
+
+;; 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 is an attempt to make the pig fly.
+;; Or, to put it another way to make a 911 out of a turbocharged VW Bug.
+
+;;; Code:
+
+(require 'bytecomp)
+(require 'cl-extra)
+(require 'cl-lib)
+(require 'cl-macs)
+(require 'cl-seq)
+(require 'gv)
+(require 'rx)
+(require 'subr-x)
+(require 'warnings)
+(require 'comp-cstr)
+
+(defgroup comp nil
+ "Emacs Lisp native compiler."
+ :group 'lisp)
+
+(defcustom comp-speed 2
+ "Optimization level for native compilation, a number between -1 and 3.
+ -1 functions are kept in bytecode form and no native compilation is performed.
+ 0 native compilation is performed with no optimizations.
+ 1 light optimizations.
+ 2 max optimization level fully adherent to the language semantic.
+ 3 max optimization level, to be used only when necessary.
+ Warning: with 3, the compiler is free to perform dangerous optimizations."
+ :type 'integer
+ :safe #'integerp
+ :version "28.1")
+
+(defcustom comp-debug (if (eq 'windows-nt system-type) 1 0)
+ "Debug level for native compilation, a number between 0 and 3.
+This is intended for debugging the compiler itself.
+ 0 no debug output.
+ 1 emit debug symbols.
+ 2 emit debug symbols and dump pseudo C code.
+ 3 emit debug symbols and dump: pseudo C code, GCC intermediate
+ passes and libgccjit log file."
+ :type 'integer
+ :safe #'natnump
+ :version "28.1")
+
+(defcustom comp-verbose 0
+ "Compiler verbosity for native compilation, a number between 0 and 3.
+This is intended for debugging the compiler itself.
+ 0 no logging.
+ 1 final LIMPLE is logged.
+ 2 LAP, final LIMPLE, and some pass info are logged.
+ 3 max verbosity."
+ :type 'integer
+ :risky t
+ :version "28.1")
+
+(defcustom comp-always-compile nil
+ "Non-nil means unconditionally (re-)compile all files."
+ :type 'boolean
+ :version "28.1")
+
+(defcustom comp-deferred-compilation-deny-list
+ '()
+ "List of regexps to exclude matching files from deferred native compilation.
+Files whose names match any regexp are excluded from native compilation."
+ :type '(repeat regexp)
+ :version "28.1")
+
+(defcustom comp-bootstrap-deny-list
+ '()
+ "List of regexps to exclude files from native compilation during bootstrap.
+Files whose names match any regexp are excluded from native compilation
+during bootstrap."
+ :type '(repeat regexp)
+ :version "28.1")
+
+(defcustom comp-never-optimize-functions
+ '(;; The following two are mandatory for Emacs to be working
+ ;; correctly (see comment in `advice--add-function'). DO NOT
+ ;; REMOVE.
+ macroexpand rename-buffer)
+ "Primitive functions to exclude from trampoline optimization."
+ :type '(repeat symbol)
+ :version "28.1")
+
+(defcustom comp-async-jobs-number 0
+ "Default number of subprocesses used for async native compilation.
+Value of zero means to use half the number of the CPU's execution units,
+or one if there's just one execution unit."
+ :type 'integer
+ :risky t
+ :version "28.1")
+
+(defcustom comp-async-cu-done-functions nil
+ "List of functions to call after asynchronously compiling one compilation
unit.
+Called with one argument FILE, the filename used as input to
+compilation."
+ :type 'hook
+ :version "28.1")
+
+(defcustom comp-async-all-done-hook nil
+ "Hook run after completing asynchronous compilation of all input files."
+ :type 'hook
+ :version "28.1")
+
+(defcustom comp-async-env-modifier-form nil
+ "Form evaluated before compilation by each asynchronous compilation
subprocess.
+Used to modify the compiler environment."
+ :type 'sexp
+ :risky t
+ :version "28.1")
+
+(defcustom comp-async-report-warnings-errors t
+ "Whether to report warnings and errors from asynchronous native compilation.
+
+When native compilation happens asynchronously, it can produce
+warnings and errors, some of which might not be emitted by a
+byte-compilation. The typical case for that is native-compiling
+a file that is missing some `require' of a necessary feature,
+while having it already loaded into the environment when
+byte-compiling.
+
+As asynchronous native compilation always starts from a pristine
+environment, it is more sensitive to such omissions, and might be
+unable to compile such Lisp source files correctly.
+
+Set this variable to nil if these warnings annoy you."
+ :type 'boolean
+ :version "28.1")
+
+(defcustom comp-async-query-on-exit nil
+ "Whether to query the user about killing async compilations when exiting.
+If this is non-nil, Emacs will ask for confirmation to exit and kill the
+asynchronous native compilations if any are running. If nil, when you
+exit Emacs, it will silently kill those asynchronous compilations even
+if `confirm-kill-processes' is non-nil."
+ :type 'boolean
+ :version "28.1")
+
+(defcustom comp-native-driver-options nil
+ "Options passed verbatim to the native compiler's back-end driver.
+Note that not all options are meaningful; typically only the options
+affecting the assembler and linker are likely to be useful.
+
+Passing these options is only available in libgccjit version 9
+and above."
+ :type '(repeat string) ; FIXME is this right?
+ :version "28.1")
+
+(defcustom comp-libgccjit-reproducer nil
+ "When non-nil produce a libgccjit reproducer.
+The reproducer is a file ELNFILENAME_libgccjit_repro.c deposed in
+the .eln output directory."
+ :type 'boolean
+ :version "28.1")
+
+(defcustom comp-warning-on-missing-source t
+ "Emit a warning if a byte-code file being loaded has no corresponding source.
+The source file is necessary for native code file look-up and deferred
+compilation mechanism."
+ :type 'boolean
+ :version "28.1")
+
+(defvar no-native-compile nil
+ "Non-nil to prevent native-compiling of Emacs Lisp code.
+Note that when `no-byte-compile' is set to non-nil it overrides the value of
+`no-native-compile'.
+This is normally set in local file variables at the end of the
+Emacs Lisp file:
+
+\;; Local Variables:\n;; no-native-compile: t\n;; End:")
+;;;###autoload(put 'no-native-compile 'safe-local-variable 'booleanp)
+
+(defvar comp-log-time-report nil
+ "If non-nil, log a time report for each pass.")
+
+(defvar comp-dry-run nil
+ "If non-nil, run everything but the C back-end.")
+
+(defconst comp-valid-source-re (rx ".el" (? ".gz") eos)
+ "Regexp to match filename of valid input source files.")
+
+(defconst comp-log-buffer-name "*Native-compile-Log*"
+ "Name of the native-compiler log buffer.")
+
+(defconst comp-async-buffer-name "*Async-native-compile-log*"
+ "Name of the async compilation buffer log.")
+
+(defvar comp-native-compiling nil
+ "This gets bound to t during native compilation.
+Intended to be used by code that needs to work differently when
+native compilation runs.")
+
+(defvar comp-pass nil
+ "Every native-compilation pass can bind this to whatever it likes.")
+
+(defvar comp-curr-allocation-class 'd-default
+ "Current allocation class.
+Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.")
+
+(defconst comp-passes '(comp-spill-lap
+ comp-limplify
+ comp-fwprop
+ comp-call-optim
+ comp-ipa-pure
+ comp-add-cstrs
+ comp-fwprop
+ comp-tco
+ comp-fwprop
+ comp-remove-type-hints
+ comp-final)
+ "Passes to be executed in order.")
+
+(defvar comp-disabled-passes '()
+ "List of disabled passes.
+For internal use by the test suite only.")
+
+(defvar comp-post-pass-hooks '()
+ "Alist whose elements are of the form (PASS FUNCTIONS...).
+Each function in FUNCTIONS is run after PASS.
+Useful to hook into pass checkers.")
+
+;; FIXME this probably should not be here but... good for now.
+(defconst comp-known-type-specifiers
+ `(
+ ;; Functions we can trust not to be or if redefined should expose
+ ;; the same type. Vast majority of these is either pure or
+ ;; primitive, the original list is the union of pure +
+ ;; side-effect-free-fns + side-effect-and-error-free-fns:
+ (% (function ((or number marker) (or number marker)) number))
+ (* (function (&rest (or number marker)) number))
+ (+ (function (&rest (or number marker)) number))
+ (- (function (&rest (or number marker)) number))
+ (/ (function ((or number marker) &rest (or number marker)) number))
+ (/= (function ((or number marker) (or number marker)) boolean))
+ (1+ (function ((or number marker)) number))
+ (1- (function ((or number marker)) number))
+ (< (function ((or number marker) &rest (or number marker)) boolean))
+ (<= (function ((or number marker) &rest (or number marker)) boolean))
+ (= (function ((or number marker) &rest (or number marker)) boolean))
+ (> (function ((or number marker) &rest (or number marker)) boolean))
+ (>= (function ((or number marker) &rest (or number marker)) boolean))
+ (abs (function (number) number))
+ (acos (function (number) float))
+ (append (function (&rest t) t))
+ (aref (function (t fixnum) t))
+ (arrayp (function (t) boolean))
+ (ash (function (integer integer) integer))
+ (asin (function (number) float))
+ (assq (function (t list) list))
+ (atan (function (number &optional number) float))
+ (atom (function (t) boolean))
+ (bignump (function (t) boolean))
+ (bobp (function () boolean))
+ (bolp (function () boolean))
+ (bool-vector-count-consecutive (function (bool-vector boolean integer)
fixnum))
+ (bool-vector-count-population (function (bool-vector) fixnum))
+ (bool-vector-not (function (bool-vector &optional bool-vector)
bool-vector))
+ (bool-vector-p (function (t) boolean))
+ (bool-vector-subsetp (function (bool-vector bool-vector) boolean))
+ (boundp (function (symbol) boolean))
+ (buffer-end (function ((or number marker)) integer))
+ (buffer-file-name (function (&optional buffer) string))
+ (buffer-list (function (&optional frame) list))
+ (buffer-local-variables (function (&optional buffer) list))
+ (buffer-modified-p (function (&optional buffer) boolean))
+ (buffer-size (function (&optional buffer) integer))
+ (buffer-string (function () string))
+ (buffer-substring (function ((or integer marker) (or integer marker))
string))
+ (bufferp (function (t) boolean))
+ (byte-code-function-p (function (t) boolean))
+ (capitalize (function (or integer string) (or integer string)))
+ (car (function (list) t))
+ (car-less-than-car (function (list list) boolean))
+ (car-safe (function (t) t))
+ (case-table-p (function (t) boolean))
+ (cdr (function (list) t))
+ (cdr-safe (function (t) t))
+ (ceiling (function (number &optional number) integer))
+ (char-after (function (&optional (or marker integer)) fixnum))
+ (char-before (function (&optional (or marker integer)) fixnum))
+ (char-equal (function (integer integer) boolean))
+ (char-or-string-p (function (t) boolean))
+ (char-to-string (function (fixnum) string))
+ (char-width (function (fixnum) fixnum))
+ (characterp (function (t &optional t) boolean))
+ (charsetp (function (t) boolean))
+ (commandp (function (t &optional t) boolean))
+ (compare-strings (function (string (or integer marker null) (or integer
marker null) string (or integer marker null) (or integer marker null) &optional
t) (or (member t) fixnum)))
+ (concat (function (&rest sequence) string))
+ (cons (function (t t) cons))
+ (consp (function (t) boolean))
+ (coordinates-in-window-p (function (cons window) boolean))
+ (copy-alist (function (list) list))
+ (copy-marker (function (&optional (or integer marker) boolean) marker))
+ (copy-sequence (function (sequence) sequence))
+ (copysign (function (float float) float))
+ (cos (function (number) float))
+ (count-lines (function ((or integer marker) (or integer marker) &optional
t) integer))
+ (current-buffer (function () buffer))
+ (current-global-map (function () cons))
+ (current-indentation (function () integer))
+ (current-local-map (function () cons))
+ (current-minor-mode-maps (function () cons))
+ (current-time (function () cons))
+ (current-time-string (function (&optional string boolean) string))
+ (current-time-zone (function (&optional string boolean) cons))
+ (custom-variable-p (function (symbol) boolean))
+ (decode-char (function (cons t) (or fixnum null)))
+ (decode-time (function (&optional string symbol symbol) cons))
+ (default-boundp (function (symbol) boolean))
+ (default-value (function (symbol) t))
+ (degrees-to-radians (function (number) float))
+ (documentation (function ((or function symbol subr) &optional t) (or null
string)))
+ (downcase (function ((or fixnum string)) (or fixnum string)))
+ (elt (function (sequence integer) t))
+ (encode-char (function (fixnum symbol) (or fixnum null)))
+ (encode-time (function (cons &rest t) cons))
+ (eobp (function () boolean))
+ (eolp (function () boolean))
+ (eq (function (t t) boolean))
+ (eql (function (t t) boolean))
+ (equal (function (t t) boolean))
+ (error-message-string (function (list) string))
+ (eventp (function (t) boolean))
+ (exp (function (number) float))
+ (expt (function (number number) float))
+ (fboundp (function (symbol) boolean))
+ (fceiling (function (float) float))
+ (featurep (function (symbol &optional symbol) boolean))
+ (ffloor (function (float) float))
+ (file-directory-p (function (string) boolean))
+ (file-exists-p (function (string) boolean))
+ (file-locked-p (function (string) boolean))
+ (file-name-absolute-p (function (string) boolean))
+ (file-newer-than-file-p (function (string string) boolean))
+ (file-readable-p (function (string) boolean))
+ (file-symlink-p (function (string) boolean))
+ (file-writable-p (function (string) boolean))
+ (fixnump (function (t) boolean))
+ (float (function (number) float))
+ (float-time (function (&optional cons) float))
+ (floatp (function (t) boolean))
+ (floor (function (number &optional number) integer))
+ (following-char (function () fixnum))
+ (format (function (string &rest t) string))
+ (format-time-string (function (string &optional cons symbol) string))
+ (frame-first-window (function ((or frame window)) window))
+ (frame-root-window (function (&optional (or frame window)) window))
+ (frame-selected-window (function (&optional (or frame window)) window))
+ (frame-visible-p (function (frame) boolean))
+ (framep (function (t) boolean))
+ (fround (function (float) float))
+ (ftruncate (function (float) float))
+ (get (function (symbol symbol) t))
+ (get-buffer (function ((or buffer string)) (or buffer null)))
+ (get-buffer-window (function (&optional (or buffer string) (or symbol
(integer 0 0))) (or null window)))
+ (get-file-buffer (function (string) (or null buffer)))
+ (get-largest-window (function (&optional t t t) window))
+ (get-lru-window (function (&optional t t t) window))
+ (getenv (function (string &optional frame) (or null string)))
+ (gethash (function (t hash-table &optional t) t))
+ (hash-table-count (function (hash-table) integer))
+ (hash-table-p (function (t) boolean))
+ (identity (function (t) t))
+ (ignore (function (&rest t) null))
+ (int-to-string (function (number) string))
+ (integer-or-marker-p (function (t) boolean))
+ (integerp (function (t) boolean))
+ (interactive-p (function () boolean))
+ (intern-soft (function ((or string symbol) &optional vector) symbol))
+ (invocation-directory (function () string))
+ (invocation-name (function () string))
+ (isnan (function (float) boolean))
+ (keymap-parent (function (cons) (or cons null)))
+ (keymapp (function (t) boolean))
+ (keywordp (function (t) boolean))
+ (last (function (list &optional integer) list))
+ (lax-plist-get (function (list t) t))
+ (ldexp (function (number integer) float))
+ (length (function (t) (integer 0 *)))
+ (length< (function (sequence fixnum) boolean))
+ (length= (function (sequence fixnum) boolean))
+ (length> (function (sequence fixnum) boolean))
+ (line-beginning-position (function (&optional integer) integer))
+ (line-end-position (function (&optional integer) integer))
+ (list (function (&rest t) list))
+ (listp (function (t) boolean))
+ (local-variable-if-set-p (function (symbol &optional buffer) boolean))
+ (local-variable-p (function (symbol &optional buffer) boolean))
+ (locale-info (function ((member codeset days months paper)) (or null
string)))
+ (log (function (number number) float))
+ (log10 (function (number) float))
+ (logand (function (&rest (or integer marker)) integer))
+ (logb (function (number) integer))
+ (logcount (function (integer) integer))
+ (logior (function (&rest (or integer marker)) integer))
+ (lognot (function (integer) integer))
+ (logxor (function (&rest (or integer marker)) integer))
+ ;; (lsh (function ((integer ,most-negative-fixnum *) integer) integer)) ?
+ (lsh (function (integer integer) integer))
+ (make-byte-code (function ((or fixnum list) string vector integer
&optional string t &rest t) vector))
+ (make-list (function (integer t) list))
+ (make-marker (function () marker))
+ (make-string (function (integer fixnum &optional t) string))
+ (make-symbol (function (string) symbol))
+ (mark (function (&optional t) (or integer null)))
+ (mark-marker (function () marker))
+ (marker-buffer (function (marker) buffer))
+ (markerp (function (t) boolean))
+ (max (function ((or number marker) &rest (or number marker)) number))
+ (max-char (function () fixnum))
+ (member (function (t list) list))
+ (memory-limit (function () integer))
+ (memq (function (t list) list))
+ (memql (function (t list) list))
+ (min (function ((or number marker) &rest (or number marker)) number))
+ (minibuffer-selected-window (function () window))
+ (minibuffer-window (function (&optional frame) window))
+ (mod (function ((or number marker) (or number marker)) (or (integer 0 *)
(float 0 *))))
+ (mouse-movement-p (function (t) boolean))
+ (multibyte-char-to-unibyte (function (fixnum) fixnum))
+ (natnump (function (t) boolean))
+ (next-window (function (&optional window t t) window))
+ (nlistp (function (t) boolean))
+ (not (function (t) boolean))
+ (nth (function (integer list) t))
+ (nthcdr (function (integer t) t))
+ (null (function (t) boolean))
+ (number-or-marker-p (function (t) boolean))
+ (number-to-string (function (number) string))
+ (numberp (function (t) boolean))
+ (one-window-p (function (&optional t t) boolean))
+ (overlayp (function (t) boolean))
+ (parse-colon-path (function (string) cons))
+ (plist-get (function (list t) t))
+ (plist-member (function (list t) list))
+ (point (function () integer))
+ (point-marker (function () marker))
+ (point-max (function () integer))
+ (point-min (function () integer))
+ (preceding-char (function () fixnum))
+ (previous-window (function (&optional window t t) window))
+ (prin1-to-string (function (t &optional t) string))
+ (processp (function (t) boolean))
+ (proper-list-p (function (t) integer))
+ (propertize (function (string &rest t) string))
+ (radians-to-degrees (function (number) float))
+ (rassoc (function (t list) list))
+ (rassq (function (t list) list))
+ (read-from-string (function (string &optional integer integer) cons))
+ (recent-keys (function (&optional (or cons null)) vector))
+ (recursion-depth (function () integer))
+ (regexp-opt (function (list) string))
+ (regexp-quote (function (string) string))
+ (region-beginning (function () integer))
+ (region-end (function () integer))
+ (reverse (function (sequence) sequence))
+ (round (function (number &optional number) integer))
+ (safe-length (function (t) integer))
+ (selected-frame (function () frame))
+ (selected-window (function () window))
+ (sequencep (function (t) boolean))
+ (sin (function (number) float))
+ (sqrt (function (number) float))
+ (standard-case-table (function () char-table))
+ (standard-syntax-table (function () char-table))
+ (string (function (&rest fixnum) string))
+ (string-as-multibyte (function (string) string))
+ (string-as-unibyte (function (string) string))
+ (string-equal (function ((or string symbol) (or string symbol)) boolean))
+ (string-lessp (function ((or string symbol) (or string symbol)) boolean))
+ (string-make-multibyte (function (string) string))
+ (string-make-unibyte (function (string) string))
+ (string-search (function (string string &optional integer) (or integer
null)))
+ (string-to-char (function (string) fixnum))
+ (string-to-multibyte (function (string) string))
+ (string-to-number (function (string &optional integer) number))
+ (string-to-syntax (function (string) cons))
+ (string< (function ((or string symbol) (or string symbol)) boolean))
+ (string= (function ((or string symbol) (or string symbol)) boolean))
+ (stringp (function (t) boolean))
+ (subrp (function (t) boolean))
+ (substring (function ((or string vector) &optional integer integer) (or
string vector)))
+ (sxhash (function (t) integer))
+ (sxhash-eq (function (t) integer))
+ (sxhash-eql (function (t) integer))
+ (sxhash-equal (function (t) integer))
+ (symbol-function (function (symbol) t))
+ (symbol-name (function (symbol) string))
+ (symbol-plist (function (symbol) list))
+ (symbol-value (function (symbol) t))
+ (symbolp (function (t) boolean))
+ (syntax-table (function () char-table))
+ (syntax-table-p (function (t) boolean))
+ (tan (function (number) float))
+ (this-command-keys (function () string))
+ (this-command-keys-vector (function () vector))
+ (this-single-command-keys (function () vector))
+ (this-single-command-raw-keys (function () vector))
+ (time-convert (function (t &optional (or boolean integer)) cons))
+ (truncate (function (number &optional number) integer))
+ (type-of (function (t) symbol))
+ (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum
+ (upcase (function ((or fixnum string)) (or fixnum string)))
+ (user-full-name (function (&optional integer) (or string null)))
+ (user-login-name (function (&optional integer) (or string null)))
+ (user-original-login-name (function (&optional integer) (or string null)))
+ (user-real-login-name (function () string))
+ (user-real-uid (function () integer))
+ (user-uid (function () integer))
+ (vconcat (function (&rest sequence) vector))
+ (vector (function (&rest t) vector))
+ (vectorp (function (t) boolean))
+ (visible-frame-list (function () list))
+ (wholenump (function (t) boolean))
+ (window-configuration-p (function (t) boolean))
+ (window-live-p (function (t) boolean))
+ (window-valid-p (function (t) boolean))
+ (windowp (function (t) boolean))
+ (zerop (function (number) boolean))
+ ;; Type hints
+ (comp-hint-fixnum (function (t) fixnum))
+ (comp-hint-cons (function (t) cons))
+ ;; Non returning functions
+ (throw (function (t t) nil))
+ (error (function (string &rest t) nil))
+ (signal (function (symbol t) nil)))
+ "Alist used for type propagation.")
+
+(defconst comp-known-func-cstr-h
+ (cl-loop
+ with comp-ctxt = (make-comp-cstr-ctxt)
+ with h = (make-hash-table :test #'eq)
+ for (f type-spec) in comp-known-type-specifiers
+ for cstr = (comp-type-spec-to-cstr type-spec)
+ do (puthash f cstr h)
+ finally return h)
+ "Hash table function -> `comp-constraint'.")
+
+(defconst comp-known-predicates
+ '((arrayp . array)
+ (atom . atom)
+ (characterp . fixnum)
+ (booleanp . boolean)
+ (bool-vector-p . bool-vector)
+ (bufferp . buffer)
+ (natnump . (integer 0 *))
+ (char-table-p . char-table)
+ (hash-table-p . hash-table)
+ (consp . cons)
+ (integerp . integer)
+ (floatp . float)
+ (functionp . (or function symbol))
+ (integerp . integer)
+ (keywordp . keyword)
+ (listp . list)
+ (numberp . number)
+ (null . null)
+ (numberp . number)
+ (sequencep . sequence)
+ (stringp . string)
+ (symbolp . symbol)
+ (vectorp . vector)
+ (integer-or-marker-p . integer-or-marker))
+ "Alist predicate -> matched type specifier.")
+
+(defconst comp-known-predicates-h
+ (cl-loop
+ with comp-ctxt = (make-comp-cstr-ctxt)
+ with h = (make-hash-table :test #'eq)
+ for (pred . type-spec) in comp-known-predicates
+ for cstr = (comp-type-spec-to-cstr type-spec)
+ do (puthash pred cstr h)
+ finally return h)
+ "Hash table function -> `comp-constraint'.")
+
+(defun comp-known-predicate-p (predicate)
+ "Return t if PREDICATE is known."
+ (when (gethash predicate comp-known-predicates-h) t))
+
+(defun comp-pred-to-cstr (predicate)
+ "Given PREDICATE, return the corresponding constraint."
+ (gethash predicate comp-known-predicates-h))
+
+(defconst comp-symbol-values-optimizable '(most-positive-fixnum
+ most-negative-fixnum)
+ "Symbol values we can resolve at compile-time.")
+
+(defconst comp-type-hints '(comp-hint-fixnum
+ comp-hint-cons)
+ "List of fake functions used to give compiler hints.")
+
+(defconst comp-limple-sets '(set
+ setimm
+ set-par-to-local
+ set-args-to-local
+ set-rest-args-to-local)
+ "Limple set operators.")
+
+(defconst comp-limple-assignments `(assume
+ fetch-handler
+ ,@comp-limple-sets)
+ "Limple operators that clobber the first m-var argument.")
+
+(defconst comp-limple-calls '(call
+ callref
+ direct-call
+ direct-callref)
+ "Limple operators used to call subrs.")
+
+(defconst comp-limple-branches '(jump cond-jump)
+ "Limple operators used for conditional and unconditional branches.")
+
+(defconst comp-limple-ops `(,@comp-limple-calls
+ ,@comp-limple-assignments
+ ,@comp-limple-branches
+ return)
+ "All Limple operators.")
+
+(defvar comp-func nil
+ "Bound to the current function by most passes.")
+
+(defvar comp-block nil
+ "Bound to the current basic block by some passes.")
+
+(define-error 'native-compiler-error-dyn-func
+ "can't native compile a non-lexically-scoped function"
+ 'native-compiler-error)
+(define-error 'native-compiler-error-empty-byte
+ "empty byte compiler output"
+ 'native-compiler-error)
+
+
+;; Moved early to avoid circularity when comp.el is loaded and
+;; `macroexpand' needs to be advised (bug#47049).
+;;;###autoload
+(defun comp-subr-trampoline-install (subr-name)
+ "Make SUBR-NAME effectively advice-able when called from native code."
+ (unless (or (null comp-enable-subr-trampolines)
+ (memq subr-name comp-never-optimize-functions)
+ (gethash subr-name comp-installed-trampolines-h))
+ (cl-assert (subr-primitive-p (symbol-function subr-name)))
+ (comp--install-trampoline
+ subr-name
+ (or (comp-trampoline-search subr-name)
+ (comp-trampoline-compile subr-name)
+ ;; Should never happen.
+ (cl-assert nil)))))
+
+
+(cl-defstruct (comp-vec (:copier nil))
+ "A re-sizable vector like object."
+ (data (make-hash-table :test #'eql) :type hash-table
+ :documentation "Payload data.")
+ (beg 0 :type integer)
+ (end 0 :type natnum))
+
+(defsubst comp-vec-copy (vec)
+ "Return a copy of VEC."
+ (make-comp-vec :data (copy-hash-table (comp-vec-data vec))
+ :beg (comp-vec-beg vec)
+ :end (comp-vec-end vec)))
+
+(defsubst comp-vec-length (vec)
+ "Return the number of elements of VEC."
+ (- (comp-vec-end vec) (comp-vec-beg vec)))
+
+(defsubst comp-vec--verify-idx (vec idx)
+ "Check whether IDX is in bounds for VEC."
+ (cl-assert (and (< idx (comp-vec-end vec))
+ (>= idx (comp-vec-beg vec)))))
+
+(defsubst comp-vec-aref (vec idx)
+ "Return the element of VEC whose index is IDX."
+ (declare (gv-setter (lambda (val)
+ `(comp-vec--verify-idx ,vec ,idx)
+ `(puthash ,idx ,val (comp-vec-data ,vec)))))
+ (comp-vec--verify-idx vec idx)
+ (gethash idx (comp-vec-data vec)))
+
+(defsubst comp-vec-append (vec elt)
+ "Append ELT into VEC.
+Returns ELT."
+ (puthash (comp-vec-end vec) elt (comp-vec-data vec))
+ (cl-incf (comp-vec-end vec))
+ elt)
+
+(defsubst comp-vec-prepend (vec elt)
+ "Prepend ELT into VEC.
+Returns ELT."
+ (puthash (1- (comp-vec-beg vec)) elt (comp-vec-data vec))
+ (cl-decf (comp-vec-beg vec))
+ elt)
+
+
+
+(eval-when-compile
+ (defconst comp-op-stack-info
+ (cl-loop with h = (make-hash-table)
+ for k across byte-code-vector
+ for v across byte-stack+-info
+ when k
+ do (puthash k v h)
+ finally return h)
+ "Hash table lap-op -> stack adjustment."))
+
+(define-hash-table-test 'comp-imm-equal-test #'equal-including-properties
+ #'sxhash-equal-including-properties)
+
+(cl-defstruct comp-data-container
+ "Data relocation container structure."
+ (l () :type list
+ :documentation "Constant objects used by functions.")
+ (idx (make-hash-table :test 'comp-imm-equal-test) :type hash-table
+ :documentation "Obj -> position into the previous field."))
+
+(cl-defstruct (comp-ctxt (:include comp-cstr-ctxt))
+ "Lisp side of the compiler context."
+ (output nil :type string
+ :documentation "Target output file-name for the compilation.")
+ (speed comp-speed :type number
+ :documentation "Default speed for this compilation unit.")
+ (debug comp-debug :type number
+ :documentation "Default debug level for this compilation unit.")
+ (driver-options comp-native-driver-options :type list
+ :documentation "Options for the GCC driver.")
+ (top-level-forms () :type list
+ :documentation "List of spilled top level forms.")
+ (funcs-h (make-hash-table :test #'equal) :type hash-table
+ :documentation "c-name -> comp-func.")
+ (sym-to-c-name-h (make-hash-table :test #'eq) :type hash-table
+ :documentation "symbol-function -> c-name.
+This is only for optimizing intra CU calls at speed 3.")
+ (byte-func-to-func-h (make-hash-table :test #'equal) :type hash-table
+ :documentation "byte-function -> comp-func.
+Needed to replace immediate byte-compiled lambdas with the compiled
reference.")
+ (lambda-fixups-h (make-hash-table :test #'equal) :type hash-table
+ :documentation "Hash table byte-func -> mvar to fixup.")
+ (function-docs (make-hash-table :test #'eql) :type (or hash-table vector)
+ :documentation "Documentation index -> documentation")
+ (d-default (make-comp-data-container) :type comp-data-container
+ :documentation "Standard data relocated in use by functions.")
+ (d-impure (make-comp-data-container) :type comp-data-container
+ :documentation "Relocated data that cannot be moved into pure
space.
+This is typically for top-level forms other than defun.")
+ (d-ephemeral (make-comp-data-container) :type comp-data-container
+ :documentation "Relocated data not necessary after load.")
+ (with-late-load nil :type boolean
+ :documentation "When non-nil support late load."))
+
+(cl-defstruct comp-args-base
+ (min nil :type integer
+ :documentation "Minimum number of arguments allowed."))
+
+(cl-defstruct (comp-args (:include comp-args-base))
+ (max nil :type integer
+ :documentation "Maximum number of arguments allowed."))
+
+(cl-defstruct (comp-nargs (:include comp-args-base))
+ "Describe args when the function signature is of kind:
+(ptrdiff_t nargs, Lisp_Object *args)."
+ (nonrest nil :type integer
+ :documentation "Number of non rest arguments.")
+ (rest nil :type boolean
+ :documentation "t if rest argument is present."))
+
+(cl-defstruct (comp-block (:copier nil)
+ (:constructor nil))
+ "A base class for basic blocks."
+ (name nil :type symbol)
+ (insns () :type list
+ :documentation "List of instructions.")
+ (closed nil :type boolean
+ :documentation "t if closed.")
+ ;; All the following are for SSA and CGF analysis.
+ ;; Keep in sync with `comp-clean-ssa'!!
+ (in-edges () :type list
+ :documentation "List of incoming edges.")
+ (out-edges () :type list
+ :documentation "List of out-coming edges.")
+ (idom nil :type (or null comp-block)
+ :documentation "Immediate dominator.")
+ (df (make-hash-table) :type (or null hash-table)
+ :documentation "Dominance frontier set. Block-name -> block")
+ (post-num nil :type (or null number)
+ :documentation "Post order number.")
+ (final-frame nil :type (or null comp-vec)
+ :documentation "This is a copy of the frame when leaving the
block.
+Is in use to help the SSA rename pass."))
+
+(cl-defstruct (comp-block-lap (:copier nil)
+ (:include comp-block)
+ (:constructor make--comp-block-lap
+ (addr sp name))) ; Positional
+ "A basic block created from lap (real code)."
+ ;; These two slots are used during limplification.
+ (sp nil :type number
+ :documentation "When non-nil indicates the sp value while entering
+into it.")
+ (addr nil :type number
+ :documentation "Start block LAP address.")
+ (non-ret-insn nil :type list
+ :documentation "Insn known to perform a non local exit.
+`comp-fwprop' may identify and store here basic blocks performing
+non local exits and mark it rewrite it later.")
+ (no-ret nil :type boolean
+ :documentation "t when the block is known to perform a
+non local exit (ends with an `unreachable' insn)."))
+
+(cl-defstruct (comp-latch (:copier nil)
+ (:include comp-block))
+ "A basic block for a latch loop.")
+
+(cl-defstruct (comp-block-cstr (:copier nil)
+ (:include comp-block))
+ "A basic block holding only constraints.")
+
+(cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge))
+ "An edge connecting two basic blocks."
+ (src nil :type (or null comp-block))
+ (dst nil :type (or null comp-block))
+ (number nil :type number
+ :documentation "The index number corresponding to this edge in the
+ edge hash."))
+
+(defun make-comp-edge (&rest args)
+ "Create a `comp-edge' with basic blocks SRC and DST."
+ (let ((n (funcall (comp-func-edge-cnt-gen comp-func))))
+ (puthash
+ n
+ (apply #'make--comp-edge :number n args)
+ (comp-func-edges-h comp-func))))
+
+(defun comp-block-preds (basic-block)
+ "Return the list of predecessors of BASIC-BLOCK."
+ (mapcar #'comp-edge-src (comp-block-in-edges basic-block)))
+
+(defun comp-gen-counter ()
+ "Return a sequential number generator."
+ (let ((n -1))
+ (lambda ()
+ (cl-incf n))))
+
+(cl-defstruct (comp-func (:copier nil))
+ "LIMPLE representation of a function."
+ (name nil :type symbol
+ :documentation "Function symbol name. Nil indicates anonymous.")
+ (c-name nil :type string
+ :documentation "The function name in the native world.")
+ (byte-func nil
+ :documentation "Byte-compiled version.")
+ (doc nil :type string
+ :documentation "Doc string.")
+ (int-spec nil :type list
+ :documentation "Interactive form.")
+ (lap () :type list
+ :documentation "LAP assembly representation.")
+ (ssa-status nil :type symbol
+ :documentation "SSA status either: 'nil', 'dirty' or 't'.
+Once in SSA form this *must* be set to 'dirty' every time the topology of the
+CFG is mutated by a pass.")
+ (frame-size nil :type integer)
+ (vframe-size 0 :type integer)
+ (blocks (make-hash-table :test #'eq) :type hash-table
+ :documentation "Basic block symbol -> basic block.")
+ (lap-block (make-hash-table :test #'equal) :type hash-table
+ :documentation "LAP label -> LIMPLE basic block name.")
+ (edges-h (make-hash-table) :type hash-table
+ :documentation "Hash edge-num -> edge connecting basic two blocks.")
+ (block-cnt-gen (funcall #'comp-gen-counter) :type function
+ :documentation "Generates block numbers.")
+ (edge-cnt-gen (funcall #'comp-gen-counter) :type function
+ :documentation "Generates edges numbers.")
+ (has-non-local nil :type boolean
+ :documentation "t if non local jumps are present.")
+ (speed nil :type number
+ :documentation "Optimization level (see `comp-speed').")
+ (pure nil :type boolean
+ :documentation "t if pure nil otherwise.")
+ (type nil :type (or null comp-mvar)
+ :documentation "Mvar holding the derived return type."))
+
+(cl-defstruct (comp-func-l (:include comp-func))
+ "Lexically-scoped function."
+ (args nil :type comp-args-base
+ :documentation "Argument specification of the function"))
+
+(cl-defstruct (comp-func-d (:include comp-func))
+ "Dynamically-scoped function."
+ (lambda-list nil :type list
+ :documentation "Original lambda-list."))
+
+(cl-defstruct (comp-mvar (:constructor make--comp-mvar)
+ (:include comp-cstr))
+ "A meta-variable being a slot in the meta-stack."
+ (id nil :type (or null number)
+ :documentation "Unique id when in SSA form.")
+ (slot nil :type (or fixnum symbol)
+ :documentation "Slot number in the array if a number or
+ 'scratch' for scratch slot."))
+
+(defun comp-mvar-type-hint-match-p (mvar type-hint)
+ "Match MVAR against TYPE-HINT.
+In use by the back-end."
+ (cl-ecase type-hint
+ (cons (comp-cstr-cons-p mvar))
+ (fixnum (comp-cstr-fixnum-p mvar))))
+
+
+
+(defun comp-ensure-native-compiler ()
+ "Make sure Emacs has native compiler support and libgccjit can be loaded.
+Signal an error otherwise.
+To be used by all entry points."
+ (cond
+ ((null (featurep 'nativecomp))
+ (error "Emacs was not compiled with native compiler support
(--with-native-compilation)"))
+ ((null (native-comp-available-p))
+ (error "Cannot find libgccjit library"))))
+
+(defun comp-equality-fun-p (function)
+ "Equality functions predicate for FUNCTION."
+ (when (memq function '(eq eql equal)) t))
+
+(defun comp-arithm-cmp-fun-p (function)
+ "Predicate for arithmetic comparison functions."
+ (when (memq function '(= > < >= <=)) t))
+
+(defun comp-set-op-p (op)
+ "Assignment predicate for OP."
+ (when (memq op comp-limple-sets) t))
+
+(defun comp-assign-op-p (op)
+ "Assignment predicate for OP."
+ (when (memq op comp-limple-assignments) t))
+
+(defun comp-call-op-p (op)
+ "Call predicate for OP."
+ (when (memq op comp-limple-calls) t))
+
+(defun comp-branch-op-p (op)
+ "Branch predicate for OP."
+ (when (memq op comp-limple-branches) t))
+
+(defsubst comp-limple-insn-call-p (insn)
+ "Limple INSN call predicate."
+ (comp-call-op-p (car-safe insn)))
+
+(defun comp-type-hint-p (func)
+ "Type-hint predicate for function name FUNC."
+ (when (memq func comp-type-hints) t))
+
+(defun comp-func-unique-in-cu-p (func)
+ "Return t if FUNC is known to be unique in the current compilation unit."
+ (if (symbolp func)
+ (cl-loop with h = (make-hash-table :test #'eq)
+ for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt)
+ for name = (comp-func-name f)
+ when (gethash name h)
+ return nil
+ do (puthash name t h)
+ finally return t)
+ t))
+
+(defsubst comp-symbol-func-to-fun (symbol-funcion)
+ "Given a function called SYMBOL-FUNCION return its `comp-func'."
+ (gethash (gethash symbol-funcion (comp-ctxt-sym-to-c-name-h
+ comp-ctxt))
+ (comp-ctxt-funcs-h comp-ctxt)))
+
+(defun comp-function-pure-p (f)
+ "Return t if F is pure."
+ (or (get f 'pure)
+ (when-let ((func (comp-symbol-func-to-fun f)))
+ (comp-func-pure func))))
+
+(defun comp-alloc-class-to-container (alloc-class)
+ "Given ALLOC-CLASS, return the data container for the current context.
+Assume allocation class 'd-default as default."
+ (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) comp-ctxt))
+
+(defsubst comp-add-const-to-relocs (obj)
+ "Keep track of OBJ into the ctxt relocations."
+ (puthash obj t (comp-data-container-idx (comp-alloc-class-to-container
+ comp-curr-allocation-class))))
+
+
+;;; Log routines.
+
+(defconst comp-limple-lock-keywords
+ `((,(rx bol "(comment" (1+ not-newline)) . font-lock-comment-face)
+ (,(rx "#(" (group-n 1 "mvar"))
+ (1 font-lock-function-name-face))
+ (,(rx bol "(" (group-n 1 "phi"))
+ (1 font-lock-variable-name-face))
+ (,(rx bol "(" (group-n 1 (or "return" "unreachable")))
+ (1 font-lock-warning-face))
+ (,(rx (group-n 1 (or "entry"
+ (seq (or "entry_" "entry_fallback_" "bb_")
+ (1+ num) (? (or "_latch"
+ (seq "_cstrs_" (1+ num))))))))
+ (1 font-lock-constant-face))
+ (,(rx-to-string
+ `(seq "(" (group-n 1 (or ,@(mapcar #'symbol-name comp-limple-ops)))))
+ (1 font-lock-keyword-face)))
+ "Highlights used by `comp-limple-mode'.")
+
+(define-derived-mode comp-limple-mode fundamental-mode "LIMPLE"
+ "Syntax-highlight LIMPLE IR."
+ (setf font-lock-defaults '(comp-limple-lock-keywords)))
+
+(cl-defun comp-log (data &optional (level 1) quoted)
+ "Log DATA at LEVEL.
+LEVEL is a number from 1-3, and defaults to 1; if it is less
+than `comp-verbose', do nothing. If `noninteractive', log
+with `message'. Otherwise, log with `comp-log-to-buffer'."
+ (when (>= comp-verbose level)
+ (if noninteractive
+ (cl-typecase data
+ (atom (message "%s" data))
+ (t (dolist (elem data)
+ (message "%s" elem))))
+ (comp-log-to-buffer data quoted))))
+
+(cl-defun comp-log-to-buffer (data &optional quoted)
+ "Log DATA to `comp-log-buffer-name'."
+ (let* ((print-f (if quoted #'prin1 #'princ))
+ (log-buffer
+ (or (get-buffer comp-log-buffer-name)
+ (with-current-buffer (get-buffer-create comp-log-buffer-name)
+ (setf buffer-read-only t)
+ (current-buffer))))
+ (log-window (get-buffer-window log-buffer))
+ (inhibit-read-only t)
+ at-end-p)
+ (with-current-buffer log-buffer
+ (unless (eq major-mode 'comp-limple-mode)
+ (comp-limple-mode))
+ (when (= (point) (point-max))
+ (setf at-end-p t))
+ (save-excursion
+ (goto-char (point-max))
+ (cl-typecase data
+ (atom (funcall print-f data log-buffer))
+ (t (dolist (elem data)
+ (funcall print-f elem log-buffer)
+ (insert "\n"))))
+ (insert "\n"))
+ (when (and at-end-p log-window)
+ ;; When log window's point is at the end, follow the tail.
+ (with-selected-window log-window
+ (goto-char (point-max)))))))
+
+(defun comp-prettyformat-mvar (mvar)
+ (format "#(mvar %s %s %S)"
+ (comp-mvar-id mvar)
+ (comp-mvar-slot mvar)
+ (comp-cstr-to-type-spec mvar)))
+
+(defun comp-prettyformat-insn (insn)
+ (cl-typecase insn
+ (comp-mvar (comp-prettyformat-mvar insn))
+ (atom (prin1-to-string insn))
+ (cons (concat "(" (mapconcat #'comp-prettyformat-insn insn " ") ")"))))
+
+(defun comp-log-func (func verbosity)
+ "Log function FUNC at VERBOSITY.
+VERBOSITY is a number between 0 and 3."
+ (when (>= comp-verbose verbosity)
+ (comp-log (format "\nFunction: %s\n" (comp-func-name func)) verbosity)
+ (cl-loop
+ for block-name being each hash-keys of (comp-func-blocks func)
+ using (hash-value bb)
+ do (comp-log (concat "<" (symbol-name block-name) ">") verbosity)
+ (cl-loop
+ for insn in (comp-block-insns bb)
+ do (comp-log (comp-prettyformat-insn insn) verbosity)))))
+
+(defun comp-log-edges (func)
+ "Log edges in FUNC."
+ (let ((edges (comp-func-edges-h func)))
+ (comp-log (format "\nEdges in function: %s\n"
+ (comp-func-name func))
+ 2)
+ (maphash (lambda (_ e)
+ (comp-log (format "n: %d src: %s dst: %s\n"
+ (comp-edge-number e)
+ (comp-block-name (comp-edge-src e))
+ (comp-block-name (comp-edge-dst e)))
+ 2))
+ edges)))
+
+
+
+(defmacro comp-loop-insn-in-block (basic-block &rest body)
+ "Loop over all insns in BASIC-BLOCK executing BODY.
+Inside BODY, `insn' and `insn-cell'can be used to read or set the
+current instruction or its cell."
+ (declare (debug (form body))
+ (indent defun))
+ `(cl-symbol-macrolet ((insn (car insn-cell)))
+ (let ((insn-cell (comp-block-insns ,basic-block)))
+ (while insn-cell
+ ,@body
+ (setf insn-cell (cdr insn-cell))))))
+
+;;; spill-lap pass specific code.
+
+(defun comp-lex-byte-func-p (f)
+ "Return t if F is a lexically-scoped byte compiled function."
+ (and (byte-code-function-p f)
+ (fixnump (aref f 0))))
+
+(defun comp-spill-decl-spec (function-name spec)
+ "Return the declared specifier SPEC for FUNCTION-NAME."
+ (plist-get (cdr (assq function-name byte-to-native-plist-environment))
+ spec))
+
+(defun comp-spill-speed (function-name)
+ "Return the speed for FUNCTION-NAME."
+ (or (comp-spill-decl-spec function-name 'speed)
+ (comp-ctxt-speed comp-ctxt)))
+
+;; Autoloaded as might be used by `disassemble-internal'.
+;;;###autoload
+(defun comp-c-func-name (name prefix &optional first)
+ "Given NAME, return a name suitable for the native code.
+Add PREFIX in front of it. If FIRST is not nil, pick the first
+available name ignoring compilation context and potential name
+clashes."
+ ;; Unfortunately not all symbol names are valid as C function names...
+ ;; Nassi's algorithm here:
+ (let* ((orig-name (if (symbolp name) (symbol-name name) name))
+ (crypted (cl-loop with str = (make-string (* 2 (length orig-name)) 0)
+ for j from 0 by 2
+ for i across orig-name
+ for byte = (format "%x" i)
+ do (aset str j (aref byte 0))
+ (aset str (1+ j) (aref byte 1))
+ finally return str))
+ (human-readable (replace-regexp-in-string
+ "-" "_" orig-name))
+ (human-readable (replace-regexp-in-string
+ (rx (not (any "0-9a-z_"))) "" human-readable)))
+ (if (null first)
+ ;; Prevent C namespace conflicts.
+ (cl-loop
+ with h = (comp-ctxt-funcs-h comp-ctxt)
+ for i from 0
+ for c-sym = (concat prefix crypted "_" human-readable "_"
+ (number-to-string i))
+ unless (gethash c-sym h)
+ return c-sym)
+ ;; When called out of a compilation context (ex disassembling)
+ ;; pick the first one.
+ (concat prefix crypted "_" human-readable "_0"))))
+
+(defun comp-decrypt-arg-list (x function-name)
+ "Decrypt argument list X for FUNCTION-NAME."
+ (unless (fixnump x)
+ (signal 'native-compiler-error-dyn-func function-name))
+ (let ((rest (not (= (logand x 128) 0)))
+ (mandatory (logand x 127))
+ (nonrest (ash x -8)))
+ (if (and (null rest)
+ (< nonrest 9)) ;; SUBR_MAX_ARGS
+ (make-comp-args :min mandatory
+ :max nonrest)
+ (make-comp-nargs :min mandatory
+ :nonrest nonrest
+ :rest rest))))
+
+(defsubst comp-byte-frame-size (byte-compiled-func)
+ "Return the frame size to be allocated for BYTE-COMPILED-FUNC."
+ (aref byte-compiled-func 3))
+
+(defun comp-add-func-to-ctxt (func)
+ "Add FUNC to the current compiler context."
+ (let ((name (comp-func-name func))
+ (c-name (comp-func-c-name func)))
+ (puthash name c-name (comp-ctxt-sym-to-c-name-h comp-ctxt))
+ (puthash c-name func (comp-ctxt-funcs-h comp-ctxt))))
+
+(cl-defgeneric comp-spill-lap-function (input)
+ "Byte-compile INPUT and spill lap for further stages.")
+
+(cl-defmethod comp-spill-lap-function ((function-name symbol))
+ "Byte-compile FUNCTION-NAME, spilling data from the byte compiler."
+ (unless (comp-ctxt-output comp-ctxt)
+ (setf (comp-ctxt-output comp-ctxt)
+ (make-temp-file (comp-c-func-name function-name "freefn-")
+ nil ".eln")))
+ (let* ((f (symbol-function function-name))
+ (c-name (comp-c-func-name function-name "F"))
+ (func (make-comp-func-l :name function-name
+ :c-name c-name
+ :doc (documentation f t)
+ :int-spec (interactive-form f)
+ :speed (comp-spill-speed function-name)
+ :pure (comp-spill-decl-spec function-name
+ 'pure))))
+ (when (byte-code-function-p f)
+ (signal 'native-compiler-error
+ "can't native compile an already byte-compiled function"))
+ (setf (comp-func-byte-func func)
+ (byte-compile (comp-func-name func)))
+ (let ((lap (byte-to-native-lambda-lap
+ (gethash (aref (comp-func-byte-func func) 1)
+ byte-to-native-lambdas-h))))
+ (cl-assert lap)
+ (comp-log lap 2 t)
+ (let ((arg-list (aref (comp-func-byte-func func) 0)))
+ (setf (comp-func-l-args func)
+ (comp-decrypt-arg-list arg-list function-name)
+ (comp-func-lap func)
+ lap
+ (comp-func-frame-size func)
+ (comp-byte-frame-size (comp-func-byte-func func))))
+ (setf (comp-ctxt-top-level-forms comp-ctxt)
+ (list (make-byte-to-native-func-def :name function-name
+ :c-name c-name)))
+ (comp-add-func-to-ctxt func))))
+
+(cl-defmethod comp-spill-lap-function ((form list))
+ "Byte-compile FORM, spilling data from the byte compiler."
+ (unless (eq (car-safe form) 'lambda)
+ (signal 'native-compiler-error
+ "Cannot native-compile, form is not a lambda"))
+ (unless (comp-ctxt-output comp-ctxt)
+ (setf (comp-ctxt-output comp-ctxt)
+ (make-temp-file "comp-lambda-" nil ".eln")))
+ (let* ((byte-code (byte-compile form))
+ (c-name (comp-c-func-name "anonymous-lambda" "F"))
+ (func (if (comp-lex-byte-func-p byte-code)
+ (make-comp-func-l :c-name c-name
+ :doc (documentation form t)
+ :int-spec (interactive-form form)
+ :speed (comp-ctxt-speed comp-ctxt))
+ (make-comp-func-d :c-name c-name
+ :doc (documentation form t)
+ :int-spec (interactive-form form)
+ :speed (comp-ctxt-speed comp-ctxt)))))
+ (let ((lap (byte-to-native-lambda-lap
+ (gethash (aref byte-code 1)
+ byte-to-native-lambdas-h))))
+ (cl-assert lap)
+ (comp-log lap 2 t)
+ (if (comp-func-l-p func)
+ (setf (comp-func-l-args func)
+ (comp-decrypt-arg-list (aref byte-code 0) byte-code))
+ (setf (comp-func-d-lambda-list func) (cadr form)))
+ (setf (comp-func-lap func) lap
+ (comp-func-frame-size func) (comp-byte-frame-size
+ byte-code))
+ (setf (comp-func-byte-func func) byte-code
+ (comp-ctxt-top-level-forms comp-ctxt)
+ (list (make-byte-to-native-func-def :name '--anonymous-lambda
+ :c-name c-name)))
+ (comp-add-func-to-ctxt func))))
+
+(defun comp-intern-func-in-ctxt (_ obj)
+ "Given OBJ of type `byte-to-native-lambda', create a function in
`comp-ctxt'."
+ (when-let ((byte-func (byte-to-native-lambda-byte-func obj)))
+ (let* ((lap (byte-to-native-lambda-lap obj))
+ (top-l-form (cl-loop
+ for form in (comp-ctxt-top-level-forms comp-ctxt)
+ when (and (byte-to-native-func-def-p form)
+ (eq (byte-to-native-func-def-byte-func form)
+ byte-func))
+ return form))
+ (name (when top-l-form
+ (byte-to-native-func-def-name top-l-form)))
+ (c-name (comp-c-func-name (or name "anonymous-lambda") "F"))
+ (func (if (comp-lex-byte-func-p byte-func)
+ (make-comp-func-l
+ :args (comp-decrypt-arg-list (aref byte-func 0)
+ name))
+ (make-comp-func-d :lambda-list (aref byte-func 0)))))
+ (setf (comp-func-name func) name
+ (comp-func-byte-func func) byte-func
+ (comp-func-doc func) (documentation byte-func t)
+ (comp-func-int-spec func) (interactive-form byte-func)
+ (comp-func-c-name func) c-name
+ (comp-func-lap func) lap
+ (comp-func-frame-size func) (comp-byte-frame-size byte-func)
+ (comp-func-speed func) (comp-spill-speed name)
+ (comp-func-pure func) (comp-spill-decl-spec name 'pure))
+
+ ;; Store the c-name to have it retrievable from
+ ;; `comp-ctxt-top-level-forms'.
+ (when top-l-form
+ (setf (byte-to-native-func-def-c-name top-l-form) c-name))
+ (unless name
+ (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt)))
+ (comp-add-func-to-ctxt func)
+ (comp-log (format "Function %s:\n" name) 1)
+ (comp-log lap 1 t))))
+
+(cl-defmethod comp-spill-lap-function ((filename string))
+ "Byte-compile FILENAME, spilling data from the byte compiler."
+ (byte-compile-file filename)
+ (when (or (null byte-native-qualities)
+ (alist-get 'no-native-compile byte-native-qualities))
+ (throw 'no-native-compile nil))
+ (unless byte-to-native-top-level-forms
+ (signal 'native-compiler-error-empty-byte filename))
+ (unless (comp-ctxt-output comp-ctxt)
+ (setf (comp-ctxt-output comp-ctxt) (comp-el-to-eln-filename
+ filename
+ (when byte-native-for-bootstrap
+ (car (last comp-eln-load-path))))))
+ (setf (comp-ctxt-speed comp-ctxt) (alist-get 'comp-speed
+ byte-native-qualities)
+ (comp-ctxt-debug comp-ctxt) (alist-get 'comp-debug
+ byte-native-qualities)
+ (comp-ctxt-driver-options comp-ctxt) (alist-get
'comp-native-driver-options
+ byte-native-qualities)
+ (comp-ctxt-top-level-forms comp-ctxt)
+ (cl-loop
+ for form in (reverse byte-to-native-top-level-forms)
+ collect
+ (if (and (byte-to-native-func-def-p form)
+ (eq -1
+ (comp-spill-speed (byte-to-native-func-def-name form))))
+ (let ((byte-code (byte-to-native-func-def-byte-func form)))
+ (remhash byte-code byte-to-native-lambdas-h)
+ (make-byte-to-native-top-level
+ :form `(defalias
+ ',(byte-to-native-func-def-name form)
+ ,byte-code
+ nil)
+ :lexical (comp-lex-byte-func-p byte-code)))
+ form)))
+ (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h))
+
+(defun comp-spill-lap (input)
+ "Byte-compile and spill the LAP representation for INPUT.
+If INPUT is a symbol, it is the function-name to be compiled.
+If INPUT is a string, it is the filename to be compiled."
+ (let ((byte-native-compiling t)
+ (byte-to-native-lambdas-h (make-hash-table :test #'eq))
+ (byte-to-native-top-level-forms ())
+ (byte-to-native-plist-environment ()))
+ (comp-spill-lap-function input)))
+
+
+;;; Limplification pass specific code.
+
+(cl-defstruct (comp-limplify (:copier nil))
+ "Support structure used during function limplification."
+ (frame nil :type (or null comp-vec)
+ :documentation "Meta-stack used to flat LAP.")
+ (curr-block nil :type comp-block
+ :documentation "Current block being limplified.")
+ (sp -1 :type number
+ :documentation "Current stack pointer while walking LAP.
+Points to the next slot to be filled.")
+ (pc 0 :type number
+ :documentation "Current program counter while walking LAP.")
+ (label-to-addr nil :type hash-table
+ :documentation "LAP hash table -> address.")
+ (pending-blocks () :type list
+ :documentation "List of blocks waiting for limplification."))
+
+(defconst comp-lap-eob-ops
+ '(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop
+ byte-goto-if-not-nil-else-pop byte-return byte-pushcatch
+ byte-switch byte-pushconditioncase)
+ "LAP end of basic blocks op codes.")
+
+(defun comp-lap-eob-p (inst)
+ "Return t if INST closes the current basic blocks, nil otherwise."
+ (when (memq (car inst) comp-lap-eob-ops)
+ t))
+
+(defun comp-lap-fall-through-p (inst)
+ "Return t if INST falls through, nil otherwise."
+ (when (not (memq (car inst) '(byte-goto byte-return)))
+ t))
+
+(defsubst comp-sp ()
+ "Current stack pointer."
+ (declare (gv-setter (lambda (val)
+ `(setf (comp-limplify-sp comp-pass) ,val))))
+ (comp-limplify-sp comp-pass))
+
+(defmacro comp-with-sp (sp &rest body)
+ "Execute BODY setting the stack pointer to SP.
+Restore the original value afterwards."
+ (declare (debug (form body))
+ (indent defun))
+ (let ((sym (gensym)))
+ `(let ((,sym (comp-sp)))
+ (setf (comp-sp) ,sp)
+ (progn ,@body)
+ (setf (comp-sp) ,sym))))
+
+(defsubst comp-slot-n (n)
+ "Slot N into the meta-stack."
+ (comp-vec-aref (comp-limplify-frame comp-pass) n))
+
+(defsubst comp-slot ()
+ "Current slot into the meta-stack pointed by sp."
+ (comp-slot-n (comp-sp)))
+
+(defsubst comp-slot+1 ()
+ "Slot into the meta-stack pointed by sp + 1."
+ (comp-slot-n (1+ (comp-sp))))
+
+(defsubst comp-label-to-addr (label)
+ "Find the address of LABEL."
+ (or (gethash label (comp-limplify-label-to-addr comp-pass))
+ (signal 'native-ice (list "label not found" label))))
+
+(defsubst comp-mark-curr-bb-closed ()
+ "Mark the current basic block as closed."
+ (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t))
+
+(defun comp-bb-maybe-add (lap-addr &optional sp)
+ "If necessary create a pending basic block for LAP-ADDR with stack depth SP.
+The basic block is returned regardless it was already declared or not."
+ (let ((bb (or (cl-loop ; See if the block was already limplified.
+ for bb being the hash-value in (comp-func-blocks comp-func)
+ when (and (comp-block-lap-p bb)
+ (equal (comp-block-lap-addr bb) lap-addr))
+ return bb)
+ (cl-find-if (lambda (bb) ; Look within the pendings blocks.
+ (and (comp-block-lap-p bb)
+ (= (comp-block-lap-addr bb) lap-addr)))
+ (comp-limplify-pending-blocks comp-pass)))))
+ (if bb
+ (progn
+ (unless (or (null sp) (= sp (comp-block-lap-sp bb)))
+ (signal 'native-ice (list "incoherent stack pointers"
+ sp (comp-block-lap-sp bb))))
+ bb)
+ (car (push (make--comp-block-lap lap-addr sp (comp-new-block-sym))
+ (comp-limplify-pending-blocks comp-pass))))))
+
+(defsubst comp-call (func &rest args)
+ "Emit a call for function FUNC with ARGS."
+ `(call ,func ,@args))
+
+(defun comp-callref (func nargs stack-off)
+ "Emit a call using narg abi for FUNC.
+NARGS is the number of arguments.
+STACK-OFF is the index of the first slot frame involved."
+ `(callref ,func ,@(cl-loop repeat nargs
+ for sp from stack-off
+ collect (comp-slot-n sp))))
+
+(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type)
+ "`comp-mvar' initializer."
+ (let ((mvar (make--comp-mvar :slot slot)))
+ (when const-vld
+ (comp-add-const-to-relocs constant)
+ (setf (comp-cstr-imm mvar) constant))
+ (when type
+ (setf (comp-mvar-typeset mvar) (list type)))
+ mvar))
+
+(defun comp-new-frame (size vsize &optional ssa)
+ "Return a clean frame of meta variables of size SIZE and VSIZE.
+If SSA is non-nil, populate it with m-var in ssa form."
+ (cl-loop with v = (make-comp-vec :beg (- vsize) :end size)
+ for i from (- vsize) below size
+ for mvar = (if ssa
+ (make-comp-ssa-mvar :slot i)
+ (make-comp-mvar :slot i))
+ do (setf (comp-vec-aref v i) mvar)
+ finally return v))
+
+(defun comp-emit (insn)
+ "Emit INSN into basic block BB."
+ (let ((bb (comp-limplify-curr-block comp-pass)))
+ (cl-assert (not (comp-block-closed bb)))
+ (push insn (comp-block-insns bb))))
+
+(defun comp-emit-set-call (call)
+ "Emit CALL assigning the result to the current slot frame.
+If the callee function is known to have a return type, propagate it."
+ (cl-assert call)
+ (comp-emit (list 'set (comp-slot) call)))
+
+(defun comp-copy-slot (src-n &optional dst-n)
+ "Set slot number DST-N to slot number SRC-N as source.
+If DST-N is specified, use it; otherwise assume it to be the current slot."
+ (comp-with-sp (or dst-n (comp-sp))
+ (let ((src-slot (comp-slot-n src-n)))
+ (cl-assert src-slot)
+ (comp-emit `(set ,(comp-slot) ,src-slot)))))
+
+(defsubst comp-emit-annotation (str)
+ "Emit annotation STR."
+ (comp-emit `(comment ,str)))
+
+(defsubst comp-emit-setimm (val)
+ "Set constant VAL to current slot."
+ (comp-add-const-to-relocs val)
+ ;; Leave relocation index nil on purpose, will be fixed-up in final
+ ;; by `comp-finalize-relocs'.
+ (comp-emit `(setimm ,(comp-slot) ,val)))
+
+(defun comp-make-curr-block (block-name entry-sp &optional addr)
+ "Create a basic block with BLOCK-NAME and set it as current block.
+ENTRY-SP is the sp value when entering.
+Add block to the current function and return it."
+ (let ((bb (make--comp-block-lap addr entry-sp block-name)))
+ (setf (comp-limplify-curr-block comp-pass) bb
+ (comp-limplify-pc comp-pass) addr
+ (comp-limplify-sp comp-pass) (when (comp-block-lap-p bb)
+ (comp-block-lap-sp bb)))
+ (puthash (comp-block-name bb) bb (comp-func-blocks comp-func))
+ bb))
+
+(defun comp-latch-make-fill (target)
+ "Create a latch pointing to TARGET and fill it.
+Return the created latch."
+ (let ((latch (make-comp-latch :name (comp-new-block-sym "latch")))
+ (curr-bb (comp-limplify-curr-block comp-pass)))
+ ;; See `comp-make-curr-block'.
+ (setf (comp-limplify-curr-block comp-pass) latch)
+ (when (< (comp-func-speed comp-func) 3)
+ ;; At speed 3 the programmer is responsible to manually
+ ;; place `comp-maybe-gc-or-quit'.
+ (comp-emit '(call comp-maybe-gc-or-quit)))
+ ;; See `comp-emit-uncond-jump'.
+ (comp-emit `(jump ,(comp-block-name target)))
+ (comp-mark-curr-bb-closed)
+ (puthash (comp-block-name latch) latch (comp-func-blocks comp-func))
+ (setf (comp-limplify-curr-block comp-pass) curr-bb)
+ latch))
+
+(defun comp-emit-uncond-jump (lap-label)
+ "Emit an unconditional branch to LAP-LABEL."
+ (cl-destructuring-bind (label-num . stack-depth) lap-label
+ (when stack-depth
+ (cl-assert (= (1- stack-depth) (comp-sp))))
+ (let* ((target-addr (comp-label-to-addr label-num))
+ (target (comp-bb-maybe-add target-addr
+ (comp-sp)))
+ (latch (when (< target-addr (comp-limplify-pc comp-pass))
+ (comp-latch-make-fill target)))
+ (eff-target-name (comp-block-name (or latch target))))
+ (comp-emit `(jump ,eff-target-name))
+ (comp-mark-curr-bb-closed))))
+
+(defun comp-emit-cond-jump (a b target-offset lap-label negated)
+ "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ.
+TARGET-OFFSET is the positive offset on the SP when branching to the target
+block.
+If NEGATED is non null, negate the tested condition.
+Return value is the fall-through block name."
+ (cl-destructuring-bind (label-num . label-sp) lap-label
+ (let* ((bb (comp-block-name (comp-bb-maybe-add
+ (1+ (comp-limplify-pc comp-pass))
+ (comp-sp)))) ; Fall through block.
+ (target-sp (+ target-offset (comp-sp)))
+ (target-addr (comp-label-to-addr label-num))
+ (target (comp-bb-maybe-add target-addr target-sp))
+ (latch (when (< target-addr (comp-limplify-pc comp-pass))
+ (comp-latch-make-fill target)))
+ (eff-target-name (comp-block-name (or latch target))))
+ (when label-sp
+ (cl-assert (= (1- label-sp) (+ target-offset (comp-sp)))))
+ (comp-emit (if negated
+ (list 'cond-jump a b bb eff-target-name)
+ (list 'cond-jump a b eff-target-name bb)))
+ (comp-mark-curr-bb-closed)
+ bb)))
+
+(defun comp-emit-handler (lap-label handler-type)
+ "Emit a nonlocal-exit handler to LAP-LABEL of type HANDLER-TYPE."
+ (cl-destructuring-bind (label-num . label-sp) lap-label
+ (cl-assert (= (- label-sp 2) (comp-sp)))
+ (setf (comp-func-has-non-local comp-func) t)
+ (let* ((guarded-bb (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass))
+ (comp-sp)))
+ (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num)
+ (1+ (comp-sp))))
+ (pop-bb (make--comp-block-lap nil (comp-sp) (comp-new-block-sym))))
+ (comp-emit (list 'push-handler
+ handler-type
+ (comp-slot+1)
+ (comp-block-name pop-bb)
+ (comp-block-name guarded-bb)))
+ (comp-mark-curr-bb-closed)
+ ;; Emit the basic block to pop the handler if we got the non local.
+ (puthash (comp-block-name pop-bb) pop-bb (comp-func-blocks comp-func))
+ (setf (comp-limplify-curr-block comp-pass) pop-bb)
+ (comp-emit `(fetch-handler ,(comp-slot+1)))
+ (comp-emit `(jump ,(comp-block-name handler-bb)))
+ (comp-mark-curr-bb-closed))))
+
+(defun comp-limplify-listn (n)
+ "Limplify list N."
+ (comp-with-sp (+ (comp-sp) n -1)
+ (comp-emit-set-call (comp-call 'cons
+ (comp-slot)
+ (make-comp-mvar :constant nil))))
+ (cl-loop for sp from (+ (comp-sp) n -2) downto (comp-sp)
+ do (comp-with-sp sp
+ (comp-emit-set-call (comp-call 'cons
+ (comp-slot)
+ (comp-slot+1))))))
+
+(defun comp-new-block-sym (&optional postfix)
+ "Return a unique symbol postfixing POSTFIX naming the next new basic block."
+ (intern (format (if postfix "bb_%s_%s" "bb_%s")
+ (funcall (comp-func-block-cnt-gen comp-func))
+ postfix)))
+
+(defun comp-fill-label-h ()
+ "Fill label-to-addr hash table for the current function."
+ (setf (comp-limplify-label-to-addr comp-pass) (make-hash-table :test 'eql))
+ (cl-loop for insn in (comp-func-lap comp-func)
+ for addr from 0
+ do (pcase insn
+ (`(TAG ,label . ,_)
+ (puthash label addr (comp-limplify-label-to-addr
comp-pass))))))
+
+(defun comp-jump-table-optimizable (jmp-table)
+ "Return t if JMP-TABLE can be optimized out."
+ (cl-loop
+ with labels = (cl-loop for target-label being each hash-value of jmp-table
+ collect target-label)
+ with x = (car labels)
+ for l in (cdr-safe labels)
+ unless (= l x)
+ return nil
+ finally return t))
+
+(defun comp-emit-switch (var last-insn)
+ "Emit a Limple for a lap jump table given VAR and LAST-INSN."
+ ;; FIXME this not efficient for big jump tables. We should have a second
+ ;; strategy for this case.
+ (pcase last-insn
+ (`(setimm ,_ ,jmp-table)
+ (unless (comp-jump-table-optimizable jmp-table)
+ (cl-loop
+ for test being each hash-keys of jmp-table
+ using (hash-value target-label)
+ with len = (hash-table-count jmp-table)
+ with test-func = (hash-table-test jmp-table)
+ for n from 1
+ for last = (= n len)
+ for m-test = (make-comp-mvar :constant test)
+ for target-name = (comp-block-name (comp-bb-maybe-add
+ (comp-label-to-addr target-label)
+ (comp-sp)))
+ for ff-bb = (if last
+ (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass))
+ (comp-sp))
+ (make--comp-block-lap nil
+ (comp-sp)
+ (comp-new-block-sym)))
+ for ff-bb-name = (comp-block-name ff-bb)
+ if (eq test-func 'eq)
+ do (comp-emit (list 'cond-jump var m-test target-name ff-bb-name))
+ else
+ ;; Store the result of the comparison into the scratch slot before
+ ;; emitting the conditional jump.
+ do (comp-emit (list 'set (make-comp-mvar :slot 'scratch)
+ (comp-call test-func var m-test)))
+ (comp-emit (list 'cond-jump
+ (make-comp-mvar :slot 'scratch)
+ (make-comp-mvar :constant nil)
+ ff-bb-name target-name))
+ unless last
+ ;; All fall through are artificially created here except the last one.
+ do (puthash ff-bb-name ff-bb (comp-func-blocks comp-func))
+ (setf (comp-limplify-curr-block comp-pass) ff-bb))))
+ (_ (signal 'native-ice
+ "missing previous setimm while creating a switch"))))
+
+(defun comp-emit-set-call-subr (subr-name sp-delta)
+ "Emit a call for SUBR-NAME.
+SP-DELTA is the stack adjustment."
+ (let ((subr (symbol-function subr-name))
+ (nargs (1+ (- sp-delta))))
+ (let* ((arity (func-arity subr))
+ (minarg (car arity))
+ (maxarg (cdr arity)))
+ (when (eq maxarg 'unevalled)
+ (signal 'native-ice (list "subr contains unevalled args" subr-name)))
+ (if (eq maxarg 'many)
+ ;; callref case.
+ (comp-emit-set-call (comp-callref subr-name nargs (comp-sp)))
+ ;; Normal call.
+ (unless (and (>= maxarg nargs) (<= minarg nargs))
+ (signal 'native-ice
+ (list "incoherent stack adjustment" nargs maxarg minarg)))
+ (let* ((subr-name subr-name)
+ (slots (cl-loop for i from 0 below maxarg
+ collect (comp-slot-n (+ i (comp-sp))))))
+ (comp-emit-set-call (apply #'comp-call (cons subr-name
slots))))))))
+
+(eval-when-compile
+ (defun comp-op-to-fun (x)
+ "Given the LAP op strip \"byte-\" to have the subr name."
+ (intern (replace-regexp-in-string "byte-" "" x)))
+
+ (defun comp-body-eff (body op-name sp-delta)
+ "Given the original BODY, compute the effective one.
+When BODY is `auto', guess function name from the LAP byte-code
+name. Otherwise expect lname fnname."
+ (pcase (car body)
+ ('auto
+ `((comp-emit-set-call-subr ',(comp-op-to-fun op-name) ,sp-delta)))
+ ((pred symbolp)
+ `((comp-emit-set-call-subr ',(car body) ,sp-delta)))
+ (_ body))))
+
+(defmacro comp-op-case (&rest cases)
+ "Expand CASES into the corresponding `pcase' expansion.
+This is responsible for generating the proper stack adjustment, when known,
+and the annotation emission."
+ (declare (debug (body))
+ (indent defun))
+ `(pcase op
+ ,@(cl-loop for (op . body) in cases
+ for sp-delta = (gethash op comp-op-stack-info)
+ for op-name = (symbol-name op)
+ if body
+ collect `(',op
+ ;; Log all LAP ops except the TAG one.
+ ;; ,(unless (eq op 'TAG)
+ ;; `(comp-emit-annotation
+ ;; ,(concat "LAP op " op-name)))
+ ;; Emit the stack adjustment if present.
+ ,(when (and sp-delta (not (eq 0 sp-delta)))
+ `(cl-incf (comp-sp) ,sp-delta))
+ ,@(comp-body-eff body op-name sp-delta))
+ else
+ collect `(',op (signal 'native-ice
+ (list "unsupported LAP op" ',op-name))))
+ (_ (signal 'native-ice (list "unexpected LAP op" (symbol-name op))))))
+
+(defun comp-limplify-lap-inst (insn)
+ "Limplify LAP instruction INSN pushing it in the proper basic block."
+ (let ((op (car insn))
+ (arg (if (consp (cdr insn))
+ (cadr insn)
+ (cdr insn))))
+ (comp-op-case
+ (TAG
+ (cl-destructuring-bind (_TAG label-num . label-sp) insn
+ ;; Paranoid?
+ (when label-sp
+ (cl-assert (= (1- label-sp) (comp-limplify-sp comp-pass))))
+ (comp-emit-annotation (format "LAP TAG %d" label-num))))
+ (byte-stack-ref
+ (comp-copy-slot (- (comp-sp) arg 1)))
+ (byte-varref
+ (comp-emit-set-call (comp-call 'symbol-value (make-comp-mvar
+ :constant arg))))
+ (byte-varset
+ (comp-emit (comp-call 'set_internal
+ (make-comp-mvar :constant arg)
+ (comp-slot+1))))
+ (byte-varbind ;; Verify
+ (comp-emit (comp-call 'specbind
+ (make-comp-mvar :constant arg)
+ (comp-slot+1))))
+ (byte-call
+ (cl-incf (comp-sp) (- arg))
+ (comp-emit-set-call (comp-callref 'funcall (1+ arg) (comp-sp))))
+ (byte-unbind
+ (comp-emit (comp-call 'helper_unbind_n
+ (make-comp-mvar :constant arg))))
+ (byte-pophandler
+ (comp-emit '(pop-handler)))
+ (byte-pushconditioncase
+ (comp-emit-handler (cddr insn) 'condition-case))
+ (byte-pushcatch
+ (comp-emit-handler (cddr insn) 'catcher))
+ (byte-nth auto)
+ (byte-symbolp auto)
+ (byte-consp auto)
+ (byte-stringp auto)
+ (byte-listp auto)
+ (byte-eq auto)
+ (byte-memq auto)
+ (byte-not
+ (comp-emit-set-call (comp-call 'eq (comp-slot-n (comp-sp))
+ (make-comp-mvar :constant nil))))
+ (byte-car auto)
+ (byte-cdr auto)
+ (byte-cons auto)
+ (byte-list1
+ (comp-limplify-listn 1))
+ (byte-list2
+ (comp-limplify-listn 2))
+ (byte-list3
+ (comp-limplify-listn 3))
+ (byte-list4
+ (comp-limplify-listn 4))
+ (byte-length auto)
+ (byte-aref auto)
+ (byte-aset auto)
+ (byte-symbol-value auto)
+ (byte-symbol-function auto)
+ (byte-set auto)
+ (byte-fset auto)
+ (byte-get auto)
+ (byte-substring auto)
+ (byte-concat2
+ (comp-emit-set-call (comp-callref 'concat 2 (comp-sp))))
+ (byte-concat3
+ (comp-emit-set-call (comp-callref 'concat 3 (comp-sp))))
+ (byte-concat4
+ (comp-emit-set-call (comp-callref 'concat 4 (comp-sp))))
+ (byte-sub1 1-)
+ (byte-add1 1+)
+ (byte-eqlsign =)
+ (byte-gtr >)
+ (byte-lss <)
+ (byte-leq <=)
+ (byte-geq >=)
+ (byte-diff -)
+ (byte-negate
+ (comp-emit-set-call (comp-call 'negate (comp-slot))))
+ (byte-plus +)
+ (byte-max auto)
+ (byte-min auto)
+ (byte-mult *)
+ (byte-point auto)
+ (byte-goto-char auto)
+ (byte-insert auto)
+ (byte-point-max auto)
+ (byte-point-min auto)
+ (byte-char-after auto)
+ (byte-following-char auto)
+ (byte-preceding-char preceding-char)
+ (byte-current-column auto)
+ (byte-indent-to
+ (comp-emit-set-call (comp-call 'indent-to
+ (comp-slot)
+ (make-comp-mvar :constant nil))))
+ (byte-scan-buffer-OBSOLETE)
+ (byte-eolp auto)
+ (byte-eobp auto)
+ (byte-bolp auto)
+ (byte-bobp auto)
+ (byte-current-buffer auto)
+ (byte-set-buffer auto)
+ (byte-save-current-buffer
+ (comp-emit (comp-call 'record_unwind_current_buffer)))
+ (byte-set-mark-OBSOLETE)
+ (byte-interactive-p-OBSOLETE)
+ (byte-forward-char auto)
+ (byte-forward-word auto)
+ (byte-skip-chars-forward auto)
+ (byte-skip-chars-backward auto)
+ (byte-forward-line auto)
+ (byte-char-syntax auto)
+ (byte-buffer-substring auto)
+ (byte-delete-region auto)
+ (byte-narrow-to-region
+ (comp-emit-set-call (comp-call 'narrow-to-region
+ (comp-slot)
+ (comp-slot+1))))
+ (byte-widen
+ (comp-emit-set-call (comp-call 'widen)))
+ (byte-end-of-line auto)
+ (byte-constant2) ; TODO
+ ;; Branches.
+ (byte-goto
+ (comp-emit-uncond-jump (cddr insn)))
+ (byte-goto-if-nil
+ (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0
+ (cddr insn) nil))
+ (byte-goto-if-not-nil
+ (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0
+ (cddr insn) t))
+ (byte-goto-if-nil-else-pop
+ (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1
+ (cddr insn) nil))
+ (byte-goto-if-not-nil-else-pop
+ (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1
+ (cddr insn) t))
+ (byte-return
+ (comp-emit `(return ,(comp-slot+1))))
+ (byte-discard 'pass)
+ (byte-dup
+ (comp-copy-slot (1- (comp-sp))))
+ (byte-save-excursion
+ (comp-emit (comp-call 'record_unwind_protect_excursion)))
+ (byte-save-window-excursion-OBSOLETE)
+ (byte-save-restriction
+ (comp-emit (comp-call 'helper_save_restriction)))
+ (byte-catch) ;; Obsolete
+ (byte-unwind-protect
+ (comp-emit (comp-call 'helper_unwind_protect (comp-slot+1))))
+ (byte-condition-case) ;; Obsolete
+ (byte-temp-output-buffer-setup-OBSOLETE)
+ (byte-temp-output-buffer-show-OBSOLETE)
+ (byte-unbind-all) ;; Obsolete
+ (byte-set-marker auto)
+ (byte-match-beginning auto)
+ (byte-match-end auto)
+ (byte-upcase auto)
+ (byte-downcase auto)
+ (byte-string= string-equal)
+ (byte-string< string-lessp)
+ (byte-equal auto)
+ (byte-nthcdr auto)
+ (byte-elt auto)
+ (byte-member auto)
+ (byte-assq auto)
+ (byte-nreverse auto)
+ (byte-setcar auto)
+ (byte-setcdr auto)
+ (byte-car-safe auto)
+ (byte-cdr-safe auto)
+ (byte-nconc auto)
+ (byte-quo /)
+ (byte-rem %)
+ (byte-numberp auto)
+ (byte-integerp auto)
+ (byte-listN
+ (cl-incf (comp-sp) (- 1 arg))
+ (comp-emit-set-call (comp-callref 'list arg (comp-sp))))
+ (byte-concatN
+ (cl-incf (comp-sp) (- 1 arg))
+ (comp-emit-set-call (comp-callref 'concat arg (comp-sp))))
+ (byte-insertN
+ (cl-incf (comp-sp) (- 1 arg))
+ (comp-emit-set-call (comp-callref 'insert arg (comp-sp))))
+ (byte-stack-set
+ (comp-copy-slot (1+ (comp-sp)) (- (comp-sp) arg -1)))
+ (byte-stack-set2 (cl-assert nil)) ;; TODO
+ (byte-discardN
+ (cl-incf (comp-sp) (- arg)))
+ (byte-switch
+ ;; Assume to follow the emission of a setimm.
+ ;; This is checked into comp-emit-switch.
+ (comp-emit-switch (comp-slot+1)
+ (cl-first (comp-block-insns
+ (comp-limplify-curr-block comp-pass)))))
+ (byte-constant
+ (comp-emit-setimm arg))
+ (byte-discardN-preserve-tos
+ (cl-incf (comp-sp) (- arg))
+ (comp-copy-slot (+ arg (comp-sp)))))))
+
+(defun comp-emit-narg-prologue (minarg nonrest rest)
+ "Emit the prologue for a narg function."
+ (cl-loop for i below minarg
+ do (comp-emit `(set-args-to-local ,(comp-slot-n i)))
+ (comp-emit '(inc-args)))
+ (cl-loop for i from minarg below nonrest
+ for bb = (intern (format "entry_%s" i))
+ for fallback = (intern (format "entry_fallback_%s" i))
+ do (comp-emit `(cond-jump-narg-leq ,i ,fallback ,bb))
+ (comp-make-curr-block bb (comp-sp))
+ (comp-emit `(set-args-to-local ,(comp-slot-n i)))
+ (comp-emit '(inc-args))
+ finally (comp-emit '(jump entry_rest_args)))
+ (when (/= minarg nonrest)
+ (cl-loop for i from minarg below nonrest
+ for bb = (intern (format "entry_fallback_%s" i))
+ for next-bb = (if (= (1+ i) nonrest)
+ 'entry_rest_args
+ (intern (format "entry_fallback_%s" (1+ i))))
+ do (comp-with-sp i
+ (comp-make-curr-block bb (comp-sp))
+ (comp-emit-setimm nil)
+ (comp-emit `(jump ,next-bb)))))
+ (comp-make-curr-block 'entry_rest_args (comp-sp))
+ (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest)))
+ (setf (comp-sp) nonrest)
+ (when (and (> nonrest 8) (null rest))
+ (cl-decf (comp-sp))))
+
+(defun comp-limplify-finalize-function (func)
+ "Reverse insns into all basic blocks of FUNC."
+ (cl-loop for bb being the hash-value in (comp-func-blocks func)
+ do (setf (comp-block-insns bb)
+ (nreverse (comp-block-insns bb))))
+ (comp-log-func func 2)
+ func)
+
+(cl-defgeneric comp-prepare-args-for-top-level (function)
+ "Given FUNCTION, return the two arguments for comp--register-...")
+
+(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-l))
+ "Lexically-scoped FUNCTION."
+ (let ((args (comp-func-l-args function)))
+ (cons (make-comp-mvar :constant (comp-args-base-min args))
+ (make-comp-mvar :constant (if (comp-args-p args)
+ (comp-args-max args)
+ 'many)))))
+
+(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-d))
+ "Dynamically scoped FUNCTION."
+ (cons (make-comp-mvar :constant (func-arity (comp-func-byte-func function)))
+ (let ((comp-curr-allocation-class 'd-default))
+ ;; Lambda-lists must stay in the same relocation class of
+ ;; the object referenced by code to respect uninterned
+ ;; symbols.
+ (make-comp-mvar :constant (comp-func-d-lambda-list function)))))
+
+(cl-defgeneric comp-emit-for-top-level (form for-late-load)
+ "Emit the Limple code for top level FORM.")
+
+(cl-defmethod comp-emit-for-top-level ((form byte-to-native-func-def)
+ for-late-load)
+ (let* ((name (byte-to-native-func-def-name form))
+ (c-name (byte-to-native-func-def-c-name form))
+ (f (gethash c-name (comp-ctxt-funcs-h comp-ctxt)))
+ (args (comp-prepare-args-for-top-level f)))
+ (cl-assert (and name f))
+ (comp-emit
+ `(set ,(make-comp-mvar :slot 1)
+ ,(comp-call (if for-late-load
+ 'comp--late-register-subr
+ 'comp--register-subr)
+ (make-comp-mvar :constant name)
+ (make-comp-mvar :constant c-name)
+ (car args)
+ (cdr args)
+ (setf (comp-func-type f)
+ (make-comp-mvar :constant nil))
+ (make-comp-mvar
+ :constant
+ (list
+ (let* ((h (comp-ctxt-function-docs comp-ctxt))
+ (i (hash-table-count h)))
+ (puthash i (comp-func-doc f) h)
+ i)
+ (comp-func-int-spec f)))
+ ;; This is the compilation unit it-self passed as
+ ;; parameter.
+ (make-comp-mvar :slot 0))))))
+
+(cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)
+ for-late-load)
+ (unless for-late-load
+ (comp-emit
+ (comp-call 'eval
+ (let ((comp-curr-allocation-class 'd-impure))
+ (make-comp-mvar :constant
+ (byte-to-native-top-level-form form)))
+ (make-comp-mvar :constant
+ (byte-to-native-top-level-lexical form))))))
+
+(defun comp-emit-lambda-for-top-level (func)
+ "Emit the creation of subrs for lambda FUNC.
+These are stored in the reloc data array."
+ (let ((args (comp-prepare-args-for-top-level func)))
+ (let ((comp-curr-allocation-class 'd-impure))
+ (comp-add-const-to-relocs (comp-func-byte-func func)))
+ (comp-emit
+ (comp-call 'comp--register-lambda
+ ;; mvar to be fixed-up when containers are
+ ;; finalized.
+ (or (gethash (comp-func-byte-func func)
+ (comp-ctxt-lambda-fixups-h comp-ctxt))
+ (puthash (comp-func-byte-func func)
+ (make-comp-mvar :constant nil)
+ (comp-ctxt-lambda-fixups-h comp-ctxt)))
+ (make-comp-mvar :constant (comp-func-c-name func))
+ (car args)
+ (cdr args)
+ (setf (comp-func-type func)
+ (make-comp-mvar :constant nil))
+ (make-comp-mvar
+ :constant
+ (list
+ (let* ((h (comp-ctxt-function-docs comp-ctxt))
+ (i (hash-table-count h)))
+ (puthash i (comp-func-doc func) h)
+ i)
+ (comp-func-int-spec func)))
+ ;; This is the compilation unit it-self passed as
+ ;; parameter.
+ (make-comp-mvar :slot 0)))))
+
+(defun comp-limplify-top-level (for-late-load)
+ "Create a Limple function to modify the global environment at load.
+When FOR-LATE-LOAD is non-nil, the emitted function modifies only
+function definition.
+
+Synthesize a function called `top_level_run' that gets one single
+parameter (the compilation unit itself). To define native
+functions, `top_level_run' will call back `comp--register-subr'
+into the C code forwarding the compilation unit."
+ ;; Once an .eln is loaded and Emacs is dumped 'top_level_run' has no
+ ;; reasons to be executed ever again. Therefore all objects can be
+ ;; just ephemeral.
+ (let* ((comp-curr-allocation-class 'd-ephemeral)
+ (func (make-comp-func-l :name (if for-late-load
+ 'late-top-level-run
+ 'top-level-run)
+ :c-name (if for-late-load
+ "late_top_level_run"
+ "top_level_run")
+ :args (make-comp-args :min 1 :max 1)
+ ;; Frame is 2 wide: Slot 0 is the
+ ;; compilation unit being loaded
+ ;; (incoming parameter). Slot 1 is
+ ;; the last function being
+ ;; registered.
+ :frame-size 2
+ :speed (comp-ctxt-speed comp-ctxt)))
+ (comp-func func)
+ (comp-pass (make-comp-limplify
+ :curr-block (make--comp-block-lap -1 0 'top-level)
+ :frame (comp-new-frame 1 0))))
+ (comp-make-curr-block 'entry (comp-sp))
+ (comp-emit-annotation (if for-late-load
+ "Late top level"
+ "Top level"))
+ ;; Assign the compilation unit incoming as parameter to the slot frame 0.
+ (comp-emit `(set-par-to-local ,(comp-slot-n 0) 0))
+ (maphash (lambda (_ func)
+ (comp-emit-lambda-for-top-level func))
+ (comp-ctxt-byte-func-to-func-h comp-ctxt))
+ (mapc (lambda (x) (comp-emit-for-top-level x for-late-load))
+ (comp-ctxt-top-level-forms comp-ctxt))
+ (comp-emit `(return ,(make-comp-mvar :slot 1)))
+ (comp-limplify-finalize-function func)))
+
+(defun comp-addr-to-bb-name (addr)
+ "Search for a block starting at ADDR into pending or limplified blocks."
+ ;; FIXME Actually we could have another hash for this.
+ (cl-flet ((pred (bb)
+ (equal (comp-block-lap-addr bb) addr)))
+ (if-let ((pending (cl-find-if #'pred
+ (comp-limplify-pending-blocks comp-pass))))
+ (comp-block-name pending)
+ (cl-loop for bb being the hash-value in (comp-func-blocks comp-func)
+ when (pred bb)
+ return (comp-block-name bb)))))
+
+(defun comp-limplify-block (bb)
+ "Limplify basic-block BB and add it to the current function."
+ (setf (comp-limplify-curr-block comp-pass) bb
+ (comp-limplify-sp comp-pass) (comp-block-lap-sp bb)
+ (comp-limplify-pc comp-pass) (comp-block-lap-addr bb))
+ (puthash (comp-block-name bb) bb (comp-func-blocks comp-func))
+ (cl-loop
+ for inst-cell on (nthcdr (comp-limplify-pc comp-pass)
+ (comp-func-lap comp-func))
+ for inst = (car inst-cell)
+ for next-inst = (car-safe (cdr inst-cell))
+ do (comp-limplify-lap-inst inst)
+ (cl-incf (comp-limplify-pc comp-pass))
+ when (comp-lap-fall-through-p inst)
+ do (pcase next-inst
+ (`(TAG ,_label . ,label-sp)
+ (when label-sp
+ (cl-assert (= (1- label-sp) (comp-sp))))
+ (let* ((stack-depth (if label-sp
+ (1- label-sp)
+ (comp-sp)))
+ (next-bb (comp-block-name (comp-bb-maybe-add
+ (comp-limplify-pc comp-pass)
+ stack-depth))))
+ (unless (comp-block-closed bb)
+ (comp-emit `(jump ,next-bb))))
+ (cl-return)))
+ until (comp-lap-eob-p inst)))
+
+(defun comp-limplify-function (func)
+ "Limplify a single function FUNC."
+ (let* ((frame-size (comp-func-frame-size func))
+ (comp-func func)
+ (comp-pass (make-comp-limplify
+ :frame (comp-new-frame frame-size 0))))
+ (comp-fill-label-h)
+ ;; Prologue
+ (comp-make-curr-block 'entry (comp-sp))
+ (comp-emit-annotation (concat "Lisp function: "
+ (symbol-name (comp-func-name func))))
+ ;; Dynamic functions have parameters bound by the trampoline.
+ (when (comp-func-l-p func)
+ (let ((args (comp-func-l-args func)))
+ (if (comp-args-p args)
+ (cl-loop for i below (comp-args-max args)
+ do (cl-incf (comp-sp))
+ (comp-emit `(set-par-to-local ,(comp-slot) ,i)))
+ (comp-emit-narg-prologue (comp-args-base-min args)
+ (comp-nargs-nonrest args)
+ (comp-nargs-rest args)))))
+ (comp-emit '(jump bb_0))
+ ;; Body
+ (comp-bb-maybe-add 0 (comp-sp))
+ (cl-loop for next-bb = (pop (comp-limplify-pending-blocks comp-pass))
+ while next-bb
+ do (comp-limplify-block next-bb))
+ ;; Sanity check against block duplication.
+ (cl-loop with addr-h = (make-hash-table)
+ for bb being the hash-value in (comp-func-blocks func)
+ for addr = (when (comp-block-lap-p bb)
+ (comp-block-lap-addr bb))
+ when addr
+ do (cl-assert (null (gethash addr addr-h)))
+ (puthash addr t addr-h))
+ (comp-limplify-finalize-function func)))
+
+(defun comp-limplify (_)
+ "Compute LIMPLE IR for forms in `comp-ctxt'."
+ (maphash (lambda (_ f) (comp-limplify-function f))
+ (comp-ctxt-funcs-h comp-ctxt))
+ (comp-add-func-to-ctxt (comp-limplify-top-level nil))
+ (when (comp-ctxt-with-late-load comp-ctxt)
+ (comp-add-func-to-ctxt (comp-limplify-top-level t))))
+
+
+;;; add-cstrs pass specific code.
+
+;; This pass is responsible for adding constraints, these are
+;; generated from:
+;;
+;; - Conditional branches: each branch taken or non taken can be used
+;; in the CFG to infer information on the tested variables.
+;;
+;; - Range propagation under test and branch (when the test is an
+;; arithmetic comparison).
+;;
+;; - Type constraint under test and branch (when the test is a
+;; known predicate).
+;;
+;; - Function calls: function calls to function assumed to be not
+;; redefinable can be used to add constrains on the function
+;; arguments. Ex: if we execute successfully (= x y) we know that
+;; afterwards both x and y must satisfy the (or number marker)
+;; type specifier.
+
+
+(defsubst comp-mvar-used-p (mvar)
+ "Non-nil when MVAR is used as lhs in the current function."
+ (declare (gv-setter (lambda (val)
+ `(puthash ,mvar ,val comp-pass))))
+ (gethash mvar comp-pass))
+
+(defun comp-collect-mvars (form)
+ "Add rhs m-var present in FORM into `comp-pass'."
+ (cl-loop for x in form
+ if (consp x)
+ do (comp-collect-mvars x)
+ else
+ when (comp-mvar-p x)
+ do (setf (comp-mvar-used-p x) t)))
+
+(defun comp-collect-rhs ()
+ "Collect all lhs mvars into `comp-pass'."
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do (cl-loop
+ for insn in (comp-block-insns b)
+ for (op . args) = insn
+ if (comp-assign-op-p op)
+ do (comp-collect-mvars (cdr args))
+ else
+ do (comp-collect-mvars args))))
+
+(defun comp-negate-arithm-cmp-fun (function)
+ "Negate FUNCTION.
+Return nil if we don't want to emit constraints for its negation."
+ (cl-ecase function
+ (= nil)
+ (> '<=)
+ (< '>=)
+ (>= '<)
+ (<= '>)))
+
+(defun comp-reverse-arithm-fun (function)
+ "Reverse FUNCTION."
+ (cl-case function
+ (= '=)
+ (> '<)
+ (< '>)
+ (>= '<=)
+ (<= '>=)
+ (t function)))
+
+(defun comp-emit-assume (kind lhs rhs bb negated)
+ "Emit an assume of kind KIND for mvar LHS being RHS.
+When NEGATED is non-nil, the assumption is negated.
+The assume is emitted at the beginning of the block BB."
+ (let ((lhs-slot (comp-mvar-slot lhs)))
+ (cl-assert lhs-slot)
+ (pcase kind
+ ((or 'and 'and-nhc)
+ (if (comp-mvar-p rhs)
+ (let ((tmp-mvar (if negated
+ (make-comp-mvar :slot (comp-mvar-slot rhs))
+ rhs)))
+ (push `(assume ,(make-comp-mvar :slot lhs-slot)
+ (,kind ,lhs ,tmp-mvar))
+ (comp-block-insns bb))
+ (if negated
+ (push `(assume ,tmp-mvar (not ,rhs))
+ (comp-block-insns bb))))
+ ;; If is only a constraint we can negate it directly.
+ (push `(assume ,(make-comp-mvar :slot lhs-slot)
+ (,kind ,lhs ,(if negated
+ (comp-cstr-negation-make rhs)
+ rhs)))
+ (comp-block-insns bb))))
+ ((pred comp-arithm-cmp-fun-p)
+ (when-let ((kind (if negated
+ (comp-negate-arithm-cmp-fun kind)
+ kind)))
+ (push `(assume ,(make-comp-mvar :slot lhs-slot)
+ (,kind ,lhs
+ ,(if-let* ((vld (comp-cstr-imm-vld-p rhs))
+ (val (comp-cstr-imm rhs))
+ (ok (and (integerp val)
+ (not (memq kind '(= !=))))))
+ val
+ (make-comp-mvar :slot (comp-mvar-slot
rhs)))))
+ (comp-block-insns bb))))
+ (_ (cl-assert nil)))
+ (setf (comp-func-ssa-status comp-func) 'dirty)))
+
+(defun comp-maybe-add-vmvar (op cmp-res insns-seq)
+ "If CMP-RES is clobbering OP emit a new constrained mvar and return it.
+Return OP otherwise."
+ (if-let ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res)))
+ (new-mvar (make-comp-mvar
+ :slot
+ (- (cl-incf (comp-func-vframe-size comp-func))))))
+ (progn
+ (push `(assume ,new-mvar ,op) (cdr insns-seq))
+ new-mvar)
+ op))
+
+(defun comp-add-new-block-between (bb-symbol bb-a bb-b)
+ "Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B."
+ (cl-loop
+ with new-bb = (make-comp-block-cstr :name bb-symbol
+ :insns `((jump ,(comp-block-name
bb-b))))
+ with new-edge = (make-comp-edge :src bb-a :dst new-bb)
+ for ed in (comp-block-in-edges bb-b)
+ when (eq (comp-edge-src ed) bb-a)
+ do
+ ;; Connect `ed' to `new-bb' and disconnect it from `bb-a'.
+ (cl-assert (memq ed (comp-block-out-edges bb-a)))
+ (setf (comp-edge-src ed) new-bb
+ (comp-block-out-edges bb-a) (delq ed (comp-block-out-edges bb-a)))
+ (push ed (comp-block-out-edges new-bb))
+ ;; Connect `bb-a' `new-bb' with `new-edge'.
+ (push new-edge (comp-block-out-edges bb-a))
+ (push new-edge (comp-block-in-edges new-bb))
+ (setf (comp-func-ssa-status comp-func) 'dirty)
+ ;; Add `new-edge' to the current function and return it.
+ (cl-return (puthash bb-symbol new-bb (comp-func-blocks comp-func)))
+ finally (cl-assert nil)))
+
+;; Cheap substitute to a copy propagation pass...
+(defun comp-cond-cstrs-target-mvar (mvar exit-insn bb)
+ "Given MVAR, search in BB the original mvar MVAR got assigned from.
+Keep on searching till EXIT-INSN is encountered."
+ (cl-flet ((targetp (x)
+ ;; Ret t if x is an mvar and target the correct slot number.
+ (and (comp-mvar-p x)
+ (eql (comp-mvar-slot mvar) (comp-mvar-slot x)))))
+ (cl-loop
+ with res = nil
+ for insn in (comp-block-insns bb)
+ when (eq insn exit-insn)
+ do (cl-return (and (comp-mvar-p res) res))
+ do (pcase insn
+ (`(,(pred comp-assign-op-p) ,(pred targetp) ,rhs)
+ (setf res rhs)))
+ finally (cl-assert nil))))
+
+(defun comp-add-cond-cstrs-target-block (curr-bb target-bb-sym)
+ "Return the appropriate basic block to add constraint assumptions into.
+CURR-BB is the current basic block.
+TARGET-BB-SYM is the symbol name of the target block."
+ (let* ((target-bb (gethash target-bb-sym
+ (comp-func-blocks comp-func)))
+ (target-bb-in-edges (comp-block-in-edges target-bb)))
+ (cl-assert target-bb-in-edges)
+ (if (length= target-bb-in-edges 1)
+ ;; If block has only one predecessor is already suitable for
+ ;; adding constraint assumptions.
+ target-bb
+ (cl-loop
+ ;; Search for the first suitable basic block name.
+ for i from 0
+ for new-name = (intern (format "%s_cstrs_%d" (symbol-name target-bb-sym)
+ i))
+ until (null (gethash new-name (comp-func-blocks comp-func)))
+ finally
+ ;; Add it.
+ (cl-return (comp-add-new-block-between new-name curr-bb target-bb))))))
+
+(defun comp-add-cond-cstrs-simple ()
+ "`comp-add-cstrs' worker function for each selected function."
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do
+ (cl-loop
+ named in-the-basic-block
+ for insn-seq on (comp-block-insns b)
+ do
+ (pcase insn-seq
+ (`((set ,(and (pred comp-mvar-p) tmp-mvar) ,(pred comp-mvar-p))
+ ;; (comment ,_comment-str)
+ (cond-jump ,tmp-mvar ,obj2 . ,blocks))
+ (cl-loop
+ for branch-target-cell on blocks
+ for branch-target = (car branch-target-cell)
+ for negated in '(nil t)
+ when (comp-mvar-used-p tmp-mvar)
+ do
+ (let ((block-target (comp-add-cond-cstrs-target-block b branch-target)))
+ (setf (car branch-target-cell) (comp-block-name block-target))
+ (comp-emit-assume 'and tmp-mvar obj2 block-target negated))
+ finally (cl-return-from in-the-basic-block)))
+ (`((cond-jump ,obj1 ,obj2 . ,blocks))
+ (cl-loop
+ for branch-target-cell on blocks
+ for branch-target = (car branch-target-cell)
+ for negated in '(nil t)
+ when (comp-mvar-used-p obj1)
+ do
+ (let ((block-target (comp-add-cond-cstrs-target-block b branch-target)))
+ (setf (car branch-target-cell) (comp-block-name block-target))
+ (comp-emit-assume 'and obj1 obj2 block-target negated))
+ finally (cl-return-from in-the-basic-block)))))))
+
+(defun comp-add-cond-cstrs ()
+ "`comp-add-cstrs' worker function for each selected function."
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do
+ (cl-loop
+ named in-the-basic-block
+ with prev-insns-seq
+ for insns-seq on (comp-block-insns b)
+ do
+ (pcase insns-seq
+ (`((set ,(and (pred comp-mvar-p) cmp-res)
+ (,(pred comp-call-op-p)
+ ,(and (or (pred comp-equality-fun-p)
+ (pred comp-arithm-cmp-fun-p))
+ fun)
+ ,op1 ,op2))
+ ;; (comment ,_comment-str)
+ (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks))
+ (cl-loop
+ with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b)
+ with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b)
+ for branch-target-cell on blocks
+ for branch-target = (car branch-target-cell)
+ for negated in '(t nil)
+ for kind = (cl-case fun
+ (equal 'and-nhc)
+ (eql 'and-nhc)
+ (eq 'and)
+ (t fun))
+ when (or (comp-mvar-used-p target-mvar1)
+ (comp-mvar-used-p target-mvar2))
+ do
+ (let ((block-target (comp-add-cond-cstrs-target-block b
branch-target)))
+ (setf (car branch-target-cell) (comp-block-name block-target))
+ (when (comp-mvar-used-p target-mvar1)
+ (comp-emit-assume kind target-mvar1
+ (comp-maybe-add-vmvar op2 cmp-res prev-insns-seq)
+ block-target negated))
+ (when (comp-mvar-used-p target-mvar2)
+ (comp-emit-assume (comp-reverse-arithm-fun kind)
+ target-mvar2
+ (comp-maybe-add-vmvar op1 cmp-res prev-insns-seq)
+ block-target negated)))
+ finally (cl-return-from in-the-basic-block)))
+ (`((set ,(and (pred comp-mvar-p) cmp-res)
+ (,(pred comp-call-op-p)
+ ,(and (pred comp-known-predicate-p) fun)
+ ,op))
+ ;; (comment ,_comment-str)
+ (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks))
+ (cl-loop
+ with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b)
+ with cstr = (comp-pred-to-cstr fun)
+ for branch-target-cell on blocks
+ for branch-target = (car branch-target-cell)
+ for negated in '(t nil)
+ when (comp-mvar-used-p target-mvar)
+ do
+ (let ((block-target (comp-add-cond-cstrs-target-block b
branch-target)))
+ (setf (car branch-target-cell) (comp-block-name block-target))
+ (comp-emit-assume 'and target-mvar cstr block-target negated))
+ finally (cl-return-from in-the-basic-block)))
+ ;; Match predicate on the negated branch (unless).
+ (`((set ,(and (pred comp-mvar-p) cmp-res)
+ (,(pred comp-call-op-p)
+ ,(and (pred comp-known-predicate-p) fun)
+ ,op))
+ (set ,neg-cmp-res (call eq ,cmp-res ,(pred comp-cstr-null-p)))
+ (cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks))
+ (cl-loop
+ with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b)
+ with cstr = (comp-pred-to-cstr fun)
+ for branch-target-cell on blocks
+ for branch-target = (car branch-target-cell)
+ for negated in '(nil t)
+ when (comp-mvar-used-p target-mvar)
+ do
+ (let ((block-target (comp-add-cond-cstrs-target-block b
branch-target)))
+ (setf (car branch-target-cell) (comp-block-name block-target))
+ (comp-emit-assume 'and target-mvar cstr block-target negated))
+ finally (cl-return-from in-the-basic-block))))
+ (setf prev-insns-seq insns-seq))))
+
+(defsubst comp-insert-insn (insn insn-cell)
+ "Insert INSN as second insn of INSN-CELL."
+ (let ((next-cell (cdr insn-cell))
+ (new-cell `(,insn)))
+ (setf (cdr insn-cell) new-cell
+ (cdr new-cell) next-cell
+ (comp-func-ssa-status comp-func) 'dirty)))
+
+(defun comp-emit-call-cstr (mvar call-cell cstr)
+ "Emit a constraint CSTR for MVAR after CALL-CELL."
+ (let* ((new-mvar (make-comp-mvar :slot (comp-mvar-slot mvar)))
+ ;; Have new-mvar as LHS *and* RHS to ensure monotonicity and
+ ;; fwprop convergence!!
+ (insn `(assume ,new-mvar (and ,new-mvar ,mvar ,cstr))))
+ (comp-insert-insn insn call-cell)))
+
+(defun comp-lambda-list-gen (lambda-list)
+ "Return a generator to iterate over LAMBDA-LIST."
+ (lambda ()
+ (cl-case (car lambda-list)
+ (&optional
+ (setf lambda-list (cdr lambda-list))
+ (prog1
+ (car lambda-list)
+ (setf lambda-list (cdr lambda-list))))
+ (&rest
+ (cadr lambda-list))
+ (t
+ (prog1
+ (car lambda-list)
+ (setf lambda-list (cdr lambda-list)))))))
+
+(defun comp-add-call-cstr ()
+ "Add args assumptions for each function of which the type specifier is
known."
+ (cl-loop
+ for bb being each hash-value of (comp-func-blocks comp-func)
+ do
+ (comp-loop-insn-in-block bb
+ (when-let ((match
+ (pcase insn
+ (`(set ,lhs (,(pred comp-call-op-p) ,f . ,args))
+ (when-let ((cstr-f (gethash f comp-known-func-cstr-h)))
+ (cl-values f cstr-f lhs args)))
+ (`(,(pred comp-call-op-p) ,f . ,args)
+ (when-let ((cstr-f (gethash f comp-known-func-cstr-h)))
+ (cl-values f cstr-f nil args))))))
+ (cl-multiple-value-bind (f cstr-f lhs args) match
+ (cl-loop
+ with gen = (comp-lambda-list-gen (comp-cstr-f-args cstr-f))
+ for arg in args
+ for cstr = (funcall gen)
+ for target = (comp-cond-cstrs-target-mvar arg insn bb)
+ unless (comp-cstr-p cstr)
+ do (signal 'native-ice
+ (list "Incoherent type specifier for function" f))
+ when (and target
+ ;; No need to add call constraints if this is t
+ ;; (bug#45812 bug#45705 bug#45751).
+ (not (equal comp-cstr-t cstr))
+ (or (null lhs)
+ (not (eql (comp-mvar-slot lhs)
+ (comp-mvar-slot target)))))
+ do (comp-emit-call-cstr target insn-cell cstr)))))))
+
+(defun comp-add-cstrs (_)
+ "Rewrite conditional branches adding appropriate 'assume' insns.
+This is introducing and placing 'assume' insns in use by fwprop
+to propagate conditional branch test information on target basic
+blocks."
+ (maphash (lambda (_ f)
+ (when (and (>= (comp-func-speed f) 1)
+ ;; No point to run this on dynamic scope as
+ ;; this pass is effective only on local
+ ;; variables.
+ (comp-func-l-p f)
+ (not (comp-func-has-non-local f)))
+ (let ((comp-func f)
+ (comp-pass (make-hash-table :test #'eq)))
+ (comp-collect-rhs)
+ (comp-add-cond-cstrs-simple)
+ (comp-add-cond-cstrs)
+ (comp-add-call-cstr)
+ (comp-log-func comp-func 3))))
+ (comp-ctxt-funcs-h comp-ctxt)))
+
+
+;;; pure-func pass specific code.
+
+;; Simple IPA pass to infer function purity of functions not
+;; explicitly declared as such. This is effective only at speed 3 to
+;; avoid optimizing-out functions and preventing their redefinition
+;; being effective.
+
+(defun comp-collect-calls (f)
+ "Return a list with all the functions called by F."
+ (cl-loop
+ with h = (make-hash-table :test #'eq)
+ for b being each hash-value of (comp-func-blocks f)
+ do (cl-loop
+ for insn in (comp-block-insns b)
+ do (pcase insn
+ (`(set ,_lval (,(pred comp-call-op-p) ,f . ,_rest))
+ (puthash f t h))
+ (`(,(pred comp-call-op-p) ,f . ,_rest)
+ (puthash f t h))))
+ finally return (cl-loop
+ for f being each hash-key of h
+ collect (if (stringp f)
+ (comp-func-name
+ (gethash f
+ (comp-ctxt-funcs-h comp-ctxt)))
+ f))))
+
+(defun comp-pure-infer-func (f)
+ "If all functions called by F are pure then F is pure too."
+ (when (and (cl-every (lambda (x)
+ (or (comp-function-pure-p x)
+ (eq x (comp-func-name f))))
+ (comp-collect-calls f))
+ (not (eq (comp-func-pure f) t)))
+ (comp-log (format "%s inferred to be pure" (comp-func-name f)))
+ (setf (comp-func-pure f) t)))
+
+(defun comp-ipa-pure (_)
+ "Infer function purity."
+ (cl-loop
+ with pure-n = 0
+ for n from 1
+ while
+ (/= pure-n
+ (setf pure-n
+ (cl-loop
+ for f being each hash-value of (comp-ctxt-funcs-h comp-ctxt)
+ when (and (>= (comp-func-speed f) 3)
+ (comp-func-l-p f)
+ (not (comp-func-pure f)))
+ do (comp-pure-infer-func f)
+ count (comp-func-pure f))))
+ finally (comp-log (format "ipa-pure iterated %d times" n))))
+
+
+;;; SSA pass specific code.
+;; After limplification no edges are present between basic blocks and an
+;; implicit phi is present for every slot at the beginning of every basic
block.
+;; This pass is responsible for building all the edges and replace all m-vars
+;; plus placing the needed phis.
+;; Because the number of phis placed is (supposed) to be the minimum necessary
+;; this form is called 'minimal SSA form'.
+;; This pass should be run every time basic blocks or m-var are shuffled.
+
+(cl-defun make-comp-ssa-mvar (&rest rest &key _slot _constant _type)
+ "Same as `make-comp-mvar' but set the `id' slot."
+ (let ((mvar (apply #'make-comp-mvar rest)))
+ (setf (comp-mvar-id mvar) (sxhash-eq mvar))
+ mvar))
+
+(defun comp-clean-ssa (f)
+ "Clean-up SSA for function F."
+ (setf (comp-func-edges-h f) (make-hash-table))
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks f)
+ do (setf (comp-block-in-edges b) ()
+ (comp-block-out-edges b) ()
+ (comp-block-idom b) nil
+ (comp-block-df b) (make-hash-table)
+ (comp-block-post-num b) nil
+ (comp-block-final-frame b) nil
+ ;; Prune all phis.
+ (comp-block-insns b) (cl-loop for insn in (comp-block-insns b)
+ unless (eq 'phi (car insn))
+ collect insn))))
+
+(defun comp-compute-edges ()
+ "Compute the basic block edges for the current function."
+ (cl-loop with blocks = (comp-func-blocks comp-func)
+ for bb being each hash-value of blocks
+ for last-insn = (car (last (comp-block-insns bb)))
+ for (op first second third forth) = last-insn
+ do (cl-case op
+ (jump
+ (make-comp-edge :src bb :dst (gethash first blocks)))
+ (cond-jump
+ (make-comp-edge :src bb :dst (gethash third blocks))
+ (make-comp-edge :src bb :dst (gethash forth blocks)))
+ (cond-jump-narg-leq
+ (make-comp-edge :src bb :dst (gethash second blocks))
+ (make-comp-edge :src bb :dst (gethash third blocks)))
+ (push-handler
+ (make-comp-edge :src bb :dst (gethash third blocks))
+ (make-comp-edge :src bb :dst (gethash forth blocks)))
+ (return)
+ (unreachable)
+ (otherwise
+ (signal 'native-ice
+ (list "block does not end with a branch"
+ bb
+ (comp-func-name comp-func)))))
+ ;; Update edge refs into blocks.
+ finally
+ (cl-loop
+ for edge being the hash-value in (comp-func-edges-h comp-func)
+ do
+ (push edge
+ (comp-block-out-edges (comp-edge-src edge)))
+ (push edge
+ (comp-block-in-edges (comp-edge-dst edge))))
+ (comp-log-edges comp-func)))
+
+(defun comp-collect-rev-post-order (basic-block)
+ "Walk BASIC-BLOCK children and return their name in reversed post-order."
+ (let ((visited (make-hash-table))
+ (acc ()))
+ (cl-labels ((collect-rec (bb)
+ (let ((name (comp-block-name bb)))
+ (unless (gethash name visited)
+ (puthash name t visited)
+ (cl-loop for e in (comp-block-out-edges bb)
+ for dst-block = (comp-edge-dst e)
+ do (collect-rec dst-block))
+ (push name acc)))))
+ (collect-rec basic-block)
+ acc)))
+
+(defun comp-compute-dominator-tree ()
+ "Compute immediate dominators for each basic block in current function."
+ ;; Originally based on: "A Simple, Fast Dominance Algorithm"
+ ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001).
+ (cl-flet ((intersect (b1 b2)
+ (let ((finger1 (comp-block-post-num b1))
+ (finger2 (comp-block-post-num b2)))
+ (while (not (= finger1 finger2))
+ (while (< finger1 finger2)
+ (setf b1 (comp-block-idom b1)
+ finger1 (comp-block-post-num b1)))
+ (while (< finger2 finger1)
+ (setf b2 (comp-block-idom b2)
+ finger2 (comp-block-post-num b2))))
+ b1))
+ (first-processed (l)
+ (if-let ((p (cl-find-if (lambda (p) (comp-block-idom p)) l)))
+ p
+ (signal 'native-ice "cant't find first preprocessed"))))
+
+ (when-let ((blocks (comp-func-blocks comp-func))
+ (entry (gethash 'entry blocks))
+ ;; No point to go on if the only bb is 'entry'.
+ (bb0 (gethash 'bb_0 blocks)))
+ (cl-loop
+ with rev-bb-list = (comp-collect-rev-post-order entry)
+ with changed = t
+ while changed
+ initially (progn
+ (comp-log "Computing dominator tree...\n" 2)
+ (setf (comp-block-idom entry) entry)
+ ;; Set the post order number.
+ (cl-loop for name in (reverse rev-bb-list)
+ for b = (gethash name blocks)
+ for i from 0
+ do (setf (comp-block-post-num b) i)))
+ do (cl-loop
+ for name in (cdr rev-bb-list)
+ for b = (gethash name blocks)
+ for preds = (comp-block-preds b)
+ for new-idom = (first-processed preds)
+ initially (setf changed nil)
+ do (cl-loop for p in (delq new-idom preds)
+ when (comp-block-idom p)
+ do (setf new-idom (intersect p new-idom)))
+ unless (eq (comp-block-idom b) new-idom)
+ do (setf (comp-block-idom b) (unless (and (comp-block-lap-p
new-idom)
+ (comp-block-lap-no-ret
+ new-idom))
+ new-idom)
+ changed t))))))
+
+(defun comp-compute-dominator-frontiers ()
+ "Compute the dominator frontier for each basic block in `comp-func'."
+ ;; Originally based on: "A Simple, Fast Dominance Algorithm"
+ ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001).
+ (cl-loop with blocks = (comp-func-blocks comp-func)
+ for b-name being each hash-keys of blocks
+ using (hash-value b)
+ for preds = (comp-block-preds b)
+ when (length> preds 1) ; All joins
+ do (cl-loop for p in preds
+ for runner = p
+ do (while (not (eq runner (comp-block-idom b)))
+ (puthash b-name b (comp-block-df runner))
+ (setf runner (comp-block-idom runner))))))
+
+(defun comp-log-block-info ()
+ "Log basic blocks info for the current function."
+ (maphash (lambda (name bb)
+ (let ((dom (comp-block-idom bb))
+ (df (comp-block-df bb)))
+ (comp-log (format "block: %s idom: %s DF %s\n"
+ name
+ (when dom (comp-block-name dom))
+ (cl-loop for b being each hash-keys of df
+ collect b))
+ 3)))
+ (comp-func-blocks comp-func)))
+
+(defun comp-place-phis ()
+ "Place phi insns into the current function."
+ ;; Originally based on: Static Single Assignment Book
+ ;; Algorithm 3.1: Standard algorithm for inserting phi-functions
+ (cl-flet ((add-phi (slot-n bb)
+ ;; Add a phi func for slot SLOT-N at the top of BB.
+ (push `(phi ,slot-n) (comp-block-insns bb)))
+ (slot-assigned-p (slot-n bb)
+ ;; Return t if a SLOT-N was assigned within BB.
+ (cl-loop for insn in (comp-block-insns bb)
+ for op = (car insn)
+ when (or (and (comp-assign-op-p op)
+ (eql slot-n (comp-mvar-slot (cadr insn))))
+ ;; fetch-handler is after a non local
+ ;; therefore clobbers all frame!!!
+ (eq op 'fetch-handler))
+ return t)))
+
+ (cl-loop for i from (- (comp-func-vframe-size comp-func))
+ below (comp-func-frame-size comp-func)
+ ;; List of blocks with a definition of mvar i
+ for defs-v = (cl-loop with blocks = (comp-func-blocks comp-func)
+ for b being each hash-value of blocks
+ when (slot-assigned-p i b)
+ collect b)
+ ;; Set of basic blocks where phi is added.
+ for f = ()
+ ;; Worklist, set of basic blocks that contain definitions of v.
+ for w = defs-v
+ do
+ (while w
+ (let ((x (pop w)))
+ (cl-loop for y being each hash-value of (comp-block-df x)
+ unless (cl-find y f)
+ do (add-phi i y)
+ (push y f)
+ ;; Adding a phi implies mentioning the
+ ;; corresponding slot so in case adjust w.
+ (unless (cl-find y defs-v)
+ (push y w))))))))
+
+(defun comp-dom-tree-walker (bb pre-lambda post-lambda)
+ "Dominator tree walker function starting from basic block BB.
+PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
+ (when pre-lambda
+ (funcall pre-lambda bb))
+ (when-let ((out-edges (comp-block-out-edges bb)))
+ (cl-loop for ed in out-edges
+ for child = (comp-edge-dst ed)
+ when (eq bb (comp-block-idom child))
+ ;; Current block is the immediate dominator then recur.
+ do (comp-dom-tree-walker child pre-lambda post-lambda)))
+ (when post-lambda
+ (funcall post-lambda bb)))
+
+(cl-defstruct (comp-ssa (:copier nil))
+ "Support structure used while SSA renaming."
+ (frame (comp-new-frame (comp-func-frame-size comp-func)
+ (comp-func-vframe-size comp-func) t)
+ :type comp-vec
+ :documentation "`comp-vec' of m-vars."))
+
+(defun comp-ssa-rename-insn (insn frame)
+ (cl-loop
+ for slot-n from (- (comp-func-vframe-size comp-func))
+ below (comp-func-frame-size comp-func)
+ do
+ (cl-flet ((targetp (x)
+ ;; Ret t if x is an mvar and target the correct slot number.
+ (and (comp-mvar-p x)
+ (eql slot-n (comp-mvar-slot x))))
+ (new-lvalue ()
+ ;; If is an assignment make a new mvar and put it as l-value.
+ (let ((mvar (make-comp-ssa-mvar :slot slot-n)))
+ (setf (comp-vec-aref frame slot-n) mvar
+ (cadr insn) mvar))))
+ (pcase insn
+ (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_)
+ (let ((mvar (comp-vec-aref frame slot-n)))
+ (setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn))))
+ (new-lvalue))
+ (`(fetch-handler . ,_)
+ ;; Clobber all no matter what!
+ (setf (comp-vec-aref frame slot-n) (make-comp-ssa-mvar :slot slot-n)))
+ (`(phi ,n)
+ (when (equal n slot-n)
+ (new-lvalue)))
+ (_
+ (let ((mvar (comp-vec-aref frame slot-n)))
+ (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn)))))))))
+
+(defun comp-ssa-rename ()
+ "Entry point to rename into SSA within the current function."
+ (comp-log "Renaming\n" 2)
+ (let ((visited (make-hash-table)))
+ (cl-labels ((ssa-rename-rec (bb in-frame)
+ (unless (gethash bb visited)
+ (puthash bb t visited)
+ (cl-loop for insn in (comp-block-insns bb)
+ do (comp-ssa-rename-insn insn in-frame))
+ (setf (comp-block-final-frame bb)
+ (copy-sequence in-frame))
+ (when-let ((out-edges (comp-block-out-edges bb)))
+ (cl-loop
+ for ed in out-edges
+ for child = (comp-edge-dst ed)
+ ;; Provide a copy of the same frame to all children.
+ do (ssa-rename-rec child (comp-vec-copy in-frame)))))))
+
+ (ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func))
+ (comp-new-frame (comp-func-frame-size comp-func)
+ (comp-func-vframe-size comp-func)
+ t)))))
+
+(defun comp-finalize-phis ()
+ "Fixup r-values into phis in all basic blocks."
+ (cl-flet ((finalize-phi (args b)
+ ;; Concatenate into args all incoming m-vars for this phi.
+ (setcdr args
+ (cl-loop with slot-n = (comp-mvar-slot (car args))
+ for e in (comp-block-in-edges b)
+ for b = (comp-edge-src e)
+ for in-frame = (comp-block-final-frame b)
+ collect (list (comp-vec-aref in-frame slot-n)
+ (comp-block-name b))))))
+
+ (cl-loop for b being each hash-value of (comp-func-blocks comp-func)
+ do (cl-loop for (op . args) in (comp-block-insns b)
+ when (eq op 'phi)
+ do (finalize-phi args b)))))
+
+(defun comp-remove-unreachable-blocks ()
+ "Remove unreachable basic blocks.
+Return t when one or more block was removed, nil otherwise."
+ (cl-loop
+ with ret
+ for bb being each hash-value of (comp-func-blocks comp-func)
+ for bb-name = (comp-block-name bb)
+ when (and (not (eq 'entry bb-name))
+ (null (comp-block-idom bb)))
+ do
+ (comp-log (format "Removing block: %s" bb-name) 1)
+ (remhash bb-name (comp-func-blocks comp-func))
+ (setf (comp-func-ssa-status comp-func) t
+ ret t)
+ finally return ret))
+
+(defun comp-ssa ()
+ "Port all functions into minimal SSA form."
+ (maphash (lambda (_ f)
+ (let* ((comp-func f)
+ (ssa-status (comp-func-ssa-status f)))
+ (unless (eq ssa-status t)
+ (cl-loop
+ when (eq ssa-status 'dirty)
+ do (comp-clean-ssa f)
+ do (comp-compute-edges)
+ (comp-compute-dominator-tree)
+ until (null (comp-remove-unreachable-blocks)))
+ (comp-compute-dominator-frontiers)
+ (comp-log-block-info)
+ (comp-place-phis)
+ (comp-ssa-rename)
+ (comp-finalize-phis)
+ (comp-log-func comp-func 3)
+ (setf (comp-func-ssa-status f) t))))
+ (comp-ctxt-funcs-h comp-ctxt)))
+
+
+;;; propagate pass specific code.
+;; A very basic propagation pass follows.
+;; This propagates values and types plus ref property in the control flow
graph.
+;; This is also responsible for removing function calls to pure functions if
+;; possible.
+
+(defconst comp-fwprop-max-insns-scan 4500
+ ;; Chosen as ~ the greatest required value for full convergence
+ ;; native compiling all Emacs code-base.
+ "Max number of scanned insn before giving-up.")
+
+(defun comp-copy-insn (insn)
+ "Deep copy INSN."
+ ;; Adapted from `copy-tree'.
+ (if (consp insn)
+ (let (result)
+ (while (consp insn)
+ (let ((newcar (car insn)))
+ (if (or (consp (car insn)) (comp-mvar-p (car insn)))
+ (setf newcar (comp-copy-insn (car insn))))
+ (push newcar result))
+ (setf insn (cdr insn)))
+ (nconc (nreverse result)
+ (if (comp-mvar-p insn) (comp-copy-insn insn) insn)))
+ (if (comp-mvar-p insn)
+ (copy-comp-mvar insn)
+ insn)))
+
+(defmacro comp-apply-in-env (func &rest args)
+ "Apply FUNC to ARGS in the current compilation environment."
+ `(let ((env (cl-loop
+ for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt)
+ for func-name = (comp-func-name f)
+ for byte-code = (comp-func-byte-func f)
+ when func-name
+ collect `(,func-name . ,(symbol-function func-name))
+ and do
+ (setf (symbol-function func-name) byte-code))))
+ (unwind-protect
+ (apply ,func ,@args)
+ (cl-loop
+ for (func-name . def) in env
+ do (setf (symbol-function func-name) def)))))
+
+(defun comp-fwprop-prologue ()
+ "Prologue for the propagate pass.
+Here goes everything that can be done not iteratively (read once).
+Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved
or invoked?
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do (cl-loop
+ for insn in (comp-block-insns b)
+ do (pcase insn
+ (`(setimm ,lval ,v)
+ (setf (comp-cstr-imm lval) v))))))
+
+(defun comp-mvar-propagate (lval rval)
+ "Propagate into LVAL properties of RVAL."
+ (setf (comp-mvar-typeset lval) (comp-mvar-typeset rval)
+ (comp-mvar-valset lval) (comp-mvar-valset rval)
+ (comp-mvar-range lval) (comp-mvar-range rval)
+ (comp-mvar-neg lval) (comp-mvar-neg rval)))
+
+(defun comp-function-foldable-p (f args)
+ "Given function F called with ARGS, return non-nil when optimizable."
+ (and (comp-function-pure-p f)
+ (cl-every #'comp-cstr-imm-vld-p args)))
+
+(defun comp-function-call-maybe-fold (insn f args)
+ "Given INSN, when F is pure if all ARGS are known, remove the function call.
+Return non-nil if the function is folded successfully."
+ (cl-flet ((rewrite-insn-as-setimm (insn value)
+ ;; See `comp-emit-setimm'.
+ (comp-add-const-to-relocs value)
+ (setf (car insn) 'setimm
+ (cddr insn) `(,value))))
+ (cond
+ ((eq f 'symbol-value)
+ (when-let* ((arg0 (car args))
+ (const (comp-cstr-imm-vld-p arg0))
+ (ok-to-optim (member (comp-cstr-imm arg0)
+ comp-symbol-values-optimizable)))
+ (rewrite-insn-as-setimm insn (symbol-value (comp-cstr-imm
+ (car args))))))
+ ((comp-function-foldable-p f args)
+ (ignore-errors
+ ;; No point to complain here in case of error because we
+ ;; should do basic block pruning in order to be sure that this
+ ;; is not dead-code. This is now left to gcc, to be
+ ;; implemented only if we want a reliable diagnostic here.
+ (let* ((f (if-let (f-in-ctxt (comp-symbol-func-to-fun f))
+ ;; If the function is IN the compilation ctxt
+ ;; and know to be pure.
+ (comp-func-byte-func f-in-ctxt)
+ f))
+ (value (comp-apply-in-env f (mapcar #'comp-cstr-imm args))))
+ (rewrite-insn-as-setimm insn value)))))))
+
+(defun comp-fwprop-call (insn lval f args)
+ "Propagate on a call INSN into LVAL.
+F is the function being called with arguments ARGS.
+Fold the call in case."
+ (unless (comp-function-call-maybe-fold insn f args)
+ (when (and (eq 'funcall f)
+ (comp-cstr-imm-vld-p (car args)))
+ (setf f (comp-cstr-imm (car args))
+ args (cdr args)))
+ (when-let ((cstr-f (gethash f comp-known-func-cstr-h)))
+ (let ((cstr (comp-cstr-f-ret cstr-f)))
+ (when (comp-cstr-empty-p cstr)
+ ;; Store it to be rewritten as non local exit.
+ (setf (comp-block-lap-non-ret-insn comp-block) insn))
+ (setf (comp-mvar-range lval) (comp-cstr-range cstr)
+ (comp-mvar-valset lval) (comp-cstr-valset cstr)
+ (comp-mvar-typeset lval) (comp-cstr-typeset cstr)
+ (comp-mvar-neg lval) (comp-cstr-neg cstr))))
+ (cl-case f
+ (+ (comp-cstr-add lval args))
+ (- (comp-cstr-sub lval args))
+ (1+ (comp-cstr-add lval `(,(car args) ,comp-cstr-one)))
+ (1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one))))))
+
+(defun comp-fwprop-insn (insn)
+ "Propagate within INSN."
+ (pcase insn
+ (`(set ,lval ,rval)
+ (pcase rval
+ (`(,(or 'call 'callref) ,f . ,args)
+ (comp-fwprop-call insn lval f args))
+ (`(,(or 'direct-call 'direct-callref) ,f . ,args)
+ (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt)))))
+ (comp-fwprop-call insn lval f args)))
+ (_
+ (comp-mvar-propagate lval rval))))
+ (`(assume ,lval ,(and (pred comp-mvar-p) rval))
+ (comp-mvar-propagate lval rval))
+ (`(assume ,lval (,kind . ,operands))
+ (cl-case kind
+ (and
+ (apply #'comp-cstr-intersection lval operands))
+ (and-nhc
+ (apply #'comp-cstr-intersection-no-hashcons lval operands))
+ (not
+ ;; Prevent double negation!
+ (unless (comp-cstr-neg (car operands))
+ (comp-cstr-value-negation lval (car operands))))
+ (>
+ (comp-cstr-> lval (car operands) (cadr operands)))
+ (>=
+ (comp-cstr->= lval (car operands) (cadr operands)))
+ (<
+ (comp-cstr-< lval (car operands) (cadr operands)))
+ (<=
+ (comp-cstr-<= lval (car operands) (cadr operands)))
+ (=
+ (comp-cstr-= lval (car operands) (cadr operands)))))
+ (`(setimm ,lval ,v)
+ (setf (comp-cstr-imm lval) v))
+ (`(phi ,lval . ,rest)
+ (let* ((from-latch (cl-some
+ (lambda (x)
+ (let* ((bb-name (cadr x))
+ (bb (gethash bb-name
+ (comp-func-blocks comp-func))))
+ (or (comp-latch-p bb)
+ (when (comp-block-cstr-p bb)
+ (comp-latch-p (car (comp-block-preds
bb)))))))
+ rest))
+ (prop-fn (if from-latch
+ #'comp-cstr-union-no-range
+ #'comp-cstr-union))
+ (rvals (mapcar #'car rest)))
+ (apply prop-fn lval rvals)))))
+
+(defun comp-fwprop* ()
+ "Propagate for set* and phi operands.
+Return t if something was changed."
+ (cl-loop named outer
+ with modified = nil
+ with i = 0
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do (cl-loop
+ with comp-block = b
+ for insn in (comp-block-insns b)
+ for orig-insn = (unless modified
+ ;; Save consing after 1st change.
+ (comp-copy-insn insn))
+ do
+ (comp-fwprop-insn insn)
+ (cl-incf i)
+ when (and (null modified) (not (equal insn orig-insn)))
+ do (setf modified t))
+ when (> i comp-fwprop-max-insns-scan)
+ do (cl-return-from outer nil)
+ finally return modified))
+
+(defun comp-rewrite-non-locals ()
+ "Make explicit in LIMPLE non-local exits if identified."
+ (cl-loop
+ for bb being each hash-value of (comp-func-blocks comp-func)
+ for non-local-insn = (and (comp-block-lap-p bb)
+ (comp-block-lap-non-ret-insn bb))
+ when non-local-insn
+ do
+ ;; Rework the current block.
+ (let* ((insn-seq (memq non-local-insn (comp-block-insns bb))))
+ (setf (comp-block-lap-non-ret-insn bb) ()
+ (comp-block-lap-no-ret bb) t
+ (comp-block-out-edges bb) ()
+ ;; Prune unnecessary insns!
+ (cdr insn-seq) '((unreachable))
+ (comp-func-ssa-status comp-func) 'dirty))))
+
+(defun comp-fwprop (_)
+ "Forward propagate types and consts within the lattice."
+ (comp-ssa)
+ (comp-dead-code)
+ (maphash (lambda (_ f)
+ (when (and (>= (comp-func-speed f) 2)
+ ;; FIXME remove the following condition when tested.
+ (not (comp-func-has-non-local f)))
+ (let ((comp-func f))
+ (comp-fwprop-prologue)
+ (cl-loop
+ for i from 1 to 100
+ while (comp-fwprop*)
+ finally
+ (when (= i 100)
+ (display-warning
+ 'comp
+ (format "fwprop pass jammed into %s?" (comp-func-name
f))))
+ (comp-log (format "Propagation run %d times\n" i) 2))
+ (comp-rewrite-non-locals)
+ (comp-log-func comp-func 3))))
+ (comp-ctxt-funcs-h comp-ctxt)))
+
+
+;;; Call optimizer pass specific code.
+;; This pass is responsible for the following optimizations:
+;; - Call to subrs that are in defined in the C source and are passing through
+;; funcall trampoline gets optimized into normal indirect calls.
+;; This makes effectively this calls equivalent to all the subrs that got
+;; dedicated byte-code ops.
+;; Triggered at comp-speed >= 2.
+;; - Recursive calls gets optimized into direct calls.
+;; Triggered at comp-speed >= 2.
+;; - Intra compilation unit procedure calls gets optimized into direct calls.
+;; This can be a big win and even allow gcc to inline but does not make
+;; function in the compilation unit re-definable safely without recompiling
+;; the full compilation unit.
+;; For this reason this is triggered only at comp-speed == 3.
+
+(defun comp-func-in-unit (func)
+ "Given FUNC return the `comp-fun' definition in the current context.
+FUNCTION can be a function-name or byte compiled function."
+ (if (symbolp func)
+ (comp-symbol-func-to-fun func)
+ (cl-assert (byte-code-function-p func))
+ (gethash func (comp-ctxt-byte-func-to-func-h comp-ctxt))))
+
+(defun comp-call-optim-form-call (callee args)
+ (cl-flet ((fill-args (args total)
+ ;; Fill missing args to reach TOTAL
+ (append args (cl-loop repeat (- total (length args))
+ collect (make-comp-mvar :constant nil)))))
+ (when (and callee
+ (or (symbolp callee)
+ (gethash callee (comp-ctxt-byte-func-to-func-h comp-ctxt)))
+ (not (memq callee comp-never-optimize-functions)))
+ (let* ((f (if (symbolp callee)
+ (symbol-function callee)
+ (cl-assert (byte-code-function-p callee))
+ callee))
+ (subrp (subrp f))
+ (comp-func-callee (comp-func-in-unit callee)))
+ (cond
+ ((and subrp (not (subr-native-elisp-p f)))
+ ;; Trampoline removal.
+ (let* ((callee (intern (subr-name f))) ; Fix aliased names.
+ (maxarg (cdr (subr-arity f)))
+ (call-type (if (if subrp
+ (not (numberp maxarg))
+ (comp-nargs-p comp-func-callee))
+ 'callref
+ 'call))
+ (args (if (eq call-type 'callref)
+ args
+ (fill-args args maxarg))))
+ `(,call-type ,callee ,@args)))
+ ;; Intra compilation unit procedure call optimization.
+ ;; Attention speed 3 triggers this for non self calls too!!
+ ((and comp-func-callee
+ (comp-func-c-name comp-func-callee)
+ (or (and (>= (comp-func-speed comp-func) 3)
+ (comp-func-unique-in-cu-p callee))
+ (and (>= (comp-func-speed comp-func) 2)
+ ;; Anonymous lambdas can't be redefined so are
+ ;; always safe to optimize.
+ (byte-code-function-p callee))))
+ (let* ((func-args (comp-func-l-args comp-func-callee))
+ (nargs (comp-nargs-p func-args))
+ (call-type (if nargs 'direct-callref 'direct-call))
+ (args (if (eq call-type 'direct-callref)
+ args
+ (fill-args args (comp-args-max func-args)))))
+ `(,call-type ,(comp-func-c-name comp-func-callee) ,@args)))
+ ((comp-type-hint-p callee)
+ `(call ,callee ,@args)))))))
+
+(defun comp-call-optim-func ()
+ "Perform the trampoline call optimization for the current function."
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do (comp-loop-insn-in-block b
+ (pcase insn
+ (`(set ,lval (callref funcall ,f . ,rest))
+ (when-let ((ok (comp-cstr-imm-vld-p f))
+ (new-form (comp-call-optim-form-call
+ (comp-cstr-imm f) rest)))
+ (setf insn `(set ,lval ,new-form))))
+ (`(callref funcall ,f . ,rest)
+ (when-let ((ok (comp-cstr-imm-vld-p f))
+ (new-form (comp-call-optim-form-call
+ (comp-cstr-imm f) rest)))
+ (setf insn new-form)))))))
+
+(defun comp-call-optim (_)
+ "Try to optimize out funcall trampoline usage when possible."
+ (maphash (lambda (_ f)
+ (when (and (>= (comp-func-speed f) 2)
+ (comp-func-l-p f))
+ (let ((comp-func f))
+ (comp-call-optim-func))))
+ (comp-ctxt-funcs-h comp-ctxt)))
+
+
+;;; Dead code elimination pass specific code.
+;; This simple pass try to eliminate insns became useful after propagation.
+;; Even if gcc would take care of this is good to perform this here
+;; in the hope of removing memory references.
+;;
+;; This pass can be run as last optim.
+
+(defun comp-collect-mvar-ids (insn)
+ "Collect the m-var unique identifiers into INSN."
+ (cl-loop for x in insn
+ if (consp x)
+ append (comp-collect-mvar-ids x)
+ else
+ when (comp-mvar-p x)
+ collect (comp-mvar-id x)))
+
+(defun comp-dead-assignments-func ()
+ "Clean-up dead assignments into current function.
+Return the list of m-var ids nuked."
+ (let ((l-vals ())
+ (r-vals ()))
+ ;; Collect used r and l-values.
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do (cl-loop
+ for insn in (comp-block-insns b)
+ for (op arg0 . rest) = insn
+ if (comp-assign-op-p op)
+ do (push (comp-mvar-id arg0) l-vals)
+ (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals))
+ else
+ do (setf r-vals (nconc (comp-collect-mvar-ids insn) r-vals))))
+ ;; Every l-value appearing that does not appear as r-value has no right to
+ ;; exist and gets nuked.
+ (let ((nuke-list (cl-set-difference l-vals r-vals)))
+ (comp-log (format "Function %s\nl-vals %s\nr-vals %s\nNuking ids: %s\n"
+ (comp-func-name comp-func)
+ l-vals
+ r-vals
+ nuke-list)
+ 3)
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do (comp-loop-insn-in-block b
+ (cl-destructuring-bind (op &optional arg0 arg1 &rest rest) insn
+ (when (and (comp-assign-op-p op)
+ (memq (comp-mvar-id arg0) nuke-list))
+ (setf insn
+ (if (comp-limple-insn-call-p arg1)
+ arg1
+ `(comment ,(format "optimized out: %s"
+ insn))))))))
+ nuke-list)))
+
+(defun comp-dead-code ()
+ "Dead code elimination."
+ (maphash (lambda (_ f)
+ (when (and (>= (comp-func-speed f) 2)
+ ;; FIXME remove the following condition when tested.
+ (not (comp-func-has-non-local f)))
+ (cl-loop
+ for comp-func = f
+ for i from 1
+ while (comp-dead-assignments-func)
+ finally (comp-log (format "dead code rm run %d times\n" i) 2)
+ (comp-log-func comp-func 3))))
+ (comp-ctxt-funcs-h comp-ctxt)))
+
+
+;;; Tail Call Optimization pass specific code.
+
+(defun comp-form-tco-call-seq (args)
+ "Generate a TCO sequence for ARGS."
+ `(,@(cl-loop for arg in args
+ for i from 0
+ collect `(set ,(make-comp-mvar :slot i) ,arg))
+ (jump bb_0)))
+
+(defun comp-tco-func ()
+ "Try to pattern match and perform TCO within the current function."
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do (cl-loop
+ named in-the-basic-block
+ for insns-seq on (comp-block-insns b)
+ do (pcase insns-seq
+ (`((set ,l-val (direct-call ,func . ,args))
+ ;; (comment ,_comment)
+ (return ,ret-val))
+ (when (and (string= func (comp-func-c-name comp-func))
+ (eq l-val ret-val))
+ (let ((tco-seq (comp-form-tco-call-seq args)))
+ (setf (car insns-seq) (car tco-seq)
+ (cdr insns-seq) (cdr tco-seq)
+ (comp-func-ssa-status comp-func) 'dirty)
+ (cl-return-from in-the-basic-block))))))))
+
+(defun comp-tco (_)
+ "Simple peephole pass performing self TCO."
+ (maphash (lambda (_ f)
+ (when (and (>= (comp-func-speed f) 3)
+ (comp-func-l-p f)
+ (not (comp-func-has-non-local f)))
+ (let ((comp-func f))
+ (comp-tco-func)
+ (comp-log-func comp-func 3))))
+ (comp-ctxt-funcs-h comp-ctxt)))
+
+
+;;; Type hint removal pass specific code.
+
+;; This must run after all SSA prop not to have the type hint
+;; information overwritten.
+
+(defun comp-remove-type-hints-func ()
+ "Remove type hints from the current function.
+These are substituted with a normal 'set' op."
+ (cl-loop
+ for b being each hash-value of (comp-func-blocks comp-func)
+ do (comp-loop-insn-in-block b
+ (pcase insn
+ (`(set ,l-val (call ,(pred comp-type-hint-p) ,r-val))
+ (setf insn `(set ,l-val ,r-val)))))))
+
+(defun comp-remove-type-hints (_)
+ "Dead code elimination."
+ (maphash (lambda (_ f)
+ (when (>= (comp-func-speed f) 2)
+ (let ((comp-func f))
+ (comp-remove-type-hints-func)
+ (comp-log-func comp-func 3))))
+ (comp-ctxt-funcs-h comp-ctxt)))
+
+
+;;; Final pass specific code.
+
+(defun comp-args-to-lambda-list (args)
+ "Return a lambda list for ARGS."
+ (cl-loop
+ with res
+ repeat (comp-args-base-min args)
+ do (push t res)
+ finally
+ (if (comp-args-p args)
+ (cl-loop
+ with n = (- (comp-args-max args) (comp-args-min args))
+ initially (unless (zerop n)
+ (push '&optional res))
+ repeat n
+ do (push t res))
+ (cl-loop
+ with n = (- (comp-nargs-nonrest args) (comp-nargs-min args))
+ initially (unless (zerop n)
+ (push '&optional res))
+ repeat n
+ do (push t res)
+ finally (when (comp-nargs-rest args)
+ (push '&rest res)
+ (push 't res))))
+ (cl-return (reverse res))))
+
+(defun comp-compute-function-type (_ func)
+ "Compute type specifier for `comp-func' FUNC.
+Set it into the `type' slot."
+ (when (and (comp-func-l-p func)
+ (comp-mvar-p (comp-func-type func)))
+ (let* ((comp-func (make-comp-func))
+ (res-mvar (apply #'comp-cstr-union
+ (make-comp-cstr)
+ (cl-loop
+ with res = nil
+ for bb being the hash-value in (comp-func-blocks
+ func)
+ do (cl-loop
+ for insn in (comp-block-insns bb)
+ ;; Collect over every exit point the returned
+ ;; mvars and union results.
+ do (pcase insn
+ (`(return ,mvar)
+ (push mvar res))))
+ finally return res)))
+ (type `(function ,(comp-args-to-lambda-list (comp-func-l-args func))
+ ,(comp-cstr-to-type-spec res-mvar))))
+ (comp-add-const-to-relocs type)
+ ;; Fix it up.
+ (setf (comp-cstr-imm (comp-func-type func)) type))))
+
+(defun comp-finalize-container (cont)
+ "Finalize data container CONT."
+ (setf (comp-data-container-l cont)
+ (cl-loop with h = (comp-data-container-idx cont)
+ for obj each hash-keys of h
+ for i from 0
+ do (puthash obj i h)
+ ;; Prune byte-code objects coming from lambdas.
+ ;; These are not anymore necessary as they will be
+ ;; replaced at load time by native-elisp-subrs.
+ ;; Note: we leave the objects in the idx hash table
+ ;; to still be able to retrieve the correct index
+ ;; from the corresponding m-var.
+ collect (if (gethash obj
+ (comp-ctxt-byte-func-to-func-h
comp-ctxt))
+ 'lambda-fixup
+ obj))))
+
+(defun comp-finalize-relocs ()
+ "Finalize data containers for each relocation class.
+Remove immediate duplicates within relocation classes.
+Update all insn accordingly."
+ ;; Symbols imported by C inlined functions. We do this here because
+ ;; is better to add all objs to the relocation containers before we
+ ;; compacting them.
+ (mapc #'comp-add-const-to-relocs '(nil t consp listp))
+
+ (let* ((d-default (comp-ctxt-d-default comp-ctxt))
+ (d-default-idx (comp-data-container-idx d-default))
+ (d-impure (comp-ctxt-d-impure comp-ctxt))
+ (d-impure-idx (comp-data-container-idx d-impure))
+ (d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt))
+ (d-ephemeral-idx (comp-data-container-idx d-ephemeral)))
+ ;; We never want compiled lambdas ending up in pure space. A copy must
+ ;; be already present in impure (see `comp-emit-lambda-for-top-level').
+ (cl-loop for obj being each hash-keys of d-default-idx
+ when (gethash obj (comp-ctxt-lambda-fixups-h comp-ctxt))
+ do (cl-assert (gethash obj d-impure-idx))
+ (remhash obj d-default-idx))
+ ;; Remove entries in d-impure already present in d-default.
+ (cl-loop for obj being each hash-keys of d-impure-idx
+ when (gethash obj d-default-idx)
+ do (remhash obj d-impure-idx))
+ ;; Remove entries in d-ephemeral already present in d-default or
+ ;; d-impure.
+ (cl-loop for obj being each hash-keys of d-ephemeral-idx
+ when (or (gethash obj d-default-idx) (gethash obj d-impure-idx))
+ do (remhash obj d-ephemeral-idx))
+ ;; Fix-up indexes in each relocation class and fill corresponding
+ ;; reloc lists.
+ (mapc #'comp-finalize-container (list d-default d-impure d-ephemeral))
+ ;; Make a vector from the function documentation hash table.
+ (cl-loop with h = (comp-ctxt-function-docs comp-ctxt)
+ with v = (make-vector (hash-table-count h) nil)
+ for idx being each hash-keys of h
+ for doc = (gethash idx h)
+ do (setf (aref v idx) doc)
+ finally
+ do (setf (comp-ctxt-function-docs comp-ctxt) v))
+ ;; And now we conclude with the following: We need to pass to
+ ;; `comp--register-lambda' the index in the impure relocation
+ ;; array to store revived lambdas, but given we know it only now
+ ;; we fix it up as last.
+ (cl-loop for f being each hash-keys of (comp-ctxt-lambda-fixups-h
comp-ctxt)
+ using (hash-value mvar)
+ with reverse-h = (make-hash-table) ;; Make sure idx is unique.
+ for idx = (gethash f d-impure-idx)
+ do
+ (cl-assert (null (gethash idx reverse-h)))
+ (cl-assert (fixnump idx))
+ (setf (comp-mvar-valset mvar) ()
+ (comp-mvar-range mvar) (list (cons idx idx)))
+ (puthash idx t reverse-h))))
+
+(defun comp-compile-ctxt-to-file (name)
+ "Compile as native code the current context naming it NAME.
+Prepare every function for final compilation and drive the C back-end."
+ (let ((dir (file-name-directory name)))
+ (comp-finalize-relocs)
+ (maphash (lambda (_ f)
+ (comp-log-func f 1))
+ (comp-ctxt-funcs-h comp-ctxt))
+ (unless (file-exists-p dir)
+ ;; In case it's created in the meanwhile.
+ (ignore-error file-already-exists
+ (make-directory dir t)))
+ (comp--compile-ctxt-to-file name)))
+
+(defun comp-final1 ()
+ (let (compile-result)
+ (comp--init-ctxt)
+ (unwind-protect
+ (setf compile-result
+ (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt)))
+ (and (comp--release-ctxt)
+ compile-result))))
+
+(defvar comp-async-compilation nil
+ "Non-nil while executing an asynchronous native compilation.")
+
+(defun comp-final (_)
+ "Final pass driving the C back-end for code emission."
+ (maphash #'comp-compute-function-type (comp-ctxt-funcs-h comp-ctxt))
+ (unless comp-dry-run
+ ;; Always run the C side of the compilation as a sub-process
+ ;; unless during bootstrap or async compilation (bug#45056). GCC
+ ;; leaks memory but also interfere with the ability of Emacs to
+ ;; detect when a sub-process completes (TODO understand why).
+ (if (or byte-native-for-bootstrap comp-async-compilation)
+ (comp-final1)
+ ;; Call comp-final1 in a child process.
+ (let* ((output (comp-ctxt-output comp-ctxt))
+ (print-escape-newlines t)
+ (print-length nil)
+ (print-level nil)
+ (print-quoted t)
+ (print-gensym t)
+ (print-circle t)
+ (print-escape-multibyte t)
+ (expr `((require 'comp)
+ (setf comp-verbose ,comp-verbose
+ comp-libgccjit-reproducer ,comp-libgccjit-reproducer
+ comp-ctxt ,comp-ctxt
+ comp-eln-load-path ',comp-eln-load-path
+ comp-native-driver-options
+ ',comp-native-driver-options
+ load-path ',load-path)
+ ,comp-async-env-modifier-form
+ (message "Compiling %s..." ',output)
+ (comp-final1)))
+ (temp-file (make-temp-file
+ (concat "emacs-int-comp-"
+ (file-name-base output) "-")
+ nil ".el")))
+ (with-temp-file temp-file
+ (insert ";; -*-coding: nil; -*-\n")
+ (mapc (lambda (e)
+ (insert (prin1-to-string e)))
+ expr))
+ (with-temp-buffer
+ (unwind-protect
+ (if (zerop
+ (call-process (expand-file-name invocation-name
+ invocation-directory)
+ nil t t "--batch" "-l" temp-file))
+ (progn
+ (delete-file temp-file)
+ output)
+ (signal 'native-compiler-error (buffer-string)))
+ (comp-log-to-buffer (buffer-string))))))))
+
+
+;;; Compiler type hints.
+;; Public entry points to be used by user code to give comp
+;; suggestions about types. These are used to implement CL style
+;; `cl-the' and hopefully parameter type declaration.
+;; Note: types will propagates.
+;; WARNING: At speed >= 2 type checking is not performed anymore and
suggestions
+;; are assumed just to be true. Use with extreme caution...
+
+(defun comp-hint-fixnum (x)
+ (declare (gv-setter (lambda (val) `(setf ,x ,val))))
+ x)
+
+(defun comp-hint-cons (x)
+ (declare (gv-setter (lambda (val) `(setf ,x ,val))))
+ x)
+
+
+;; Primitive function advice machinery
+
+(defun comp-eln-load-path-eff ()
+ "Return a list of effective eln load directories.
+Account for `comp-eln-load-path' and `comp-native-version-dir'."
+ (mapcar (lambda (dir)
+ (expand-file-name comp-native-version-dir
+ (file-name-as-directory
+ (expand-file-name dir invocation-directory))))
+ comp-eln-load-path))
+
+(defun comp-trampoline-filename (subr-name)
+ "Given SUBR-NAME return the filename containing the trampoline."
+ (concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln"))
+
+(defun comp-make-lambda-list-from-subr (subr)
+ "Given SUBR return the equivalent lambda-list."
+ (pcase-let ((`(,min . ,max) (subr-arity subr))
+ (lambda-list '()))
+ (cl-loop repeat min
+ do (push (gensym "arg") lambda-list))
+ (if (numberp max)
+ (cl-loop
+ initially (push '&optional lambda-list)
+ repeat (- max min)
+ do (push (gensym "arg") lambda-list))
+ (push '&rest lambda-list)
+ (push (gensym "arg") lambda-list))
+ (reverse lambda-list)))
+
+(defun comp-trampoline-search (subr-name)
+ "Search a trampoline file for SUBR-NAME.
+Return the trampoline if found or nil otherwise."
+ (cl-loop
+ with rel-filename = (comp-trampoline-filename subr-name)
+ for dir in (comp-eln-load-path-eff)
+ for filename = (expand-file-name rel-filename dir)
+ when (file-exists-p filename)
+ do (cl-return (native-elisp-load filename))))
+
+(defun comp-trampoline-compile (subr-name)
+ "Synthesize compile and return a trampoline for SUBR-NAME."
+ (let* ((lambda-list (comp-make-lambda-list-from-subr
+ (symbol-function subr-name)))
+ ;; The synthesized trampoline must expose the exact same ABI of
+ ;; the primitive we are replacing in the function reloc table.
+ (form `(lambda ,lambda-list
+ (let ((f #',subr-name))
+ (,(if (memq '&rest lambda-list) #'apply 'funcall)
+ f
+ ,@(cl-loop
+ for arg in lambda-list
+ unless (memq arg '(&optional &rest))
+ collect arg)))))
+ ;; Use speed 0 to maximize compilation speed and not to
+ ;; optimize away funcall calls!
+ (byte-optimize nil)
+ (comp-speed 1)
+ (lexical-binding t))
+ (comp--native-compile
+ form nil
+ (cl-loop
+ for dir in (comp-eln-load-path-eff)
+ for f = (expand-file-name
+ (comp-trampoline-filename subr-name)
+ dir)
+ unless (file-exists-p dir)
+ do (ignore-errors
+ (make-directory dir t)
+ (cl-return f))
+ when (file-writable-p f)
+ do (cl-return f)
+ finally (error "Cannot find suitable directory for output in \
+`comp-eln-load-path'")))))
+
+
+;; Some entry point support code.
+
+;;;###autoload
+(defun comp-clean-up-stale-eln (file)
+ "Given FILE remove all its *.eln files in `comp-eln-load-path'
+sharing the original source filename (including FILE)."
+ (when (string-match (rx "-" (group-n 1 (1+ hex)) "-" (1+ hex) ".eln" eos)
+ file)
+ (cl-loop
+ with filename-hash = (match-string 1 file)
+ with regexp = (rx-to-string
+ `(seq "-" ,filename-hash "-" (1+ hex) ".eln" eos))
+ for dir in (comp-eln-load-path-eff)
+ do (cl-loop
+ for f in (when (file-exists-p dir)
+ (directory-files dir t regexp t))
+ ;; We may not be able to delete the file if we have no write
+ ;; permission.
+ do (ignore-error file-error
+ (comp-delete-or-replace-file f))))))
+
+(defun comp-delete-or-replace-file (oldfile &optional newfile)
+ "Replace OLDFILE with NEWFILE.
+When NEWFILE is nil just delete OLDFILE.
+Takes the necessary steps when dealing with OLDFILE being a
+shared library that might be currently loaded into a running Emacs
+session."
+ (cond ((eq 'windows-nt system-type)
+ (ignore-errors (delete-file oldfile))
+ (while
+ (condition-case _
+ (progn
+ ;; oldfile maybe recreated by another Emacs in
+ ;; between the following two rename-file calls
+ (if (file-exists-p oldfile)
+ (rename-file oldfile (make-temp-file-internal
+ (file-name-sans-extension oldfile)
+ nil ".eln.old" nil)
+ t))
+ (when newfile
+ (rename-file newfile oldfile nil))
+ ;; Keep on trying.
+ nil)
+ (file-already-exists
+ ;; Done
+ t))))
+ ;; Remove the old eln instead of copying the new one into it
+ ;; to get a new inode and prevent crashes in case the old one
+ ;; is currently loaded.
+ (t (delete-file oldfile)
+ (when newfile
+ (rename-file newfile oldfile)))))
+
+(defvar comp-files-queue ()
+ "List of Emacs Lisp files to be compiled.")
+
+(defvar comp-async-compilations (make-hash-table :test #'equal)
+ "Hash table file-name -> async compilation process.")
+
+(defun comp-async-runnings ()
+ "Return the number of async compilations currently running.
+This function has the side effect of cleaning-up finished
+processes from `comp-async-compilations'"
+ (cl-loop
+ for file-name in (cl-loop
+ for file-name being each hash-key of
comp-async-compilations
+ for prc = (gethash file-name comp-async-compilations)
+ unless (process-live-p prc)
+ collect file-name)
+ do (remhash file-name comp-async-compilations))
+ (hash-table-count comp-async-compilations))
+
+(declare-function w32-get-nproc "w32.c")
+(defvar comp-num-cpus nil)
+(defun comp-effective-async-max-jobs ()
+ "Compute the effective number of async jobs."
+ (if (zerop comp-async-jobs-number)
+ (or comp-num-cpus
+ (setf comp-num-cpus
+ ;; FIXME: we already have a function to determine
+ ;; the number of processors, see get_native_system_info in
w32.c.
+ ;; The result needs to be exported to Lisp.
+ (max 1 (/ (cond ((eq 'windows-nt system-type)
+ (w32-get-nproc))
+ ((executable-find "nproc")
+ (string-to-number
+ (shell-command-to-string "nproc")))
+ ((eq 'berkeley-unix system-type)
+ (string-to-number
+ (shell-command-to-string "sysctl -n
hw.ncpu")))
+ (t 1))
+ 2))))
+ comp-async-jobs-number))
+
+(defvar comp-last-scanned-async-output nil)
+(make-variable-buffer-local 'comp-last-scanned-async-output)
+(defun comp-accept-and-process-async-output (process)
+ "Accept PROCESS output and check for diagnostic messages."
+ (if comp-async-report-warnings-errors
+ (with-current-buffer (process-buffer process)
+ (save-excursion
+ (accept-process-output process)
+ (goto-char (or comp-last-scanned-async-output (point-min)))
+ (while (re-search-forward "^.*?\\(?:Error\\|Warning\\): .*$"
+ nil t)
+ (display-warning 'comp (match-string 0)))
+ (setq comp-last-scanned-async-output (point-max))))
+ (accept-process-output process)))
+
+(defun comp-run-async-workers ()
+ "Start compiling files from `comp-files-queue' asynchronously.
+When compilation is finished, run `comp-async-all-done-hook' and
+display a message."
+ (if (or comp-files-queue
+ (> (comp-async-runnings) 0))
+ (unless (>= (comp-async-runnings) (comp-effective-async-max-jobs))
+ (cl-loop
+ for (source-file . load) = (pop comp-files-queue)
+ while source-file
+ do (cl-assert (string-match-p comp-valid-source-re source-file) nil
+ "`comp-files-queue' should be \".el\" files: %s"
+ source-file)
+ when (or comp-always-compile
+ load ; Always compile when the compilation is
+ ; commanded for late load.
+ (file-newer-than-file-p
+ source-file (comp-el-to-eln-filename source-file)))
+ do (let* ((expr `((require 'comp)
+ ,(when (boundp 'backtrace-line-length)
+ `(setf backtrace-line-length
,backtrace-line-length))
+ (setf comp-speed ,comp-speed
+ comp-debug ,comp-debug
+ comp-verbose ,comp-verbose
+ comp-libgccjit-reproducer
,comp-libgccjit-reproducer
+ comp-async-compilation t
+ comp-eln-load-path ',comp-eln-load-path
+ comp-native-driver-options
+ ',comp-native-driver-options
+ load-path ',load-path
+ warning-fill-column most-positive-fixnum)
+ ,comp-async-env-modifier-form
+ (message "Compiling %s..." ,source-file)
+ (comp--native-compile ,source-file ,(and load t))))
+ (source-file1 source-file) ;; Make the closure works :/
+ (temp-file (make-temp-file
+ (concat "emacs-async-comp-"
+ (file-name-base source-file) "-")
+ nil ".el"))
+ (expr-strings (mapcar #'prin1-to-string expr))
+ (_ (progn
+ (with-temp-file temp-file
+ (mapc #'insert expr-strings))
+ (comp-log "\n")
+ (mapc #'comp-log expr-strings)))
+ (load1 load)
+ (process (make-process
+ :name (concat "Compiling: " source-file)
+ :buffer (get-buffer-create comp-async-buffer-name)
+ :command (list
+ (expand-file-name invocation-name
+ invocation-directory)
+ "--batch" "-l" temp-file)
+ :sentinel
+ (lambda (process _event)
+ (run-hook-with-args
+ 'comp-async-cu-done-functions
+ source-file)
+ (comp-accept-and-process-async-output process)
+ (ignore-errors (delete-file temp-file))
+ (when (and load1
+ (zerop (process-exit-status
process)))
+ (native-elisp-load
+ (comp-el-to-eln-filename source-file1)
+ (eq load1 'late)))
+ (comp-run-async-workers))
+ :noquery (not comp-async-query-on-exit))))
+ (puthash source-file process comp-async-compilations))
+ when (>= (comp-async-runnings) (comp-effective-async-max-jobs))
+ do (cl-return)))
+ ;; No files left to compile and all processes finished.
+ (run-hooks 'comp-async-all-done-hook)
+ (with-current-buffer (get-buffer-create comp-async-buffer-name)
+ (save-excursion
+ (goto-char (point-max))
+ (insert "Compilation finished.\n")))
+ ;; `comp-deferred-pending-h' should be empty at this stage.
+ ;; Reset it anyway.
+ (clrhash comp-deferred-pending-h)))
+
+(defun comp--native-compile (function-or-file &optional with-late-load output)
+ "Compile FUNCTION-OR-FILE into native code.
+When WITH-LATE-LOAD is non-nil, mark the compilation unit for late
+load once it finishes compiling.
+This serves as internal implementation of `native-compile' but
+allowing for WITH-LATE-LOAD to be controlled is in use also for
+the deferred compilation mechanism."
+ (comp-ensure-native-compiler)
+ (unless (or (functionp function-or-file)
+ (stringp function-or-file))
+ (signal 'native-compiler-error
+ (list "Not a function symbol or file" function-or-file)))
+ (catch 'no-native-compile
+ (let* ((data function-or-file)
+ (comp-native-compiling t)
+ (byte-native-qualities nil)
+ ;; Have byte compiler signal an error when compilation fails.
+ (byte-compile-debug t)
+ (comp-ctxt (make-comp-ctxt :output output
+ :with-late-load with-late-load)))
+ (comp-log "\n \n" 1)
+ (condition-case err
+ (cl-loop
+ with report = nil
+ for t0 = (current-time)
+ for pass in comp-passes
+ unless (memq pass comp-disabled-passes)
+ do
+ (comp-log (format "(%s) Running pass %s:\n"
+ function-or-file pass)
+ 2)
+ (setf data (funcall pass data))
+ (push (cons pass (float-time (time-since t0))) report)
+ (cl-loop for f in (alist-get pass comp-post-pass-hooks)
+ do (funcall f data))
+ finally
+ (when comp-log-time-report
+ (comp-log (format "Done compiling %s" data) 0)
+ (cl-loop for (pass . time) in (reverse report)
+ do (comp-log (format "Pass %s took: %fs." pass time)
0))))
+ (native-compiler-skip)
+ (t
+ (let ((err-val (cdr err)))
+ ;; If we are doing an async native compilation print the
+ ;; error in the correct format so is parsable and abort.
+ (if (and comp-async-compilation
+ (not (eq (car err) 'native-compiler-error)))
+ (progn
+ (message (if err-val
+ "%s: Error: %s %s"
+ "%s: Error %s")
+ function-or-file
+ (get (car err) 'error-message)
+ (car-safe err-val))
+ (kill-emacs -1))
+ ;; Otherwise re-signal it adding the compilation input.
+ (signal (car err) (if (consp err-val)
+ (cons function-or-file err-val)
+ (list function-or-file err-val)))))))
+ (if (stringp function-or-file)
+ data
+ ;; So we return the compiled function.
+ (native-elisp-load data)))))
+
+(defun native-compile-async-skip-p (file load selector)
+ "Return non-nil if FILE's compilation should be skipped.
+
+LOAD and SELECTOR work as described in `native--compile-async'."
+ ;; Make sure we are not already compiling `file' (bug#40838).
+ (or (gethash file comp-async-compilations)
+ (cond
+ ((null selector) nil)
+ ((functionp selector) (not (funcall selector file)))
+ ((stringp selector) (not (string-match-p selector file)))
+ (t (error "SELECTOR must be a function a regexp or nil")))
+ ;; Also exclude files from deferred compilation if
+ ;; any of the regexps in
+ ;; `comp-deferred-compilation-deny-list' matches.
+ (and (eq load 'late)
+ (cl-some (lambda (re)
+ (string-match-p re file))
+ comp-deferred-compilation-deny-list))))
+
+(defun native--compile-async (files &optional recursively load selector)
+ "Compile FILES asynchronously.
+FILES is one filename or a list of filenames or directories.
+
+If optional argument RECURSIVELY is non-nil, recurse into
+subdirectories of given directories.
+
+If optional argument LOAD is non-nil, request to load the file
+after compiling.
+
+The optional argument SELECTOR has the following valid values:
+
+nil -- Select all files.
+a string -- A regular expression selecting files with matching names.
+a function -- A function selecting files with matching names.
+
+The variable `comp-async-jobs-number' specifies the number
+of (commands) to run simultaneously.
+
+LOAD can also be the symbol `late'. This is used internally if
+the byte code has already been loaded when this function is
+called. It means that we request the special kind of load
+necessary in that situation, called \"late\" loading.
+
+During a \"late\" load, instead of executing all top-level forms
+of the original files, only function definitions are
+loaded (paying attention to have these effective only if the
+bytecode definition was not changed in the meantime)."
+ (comp-ensure-native-compiler)
+ (unless (member load '(nil t late))
+ (error "LOAD must be nil, t or 'late"))
+ (unless (listp files)
+ (setf files (list files)))
+ (let (file-list)
+ (dolist (path files)
+ (cond ((file-directory-p path)
+ (dolist (file (if recursively
+ (directory-files-recursively
+ path comp-valid-source-re)
+ (directory-files path t comp-valid-source-re)))
+ (push file file-list)))
+ ((file-exists-p path) (push path file-list))
+ (t (signal 'native-compiler-error
+ (list "Path not a file nor directory" path)))))
+ (dolist (file file-list)
+ (if-let ((entry (cl-find file comp-files-queue :key #'car :test
#'string=)))
+ ;; Most likely the byte-compiler has requested a deferred
+ ;; compilation, so update `comp-files-queue' to reflect that.
+ (unless (or (null load)
+ (eq load (cdr entry)))
+ (cl-substitute (cons file load) (car entry) comp-files-queue
+ :key #'car :test #'string=))
+
+ (unless (native-compile-async-skip-p file load selector)
+ (let* ((out-filename (comp-el-to-eln-filename file))
+ (out-dir (file-name-directory out-filename)))
+ (unless (file-exists-p out-dir)
+ (make-directory out-dir t))
+ (if (file-writable-p out-filename)
+ (setf comp-files-queue
+ (append comp-files-queue `((,file . ,load))))
+ (display-warning 'comp
+ (format "No write access for %s skipping."
+ out-filename)))))))
+ (when (zerop (comp-async-runnings))
+ (comp-run-async-workers))))
+
+
+;;; Compiler entry points.
+
+;;;###autoload
+(defun comp-lookup-eln (filename)
+ "Given a Lisp source FILENAME return the corresponding .eln file if found.
+Search happens in `comp-eln-load-path'."
+ (cl-loop
+ with eln-filename = (comp-el-to-eln-rel-filename filename)
+ for dir in comp-eln-load-path
+ for f = (expand-file-name eln-filename
+ (expand-file-name comp-native-version-dir
+ (expand-file-name
+ dir
+ invocation-directory)))
+ when (file-exists-p f)
+ do (cl-return f)))
+
+;;;###autoload
+(defun native-compile (function-or-file &optional output)
+ "Compile FUNCTION-OR-FILE into native code.
+This is the synchronous entry-point for the Emacs Lisp native
+compiler.
+FUNCTION-OR-FILE is a function symbol, a form, or the filename of
+an Emacs Lisp source file.
+If OUTPUT is non-nil, use it as the filename for the compiled
+object.
+If FUNCTION-OR-FILE is a filename, return the filename of the
+compiled object. If FUNCTION-OR-FILE is a function symbol or a
+form, return the compiled function."
+ (comp--native-compile function-or-file nil output))
+
+;;;###autoload
+(defun batch-native-compile ()
+ "Perform native compilation on remaining command-line arguments.
+Use this from the command line, with ‘-batch’;
+it won’t work in an interactive Emacs.
+Native compilation equivalent to `batch-byte-compile'."
+ (comp-ensure-native-compiler)
+ (cl-loop for file in command-line-args-left
+ if (or (null byte-native-for-bootstrap)
+ (cl-notany (lambda (re) (string-match re file))
+ comp-bootstrap-deny-list))
+ do (comp--native-compile file)
+ else
+ do (byte-compile-file file)))
+
+;;;###autoload
+(defun batch-byte-native-compile-for-bootstrap ()
+ "Like `batch-native-compile', but used for bootstrap.
+Generate .elc files in addition to the .eln files.
+Force the produced .eln to be outputted in the eln system
+directory (the last entry in `comp-eln-load-path').
+If the environment variable 'NATIVE_DISABLED' is set, only byte
+compile."
+ (comp-ensure-native-compiler)
+ (if (equal (getenv "NATIVE_DISABLED") "1")
+ (batch-byte-compile)
+ (cl-assert (length= command-line-args-left 1))
+ (let ((byte-native-for-bootstrap t)
+ (byte-to-native-output-file nil))
+ (batch-native-compile)
+ (pcase byte-to-native-output-file
+ (`(,tempfile . ,target-file)
+ (rename-file tempfile target-file t))))))
+
+;;;###autoload
+(defun native-compile-async (files &optional recursively load selector)
+ "Compile FILES asynchronously.
+FILES is one file or a list of filenames or directories.
+
+If optional argument RECURSIVELY is non-nil, recurse into
+subdirectories of given directories.
+
+If optional argument LOAD is non-nil, request to load the file
+after compiling.
+
+The optional argument SELECTOR has the following valid values:
+
+nil -- Select all files.
+a string -- A regular expression selecting files with matching names.
+a function -- A function selecting files with matching names.
+
+The variable `comp-async-jobs-number' specifies the number
+of (commands) to run simultaneously."
+ ;; Normalize: we only want to pass t or nil, never e.g. `late'.
+ (let ((load (not (not load))))
+ (native--compile-async files recursively load selector)))
+
+(provide 'comp)
+
+;; LocalWords: limplified limplified limplification limplify Limple LIMPLE
libgccjit elc eln
+
+;;; comp.el ends here
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index b2d54c7..069c7a9 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -213,7 +213,7 @@ the debugger will not be entered."
last-input-event last-command-event last-nonmenu-event
last-event-frame
overriding-local-map
- load-read-function
+ (load-read-function #'read)
;; If we are inside a minibuffer, allow nesting
;; so that we don't get an error from the `e' command.
(enable-recursive-minibuffers
diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el
index 0d28909..6ac76f1 100644
--- a/lisp/emacs-lisp/disass.el
+++ b/lisp/emacs-lisp/disass.el
@@ -43,6 +43,8 @@
;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt.
(require 'byte-compile "bytecomp")
+(declare-function comp-c-func-name "comp.el")
+
(defvar disassemble-column-1-indent 8 "*")
(defvar disassemble-column-2-indent 10 "*")
@@ -73,8 +75,9 @@ redefine OBJECT if it is a symbol."
(disassemble-internal object indent nil)))
nil)
-
-(defun disassemble-internal (obj indent interactive-p)
+(declare-function native-comp-unit-file "data.c")
+(declare-function subr-native-comp-unit "data.c")
+(cl-defun disassemble-internal (obj indent interactive-p)
(let ((macro 'nil)
(name (when (symbolp obj)
(prog1 obj
@@ -82,7 +85,27 @@ redefine OBJECT if it is a symbol."
args)
(setq obj (autoload-do-load obj name))
(if (subrp obj)
- (error "Can't disassemble #<subr %s>" name))
+ (if (and (fboundp 'subr-native-elisp-p)
+ (subr-native-elisp-p obj))
+ (progn
+ (require 'comp)
+ (call-process "objdump" nil (current-buffer) t "-S"
+ (native-comp-unit-file (subr-native-comp-unit
obj)))
+ (goto-char (point-min))
+ (re-search-forward (concat "^.*"
+ (regexp-quote
+ (concat "<"
+ (comp-c-func-name
+ (subr-name obj) "F" t)
+ ">:"))))
+ (beginning-of-line)
+ (delete-region (point-min) (point))
+ (when (re-search-forward "^.*<.*>:" nil t 2)
+ (delete-region (match-beginning 0) (point-max)))
+ (asm-mode)
+ (setq buffer-read-only t)
+ (cl-return-from disassemble-internal))
+ (error "Can't disassemble #<subr %s>" name)))
(if (eq (car-safe obj) 'macro) ;Handle macros.
(setq macro t
obj (cdr obj)))
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index addb58c..0a6d4ec 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -116,9 +116,9 @@ it is disabled.")
doc nil nil 1)))))
;;;###autoload
-(defalias 'easy-mmode-define-minor-mode 'define-minor-mode)
+(defalias 'easy-mmode-define-minor-mode #'define-minor-mode)
;;;###autoload
-(defmacro define-minor-mode (mode doc &optional init-value lighter keymap
&rest body)
+(defmacro define-minor-mode (mode doc &rest body)
"Define a new minor mode MODE.
This defines the toggle command MODE and (by default) a control variable
MODE (you can override this with the :variable keyword, see below).
@@ -139,39 +139,31 @@ 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.
- Note that the minor mode function won't be called by setting
- this option, so the value *reflects* the minor mode's natural
- initial state, rather than *setting* it.
- In the vast majority of cases it should be nil.
-Optional LIGHTER is displayed in the mode line when the mode is on.
-Optional KEYMAP is the default keymap bound to the mode keymap.
- If non-nil, it should be a variable name (whose value is a keymap),
- or an expression that returns either a keymap or a list of
- (KEY . BINDING) pairs where KEY and BINDING are suitable for
- `define-key'. If you supply a KEYMAP argument that is not a
- symbol, this macro defines the variable MODE-map and gives it
- the value that KEYMAP specifies.
-
BODY contains code to execute each time the mode is enabled or disabled.
It is executed after toggling the mode, and before running MODE-hook.
Before the actual body code, you can write keyword arguments, i.e.
alternating keywords and values. If you provide BODY, then you must
- provide (even if just nil) INIT-VALUE, LIGHTER, and KEYMAP, or provide
- at least one keyword argument, or both; otherwise, BODY would be
- misinterpreted as the first omitted argument. The following special
- keywords are supported (other keywords are passed to `defcustom' if
- the minor mode is global):
+ provide at least one keyword argument (e.g. `:lighter nil`).
+ The following special keywords are supported (other keywords are passed
+ to `defcustom' if the minor mode is global):
-:group GROUP Custom group name to use in all generated `defcustom' forms.
:global GLOBAL If non-nil specifies that the minor mode is not meant to be
buffer-local, so don't make the variable MODE buffer-local.
By default, the mode is buffer-local.
-:init-value VAL Same as the INIT-VALUE argument.
+:init-value VAL the initial value of the mode's variable.
+ Note that the minor mode function won't be called by setting
+ this option, so the value *reflects* the minor mode's natural
+ initial state, rather than *setting* it.
+ In the vast majority of cases it should be nil.
Not used if you also specify :variable.
-:lighter SPEC Same as the LIGHTER argument.
-:keymap MAP Same as the KEYMAP argument.
-:require SYM Same as in `defcustom'.
+:lighter SPEC Text displayed in the mode line when the mode is on.
+:keymap MAP Keymap bound to the mode keymap. Defaults to `MODE-map'.
+ If non-nil, it should be a variable name (whose value is
+ a keymap), or an expression that returns either a keymap or
+ a list of (KEY . BINDING) pairs where KEY and BINDING are
+ suitable for `define-key'. If you supply a KEYMAP argument
+ that is not a symbol, this macro defines the variable MODE-map
+ and gives it the value that KEYMAP specifies.
:interactive VAL Whether this mode should be a command or not. The default
is to make it one; use nil to avoid that. If VAL is a list,
it's interpreted as a list of major modes this minor mode
@@ -185,14 +177,19 @@ BODY contains code to execute each time the mode is
enabled or disabled.
sets it. If you specify a :variable, this function does
not define a MODE variable (nor any of the terms used
in :variable).
-
:after-hook A single lisp form which is evaluated after the mode hooks
have been run. It should not be quoted.
For example, you could write
(define-minor-mode foo-mode \"If enabled, foo on you!\"
:lighter \" Foo\" :require \\='foo :global t :group \\='hassle :version
\"27.5\"
- ...BODY CODE...)"
+ ...BODY CODE...)
+
+For backward compatibility with the Emacs<21 calling convention,
+the keywords can also be preceded by the obsolete triplet
+INIT-VALUE LIGHTER KEYMAP.
+
+\(fn MODE DOC [KEYWORD VAL ... &rest BODY])"
(declare (doc-string 2)
(debug (&define name string-or-null-p
[&optional [¬ keywordp] sexp
@@ -201,23 +198,15 @@ For example, you could write
[&rest [keywordp sexp]]
def-body)))
- ;; Allow skipping the first three args.
- (cond
- ((keywordp init-value)
- (setq body (if keymap `(,init-value ,lighter ,keymap ,@body)
- `(,init-value ,lighter))
- init-value nil lighter nil keymap nil))
- ((keywordp lighter)
- (setq body `(,lighter ,keymap ,@body) lighter nil keymap nil))
- ((keywordp keymap) (push keymap body) (setq keymap nil)))
-
(let* ((last-message (make-symbol "last-message"))
(mode-name (symbol-name mode))
- (pretty-name (easy-mmode-pretty-mode-name mode lighter))
+ (init-value nil)
+ (keymap nil)
+ (lighter nil)
+ (pretty-name nil)
(globalp nil)
(set nil)
(initialize nil)
- (group nil)
(type nil)
(extra-args nil)
(extra-keywords nil)
@@ -225,14 +214,26 @@ For example, you could write
(setter `(setq ,mode)) ;The beginning of the exp to set the mode var.
(getter mode) ;The exp to get the mode value.
(modefun mode) ;The minor mode function name we're defining.
- (require t)
(after-hook nil)
(hook (intern (concat mode-name "-hook")))
(hook-on (intern (concat mode-name "-on-hook")))
(hook-off (intern (concat mode-name "-off-hook")))
(interactive t)
+ (warnwrap (if (or (null body) (keywordp (car body))) #'identity
+ (lambda (exp)
+ (macroexp-warn-and-return
+ "Use keywords rather than deprecated positional
arguments to `define-minor-mode'"
+ exp))))
keyw keymap-sym tmp)
+ ;; Allow BODY to start with the old INIT-VALUE LIGHTER KEYMAP triplet.
+ (unless (keywordp (car body))
+ (setq init-value (pop body))
+ (unless (keywordp (car body))
+ (setq lighter (pop body))
+ (unless (keywordp (car body))
+ (setq keymap (pop body)))))
+
;; Check keys.
(while (keywordp (setq keyw (car body)))
(setq body (cdr body))
@@ -246,9 +247,7 @@ For example, you could write
(:extra-args (setq extra-args (pop body)))
(:set (setq set (list :set (pop body))))
(:initialize (setq initialize (list :initialize (pop body))))
- (:group (setq group (nconc group (list :group (pop body)))))
(:type (setq type (list :type (pop body))))
- (:require (setq require (pop body)))
(:keymap (setq keymap (pop body)))
(:interactive (setq interactive (pop body)))
(:variable (setq variable (pop body))
@@ -264,13 +263,14 @@ For example, you could write
(:after-hook (setq after-hook (pop body)))
(_ (push keyw extra-keywords) (push (pop body) extra-keywords))))
+ (setq pretty-name (easy-mmode-pretty-mode-name mode lighter))
(setq keymap-sym (if (and keymap (symbolp keymap)) keymap
(intern (concat mode-name "-map"))))
(unless set (setq set '(:set #'custom-set-minor-mode)))
(unless initialize
- (setq initialize '(:initialize 'custom-initialize-default)))
+ (setq initialize '(:initialize #'custom-initialize-default)))
;; TODO? Mark booleans as safe if booleanp? Eg abbrev-mode.
(unless type (setq type '(:type 'boolean)))
@@ -301,70 +301,72 @@ or call the function `%s'."))))
,(format base-doc-string pretty-name mode mode)
,@set
,@initialize
- ,@group
,@type
- ,@(unless (eq require t) `(:require ,require))
,@(nreverse extra-keywords)))))
;; The actual function.
- (defun ,modefun (&optional arg ,@extra-args)
- ,(easy-mmode--mode-docstring doc pretty-name keymap-sym)
- ,(when interactive
- ;; Use `toggle' rather than (if ,mode 0 1) so that using
- ;; repeat-command still does the toggling correctly.
- (if (consp interactive)
- `(interactive
- (list (if current-prefix-arg
- (prefix-numeric-value current-prefix-arg)
- 'toggle))
- ,@interactive)
- '(interactive (list (if current-prefix-arg
- (prefix-numeric-value current-prefix-arg)
- 'toggle)))))
- (let ((,last-message (current-message)))
- (,@setter
- (cond ((eq arg 'toggle)
- (not ,getter))
- ((and (numberp arg)
- (< arg 1))
- nil)
- (t
- t)))
- ;; Keep minor modes list up to date.
- ,@(if globalp
- ;; When running this byte-compiled code in earlier
- ;; Emacs versions, these variables may not be defined
- ;; there. So check defensively, even if they're
- ;; always defined in Emacs 28 and up.
- `((when (boundp 'global-minor-modes)
- (setq global-minor-modes
- (delq ',modefun global-minor-modes))
- (when ,getter
- (push ',modefun global-minor-modes))))
- ;; Ditto check.
- `((when (boundp 'local-minor-modes)
- (setq local-minor-modes (delq ',modefun local-minor-modes))
- (when ,getter
- (push ',modefun local-minor-modes)))))
- ,@body
- ;; The on/off hooks are here for backward compatibility only.
- (run-hooks ',hook (if ,getter ',hook-on ',hook-off))
- (if (called-interactively-p 'any)
- (progn
- ,(if (and globalp (not variable))
- `(customize-mark-as-set ',mode))
- ;; Avoid overwriting a message shown by the body,
- ;; but do overwrite previous messages.
- (unless (and (current-message)
- (not (equal ,last-message
- (current-message))))
- (let ((local ,(if globalp "" " in current buffer")))
- (message ,(format "%s %%sabled%%s" pretty-name)
- (if ,getter "en" "dis") local)))))
- ,@(when after-hook `(,after-hook)))
- (force-mode-line-update)
- ;; Return the new setting.
- ,getter)
+ ,(funcall
+ warnwrap
+ `(defun ,modefun (&optional arg ,@extra-args)
+ ,(easy-mmode--mode-docstring doc pretty-name keymap-sym)
+ ,(when interactive
+ ;; Use `toggle' rather than (if ,mode 0 1) so that using
+ ;; repeat-command still does the toggling correctly.
+ (if (consp interactive)
+ `(interactive
+ (list (if current-prefix-arg
+ (prefix-numeric-value current-prefix-arg)
+ 'toggle))
+ ,@interactive)
+ '(interactive
+ (list (if current-prefix-arg
+ (prefix-numeric-value current-prefix-arg)
+ 'toggle)))))
+ (let ((,last-message (current-message)))
+ (,@setter
+ (cond ((eq arg 'toggle)
+ (not ,getter))
+ ((and (numberp arg)
+ (< arg 1))
+ nil)
+ (t
+ t)))
+ ;; Keep minor modes list up to date.
+ ,@(if globalp
+ ;; When running this byte-compiled code in earlier
+ ;; Emacs versions, these variables may not be defined
+ ;; there. So check defensively, even if they're
+ ;; always defined in Emacs 28 and up.
+ `((when (boundp 'global-minor-modes)
+ (setq global-minor-modes
+ (delq ',modefun global-minor-modes))
+ (when ,getter
+ (push ',modefun global-minor-modes))))
+ ;; Ditto check.
+ `((when (boundp 'local-minor-modes)
+ (setq local-minor-modes
+ (delq ',modefun local-minor-modes))
+ (when ,getter
+ (push ',modefun local-minor-modes)))))
+ ,@body
+ ;; The on/off hooks are here for backward compatibility only.
+ (run-hooks ',hook (if ,getter ',hook-on ',hook-off))
+ (if (called-interactively-p 'any)
+ (progn
+ ,(if (and globalp (not variable))
+ `(customize-mark-as-set ',mode))
+ ;; Avoid overwriting a message shown by the body,
+ ;; but do overwrite previous messages.
+ (unless (and (current-message)
+ (not (equal ,last-message
+ (current-message))))
+ (let ((local ,(if globalp "" " in current buffer")))
+ (message ,(format "%s %%sabled%%s" pretty-name)
+ (if ,getter "en" "dis") local)))))
+ ,@(when after-hook `(,after-hook)))
+ (force-mode-line-update)
+ ;; Return the new setting.
+ ,getter))
;; Autoloading a define-minor-mode autoloads everything
;; up-to-here.
@@ -406,9 +408,9 @@ No problems result if this variable is not bound.
;;;
;;;###autoload
-(defalias 'easy-mmode-define-global-mode 'define-globalized-minor-mode)
+(defalias 'easy-mmode-define-global-mode #'define-globalized-minor-mode)
;;;###autoload
-(defalias 'define-global-minor-mode 'define-globalized-minor-mode)
+(defalias 'define-global-minor-mode #'define-globalized-minor-mode)
;;;###autoload
(defmacro define-globalized-minor-mode (global-mode mode turn-on &rest body)
"Make a global mode GLOBAL-MODE corresponding to buffer-local minor MODE.
@@ -510,12 +512,12 @@ disable it. If called from Lisp, enable the mode if ARG
is omitted or nil.\n\n"
(if ,global-mode
(progn
(add-hook 'after-change-major-mode-hook
- ',MODE-enable-in-buffers)
- (add-hook 'find-file-hook ',MODE-check-buffers)
- (add-hook 'change-major-mode-hook ',MODE-cmhh))
- (remove-hook 'after-change-major-mode-hook ',MODE-enable-in-buffers)
- (remove-hook 'find-file-hook ',MODE-check-buffers)
- (remove-hook 'change-major-mode-hook ',MODE-cmhh))
+ #',MODE-enable-in-buffers)
+ (add-hook 'find-file-hook #',MODE-check-buffers)
+ (add-hook 'change-major-mode-hook #',MODE-cmhh))
+ (remove-hook 'after-change-major-mode-hook #',MODE-enable-in-buffers)
+ (remove-hook 'find-file-hook #',MODE-check-buffers)
+ (remove-hook 'change-major-mode-hook #',MODE-cmhh))
;; Go through existing buffers.
(dolist (buf (buffer-list))
@@ -555,7 +557,7 @@ list."
;; A function which checks whether MODE has been disabled in the major
;; mode hook which has just been run.
- (add-hook ',minor-MODE-hook ',MODE-set-explicitly)
+ (add-hook ',minor-MODE-hook #',MODE-set-explicitly)
;; List of buffers left to process.
(defvar ,MODE-buffers nil)
@@ -582,13 +584,13 @@ list."
(defun ,MODE-check-buffers ()
(,MODE-enable-in-buffers)
- (remove-hook 'post-command-hook ',MODE-check-buffers))
+ (remove-hook 'post-command-hook #',MODE-check-buffers))
(put ',MODE-check-buffers 'definition-name ',global-mode)
;; The function that catches kill-all-local-variables.
(defun ,MODE-cmhh ()
(add-to-list ',MODE-buffers (current-buffer))
- (add-hook 'post-command-hook ',MODE-check-buffers))
+ (add-hook 'post-command-hook #',MODE-check-buffers))
(put ',MODE-cmhh 'definition-name ',global-mode))))
(defun easy-mmode--globalized-predicate-p (predicate)
diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el
index 87b34e7..f666154 100644
--- a/lisp/emacs-lisp/easymenu.el
+++ b/lisp/emacs-lisp/easymenu.el
@@ -494,14 +494,16 @@ To implement dynamic menus, either call this from
`menu-bar-update-hook' or use a menu filter."
(easy-menu-add-item map path (easy-menu-create-menu name items) before))
-(define-obsolete-function-alias 'easy-menu-remove #'ignore "28.1"
+(defalias 'easy-menu-remove #'ignore
"Remove MENU from the current menu bar.
Contrary to XEmacs, this is a nop on Emacs since menus are automatically
\(de)activated when the corresponding keymap is (de)activated.
\(fn MENU)")
+(make-obsolete 'easy-menu-remove "this was always a no-op in Emacs \
+and can be safely removed." "28.1")
-(define-obsolete-function-alias 'easy-menu-add #'ignore "28.1"
+(defalias 'easy-menu-add #'ignore
"Add the menu to the menubar.
On Emacs this is a nop, because menus are already automatically
activated when the corresponding keymap is activated. On XEmacs
@@ -511,6 +513,8 @@ You should call this once the menu and keybindings are set
up
completely and menu filter functions can be expected to work.
\(fn MENU &optional MAP)")
+(make-obsolete 'easy-menu-add "this was always a no-op in Emacs \
+and can be safely removed." "28.1")
(defun add-submenu (menu-path submenu &optional before in-menu)
"Add submenu SUBMENU in the menu at MENU-PATH.
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index f1455ff..b08ee3c 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -459,6 +459,9 @@ invoked without a prefix argument.
If acting on a `defun' for FUNCTION, and the function was instrumented,
`Edebug: FUNCTION' is printed in the minibuffer. If not instrumented,
just FUNCTION is printed."
+ ;; Re-install our advice, in case `debug' re-bound `load-read-function' to
+ ;; its default value.
+ (add-function :around load-read-function #'edebug--read)
(let* ((edebug-all-forms (not (eq (not edebug-it) (not edebug-all-defs))))
(edebug-all-defs edebug-all-forms))
(funcall orig-fun nil)))
@@ -1942,14 +1945,16 @@ a sequence of elements."
;; Normally, &define is interpreted specially other places.
;; This should only be called inside of a spec list to match the remainder
;; of the current list. e.g. ("lambda" &define args def-body)
- (edebug-make-form-wrapper
- cursor
- (edebug-before-offset cursor)
- ;; Find the last offset in the list.
- (let ((offsets (edebug-cursor-offsets cursor)))
- (while (consp offsets) (setq offsets (cdr offsets)))
- offsets)
- specs))
+ (prog1 (edebug-make-form-wrapper
+ cursor
+ (edebug-before-offset cursor)
+ ;; Find the last offset in the list.
+ (let ((offsets (edebug-cursor-offsets cursor)))
+ (while (consp offsets) (setq offsets (cdr offsets)))
+ offsets)
+ specs)
+ ;; Stop backtracking here (Bug#41988).
+ (setq edebug-gate t)))
(cl-defmethod edebug--match-&-spec-op ((_ (eql &name)) cursor specs)
"Compute the name for `&name SPEC FUN` spec operator.
@@ -4114,12 +4119,12 @@ This should be a list of `edebug---frame' objects.")
"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))
+ "Data structure for backtrace frames with information
+from Edebug instrumentation found in the backtrace."
def-name before-index after-index)
(defun edebug-pop-to-backtrace ()
diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index ec1077d..641882c 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -1,7 +1,6 @@
;;; eieio-base.el --- Base classes for EIEIO. -*- lexical-binding:t -*-
-;;; Copyright (C) 2000-2002, 2004-2005, 2007-2021 Free Software
-;;; Foundation, Inc.
+;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: OO, lisp
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index e7727fd..2923dff 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -169,7 +169,7 @@ Return nil if that option doesn't exist."
(and (recordp obj)
(eieio--class-p (eieio--object-class obj))))
-(define-obsolete-function-alias 'object-p 'eieio-object-p "25.1")
+(define-obsolete-function-alias 'object-p #'eieio-object-p "25.1")
(defun class-abstract-p (class)
"Return non-nil if CLASS is abstract.
@@ -242,9 +242,9 @@ use \\='%s or turn off `eieio-backward-compatibility'
instead" cname)
(cl-deftype list-of (elem-type)
`(and list
- (satisfies (lambda (list)
- (cl-every (lambda (elem) (cl-typep elem ',elem-type))
- list)))))
+ (satisfies ,(lambda (list)
+ (cl-every (lambda (elem) (cl-typep elem elem-type))
+ list)))))
(defun eieio-make-class-predicate (class)
@@ -787,7 +787,7 @@ Fills in OBJ's SLOT with its default value."
(cond
;; Is it a function call? If so, evaluate it.
((eieio-eval-default-p val)
- (eval val))
+ (eval val t))
;;;; check for quoted things, and unquote them
;;((and (consp val) (eq (car val) 'quote))
;; (car (cdr val)))
@@ -1029,7 +1029,7 @@ method invocation orders of the involved classes."
(eieio--class-precedence-c3 class))))))
(define-obsolete-function-alias
- 'class-precedence-list 'eieio--class-precedence-list "24.4")
+ 'class-precedence-list #'eieio--class-precedence-list "24.4")
;;; Here are some special types of errors
diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el
index 184b99f..8257f7a 100644
--- a/lisp/emacs-lisp/eieio-custom.el
+++ b/lisp/emacs-lisp/eieio-custom.el
@@ -1,4 +1,4 @@
-;;; eieio-custom.el -- eieio object customization -*- lexical-binding:t -*-
+;;; eieio-custom.el --- eieio object customization -*- lexical-binding:t -*-
;; Copyright (C) 1999-2001, 2005, 2007-2021 Free Software Foundation,
;; Inc.
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el
index e65f424..08a6deb 100644
--- a/lisp/emacs-lisp/eieio-opt.el
+++ b/lisp/emacs-lisp/eieio-opt.el
@@ -1,4 +1,4 @@
-;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) -*-
lexical-binding: t; -*-
+;;; eieio-opt.el --- eieio optional functions (debug, printing, speedbar) -*-
lexical-binding: t; -*-
;; Copyright (C) 1996, 1998-2003, 2005, 2008-2021 Free Software
;; Foundation, Inc.
diff --git a/lisp/emacs-lisp/eieio-speedbar.el
b/lisp/emacs-lisp/eieio-speedbar.el
index 8bf77e2..c25ea8a 100644
--- a/lisp/emacs-lisp/eieio-speedbar.el
+++ b/lisp/emacs-lisp/eieio-speedbar.el
@@ -1,4 +1,4 @@
-;;; eieio-speedbar.el -- Classes for managing speedbar displays. -*-
lexical-binding:t -*-
+;;; eieio-speedbar.el --- Classes for managing speedbar displays. -*-
lexical-binding:t -*-
;; Copyright (C) 1999-2002, 2005, 2007-2021 Free Software Foundation,
;; Inc.
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 910023b..31b6b09 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -981,4 +981,4 @@ of `eq'."
(provide 'eieio)
-;;; eieio ends here
+;;; eieio.el ends here
diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el
index a02406a..b4f068c 100644
--- a/lisp/emacs-lisp/eldoc.el
+++ b/lisp/emacs-lisp/eldoc.el
@@ -63,7 +63,7 @@ If this variable is set to 0, no idle time is required."
:type 'number)
(defcustom eldoc-print-after-edit nil
- "If non-nil eldoc info is only shown when editing.
+ "If non-nil, eldoc info is only shown when editing.
Changing the value requires toggling `eldoc-mode'."
:type 'boolean)
@@ -391,12 +391,12 @@ name, inside its arg list, or on any object with some
associated
information.
Each hook function is called with at least one argument CALLBACK,
-a function, and decides whether to display a doc short string
+a function, and decides whether to display a short doc string
about the context around point.
- If that decision can be taken quickly, the hook function may
- call CALLBACK immediately following the protocol described
- below. Alternatively it may ignore CALLBACK entirely and
+ call CALLBACK immediately, following the protocol described
+ below. Alternatively, it may ignore CALLBACK entirely and
return either the doc string, or nil if there's no doc
appropriate for the context.
@@ -688,11 +688,11 @@ following values are allowed:
- `eldoc-documentation-compose': calls all functions in the
special hook and displays all of the resulting doc strings
together. Wait for all strings to be ready, and preserve their
- relative as specified by the order of functions in the hook;
+ relative order as specified by the order of functions in the hook;
- `eldoc-documentation-compose-eagerly': calls all functions in
- the special hook and display as many of the resulting doc
- strings as possible, as soon as possible. Preserving the
+ the special hook and displays as many of the resulting doc
+ strings as possible, as soon as possible. Preserves the
relative order of doc strings;
- `eldoc-documentation-enthusiast': calls all functions in the
@@ -793,7 +793,7 @@ function passes responsibility to the functions in
Other third-party values of `eldoc-documentation-strategy' should
not use `eldoc--make-callback'. They must find some alternate
way to produce callbacks to feed to
-`eldoc-documentation-function' and should endeavour to display
+`eldoc-documentation-functions' and should endeavour to display
the docstrings eventually produced, using
`eldoc-display-functions'."
(let* (;; How many callbacks have been created by the strategy
diff --git a/lisp/emacs-lisp/faceup.el b/lisp/emacs-lisp/faceup.el
index 6c3931f..162c396 100644
--- a/lisp/emacs-lisp/faceup.el
+++ b/lisp/emacs-lisp/faceup.el
@@ -1170,11 +1170,6 @@ Intended to be called when a file is loaded."
;; 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 c399a68..58876a4 100644
--- a/lisp/emacs-lisp/find-func.el
+++ b/lisp/emacs-lisp/find-func.el
@@ -178,13 +178,18 @@ See the functions `find-function' and `find-variable'."
(setq name rel))))
(unless (equal name library) name)))
+(defvar comp-eln-to-el-h)
+
(defun find-library-name (library)
"Return the absolute file name of the Emacs Lisp source of LIBRARY.
LIBRARY should be a string (the name of the library)."
;; If the library is byte-compiled, try to find a source library by
;; the same name.
- (when (string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library)
+ (cond
+ ((string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library)
(setq library (replace-match "" t t library)))
+ ((string-match "\\.eln\\'" library)
+ (setq library (gethash (file-name-nondirectory library)
comp-eln-to-el-h))))
(or
(locate-file library
(or find-function-source-path load-path)
@@ -203,7 +208,7 @@ LIBRARY should be a string (the name of the library)."
(or find-function-source-path load-path)
load-file-rep-suffixes)))))
(find-library--from-load-history library)
- (error "Can't find library %s" library)))
+ (signal 'file-error (list "Can't find library" library))))
(defun find-library--from-load-history (library)
;; In `load-history', the file may be ".elc", ".el", ".el.gz", and
@@ -491,7 +496,7 @@ message about the whole chain of aliases."
(cons function
(cond
((autoloadp def) (nth 1 def))
- ((subrp def)
+ ((subr-primitive-p def)
(if lisp-only
(error "%s is a built-in function" function))
(help-C-file-name def 'subr))
diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el
index 4256bd5..0e86b92 100644
--- a/lisp/emacs-lisp/float-sup.el
+++ b/lisp/emacs-lisp/float-sup.el
@@ -31,6 +31,7 @@
(with-suppressed-warnings ((lexical pi))
(defconst pi float-pi
"Obsolete since Emacs-23.3. Use `float-pi' instead."))
+(make-obsolete-variable 'pi 'float-pi "23.3")
(internal-make-var-non-special 'pi)
(defconst float-e (exp 1) "The value of e (2.7182818...).")
diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el
index 6d9c8c3..73a33a5 100644
--- a/lisp/emacs-lisp/lisp-mnt.el
+++ b/lisp/emacs-lisp/lisp-mnt.el
@@ -109,11 +109,6 @@
;; * Footer line --- marks end-of-file so it can be distinguished from
;; an expanded formfeed or the results of truncation.
-;;; Change Log:
-
-;; Tue Jul 14 23:44:17 1992 ESR
-;; * Created.
-
;;; Code:
;;; Variables:
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 59ada5e..df86446 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -394,7 +394,8 @@ Assumes the caller has bound `macroexpand-all-environment'."
;; Record which arguments expect functions, so we can warn when those
;; are accidentally quoted with ' rather than with #'
-(dolist (f '(funcall apply mapcar mapatoms mapconcat mapc cl-mapcar maphash))
+(dolist (f '( funcall apply mapcar mapatoms mapconcat mapc cl-mapcar maphash
+ map-char-table map-keymap map-keymap-internal))
(put f 'funarg-positions '(1)))
(dolist (f '( add-hook remove-hook advice-remove advice--remove-function
defalias fset global-set-key run-after-idle-timeout
diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el
index 86a0c76..0522b31 100644
--- a/lisp/emacs-lisp/map-ynp.el
+++ b/lisp/emacs-lisp/map-ynp.el
@@ -38,46 +38,62 @@
(defun map-y-or-n-p (prompter actor list &optional help action-alist
no-cursor-in-echo-area)
- "Ask a series of boolean questions.
-Takes args PROMPTER ACTOR LIST, and optional args HELP and ACTION-ALIST.
+ "Ask a boolean question per PROMPTER for each object in LIST, then call
ACTOR.
LIST is a list of objects, or a function of no arguments to return the next
-object or nil.
-
-If PROMPTER is a string, the prompt is \(format PROMPTER OBJECT). If not
-a string, PROMPTER is a function of one arg (an object from LIST), which
-returns a string to be used as the prompt for that object. If the return
-value is not a string, it may be nil to ignore the object or non-nil to act
-on the object without asking the user.
-
-ACTOR is a function of one arg (an object from LIST),
-which gets called with each object that the user answers `yes' for.
-
-If HELP is given, it is a list (OBJECT OBJECTS ACTION),
-where OBJECT is a string giving the singular noun for an elt of LIST;
-OBJECTS is the plural noun for elts of LIST, and ACTION is a transitive
-verb describing ACTOR. The default is \(\"object\" \"objects\" \"act on\").
-
-At the prompts, the user may enter y, Y, or SPC to act on that object;
-n, N, or DEL to skip that object; ! to act on all following objects;
-ESC or q to exit (skip all following objects); . (period) to act on the
-current object and then exit; or \\[help-command] to get help.
-
-If ACTION-ALIST is given, it is an alist (KEY FUNCTION HELP) of extra keys
-that will be accepted. KEY is a character; FUNCTION is a function of one
-arg (an object from LIST); HELP is a string. When the user hits KEY,
-FUNCTION is called. If it returns non-nil, the object is considered
-\"acted upon\", and the next object from LIST is processed. If it returns
-nil, the prompt is repeated for the same object.
-
-Final optional argument NO-CURSOR-IN-ECHO-AREA non-nil says not to set
-`cursor-in-echo-area' while prompting.
+object; when it returns nil, the list of objects is considered exhausted.
+
+If PROMPTER is a string, it should be a format string to be used to format
+the question as \(format PROMPTER OBJECT).
+If PROMPTER is not a string, it should be a function of one argument, an
+object from LIST, which returns a string to be used as the question for
+that object. If the function's return value is not a string, it may be
+nil to ignore the object, or non-nil to act on the object with ACTOR
+without asking the user.
+
+ACTOR is a function of one argument, an object from LIST,
+which gets called with each object for which the user answers `yes'
+to the question presented by PROMPTER.
+
+The user's answers to the questions may be one of the following:
+
+ - y, Y, or SPC to act on that object;
+ - n, N, or DEL to skip that object;
+ - ! to act on all following objects;
+ - ESC or q to exit (skip all following objects);
+ - . (period) to act on the current object and then exit; or
+ - \\[help-command] to get help.
+
+HELP provides information for displaying help when the user
+types \\[help-command]. If HELP is given, it should be a list of
+the form (OBJECT OBJECTS ACTION), where OBJECT is a string giving
+the singular noun describing an element of LIST; OBJECTS is the
+plural noun describing several elements of LIST, and ACTION is a
+transitive verb describing action by ACTOR on one or more elements
+of LIST. If HELP is omitted or nil, it defaults
+to \(\"object\" \"objects\" \"act on\").
+
+If ACTION-ALIST is given, it is an alist specifying additional keys
+that will be accepted as an answer to the questions. Each element
+of the alist has the form (KEY FUNCTION HELP), where KEY is a character;
+FUNCTION is a function of one argument (an object from LIST); and HELP
+is a string. When the user presses KEY, FUNCTION is called; if it
+returns non-nil, the object is considered to have been \"acted upon\",
+and `map-y-or-n-p' proceeeds to the next object from LIST. If
+FUNCTION returns nil, the prompt is re-issued for the same object: this
+comes in handy if FUNCTION produces some display that will allow the
+user to make an intelligent decision whether the object in question
+should be acted upon. If the user types \\[help-command], the string
+given by HELP is used to describe the effect of KEY.
+
+Optional argument NO-CURSOR-IN-ECHO-AREA, if non-nil, means not to set
+`cursor-in-echo-area' while prompting with the questions.
This function uses `query-replace-map' to define the standard responses,
-but not all of the responses which `query-replace' understands
-are meaningful here.
+but only some of the responses which `query-replace' understands
+are meaningful here, as described above.
-Returns the number of actions taken."
+The function's value is the number of actions taken."
(let* ((actions 0)
(msg (current-message))
user-keys mouse-event map prompt char elt def
diff --git a/lisp/emacs-lisp/memory-report.el b/lisp/emacs-lisp/memory-report.el
index ecbca28..f4f0313 100644
--- a/lisp/emacs-lisp/memory-report.el
+++ b/lisp/emacs-lisp/memory-report.el
@@ -182,7 +182,7 @@ by counted more than once."
(cl-defmethod memory-report--object-size-1 (_ (value symbol))
;; Don't count global symbols -- makes sizes of lists of symbols too
- ;; heavey.
+ ;; heavy.
(if (intern-soft value obarray)
0
(memory-report--size 'symbol)))
@@ -214,14 +214,14 @@ by counted more than once."
(setf (gethash value counted) t)
(when (car value)
(cl-incf total (memory-report--object-size counted (car value))))
- (if (cdr value)
- (if (consp (cdr value))
- (if (gethash (cdr value) counted)
- (setq value nil)
- (setq value (cdr value)))
- (cl-incf total (memory-report--object-size counted (cdr value)))
- (setq value nil))
- (setq value nil)))
+ (let ((next (cdr value)))
+ (setq value (when next
+ (if (consp next)
+ (unless (gethash next counted)
+ (cdr value))
+ (cl-incf total (memory-report--object-size
+ counted next))
+ nil)))))
total))
(cl-defmethod memory-report--object-size-1 (counted (value vector))
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
index afdd372..f974056 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -316,8 +316,26 @@ is also interactive. There are 3 cases:
`(advice--add-function ,where (gv-ref ,(advice--normalize-place place))
,function ,props))
+(declare-function comp-subr-trampoline-install "comp")
+
;;;###autoload
(defun advice--add-function (where ref function props)
+ (when (and (featurep 'nativecomp)
+ (subr-primitive-p (gv-deref ref)))
+ (let ((subr-name (intern (subr-name (gv-deref ref)))))
+ ;; Requiring the native compiler to advice `macroexpand' cause a
+ ;; circular dependency in eager macro expansion.
+ ;; uniquify is advising `rename-buffer' while being loaded in
+ ;; loadup.el. This would require the whole native compiler
+ ;; machinery but we don't want to include it in the dump.
+ ;; Because these two functions are already handled in
+ ;; `comp-never-optimize-functions' we hack the problem this way
+ ;; for now :/
+ (unless (memq subr-name '(macroexpand rename-buffer))
+ ;; Must require explicitly as during bootstrap we have no
+ ;; autoloads.
+ (require 'comp)
+ (comp-subr-trampoline-install subr-name))))
(let* ((name (cdr (assq 'name props)))
(a (advice--member-p (or name function) (if name t) (gv-deref ref))))
(when a
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 2ecd92c..5035850 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -73,9 +73,9 @@
;; M-x list-packages
;; Enters a mode similar to buffer-menu which lets you manage
;; packages. You can choose packages for install (mark with "i",
-;; then "x" to execute) or deletion (not implemented yet), and you
-;; can see what packages are available. This will automatically
-;; fetch the latest list of packages from ELPA.
+;; then "x" to execute) or deletion, and you can see what packages
+;; are available. This will automatically fetch the latest list of
+;; packages from ELPA.
;;
;; M-x package-install-from-buffer
;; Install a package consisting of a single .el file that appears
@@ -89,7 +89,7 @@
;; Install a package from the indicated file. The package can be
;; either a tar file or a .el file. A tar file must contain an
;; appropriately-named "-pkg.el" file; a .el file must be properly
-;; formatted as with package-install-from-buffer.
+;; formatted as with `package-install-from-buffer'.
;;; Thanks:
;;; (sorted by sort-lines):
@@ -225,7 +225,7 @@ security."
:type '(alist :key-type (string :tag "Archive name")
:value-type (string :tag "URL or directory name"))
:risky t
- :version "26.1") ; gnutls test
+ :version "28.1")
(defcustom package-menu-hide-low-priority 'archive
"If non-nil, hide low priority packages from the packages menu.
@@ -396,6 +396,12 @@ a sane initial value."
:version "25.1"
:type '(repeat symbol))
+(defcustom package-native-compile nil
+ "Non-nil means to native compile packages on installation."
+ :type '(boolean)
+ :risky t
+ :version "28.1")
+
(defcustom package-menu-async t
"If non-nil, package-menu will use async operations when possible.
Currently, only the refreshing of archive contents supports
@@ -829,8 +835,6 @@ correspond to previously loaded files (those returned by
;; Don't return nil.
t)))
-(declare-function find-library-name "find-func" (library))
-
(defun package--files-load-history ()
(delq nil
(mapcar (lambda (x)
@@ -840,20 +844,22 @@ correspond to previously loaded files (those returned by
load-history)))
(defun package--list-of-conflicts (dir history)
- (delq
- nil
- (mapcar
- (lambda (x) (let* ((file (file-relative-name x dir))
- ;; Previously loaded file, if any.
- (previous
- (ignore-errors
- (file-name-sans-extension
- (file-truename (find-library-name file)))))
- (pos (when previous (member previous history))))
- ;; Return (RELATIVE-FILENAME . HISTORY-POSITION)
- (when pos
- (cons (file-name-sans-extension file) (length pos)))))
- (directory-files-recursively dir "\\`[^\\.].*\\.el\\'"))))
+ (require 'find-func)
+ (declare-function find-library-name "find-func" (library))
+ (delq
+ nil
+ (mapcar
+ (lambda (x) (let* ((file (file-relative-name x dir))
+ ;; Previously loaded file, if any.
+ (previous
+ (ignore-error file-error ;"Can't find library"
+ (file-name-sans-extension
+ (file-truename (find-library-name file)))))
+ (pos (when previous (member previous history))))
+ ;; Return (RELATIVE-FILENAME . HISTORY-POSITION)
+ (when pos
+ (cons (file-name-sans-extension file) (length pos)))))
+ (directory-files-recursively dir "\\`[^\\.].*\\.el\\'"))))
(defun package--list-loaded-files (dir)
"Recursively list all files in DIR which correspond to loaded features.
@@ -985,6 +991,8 @@ untar into a directory named DIR; otherwise, signal an
error."
;; E.g. for multi-package installs, we should first install all
packages
;; and then compile them.
(package--compile new-desc)
+ (when package-native-compile
+ (package--native-compile-async new-desc))
;; After compilation, load again any files loaded by
;; `activate-1', so that we use the byte-compiled definitions.
(package--load-files-for-activation new-desc :reload)))
@@ -1069,6 +1077,15 @@ This assumes that `pkg-desc' has already been activated
with
(load-path load-path))
(byte-recompile-directory (package-desc-dir pkg-desc) 0 t)))
+(defun package--native-compile-async (pkg-desc)
+ "Native compile installed package PKG-DESC asynchronously.
+This assumes that `pkg-desc' has already been activated with
+`package-activate-1'."
+ (when (and (featurep 'nativecomp)
+ (native-comp-available-p))
+ (let ((warning-minimum-level :error))
+ (native-compile-async (package-desc-dir pkg-desc) t))))
+
;;;; Inferring package from current buffer
(defun package-read-from-string (str)
"Read a Lisp expression from STR.
@@ -2243,6 +2260,17 @@ confirmation to install packages."
(equal (cadr (assq (package-desc-name pkg) package-alist))
pkg))
+(declare-function comp-el-to-eln-filename "comp.c")
+(defun package--delete-directory (dir)
+ "Delete DIR recursively.
+Clean-up the corresponding .eln files if Emacs is native
+compiled."
+ (when (featurep 'nativecomp)
+ (cl-loop
+ for file in (directory-files-recursively dir ".el\\'")
+ do (comp-clean-up-stale-eln (comp-el-to-eln-filename file))))
+ (delete-directory dir t))
+
(defun package-delete (pkg-desc &optional force nosave)
"Delete package PKG-DESC.
@@ -2295,7 +2323,7 @@ If NOSAVE is non-nil, the package is not removed from
(package-desc-name pkg-used-elsewhere-by)))
(t
(add-hook 'post-command-hook #'package-menu--post-refresh)
- (delete-directory dir t)
+ (package--delete-directory dir)
;; Remove NAME-VERSION.signed and NAME-readme.txt files.
;;
;; NAME-readme.txt files are no longer created, but they
@@ -2696,9 +2724,9 @@ PROPERTIES are passed to `insert-text-button', for which
this
function is a convenience wrapper used by `describe-package-1'."
(let ((button-text (if (display-graphic-p) text (concat "[" text "]")))
(button-face (if (display-graphic-p)
- '(:box (:line-width 2 :color "dark grey")
- :background "light grey"
- :foreground "black")
+ (progn
+ (require 'cus-edit) ; for the custom-button face
+ 'custom-button)
'link)))
(apply #'insert-text-button button-text 'face button-face 'follow-link t
properties)))
@@ -4118,7 +4146,8 @@ activations need to be changed, such as when
`package-load-list' is modified."
(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 "(let ((load-true-file-name " pfile ")\
+(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)
diff --git a/lisp/emacs-lisp/ring.el b/lisp/emacs-lisp/ring.el
index 9689465..ea27bb3 100644
--- a/lisp/emacs-lisp/ring.el
+++ b/lisp/emacs-lisp/ring.el
@@ -248,8 +248,6 @@ If SEQ is already a ring, return it."
(ring-insert-at-beginning ring (elt seq count))))
ring)))
-;;; provide ourself:
-
(provide 'ring)
;;; ring.el ends here
diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el
index 56e588e..1e3eb9c 100644
--- a/lisp/emacs-lisp/rx.el
+++ b/lisp/emacs-lisp/rx.el
@@ -1210,7 +1210,7 @@ unmatchable Never match anything at all.
CHARCLASS Match a character from a character class. One of:
alpha, alphabetic, letter Alphabetic characters (defined by Unicode).
alnum, alphanumeric Alphabetic or decimal digit chars (Unicode).
- digit numeric, num 0-9.
+ digit, numeric, num 0-9.
xdigit, hex-digit, hex 0-9, A-F, a-f.
cntrl, control ASCII codes 0-31.
blank Horizontal whitespace (Unicode).
diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el
index 2b8807f..6c15463 100644
--- a/lisp/emacs-lisp/seq.el
+++ b/lisp/emacs-lisp/seq.el
@@ -147,6 +147,7 @@ the sequence, and its index within the sequence."
"Return a shallow copy of SEQUENCE."
(copy-sequence sequence))
+;;;###autoload
(cl-defgeneric seq-subseq (sequence start &optional end)
"Return the sequence of elements of SEQUENCE from START to END.
END is exclusive.
@@ -430,6 +431,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if
nil."
(setq index (1+ index)))
nil)))
+;;;###autoload
(cl-defgeneric seq-uniq (sequence &optional testfn)
"Return a list of the elements of SEQUENCE with duplicates removed.
TESTFN is used to compare elements, or `equal' if TESTFN is nil."
@@ -467,6 +469,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if
nil."
(seq-reverse sequence1)
'()))
+;;;###autoload
(cl-defgeneric seq-difference (sequence1 sequence2 &optional testfn)
"Return a list of the elements that appear in SEQUENCE1 but not in SEQUENCE2.
Equality is defined by TESTFN if non-nil or by `equal' if nil."
diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el
index 86d5130..9b31d68 100644
--- a/lisp/emacs-lisp/shortdoc.el
+++ b/lisp/emacs-lisp/shortdoc.el
@@ -1252,7 +1252,7 @@ Example:
(define-key map (kbd "C-c C-n") 'shortdoc-next-section)
(define-key map (kbd "C-c C-p") 'shortdoc-previous-section)
map)
- "Keymap for `shortdoc-mode'")
+ "Keymap for `shortdoc-mode'.")
(define-derived-mode shortdoc-mode special-mode "shortdoc"
"Mode for shortdoc.")
@@ -1269,23 +1269,27 @@ Example:
(setq ,arg (1- ,arg)))))
(defun shortdoc-next (&optional arg)
- "Move cursor to next function."
+ "Move cursor to the next function.
+With ARG, do it that many times."
(interactive "p")
(shortdoc--goto-section arg 'shortdoc-function))
(defun shortdoc-previous (&optional arg)
- "Move cursor to previous function."
+ "Move cursor to the previous function.
+With ARG, do it that many times."
(interactive "p")
(shortdoc--goto-section arg 'shortdoc-function t)
(backward-char 1))
(defun shortdoc-next-section (&optional arg)
- "Move cursor to next section."
+ "Move cursor to the next section.
+With ARG, do it that many times."
(interactive "p")
(shortdoc--goto-section arg 'shortdoc-section))
(defun shortdoc-previous-section (&optional arg)
- "Move cursor to previous section."
+ "Move cursor to the previous section.
+With ARG, do it that many times."
(interactive "p")
(shortdoc--goto-section arg 'shortdoc-section t)
(forward-line -2))
diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el
index 9944330..ab3cb3c 100644
--- a/lisp/emacs-lisp/smie.el
+++ b/lisp/emacs-lisp/smie.el
@@ -57,7 +57,7 @@
;;
;; SMIE: Weakness is Power! Auto-indentation with incomplete information
;; Stefan Monnier, <Programming> Journal 2020, volumn 5, issue 1.
-;; doi: 10.22152/programming-journal.org/2020/5/1
+;; doi: 10.22152/programming-journal.org/2021/5/1
;; A good background to understand the development (especially the parts
;; building the 2D precedence tables and then computing the precedence levels
@@ -68,7 +68,7 @@
;; OTOH we had to kill many chickens, read many coffee grounds, and practice
;; untold numbers of black magic spells, to come up with the indentation code.
;; Since then, some of that code has been beaten into submission, but the
-;; smie-indent-keyword is still pretty obscure.
+;; `smie-indent-keyword' function is still pretty obscure.
;; Conflict resolution:
@@ -247,7 +247,7 @@ be either:
;; (exp (exp (or "+" "*" "=" ..) exp)).
;; Basically, make it EBNF (except for the specification of a separator in
;; the repetition, maybe).
- (let* ((nts (mapcar 'car bnf)) ;Non-terminals.
+ (let* ((nts (mapcar #'car bnf)) ;Non-terminals.
(first-ops-table ())
(last-ops-table ())
(first-nts-table ())
@@ -266,7 +266,7 @@ be either:
(push resolver precs))
(t (error "Unknown resolver %S" resolver))))
(apply #'smie-merge-prec2s over
- (mapcar 'smie-precs->prec2 precs))))
+ (mapcar #'smie-precs->prec2 precs))))
again)
(dolist (rules bnf)
(let ((nt (car rules))
@@ -497,7 +497,7 @@ CSTS is a list of pairs representing arcs in a graph."
res))
cycle)))
(mapconcat
- (lambda (elems) (mapconcat 'identity elems "="))
+ (lambda (elems) (mapconcat #'identity elems "="))
(append names (list (car names)))
" < ")))
@@ -567,7 +567,7 @@ PREC2 is a table as returned by `smie-precs->prec2' or
;; Then eliminate trivial constraints iteratively.
(let ((i 0))
(while csts
- (let ((rhvs (mapcar 'cdr csts))
+ (let ((rhvs (mapcar #'cdr csts))
(progress nil))
(dolist (cst csts)
(unless (memq (car cst) rhvs)
@@ -657,8 +657,8 @@ use syntax-tables to handle them in efficient C code.")
Same calling convention as `smie-forward-token-function' except
it should move backward to the beginning of the previous token.")
-(defalias 'smie-op-left 'car)
-(defalias 'smie-op-right 'cadr)
+(defalias 'smie-op-left #'car)
+(defalias 'smie-op-right #'cadr)
(defun smie-default-backward-token ()
(forward-comment (- (point)))
@@ -974,8 +974,7 @@ I.e. a good choice can be:
(defcustom smie-blink-matching-inners t
"Whether SMIE should blink to matching opener for inner keywords.
If non-nil, it will blink not only for \"begin..end\" but also for
\"if...else\"."
- :type 'boolean
- :group 'smie)
+ :type 'boolean)
(defun smie-blink-matching-check (start end)
(save-excursion
@@ -1141,8 +1140,7 @@ OPENER is non-nil if TOKEN is an opener and nil if it's a
closer."
(defcustom smie-indent-basic 4
"Basic amount of indentation."
- :type 'integer
- :group 'smie)
+ :type 'integer)
(defvar smie-rules-function #'ignore
"Function providing the indentation rules.
@@ -1189,7 +1187,7 @@ designed specifically for use in this function.")
(and ;; (looking-at comment-start-skip) ;(bug#16041).
(forward-comment (point-max))))))
-(defalias 'smie-rule-hanging-p 'smie-indent--hanging-p)
+(defalias 'smie-rule-hanging-p #'smie-indent--hanging-p)
(defun smie-indent--hanging-p ()
"Return non-nil if the current token is \"hanging\".
A hanging keyword is one that's at the end of a line except it's not at
@@ -1205,7 +1203,7 @@ the beginning of a line."
(funcall smie--hanging-eolp-function)
(point))))))
-(defalias 'smie-rule-bolp 'smie-indent--bolp)
+(defalias 'smie-rule-bolp #'smie-indent--bolp)
(defun smie-indent--bolp ()
"Return non-nil if the current token is the first on the line."
(save-excursion (skip-chars-backward " \t") (bolp)))
@@ -1421,7 +1419,7 @@ BASE-POS is the position relative to which offsets should
be applied."
(forward-sexp 1)
nil)
((eobp) nil)
- (t (error "Bumped into unknown token")))))
+ (t (error "Bumped into unknown token: %S" tok)))))
(defun smie-indent-backward-token ()
"Skip token backward and return it, along with its levels."
@@ -1810,9 +1808,11 @@ Each function is called with no argument, shouldn't move
point, and should
return either nil if it has no opinion, or an integer representing the column
to which that point should be aligned, if we were to reindent it.")
+(defalias 'smie--funcall #'funcall) ;Debugging/tracing convenience indirection.
+
(defun smie-indent-calculate ()
"Compute the indentation to use for point."
- (run-hook-with-args-until-success 'smie-indent-functions))
+ (run-hook-wrapped 'smie-indent-functions #'smie--funcall))
(defun smie-indent-line ()
"Indent current line using the SMIE indentation engine."
@@ -2016,7 +2016,7 @@ value with which to replace it."
;; FIXME improve value-type.
:type '(choice (const nil)
(alist :key-type symbol))
- :initialize 'custom-initialize-set
+ :initialize #'custom-initialize-set
:set #'smie-config--setter)
(defun smie-config-local (rules)
diff --git a/lisp/emacs-lisp/tabulated-list.el
b/lisp/emacs-lisp/tabulated-list.el
index 0c299b4..0b10dfd 100644
--- a/lisp/emacs-lisp/tabulated-list.el
+++ b/lisp/emacs-lisp/tabulated-list.el
@@ -410,8 +410,7 @@ specified by `tabulated-list-sort-key'. It then erases the
buffer and inserts the entries with `tabulated-list-printer'.
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.
+to the entry with the same ID element as the current line.
Non-nil UPDATE argument means to use an alternative printing
method which is faster if most entries haven't changed since the
@@ -424,18 +423,10 @@ changing `tabulated-list-sort-key'."
(funcall tabulated-list-entries)
tabulated-list-entries))
(sorter (tabulated-list--get-sorter))
- entry-id saved-pt saved-col window-line)
+ entry-id saved-pt saved-col)
(and remember-pos
(setq entry-id (tabulated-list-get-id))
- (setq saved-col (current-column))
- (when (eq (window-buffer) (current-buffer))
- (setq window-line
- (save-excursion
- (save-restriction
- (widen)
- (narrow-to-region (window-start) (point))
- (goto-char (point-min))
- (vertical-motion (buffer-size)))))))
+ (setq saved-col (current-column)))
;; Sort the entries, if necessary.
(when sorter
(setq entries (sort entries sorter)))
@@ -490,9 +481,7 @@ changing `tabulated-list-sort-key'."
;; If REMEMBER-POS was specified, move to the "old" location.
(if saved-pt
(progn (goto-char saved-pt)
- (move-to-column saved-col)
- (when window-line
- (recenter window-line)))
+ (move-to-column saved-col))
(goto-char (point-min)))))
(defun tabulated-list-print-entry (id cols)
diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el
index d9db1d3..4460fef 100644
--- a/lisp/emacs-lisp/tcover-ses.el
+++ b/lisp/emacs-lisp/tcover-ses.el
@@ -1,4 +1,4 @@
-;;;; testcover-ses.el -- Example use of `testcover' to test "SES" -*-
lexical-binding: t; -*-
+;;; tcover-ses.el --- Example use of `testcover' to test "SES" -*-
lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -716,4 +716,4 @@ spreadsheet files with invalid formatting."
;;Could do this here: (testcover-end "ses.el")
(message "Done"))
-;;; testcover-ses.el ends here.
+;;; tcover-ses.el ends here
diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el
index 75b27d0..e75f151 100644
--- a/lisp/emacs-lisp/testcover.el
+++ b/lisp/emacs-lisp/testcover.el
@@ -1,4 +1,4 @@
-;;;; testcover.el -- Visual code-coverage tool -*- lexical-binding:t -*-
+;;; testcover.el --- Visual code-coverage tool -*- lexical-binding:t -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -675,4 +675,4 @@ The list is 1valued if all of its constituent elements are
also 1valued."
(testcover-analyze-coverage (cadr form)))
(t (testcover-analyze-coverage-backquote form))))
-;; testcover.el ends here.
+;;; testcover.el ends here
diff --git a/lisp/emacs-lisp/text-property-search.el
b/lisp/emacs-lisp/text-property-search.el
index e909e4b..69943a8 100644
--- a/lisp/emacs-lisp/text-property-search.el
+++ b/lisp/emacs-lisp/text-property-search.el
@@ -214,3 +214,5 @@ and if a matching region is found, place point at its end."
(funcall predicate value prop-value))
(provide 'text-property-search)
+
+;;; text-property-search.el ends here
diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el
index d52a6c7..fa4e058 100644
--- a/lisp/emacs-lisp/unsafep.el
+++ b/lisp/emacs-lisp/unsafep.el
@@ -1,4 +1,4 @@
-;;;; unsafep.el -- Determine whether a Lisp form is safe to evaluate -*-
lexical-binding: t; -*-
+;;; unsafep.el --- Determine whether a Lisp form is safe to evaluate -*-
lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
diff --git a/lisp/emulation/edt-mapper.el b/lisp/emulation/edt-mapper.el
index 0b15278..a723dbd 100644
--- a/lisp/emulation/edt-mapper.el
+++ b/lisp/emulation/edt-mapper.el
@@ -26,7 +26,7 @@
;; [Part of the GNU Emacs EDT Emulation.]
-;; This emacs lisp program can be used to create an emacs lisp file
+;; This Emacs Lisp program can be used to create an Emacs Lisp file
;; that defines the mapping of the user's keyboard to the LK-201
;; keyboard function keys and keypad keys (around which EDT has been
;; designed). Please read the "Usage" AND "Known Problems" sections
diff --git a/lisp/emulation/edt.el b/lisp/emulation/edt.el
index 50979c4..f11afb1 100644
--- a/lisp/emulation/edt.el
+++ b/lisp/emulation/edt.el
@@ -178,9 +178,6 @@
(defvar edt-user-global-map)
(defvar rect-start-point)
-(defconst edt-version "4.0" "EDT Emulation version number.")
-(make-obsolete-variable 'edt-version nil "28.1")
-
;;;
;;; User Configurable Variables
;;;
@@ -2533,6 +2530,9 @@ G-C-\\: Split Window | FNDNXT |
Yank | CUT |
(set-frame-width nil 132)
(message "Terminal width 132"))
+(defconst edt-version "4.0" "EDT Emulation version number.")
+(make-obsolete-variable 'edt-version 'emacs-version "28.1")
+
(provide 'edt)
;;; edt.el ends here
diff --git a/lisp/epa-file.el b/lisp/epa-file.el
index e46e368..33bf5ad 100644
--- a/lisp/epa-file.el
+++ b/lisp/epa-file.el
@@ -198,7 +198,9 @@ encryption is used."
(mapcar #'car (epg-context-result-for
context 'encrypted-to)))
(if (or beg end)
- (setq string (substring string (or beg 0) end)))
+ (setq string (substring string
+ (or beg 0)
+ (and end (min end (length string))))))
(save-excursion
;; If visiting, bind off buffer-file-name so that
;; file-locking will not ask whether we should
diff --git a/lisp/epa-mail.el b/lisp/epa-mail.el
index 7e10056..7eac1f8 100644
--- a/lisp/epa-mail.el
+++ b/lisp/epa-mail.el
@@ -59,7 +59,7 @@ Otherwise, signal an error."
;;;###autoload
(define-minor-mode epa-mail-mode
"A minor-mode for composing encrypted/clearsigned mails."
- nil " epa-mail" epa-mail-mode-map)
+ :lighter " epa-mail")
;;; Utilities
diff --git a/lisp/epg-config.el b/lisp/epg-config.el
index 59d097c..d32c8c8 100644
--- a/lisp/epg-config.el
+++ b/lisp/epg-config.el
@@ -1,4 +1,4 @@
-;;; epg-config.el --- configuration of the EasyPG Library
+;;; epg-config.el --- configuration of the EasyPG Library -*-
lexical-binding: t -*-
;; Copyright (C) 2006-2021 Free Software Foundation, Inc.
@@ -21,6 +21,8 @@
;; 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:
;;; Prelude
@@ -157,7 +159,7 @@ version requirement is met."
(setq program-alist epg-config--program-alist))
(let ((entry (assq protocol program-alist)))
(unless entry
- (error "Unknown protocol %S" protocol))
+ (error "Unknown protocol `%S'" protocol))
(cl-destructuring-bind (symbol . alist)
(cdr entry)
(let ((constructor
diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el
index b1f97ae..ea9f9a3 100644
--- a/lisp/erc/erc-backend.el
+++ b/lisp/erc/erc-backend.el
@@ -138,6 +138,13 @@ Use `erc-current-nick' to access this.")
(defvar-local erc-session-port nil
"The port used to connect to.")
+(defvar-local erc-session-client-certificate nil
+ "TLS client certificate used when connecting over TLS.
+If non-nil, should either be a list where the first element is
+the certificate key file name, and the second element is the
+certificate file name itself, or t, which means that
+`auth-source' will be queried for the key and the certificate.")
+
(defvar-local erc-server-announced-name nil
"The name the server announced to use.")
@@ -505,18 +512,23 @@ The current buffer is given by BUFFER."
(memq (process-status erc-server-process) '(run open)))))
;;;; Connecting to a server
-(defun erc-open-network-stream (name buffer host service)
- "As `open-network-stream', but does non-blocking IO"
- (make-network-process :name name :buffer buffer
- :host host :service service :nowait t))
+(defun erc-open-network-stream (name buffer host service &rest parameters)
+ "Like `open-network-stream', but does non-blocking IO."
+ (let ((p (plist-put parameters :nowait t)))
+ (apply #'open-network-stream name buffer host service p)))
-(defun erc-server-connect (server port buffer)
+(defun erc-server-connect (server port buffer &optional client-certificate)
"Perform the connection and login using the specified SERVER and PORT.
-We will store server variables in the buffer given by BUFFER."
- (let ((msg (erc-format-message 'connect ?S server ?p port)) process)
+We will store server variables in the buffer given by BUFFER.
+CLIENT-CERTIFICATE may optionally be used to specify a TLS client
+certificate to use for authentication when connecting over
+TLS (see `erc-session-client-certificate' for more details)."
+ (let ((msg (erc-format-message 'connect ?S server ?p port)) process
+ (args `(,(format "erc-%s-%s" server port) nil ,server ,port)))
+ (when client-certificate
+ (setq args `(,@args :client-certificate ,client-certificate)))
(message "%s" msg)
- (setq process (funcall erc-server-connect-function
- (format "erc-%s-%s" server port) nil server port))
+ (setq process (apply erc-server-connect-function args))
(unless (processp process)
(error "Connection attempt failed"))
;; Misc server variables
diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el
index 044776c..cb9af92 100644
--- a/lisp/erc/erc-button.el
+++ b/lisp/erc/erc-button.el
@@ -1,4 +1,4 @@
-;; erc-button.el --- A way of buttonizing certain things in ERC buffers -*-
lexical-binding:t -*-
+;;; erc-button.el --- A way of buttonizing certain things in ERC buffers -*-
lexical-binding:t -*-
;; Copyright (C) 1996-2004, 2006-2021 Free Software Foundation, Inc.
diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el
index 234b4b5..219af37 100644
--- a/lisp/erc/erc-dcc.el
+++ b/lisp/erc/erc-dcc.el
@@ -415,33 +415,33 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc."
(pcase (intern (downcase (pcomplete-arg 1)))
('chat (mapcar (lambda (elt) (plist-get elt :nick))
(cl-remove-if-not
- #'(lambda (elt)
- (eq (plist-get elt :type) 'CHAT))
+ (lambda (elt)
+ (eq (plist-get elt :type) 'CHAT))
erc-dcc-list)))
('close (delete-dups
(mapcar (lambda (elt) (symbol-name (plist-get elt :type)))
erc-dcc-list)))
('get (mapcar #'erc-dcc-nick
(cl-remove-if-not
- #'(lambda (elt)
- (eq (plist-get elt :type) 'GET))
+ (lambda (elt)
+ (eq (plist-get elt :type) 'GET))
erc-dcc-list)))
('send (pcomplete-erc-all-nicks))))
(pcomplete-here
(pcase (intern (downcase (pcomplete-arg 2)))
('get (mapcar (lambda (elt) (plist-get elt :file))
(cl-remove-if-not
- #'(lambda (elt)
- (and (eq (plist-get elt :type) 'GET)
- (erc-nick-equal-p (erc-extract-nick
- (plist-get elt :nick))
- (pcomplete-arg 1))))
+ (lambda (elt)
+ (and (eq (plist-get elt :type) 'GET)
+ (erc-nick-equal-p (erc-extract-nick
+ (plist-get elt :nick))
+ (pcomplete-arg 1))))
erc-dcc-list)))
('close (mapcar #'erc-dcc-nick
(cl-remove-if-not
- #'(lambda (elt)
- (eq (plist-get elt :type)
- (intern (upcase (pcomplete-arg 1)))))
+ (lambda (elt)
+ (eq (plist-get elt :type)
+ (intern (upcase (pcomplete-arg 1)))))
erc-dcc-list)))
('send (pcomplete-entries)))))
diff --git a/lisp/erc/erc-desktop-notifications.el
b/lisp/erc/erc-desktop-notifications.el
index 990f013..9838b23 100644
--- a/lisp/erc/erc-desktop-notifications.el
+++ b/lisp/erc/erc-desktop-notifications.el
@@ -1,4 +1,4 @@
-;; erc-desktop-notifications.el -- Send notification on PRIVMSG or mentions
-*- lexical-binding:t -*-
+;;; erc-desktop-notifications.el --- Send notification on PRIVMSG or mentions
-*- lexical-binding:t -*-
;; Copyright (C) 2012-2021 Free Software Foundation, Inc.
diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el
index 0312d22..4125668 100644
--- a/lisp/erc/erc-fill.el
+++ b/lisp/erc/erc-fill.el
@@ -46,7 +46,6 @@ the mode if ARG is omitted or nil.
ERC fill mode is a global minor mode. When enabled, messages in
the channel buffers are filled."
- nil nil nil
:global t
(if erc-fill-mode
(erc-fill-enable)
diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el
index 1143faa..fc9a8d3 100644
--- a/lisp/erc/erc-goodies.el
+++ b/lisp/erc/erc-goodies.el
@@ -1,4 +1,4 @@
-;; erc-goodies.el --- Collection of ERC modules -*- lexical-binding: t; -*-
+;;; erc-goodies.el --- Collection of ERC modules -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/erc/erc-imenu.el b/lisp/erc/erc-imenu.el
index b2a2dc5..dcf6db7 100644
--- a/lisp/erc/erc-imenu.el
+++ b/lisp/erc/erc-imenu.el
@@ -1,4 +1,4 @@
-;;; erc-imenu.el -- Imenu support for ERC -*- lexical-binding: t; -*-
+;;; erc-imenu.el --- Imenu support for ERC -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2002, 2004, 2006-2021 Free Software Foundation,
;; Inc.
diff --git a/lisp/erc/erc-menu.el b/lisp/erc/erc-menu.el
index 0dc819f..1bee6ff 100644
--- a/lisp/erc/erc-menu.el
+++ b/lisp/erc/erc-menu.el
@@ -1,4 +1,4 @@
-;; erc-menu.el -- Menu-bar definitions for ERC -*- lexical-binding: t; -*-
+;;; erc-menu.el --- Menu-bar definitions for ERC -*- lexical-binding: t; -*-
;; Copyright (C) 2001-2002, 2004-2021 Free Software Foundation, Inc.
diff --git a/lisp/erc/erc-page.el b/lisp/erc/erc-page.el
index 4c244b7..457e8cd 100644
--- a/lisp/erc/erc-page.el
+++ b/lisp/erc/erc-page.el
@@ -1,4 +1,4 @@
-;; erc-page.el - CTCP PAGE support for ERC -*- lexical-binding: t; -*-
+;;; erc-page.el --- CTCP PAGE support for ERC -*- lexical-binding: t; -*-
;; Copyright (C) 2002, 2004, 2006-2021 Free Software Foundation, Inc.
diff --git a/lisp/erc/erc-replace.el b/lisp/erc/erc-replace.el
index d08d985..3f69c4c 100644
--- a/lisp/erc/erc-replace.el
+++ b/lisp/erc/erc-replace.el
@@ -1,4 +1,4 @@
-;; erc-replace.el -- wash and massage messages inserted into the buffer -*-
lexical-binding: t; -*-
+;;; erc-replace.el --- wash and massage messages inserted into the buffer -*-
lexical-binding: t; -*-
;; Copyright (C) 2001-2002, 2004, 2006-2021 Free Software Foundation,
;; Inc.
diff --git a/lisp/erc/erc-ring.el b/lisp/erc/erc-ring.el
index 28299ae..666fd58 100644
--- a/lisp/erc/erc-ring.el
+++ b/lisp/erc/erc-ring.el
@@ -1,4 +1,4 @@
-;; erc-ring.el -- Command history handling for erc using ring.el -*-
lexical-binding: t; -*-
+;;; erc-ring.el --- Command history handling for erc using ring.el -*-
lexical-binding: t; -*-
;; Copyright (C) 2001-2004, 2006-2021 Free Software Foundation, Inc.
diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el
index 8be5555..2364d45 100644
--- a/lisp/erc/erc-track.el
+++ b/lisp/erc/erc-track.el
@@ -464,9 +464,6 @@ 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."
- :init-value nil
- :lighter ""
- :keymap erc-track-minor-mode-map
:global t)
(defun erc-track-minor-mode-maybe (&optional buffer)
@@ -686,9 +683,9 @@ Use `erc-make-mode-line-buffer-name' to create buttons."
(let* ((buffers (mapcar #'car erc-modified-channels-alist))
(counts (mapcar #'cadr erc-modified-channels-alist))
(faces (mapcar #'cddr erc-modified-channels-alist))
- (long-names (mapcar #'(lambda (buf)
- (or (buffer-name buf)
- ""))
+ (long-names (mapcar (lambda (buf)
+ (or (buffer-name buf)
+ ""))
buffers))
(short-names (if (functionp erc-track-shorten-function)
(funcall erc-track-shorten-function
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index b6dea95..6717ee3 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -9,6 +9,7 @@
;; Andreas Fuchs (afs@void.at)
;; Gergely Nagy (algernon@midgard.debian.net)
;; David Edmondson (dme@dme.org)
+;; Michael Olson (mwolson@gnu.org)
;; Kelvin White (kwhite@gnu.org)
;; Maintainer: Amin Bandali <bandali@gnu.org>
;; Keywords: IRC, chat, client, Internet
@@ -47,11 +48,12 @@
;;
;; M-x erc RET
;;
-;; After you are connected to a server, you can use C-h m or have a look at
-;; the ERC menu.
-
-;;; History:
+;; or
+;;
+;; M-x erc-tls RET
;;
+;; to connect over TLS (encrypted). Once you are connected to a
+;; server, you can use C-h m or have a look at the ERC menu.
;;; Code:
@@ -1292,7 +1294,6 @@ 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.
%s" name name doc)
- nil nil nil
;; FIXME: We don't know if this group exists, so this `:group' may
;; actually just silence a valid warning about the fact that the var
;; is not associated with any group.
@@ -1971,7 +1972,8 @@ removed from the list will be disabled."
(switch-to-buffer buffer)))))
(defun erc-open (&optional server port nick full-name
- connect passwd tgt-list channel process)
+ connect passwd tgt-list channel process
+ client-certificate)
"Connect to SERVER on PORT as NICK with FULL-NAME.
If CONNECT is non-nil, connect to the server. Otherwise assume
@@ -1981,6 +1983,13 @@ target CHANNEL.
Use PASSWD as user password on the server. If TGT-LIST is
non-nil, use it to initialize `erc-default-recipients'.
+CLIENT-CERTIFICATE, if non-nil, should either be a list where the
+first element is the file name of the private key corresponding
+to a client certificate and the second element is the file name
+of the client certificate itself to use when connecting over TLS,
+or t, which means that `auth-source' will be queried for the
+private key and the certificate.
+
Returns the buffer for the given server or channel."
(let ((server-announced-name (when (and (boundp 'erc-session-server)
(string= server erc-session-server))
@@ -2063,6 +2072,8 @@ Returns the buffer for the given server or channel."
(if (functionp secret)
(funcall secret)
secret))))
+ ;; client certificate (only useful if connecting over TLS)
+ (setq erc-session-client-certificate client-certificate)
;; debug output buffer
(setq erc-dbuf
(when erc-log-p
@@ -2083,7 +2094,10 @@ Returns the buffer for the given server or channel."
(run-hook-with-args 'erc-connect-pre-hook buffer)
(when connect
- (erc-server-connect erc-session-server erc-session-port buffer))
+ (erc-server-connect erc-session-server
+ erc-session-port
+ buffer
+ erc-session-client-certificate))
(erc-update-mode-line)
;; Now display the buffer in a window as per user wishes.
@@ -2200,22 +2214,22 @@ parameters SERVER and NICK."
"ERC is a powerful, modular, and extensible IRC client.
This function is the main entry point for ERC.
-It permits you to select connection parameters, and then starts ERC.
+It allows selecting connection parameters, and then starts ERC.
Non-interactively, it takes the keyword arguments
(server (erc-compute-server))
(port (erc-compute-port))
(nick (erc-compute-nick))
password
- (full-name (erc-compute-full-name)))
+ (full-name (erc-compute-full-name))
That is, if called with
(erc :server \"chat.freenode.net\" :full-name \"Harry S Truman\")
-then the server and full-name will be set to those values, whereas
-`erc-compute-port', `erc-compute-nick' and `erc-compute-full-name' will
-be invoked for the values of the other parameters."
+then the server and full-name will be set to those values,
+whereas `erc-compute-port' and `erc-compute-nick' will be invoked
+for the values of the other parameters."
(interactive (erc-select-read-args))
(erc-open server port nick full-name t password))
@@ -2224,21 +2238,66 @@ be invoked for the values of the other parameters."
(defalias 'erc-ssl #'erc-tls)
;;;###autoload
-(defun erc-tls (&rest r)
- "Interactively select TLS connection parameters and run ERC.
-Arguments are the same as for `erc'."
+(cl-defun erc-tls (&key (server (erc-compute-server))
+ (port (erc-compute-port))
+ (nick (erc-compute-nick))
+ password
+ (full-name (erc-compute-full-name))
+ client-certificate)
+ "ERC is a powerful, modular, and extensible IRC client.
+This function is the main entry point for ERC over TLS.
+
+It allows selecting connection parameters, and then starts ERC
+over TLS.
+
+Non-interactively, it takes the keyword arguments
+ (server (erc-compute-server))
+ (port (erc-compute-port))
+ (nick (erc-compute-nick))
+ password
+ (full-name (erc-compute-full-name))
+ client-certificate
+
+That is, if called with
+
+ (erc-tls :server \"chat.freenode.net\" :full-name \"Harry S Truman\")
+
+then the server and full-name will be set to those values,
+whereas `erc-compute-port' and `erc-compute-nick' will be invoked
+for the values of their respective parameters.
+
+CLIENT-CERTIFICATE, if non-nil, should either be a list where the
+first element is the certificate key file name, and the second
+element is the certificate file name itself, or t, which means
+that `auth-source' will be queried for the key and the
+certificate. Authenticating using a TLS client certificate is
+also refered to as \"CertFP\" (Certificate Fingerprint)
+authentication by various IRC networks.
+
+Example usage:
+
+ (erc-tls :server \"chat.freenode.net\" :port 6697
+ :client-certificate
+ '(\"/data/bandali/my-cert.key\"
+ \"/data/bandali/my-cert.crt\"))"
(interactive (let ((erc-default-port erc-default-port-tls))
(erc-select-read-args)))
(let ((erc-server-connect-function 'erc-open-tls-stream))
- (apply #'erc r)))
+ (erc-open server port nick full-name t password
+ nil nil nil client-certificate)))
-(defun erc-open-tls-stream (name buffer host port)
+(defun erc-open-tls-stream (name buffer host port &rest parameters)
"Open an TLS stream to an IRC server.
-The process will be given the name NAME, its target buffer will be
-BUFFER. HOST and PORT specify the connection target."
- (open-network-stream name buffer host port
- :nowait t
- :type 'tls))
+The process will be given the name NAME, its target buffer will
+be BUFFER. HOST and PORT specify the connection target.
+PARAMETERS should be a sequence of keywords and values, per
+`open-network-stream'."
+ (let ((p (plist-put parameters :type 'tls))
+ args)
+ (unless (plist-member p :nowait)
+ (setq p (plist-put p :nowait t)))
+ (setq args `(,name ,buffer ,host ,port ,@p))
+ (apply #'open-network-stream args)))
;;; Displaying error messages
@@ -2324,7 +2383,7 @@ If ARG is non-nil, show the *erc-protocol* buffer."
(use-local-map (make-sparse-keymap))
(local-set-key (kbd "t") 'erc-toggle-debug-irc-protocol))
(add-hook 'kill-buffer-hook
- #'(lambda () (setq erc-debug-irc-protocol nil))
+ (lambda () (setq erc-debug-irc-protocol nil))
nil 'local)
(goto-char (point-max))
(let ((inhibit-read-only t))
@@ -2948,9 +3007,9 @@ If no USER argument is specified, list the contents of
`erc-ignore-list'."
(if (null (erc-with-server-buffer erc-ignore-list))
(erc-display-line (erc-make-notice "Ignore list is empty") 'active)
(erc-display-line (erc-make-notice "Ignore list:") 'active)
- (mapc #'(lambda (item)
- (erc-display-line (erc-make-notice item)
- 'active))
+ (mapc (lambda (item)
+ (erc-display-line (erc-make-notice item)
+ 'active))
(erc-with-server-buffer erc-ignore-list))))
t)
@@ -3132,8 +3191,8 @@ were most recently invited. See also `invitation'."
(when chnl
;; Prevent double joining of same channel on same server.
(let* ((joined-channels
- (mapcar #'(lambda (chanbuf)
- (with-current-buffer chanbuf (erc-default-target)))
+ (mapcar (lambda (chanbuf)
+ (with-current-buffer chanbuf (erc-default-target)))
(erc-channel-list erc-server-process)))
(server (with-current-buffer (process-buffer erc-server-process)
(or erc-session-server erc-server-announced-name)))
@@ -4152,9 +4211,9 @@ Displays PROC and PARSED appropriately using
`erc-display-message'."
(mapconcat
#'identity
(let (res)
- (mapc #'(lambda (x)
- (if (stringp x)
- (setq res (append res (list x)))))
+ (mapc (lambda (x)
+ (if (stringp x)
+ (setq res (append res (list x)))))
parsed)
res)
" ")))
@@ -4542,10 +4601,10 @@ See also: `erc-echo-notice-in-user-buffers',
;; Remove the unbanned masks from the ban list
(setq erc-channel-banlist
(cl-delete-if
- #'(lambda (y)
- (member (upcase (cdr y))
- (mapcar #'upcase
- (cdr (split-string mode)))))
+ (lambda (y)
+ (member (upcase (cdr y))
+ (mapcar #'upcase
+ (cdr (split-string mode)))))
erc-channel-banlist)))
((string-match "^\\+" mode)
;; Add the banned mask(s) to the ban list
diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el
index c702ee1..c04a1a6 100644
--- a/lisp/eshell/em-dirs.el
+++ b/lisp/eshell/em-dirs.el
@@ -199,10 +199,10 @@ Thus, this does not include the current directory.")
(when eshell-cd-on-directory
(setq-local eshell-interpreter-alist
- (cons (cons #'(lambda (file _args)
- (eshell-lone-directory-p file))
- 'eshell-dirs-substitute-cd)
- eshell-interpreter-alist)))
+ (cons (cons (lambda (file _args)
+ (eshell-lone-directory-p file))
+ 'eshell-dirs-substitute-cd)
+ eshell-interpreter-alist)))
(add-hook 'eshell-parse-argument-hook
#'eshell-parse-user-reference nil t)
diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el
index b7b1778..e559f5b 100644
--- a/lisp/eshell/em-hist.el
+++ b/lisp/eshell/em-hist.el
@@ -758,7 +758,7 @@ matched."
(setq nth (eshell-hist-word-reference nth)))
(unless (numberp mth)
(setq mth (eshell-hist-word-reference mth)))
- (cons (mapconcat #'identity (eshell-sublist textargs nth mth) " ")
+ (cons (mapconcat #'identity (seq-subseq textargs nth (1+ mth)) " ")
end))))
(defun eshell-hist-parse-modifier (hist reference)
diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el
index aecc8bb..0780d6e 100644
--- a/lisp/eshell/em-pred.el
+++ b/lisp/eshell/em-pred.el
@@ -85,18 +85,18 @@ ordinary strings."
(?s . (eshell-pred-file-mode #o4000)) ; setuid
(?S . (eshell-pred-file-mode #o2000)) ; setgid
(?t . (eshell-pred-file-mode #o1000)) ; sticky bit
- (?U . #'(lambda (file) ; owned by effective uid
- (if (file-exists-p file)
- (= (file-attribute-user-id (file-attributes file))
- (user-uid)))))
- ;; (?G . #'(lambda (file) ; owned by effective gid
- ;; (if (file-exists-p file)
- ;; (= (file-attribute-user-id (file-attributes file))
- ;; (user-uid)))))
- (?* . #'(lambda (file)
- (and (file-regular-p file)
- (not (file-symlink-p file))
- (file-executable-p file))))
+ (?U . (lambda (file) ; owned by effective uid
+ (if (file-exists-p file)
+ (= (file-attribute-user-id (file-attributes file))
+ (user-uid)))))
+ ;; (?G . (lambda (file) ; owned by effective gid
+ ;; (if (file-exists-p file)
+ ;; (= (file-attribute-user-id (file-attributes file))
+ ;; (user-uid)))))
+ (?* . (lambda (file)
+ (and (file-regular-p file)
+ (not (file-symlink-p file))
+ (file-executable-p file))))
(?l . (eshell-pred-file-links))
(?u . (eshell-pred-user-or-group ?u "user" 2 'eshell-user-id))
(?g . (eshell-pred-user-or-group ?g "group" 3 'eshell-group-id))
@@ -114,25 +114,25 @@ The format of each entry is
(put 'eshell-predicate-alist 'risky-local-variable t)
(defcustom eshell-modifier-alist
- '((?E . #'(lambda (lst)
- (mapcar
- (lambda (str)
- (eshell-stringify
- (car (eshell-parse-argument str))))
- lst)))
- (?L . #'(lambda (lst) (mapcar 'downcase lst)))
- (?U . #'(lambda (lst) (mapcar 'upcase lst)))
- (?C . #'(lambda (lst) (mapcar 'capitalize lst)))
- (?h . #'(lambda (lst) (mapcar 'file-name-directory lst)))
+ '((?E . (lambda (lst)
+ (mapcar
+ (lambda (str)
+ (eshell-stringify
+ (car (eshell-parse-argument str))))
+ lst)))
+ (?L . (lambda (lst) (mapcar #'downcase lst)))
+ (?U . (lambda (lst) (mapcar #'upcase lst)))
+ (?C . (lambda (lst) (mapcar #'capitalize lst)))
+ (?h . (lambda (lst) (mapcar #'file-name-directory lst)))
(?i . (eshell-include-members))
(?x . (eshell-include-members t))
- (?r . #'(lambda (lst) (mapcar 'file-name-sans-extension lst)))
- (?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-uniquify-list lst)))
- (?o . #'(lambda (lst) (sort lst 'string-lessp)))
- (?O . #'(lambda (lst) (nreverse (sort lst 'string-lessp))))
+ (?r . (lambda (lst) (mapcar #'file-name-sans-extension lst)))
+ (?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) (seq-uniq lst)))
+ (?o . (lambda (lst) (sort lst #'string-lessp)))
+ (?O . (lambda (lst) (nreverse (sort lst #'string-lessp))))
(?j . (eshell-join-members))
(?S . (eshell-split-members))
(?R . 'reverse)
diff --git a/lisp/eshell/em-script.el b/lisp/eshell/em-script.el
index aecc486..1f08e89 100644
--- a/lisp/eshell/em-script.el
+++ b/lisp/eshell/em-script.el
@@ -59,11 +59,12 @@ This includes when running `eshell-command'."
(defun eshell-script-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the script parsing code."
(setq-local eshell-interpreter-alist
- (cons (cons #'(lambda (file _args)
- (string= (file-name-nondirectory file)
- "eshell"))
- 'eshell/source)
- eshell-interpreter-alist))
+ (cons (cons (lambda (file _args)
+ (and (file-regular-p file)
+ (string= (file-name-nondirectory file)
+ "eshell")))
+ 'eshell/source)
+ eshell-interpreter-alist))
(setq-local eshell-complex-commands
(append '("source" ".") eshell-complex-commands))
;; these two variables are changed through usage, but we don't want
diff --git a/lisp/eshell/em-xtra.el b/lisp/eshell/em-xtra.el
index fa3218b..f58e1b8 100644
--- a/lisp/eshell/em-xtra.el
+++ b/lisp/eshell/em-xtra.el
@@ -23,13 +23,10 @@
;;; Code:
+(require 'cl-lib)
(require 'esh-util)
(eval-when-compile
(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
;; custom groups.
@@ -49,50 +46,45 @@ naturally accessible within Emacs."
(defun eshell/expr (&rest args)
"Implementation of expr, using the calc package."
- (if (not (fboundp 'calc-eval))
- (throw 'eshell-replace-command
- (eshell-parse-command "*expr" (flatten-tree args)))
- ;; to fool the byte-compiler...
- (let ((func 'calc-eval))
- (funcall func (eshell-flatten-and-stringify args)))))
+ (calc-eval (eshell-flatten-and-stringify args)))
(defun eshell/substitute (&rest args)
- "Easy front-end to `intersection', for comparing lists of strings."
- (apply 'substitute (car args) (cadr args) :test 'equal
+ "Easy front-end to `cl-substitute', for comparing lists of strings."
+ (apply #'cl-substitute (car args) (cadr args) :test #'equal
(cddr args)))
(defun eshell/count (&rest args)
- "Easy front-end to `intersection', for comparing lists of strings."
- (apply 'count (car args) (cadr args) :test 'equal
+ "Easy front-end to `cl-count', for comparing lists of strings."
+ (apply #'cl-count (car args) (cadr args) :test #'equal
(cddr args)))
(defun eshell/mismatch (&rest args)
- "Easy front-end to `intersection', for comparing lists of strings."
- (apply 'mismatch (car args) (cadr args) :test 'equal
+ "Easy front-end to `cl-mismatch', for comparing lists of strings."
+ (apply #'cl-mismatch (car args) (cadr args) :test #'equal
(cddr args)))
(defun eshell/union (&rest args)
- "Easy front-end to `intersection', for comparing lists of strings."
- (apply 'union (car args) (cadr args) :test 'equal
+ "Easy front-end to `cl-union', for comparing lists of strings."
+ (apply #'cl-union (car args) (cadr args) :test #'equal
(cddr args)))
(defun eshell/intersection (&rest args)
- "Easy front-end to `intersection', for comparing lists of strings."
- (apply 'intersection (car args) (cadr args) :test 'equal
+ "Easy front-end to `cl-intersection', for comparing lists of strings."
+ (apply #'cl-intersection (car args) (cadr args) :test #'equal
(cddr args)))
(defun eshell/set-difference (&rest args)
- "Easy front-end to `intersection', for comparing lists of strings."
- (apply 'set-difference (car args) (cadr args) :test 'equal
+ "Easy front-end to `cl-set-difference', for comparing lists of strings."
+ (apply #'cl-set-difference (car args) (cadr args) :test #'equal
(cddr args)))
(defun eshell/set-exclusive-or (&rest args)
- "Easy front-end to `intersection', for comparing lists of strings."
- (apply 'set-exclusive-or (car args) (cadr args) :test 'equal
+ "Easy front-end to `cl-set-exclusive-or', for comparing lists of strings."
+ (apply #'cl-set-exclusive-or (car args) (cadr args) :test #'equal
(cddr args)))
-(defalias 'eshell/ff 'find-name-dired)
-(defalias 'eshell/gf 'find-grep-dired)
+(defalias 'eshell/ff #'find-name-dired)
+(defalias 'eshell/gf #'find-grep-dired)
(provide 'em-xtra)
diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el
index 3693829..96c9a60 100644
--- a/lisp/eshell/esh-proc.el
+++ b/lisp/eshell/esh-proc.el
@@ -37,23 +37,19 @@ finish."
(defcustom eshell-proc-load-hook nil
"A hook that gets run when `eshell-proc' is loaded."
:version "24.1" ; removed eshell-proc-initialize
- :type 'hook
- :group 'eshell-proc)
+ :type 'hook)
(defcustom eshell-process-wait-seconds 0
"The number of seconds to delay waiting for a synchronous process."
- :type 'integer
- :group 'eshell-proc)
+ :type 'integer)
(defcustom eshell-process-wait-milliseconds 50
"The number of milliseconds to delay waiting for a synchronous process."
- :type 'integer
- :group 'eshell-proc)
+ :type 'integer)
(defcustom eshell-done-messages-in-minibuffer t
"If non-nil, subjob \"Done\" messages will display in minibuffer."
- :type 'boolean
- :group 'eshell-proc)
+ :type 'boolean)
(defcustom eshell-delete-exited-processes t
"If nil, process entries will stick around until `jobs' is run.
@@ -72,14 +68,12 @@ subjob is done is that it will no longer appear in the
Note that Eshell will have to be restarted for a change in this
variable's value to take effect."
- :type 'boolean
- :group 'eshell-proc)
+ :type 'boolean)
(defcustom eshell-reset-signals
"^\\(interrupt\\|killed\\|quit\\|stopped\\)"
"If a termination signal matches this regexp, the terminal will be reset."
- :type 'regexp
- :group 'eshell-proc)
+ :type 'regexp)
(defcustom eshell-exec-hook nil
"Called each time a process is exec'd by `eshell-gather-process-output'.
@@ -88,8 +82,7 @@ It is useful for things that must be done each time a process
is
executed in an eshell mode buffer (e.g., `set-process-query-on-exit-flag').
In contrast, `eshell-mode-hook' is only executed once, when the buffer
is created."
- :type 'hook
- :group 'eshell-proc)
+ :type 'hook)
(defcustom eshell-kill-hook nil
"Called when a process run by `eshell-gather-process-output' has ended.
@@ -99,8 +92,7 @@ nil, in which case the user attempted to send a signal, but
there was
no relevant process. This can be used for displaying help
information, for example."
:version "24.1" ; removed eshell-reset-after-proc
- :type 'hook
- :group 'eshell-proc)
+ :type 'hook)
;;; Internal Variables:
@@ -126,8 +118,7 @@ information, for example."
Runs `eshell-reset-after-proc' and `eshell-kill-hook', passing arguments
PROC and STATUS to functions on the latter."
;; Was there till 24.1, but it is not optional.
- (if (memq #'eshell-reset-after-proc eshell-kill-hook)
- (setq eshell-kill-hook (delq #'eshell-reset-after-proc
eshell-kill-hook)))
+ (remove-hook 'eshell-kill-hook #'eshell-reset-after-proc)
(eshell-reset-after-proc status)
(run-hook-with-args 'eshell-kill-hook proc status))
@@ -165,7 +156,7 @@ The signals which will cause this to happen are matched by
eshell-process-wait-milliseconds))))
(setq procs (cdr procs))))
-(defalias 'eshell/wait 'eshell-wait-for-process)
+(defalias 'eshell/wait #'eshell-wait-for-process)
(defun eshell/jobs (&rest _args)
"List processes, if there are any."
@@ -457,8 +448,7 @@ If QUERY is non-nil, query the user with QUERY before
calling FUNC."
(defcustom eshell-kill-process-wait-time 5
"Seconds to wait between sending termination signals to a subprocess."
- :type 'integer
- :group 'eshell-proc)
+ :type 'integer)
(defcustom eshell-kill-process-signals '(SIGINT SIGQUIT SIGKILL)
"Signals used to kill processes when an Eshell buffer exits.
@@ -466,8 +456,7 @@ Eshell calls each of these signals in order when an Eshell
buffer is
killed; if the process is still alive afterwards, Eshell waits a
number of seconds defined by `eshell-kill-process-wait-time', and
tries the next signal in the list."
- :type '(repeat symbol)
- :group 'eshell-proc)
+ :type '(repeat symbol))
(defcustom eshell-kill-processes-on-exit nil
"If non-nil, kill active processes when exiting an Eshell buffer.
@@ -489,8 +478,7 @@ long to delay between signals."
:type '(choice (const :tag "Kill all, don't ask" t)
(const :tag "Ask before killing" ask)
(const :tag "Ask for each process" every)
- (const :tag "Don't kill subprocesses" nil))
- :group 'eshell-proc)
+ (const :tag "Don't kill subprocesses" nil)))
(defun eshell-round-robin-kill (&optional query)
"Kill current process by trying various signals in sequence.
diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el
index 8ef1ac9..3010481 100644
--- a/lisp/eshell/esh-util.el
+++ b/lisp/eshell/esh-util.el
@@ -23,6 +23,7 @@
;;; Code:
+(require 'seq)
(eval-when-compile (require 'cl-lib))
(defgroup eshell-util nil
@@ -37,25 +38,21 @@
If nil, t will be represented only in the exit code of the function,
and not printed as a string. This causes Lisp functions to behave
similarly to external commands, as far as successful result output."
- :type 'boolean
- :group 'eshell-util)
+ :type 'boolean)
(defcustom eshell-group-file "/etc/group"
"If non-nil, the name of the group file on your system."
- :type '(choice (const :tag "No group file" nil) file)
- :group 'eshell-util)
+ :type '(choice (const :tag "No group file" nil) file))
(defcustom eshell-passwd-file "/etc/passwd"
"If non-nil, the name of the passwd file on your system."
- :type '(choice (const :tag "No passwd file" nil) file)
- :group 'eshell-util)
+ :type '(choice (const :tag "No passwd file" nil) file))
(defcustom eshell-hosts-file "/etc/hosts"
"The name of the /etc/hosts file.
Use `pcomplete-hosts-file' instead; this variable is obsolete and
has no effect."
- :type '(choice (const :tag "No hosts file" nil) file)
- :group 'eshell-util)
+ :type '(choice (const :tag "No hosts file" nil) file))
;; Don't make it into an alias, because it doesn't really work with
;; custom and risks creating duplicate entries. Just point users to
;; the other variable, which is less frustrating.
@@ -64,25 +61,21 @@ has no effect."
(defcustom eshell-handle-errors t
"If non-nil, Eshell will handle errors itself.
Setting this to nil is offered as an aid to debugging only."
- :type 'boolean
- :group 'eshell-util)
+ :type 'boolean)
(defcustom eshell-private-file-modes 384 ; umask 177
"The file-modes value to use for creating \"private\" files."
- :type 'integer
- :group 'eshell-util)
+ :type 'integer)
(defcustom eshell-private-directory-modes 448 ; umask 077
"The file-modes value to use for creating \"private\" directories."
- :type 'integer
- :group 'eshell-util)
+ :type 'integer)
(defcustom eshell-tar-regexp
"\\.t\\(ar\\(\\.\\(gz\\|bz2\\|xz\\|Z\\)\\)?\\|gz\\|a[zZ]\\|z2\\)\\'"
"Regular expression used to match tar file names."
:version "24.1" ; added xz
- :type 'regexp
- :group 'eshell-util)
+ :type 'regexp)
(defcustom eshell-convert-numeric-arguments t
"If non-nil, converting arguments of numeric form to Lisp numbers.
@@ -99,16 +92,14 @@ following in your init file:
Any function with the property `eshell-no-numeric-conversions' set to
a non-nil value, will be passed strings, not numbers, even when an
argument matches `eshell-number-regexp'."
- :type 'boolean
- :group 'eshell-util)
+ :type 'boolean)
(defcustom eshell-number-regexp "-?\\([0-9]*\\.\\)?[0-9]+\\(e[-0-9.]+\\)?"
"Regular expression used to match numeric arguments.
If `eshell-convert-numeric-arguments' is non-nil, and an argument
matches this regexp, it will be converted to a Lisp number, using the
function `string-to-number'."
- :type 'regexp
- :group 'eshell-util)
+ :type 'regexp)
(defcustom eshell-ange-ls-uids nil
"List of user/host/id strings, used to determine remote ownership."
@@ -116,8 +107,7 @@ function `string-to-number'."
(string :tag "Hostname")
(repeat (cons :tag "User/UID List"
(string :tag "Username")
- (repeat :tag "UIDs" string)))))
- :group 'eshell-util)
+ (repeat :tag "UIDs" string))))))
;;; Internal Variables:
@@ -223,18 +213,6 @@ then quoting is done by a backslash, rather than a doubled
delimiter."
(string-to-number string)
string))))))
-(defun eshell-sublist (l &optional n m)
- "Return from LIST the N to M elements.
-If N or M is nil, it means the end of the list."
- (let ((a (copy-sequence l)))
- (if (and m (consp (nthcdr m a)))
- (setcdr (nthcdr m a) nil))
- (if n
- (setq a (nthcdr n a))
- (setq n (1- (length a))
- a (last a)))
- a))
-
(defvar-local eshell-path-env (getenv "PATH")
"Content of $PATH.
It might be different from \(getenv \"PATH\"), when
@@ -303,20 +281,6 @@ Prepend remote identification of `default-directory', if
any."
(define-obsolete-function-alias 'eshell-flatten-list #'flatten-tree "27.1")
-(defun eshell-uniquify-list (l)
- "Remove occurring multiples in L. You probably want to sort first."
- (let ((m l))
- (while m
- (while (and (cdr m)
- (string= (car m)
- (cadr m)))
- (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."
(cond
@@ -334,11 +298,11 @@ Prepend remote identification of `default-directory', if
any."
(defsubst eshell-stringify-list (args)
"Convert each element of ARGS into a string value."
- (mapcar 'eshell-stringify args))
+ (mapcar #'eshell-stringify args))
(defsubst eshell-flatten-and-stringify (&rest args)
"Flatten and stringify all of the ARGS into a single string."
- (mapconcat 'eshell-stringify (flatten-tree args) " "))
+ (mapconcat #'eshell-stringify (flatten-tree args) " "))
(defsubst eshell-directory-files (regexp &optional directory)
"Return a list of files in the given DIRECTORY matching REGEXP."
@@ -497,7 +461,7 @@ list."
(defsubst eshell-copy-environment ()
"Return an unrelated copy of `process-environment'."
- (mapcar 'concat process-environment))
+ (mapcar #'concat process-environment))
(defun eshell-subgroups (groupsym)
"Return all of the subgroups of GROUPSYM."
@@ -645,74 +609,82 @@ gid format. Valid values are `string' and `integer',
defaulting to
"If the `processp' function does not exist, PROC is not a process."
(and (fboundp 'processp) (processp proc)))
-; (defun eshell-copy-file
-; (file newname &optional ok-if-already-exists keep-date)
-; "Copy FILE to NEWNAME. See docs for `copy-file'."
-; (let (copied)
-; (if (string-match "\\`\\([^:]+\\):\\(.*\\)" file)
-; (let ((front (match-string 1 file))
-; (back (match-string 2 file))
-; buffer)
-; (if (and front (string-match eshell-tar-regexp front)
-; (setq buffer (find-file-noselect front)))
-; (with-current-buffer buffer
-; (goto-char (point-min))
-; (if (re-search-forward (concat " " (regexp-quote back)
-; "$") nil t)
-; (progn
-; (tar-copy (if (file-directory-p newname)
-; (expand-file-name
-; (file-name-nondirectory back) newname)
-; newname))
-; (setq copied t))
-; (error "%s not found in tar file %s" back front))))))
-; (unless copied
-; (copy-file file newname ok-if-already-exists keep-date))))
-
-; (defun eshell-file-attributes (filename)
-; "Return a list of attributes of file FILENAME.
-; See the documentation for `file-attributes'."
-; (let (result)
-; (when (string-match "\\`\\([^:]+\\):\\(.*\\)\\'" filename)
-; (let ((front (match-string 1 filename))
-; (back (match-string 2 filename))
-; buffer)
-; (when (and front (string-match eshell-tar-regexp front)
-; (setq buffer (find-file-noselect front)))
-; (with-current-buffer buffer
-; (goto-char (point-min))
-; (when (re-search-forward (concat " " (regexp-quote back)
-; "\\s-*$") nil t)
-; (let* ((descrip (tar-current-descriptor))
-; (tokens (tar-desc-tokens descrip)))
-; (setq result
-; (list
-; (cond
-; ((eq (tar-header-link-type tokens) 5)
-; t)
-; ((eq (tar-header-link-type tokens) t)
-; (tar-header-link-name tokens)))
-; 1
-; (tar-header-uid tokens)
-; (tar-header-gid tokens)
-; (tar-header-date tokens)
-; (tar-header-date tokens)
-; (tar-header-date tokens)
-; (tar-header-size tokens)
-; (concat
-; (cond
-; ((eq (tar-header-link-type tokens) 5) "d")
-; ((eq (tar-header-link-type tokens) t) "l")
-; (t "-"))
-; (tar-grind-file-mode (tar-header-mode tokens)
-; (make-string 9 ? ) 0))
-; nil nil nil))))))))
-; (or result
-; (file-attributes filename))))
-
+;; (defun eshell-copy-file
+;; (file newname &optional ok-if-already-exists keep-date)
+;; "Copy FILE to NEWNAME. See docs for `copy-file'."
+;; (let (copied)
+;; (if (string-match "\\`\\([^:]+\\):\\(.*\\)" file)
+;; (let ((front (match-string 1 file))
+;; (back (match-string 2 file))
+;; buffer)
+;; (if (and front (string-match eshell-tar-regexp front)
+;; (setq buffer (find-file-noselect front)))
+;; (with-current-buffer buffer
+;; (goto-char (point-min))
+;; (if (re-search-forward (concat " " (regexp-quote back)
+;; "$") nil t)
+;; (progn
+;; (tar-copy (if (file-directory-p newname)
+;; (expand-file-name
+;; (file-name-nondirectory back) newname)
+;; newname))
+;; (setq copied t))
+;; (error "%s not found in tar file %s" back front))))))
+;; (unless copied
+;; (copy-file file newname ok-if-already-exists keep-date))))
+
+;; (defun eshell-file-attributes (filename)
+;; "Return a list of attributes of file FILENAME.
+;; See the documentation for `file-attributes'."
+;; (let (result)
+;; (when (string-match "\\`\\([^:]+\\):\\(.*\\)\\'" filename)
+;; (let ((front (match-string 1 filename))
+;; (back (match-string 2 filename))
+;; buffer)
+;; (when (and front (string-match eshell-tar-regexp front)
+;; (setq buffer (find-file-noselect front)))
+;; (with-current-buffer buffer
+;; (goto-char (point-min))
+;; (when (re-search-forward (concat " " (regexp-quote back)
+;; "\\s-*$") nil t)
+;; (let* ((descrip (tar-current-descriptor))
+;; (tokens (tar-desc-tokens descrip)))
+;; (setq result
+;; (list
+;; (cond
+;; ((eq (tar-header-link-type tokens) 5)
+;; t)
+;; ((eq (tar-header-link-type tokens) t)
+;; (tar-header-link-name tokens)))
+;; 1
+;; (tar-header-uid tokens)
+;; (tar-header-gid tokens)
+;; (tar-header-date tokens)
+;; (tar-header-date tokens)
+;; (tar-header-date tokens)
+;; (tar-header-size tokens)
+;; (file-modes-number-to-symbolic
+;; (logior (tar-header-mode tokens)
+;; (cond
+;; ((eq (tar-header-link-type tokens) 5) 16384)
+;; ((eq (tar-header-link-type tokens) t) 32768))))
+;; nil nil nil))))))))
+;; (or result
+;; (file-attributes filename))))
+
+;; Obsolete.
+
+(define-obsolete-function-alias 'eshell-uniquify-list #'seq-uniq "28.1")
+(define-obsolete-function-alias 'eshell-uniqify-list #'seq-uniq "28.1")
(define-obsolete-function-alias 'eshell-copy-tree #'copy-tree "28.1")
(define-obsolete-function-alias 'eshell-user-name #'user-login-name "28.1")
+(defun eshell-sublist (l &optional n m)
+ "Return from LIST the N to M elements.
+If N or M is nil, it means the end of the list."
+ (declare (obsolete seq-subseq "28.1"))
+ (seq-subseq l n (1+ m)))
+
(provide 'esh-util)
;;; esh-util.el ends here
diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el
index 3aaf2fb..101ac86 100644
--- a/lisp/eshell/eshell.el
+++ b/lisp/eshell/eshell.el
@@ -294,9 +294,9 @@ With prefix ARG, insert output into the current buffer at
point."
(setq arg current-prefix-arg))
(let ((eshell-non-interactive-p t))
;; Enable `eshell-mode' only in this minibuffer.
- (minibuffer-with-setup-hook #'(lambda ()
- (eshell-mode)
- (eshell-command-mode +1))
+ (minibuffer-with-setup-hook (lambda ()
+ (eshell-mode)
+ (eshell-command-mode +1))
(unless command
(setq command (read-from-minibuffer "Emacs shell command: "))
(if (eshell-using-module 'eshell-hist)
diff --git a/lisp/expand.el b/lisp/expand.el
index d11ae7c..1b72201 100644
--- a/lisp/expand.el
+++ b/lisp/expand.el
@@ -484,7 +484,6 @@ This is used only in conjunction with `expand-add-abbrevs'."
(provide 'expand)
-;; run load hooks
(run-hooks 'expand-load-hook)
;;; expand.el ends here
diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index 2d06658..8db1b42 100644
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -539,6 +539,7 @@ filter out the color from the output."
This is installed as a `revert-buffer-function' in the *Colors* buffer."
(list-colors-display nil (buffer-name) list-colors-callback))
+;;;###autoload
(defun list-colors-display (&optional list buffer-name callback)
"Display names of defined colors, and show what they look like.
If the optional argument LIST is non-nil, it should be a list of
diff --git a/lisp/faces.el b/lisp/faces.el
index 42f4cdd..68bfbba 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -2244,7 +2244,8 @@ If you set `term-file-prefix' to nil, this function does
nothing."
(let ((file (locate-library (concat term-file-prefix
type))))
(and file
(or (assoc file load-history)
- (load file t t)))))
+ (load (file-name-sans-extension file)
+ t t)))))
type)
;; Next, try to find a matching initialization function, and call it.
(tty-find-type #'(lambda (type)
diff --git a/lisp/filecache.el b/lisp/filecache.el
index 67d2939..62184e1 100644
--- a/lisp/filecache.el
+++ b/lisp/filecache.el
@@ -674,10 +674,6 @@ match REGEXP."
(insert (nth 1 item) (nth 0 item) "\n"))
(pop-to-buffer buf))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Keybindings
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
(provide 'filecache)
;;; filecache.el ends here
diff --git a/lisp/filenotify.el b/lisp/filenotify.el
index 07871bb..4fc7f0a 100644
--- a/lisp/filenotify.el
+++ b/lisp/filenotify.el
@@ -505,7 +505,6 @@ DESCRIPTOR should be an object returned by
`file-notify-add-watch'."
;; due to the way events are propagated during idle time. Note: This
;; may be perfectly acceptable.
-;; The end:
(provide 'filenotify)
;;; filenotify.el ends here
diff --git a/lisp/files-x.el b/lisp/files-x.el
index 23e4562..9e19542 100644
--- a/lisp/files-x.el
+++ b/lisp/files-x.el
@@ -1,4 +1,4 @@
-;;; files-x.el --- extended file handling commands
+;;; files-x.el --- extended file handling commands -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
@@ -602,7 +602,7 @@ PROFILES is a list of connection profiles (symbols).")
"Normalize plist CRITERIA according to properties.
Return a reordered plist."
(apply
- 'append
+ #'append
(mapcar
(lambda (property)
(when (and (plist-member criteria property) (plist-get criteria
property))
diff --git a/lisp/files.el b/lisp/files.el
index 60d6034..8e8fbac 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -908,6 +908,8 @@ See `file-symlink-p' to distinguish symlinks."
(read-file-name "Load file: " nil nil 'lambda))))
(load (expand-file-name file) nil nil t))
+(defvar comp-eln-to-el-h)
+
(defun locate-file (filename path &optional suffixes predicate)
"Search for FILENAME through PATH.
If found, return the absolute file name of FILENAME; otherwise
@@ -934,7 +936,10 @@ one or more of those symbols."
(logior (if (memq 'executable predicate) 1 0)
(if (memq 'writable predicate) 2 0)
(if (memq 'readable predicate) 4 0))))
- (locate-file-internal filename path suffixes predicate))
+ (let ((file (locate-file-internal filename path suffixes predicate)))
+ (if (and file (string-match "\\.eln\\'" file))
+ (gethash (file-name-nondirectory file) comp-eln-to-el-h)
+ file)))
(defun locate-file-completion-table (dirs suffixes string pred action)
"Do completion for file names passed to `locate-file'."
@@ -1648,13 +1653,14 @@ rather than FUN itself, to `minibuffer-setup-hook'."
(when (eq (car-safe fun) :append)
(setq append '(t) fun (cadr fun)))
`(let ((,funsym ,fun)
- ,hook)
- (setq ,hook
- (lambda ()
- ;; Clear out this hook so it does not interfere
- ;; with any recursive minibuffer usage.
- (remove-hook 'minibuffer-setup-hook ,hook)
- (funcall ,funsym)))
+ ;; Use a symbol to make sure `add-hook' doesn't waste time
+ ;; in `equal'ity testing (bug#46326).
+ (,hook (make-symbol "minibuffer-setup")))
+ (fset ,hook (lambda ()
+ ;; Clear out this hook so it does not interfere
+ ;; with any recursive minibuffer usage.
+ (remove-hook 'minibuffer-setup-hook ,hook)
+ (funcall ,funsym)))
(unwind-protect
(progn
(add-hook 'minibuffer-setup-hook ,hook ,@append)
@@ -7633,6 +7639,9 @@ If CHAR is in [Xugo], the value is taken from FROM (or 0
if omitted)."
;; Rights relative to the previous file modes.
((= char ?X) (if (= (logand from #o111) 0) 0 #o0111))
((= char ?u) (let ((uright (logand #o4700 from)))
+ ;; FIXME: These divisions/shifts seem to be right
+ ;; for the `7' part of the #o4700 mask, but not
+ ;; for the `4' part. Same below for `g' and `o'.
(+ uright (/ uright #o10) (/ uright #o100))))
((= char ?g) (let ((gright (logand #o2070 from)))
(+ gright (/ gright #o10) (* gright #o10))))
@@ -7667,11 +7676,28 @@ as in \"og+rX-w\"."
op char-right)))
num-rights))
-(defun file-modes-number-to-symbolic (mode)
+(defun file-modes-number-to-symbolic (mode &optional filetype)
+ "Return a string describing a file's MODE.
+For instance, if MODE is #o700, then it produces `-rwx------'.
+FILETYPE if provided should be a character denoting the type of file,
+such as `?d' for a directory, or `?l' for a symbolic link and will override
+the leading `-' char."
(string
- (if (zerop (logand 8192 mode))
- (if (zerop (logand 16384 mode)) ?- ?d)
- ?c) ; completeness
+ (or filetype
+ (pcase (lsh mode -12)
+ ;; POSIX specifies that the file type is included in st_mode
+ ;; and provides names for the file types but values only for
+ ;; the permissions (e.g., S_IWOTH=2).
+
+ ;; (#o017 ??) ;; #define S_IFMT 00170000
+ (#o014 ?s) ;; #define S_IFSOCK 0140000
+ (#o012 ?l) ;; #define S_IFLNK 0120000
+ ;; (8 ??) ;; #define S_IFREG 0100000
+ (#o006 ?b) ;; #define S_IFBLK 0060000
+ (#o004 ?d) ;; #define S_IFDIR 0040000
+ (#o002 ?c) ;; #define S_IFCHR 0020000
+ (#o001 ?p) ;; #define S_IFIFO 0010000
+ (_ ?-)))
(if (zerop (logand 256 mode)) ?- ?r)
(if (zerop (logand 128 mode)) ?- ?w)
(if (zerop (logand 64 mode))
diff --git a/lisp/find-file.el b/lisp/find-file.el
index 8cc9c97..6c3c0f1 100644
--- a/lisp/find-file.el
+++ b/lisp/find-file.el
@@ -1,4 +1,4 @@
-;;; find-file.el --- find a file corresponding to this one given a pattern
+;;; find-file.el --- find a file corresponding to this one given a pattern
-*- lexical-binding: t; -*-
;; Author: Henry Guillaume <henri@tibco.com, henry@c032.aone.net.au>
;; Maintainer: emacs-devel@gnu.org
@@ -39,8 +39,8 @@
;; and just has a different extension as described by the ff-other-file-alist
;; variable:
;;
-;; '(("\\.cc$" (".hh" ".h"))
-;; ("\\.hh$" (".cc" ".C" ".CC" ".cxx" ".cpp")))
+;; '(("\\.cc\\'" (".hh" ".h"))
+;; ("\\.hh\\'" (".cc" ".C" ".CC" ".cxx" ".cpp")))
;;
;; If the current file has a .cc extension, ff-find-other-file will attempt
;; to look for a .hh file, and then a .h file in some directory as described
@@ -55,8 +55,8 @@
;; format above can be changed to include a function to be called when the
;; current file matches the regexp:
;;
-;; '(("\\.cc$" cc--function)
-;; ("\\.hh$" hh-function))
+;; '(("\\.cc\\'" cc--function)
+;; ("\\.hh\\'" hh-function))
;;
;; These functions must return a list consisting of the possible names of the
;; corresponding file, with or without path. There is no real need for more
@@ -64,10 +64,10 @@
;; file-alist:
;;
;; (setq cc-other-file-alist
-;; '(("\\.cc$" ff-cc-hh-converter)
-;; ("\\.hh$" ff-cc-hh-converter)
-;; ("\\.c$" (".h"))
-;; ("\\.h$" (".c" ".cc" ".C" ".CC" ".cxx" ".cpp"))))
+;; '(("\\.cc\\'" ff-cc-hh-converter)
+;; ("\\.hh\\'" ff-cc-hh-converter)
+;; ("\\.c\\'" (".h"))
+;; ("\\.h\\'" (".c" ".cc" ".C" ".CC" ".cxx" ".cpp"))))
;;
;; ff-cc-hh-converter is included at the end of this file as a reference.
;;
@@ -130,62 +130,51 @@
(defcustom ff-pre-find-hook nil
"List of functions to be called before the search for the file starts."
- :type 'hook
- :group 'ff)
+ :type 'hook)
(defcustom ff-pre-load-hook nil
"List of functions to be called before the other file is loaded."
- :type 'hook
- :group 'ff)
+ :type 'hook)
(defcustom ff-post-load-hook nil
"List of functions to be called after the other file is loaded."
- :type 'hook
- :group 'ff)
+ :type 'hook)
(defcustom ff-not-found-hook nil
"List of functions to be called if the other file could not be found."
- :type 'hook
- :group 'ff)
+ :type 'hook)
(defcustom ff-file-created-hook nil
"List of functions to be called if the other file needs to be created."
- :type 'hook
- :group 'ff)
+ :type 'hook)
(defcustom ff-case-fold-search nil
"Non-nil means ignore cases in matches (see `case-fold-search').
If you have extensions in different cases, you will want this to be nil."
- :type 'boolean
- :group 'ff)
+ :type 'boolean)
(defcustom ff-always-in-other-window nil
"If non-nil, find the corresponding file in another window by default.
To override this, give an argument to `ff-find-other-file'."
- :type 'boolean
- :group 'ff)
+ :type 'boolean)
(defcustom ff-ignore-include nil
"If non-nil, ignore `#include' lines."
- :type 'boolean
- :group 'ff)
+ :type 'boolean)
(defcustom ff-always-try-to-create t
"If non-nil, always attempt to create the other file if it was not found."
- :type 'boolean
- :group 'ff)
+ :type 'boolean)
(defcustom ff-quiet-mode nil
"If non-nil, trace which directories are being searched."
- :type 'boolean
- :group 'ff)
+ :type 'boolean)
;;;###autoload
(defcustom ff-special-constructs
;; C/C++ include, for NeXTstep too
`((,(purecopy "^#\\s *\\(include\\|import\\)\\s +[<\"]\\(.*\\)[>\"]") .
- (lambda ()
- (buffer-substring (match-beginning 2) (match-end 2)))))
+ ,(lambda () (match-string 2))))
;; We include `ff-treat-as-special' documentation here so that autoload
;; can make it available to be read prior to loading this file.
"List of special constructs recognized by `ff-treat-as-special'.
@@ -194,8 +183,7 @@ If REGEXP matches the current line (from the beginning of
the line),
`ff-treat-as-special' calls function EXTRACT with no args.
If EXTRACT returns nil, keep trying. Otherwise, return the
filename that EXTRACT returned."
- :type '(repeat (cons regexp function))
- :group 'ff)
+ :type '(repeat (cons regexp function)))
(defvaralias 'ff-related-file-alist 'ff-other-file-alist)
(defcustom ff-other-file-alist 'cc-other-file-alist
@@ -207,8 +195,7 @@ directory specified in `ff-search-directories'. If a file
is not found,
a new one is created with the first matching extension (`.cc' yields `.hh').
This alist should be set by the major mode."
:type '(choice (repeat (list regexp (choice (repeat string) function)))
- symbol)
- :group 'ff)
+ symbol))
(defcustom ff-search-directories 'cc-search-directories
"List of directories to search for a specific file.
@@ -231,14 +218,12 @@ not exist, it is replaced (silently) with an empty string.
The stars are *not* wildcards: they are searched for together with
the preceding slash. The star represents all the subdirectories except
`..', and each of these subdirectories will be searched in turn."
- :type '(choice (repeat directory) symbol)
- :group 'ff)
+ :type '(choice (repeat directory) symbol))
(defcustom cc-search-directories
'("." "/usr/include" "/usr/local/include/*")
"See the description of the `ff-search-directories' variable."
- :type '(repeat directory)
- :group 'ff)
+ :type '(repeat directory))
(defcustom cc-other-file-alist
'(("\\.cc\\'" (".hh" ".h"))
@@ -269,17 +254,15 @@ since the search algorithm searches sequentially through
each directory
specified in `ff-search-directories'. If a file is not found, a new one
is created with the first matching extension (`.cc' yields `.hh')."
:version "24.4" ; add .m
- :type '(repeat (list regexp (choice (repeat string) function)))
- :group 'ff)
+ :type '(repeat (list regexp (choice (repeat string) function))))
(defcustom modula2-other-file-alist
'(
- ("\\.mi$" (".md")) ;; Modula-2 module definition
- ("\\.md$" (".mi")) ;; and implementation.
+ ("\\.mi\\'" (".md")) ;; Modula-2 module definition
+ ("\\.md\\'" (".mi")) ;; and implementation.
)
"See the description for the `ff-search-directories' variable."
- :type '(repeat (list regexp (choice (repeat string) function)))
- :group 'ff)
+ :type '(repeat (list regexp (choice (repeat string) function))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -308,16 +291,14 @@ See also the documentation for `ff-find-other-file'.
If optional IN-OTHER-WINDOW is non-nil, find the file in another window."
(interactive "P")
- (let ((ignore ff-ignore-include))
- (setq ff-ignore-include t)
- (ff-find-the-other-file in-other-window)
- (setq ff-ignore-include ignore)))
+ (let ((ff-ignore-include t))
+ (ff-find-the-other-file in-other-window)))
;;;###autoload
-(defalias 'ff-find-related-file 'ff-find-other-file)
+(defalias 'ff-find-related-file #'ff-find-other-file)
;;;###autoload
-(defun ff-find-other-file (&optional in-other-window ignore-include)
+(defun ff-find-other-file (&optional in-other-window ignore-include event)
"Find the header or source file corresponding to this file.
Being on a `#include' line pulls in that file.
@@ -369,11 +350,11 @@ Variables of interest include:
- `ff-file-created-hook'
List of functions to be called if the other file has been created."
- (interactive "P")
- (let ((ignore ff-ignore-include))
- (setq ff-ignore-include ignore-include)
- (ff-find-the-other-file in-other-window)
- (setq ff-ignore-include ignore)))
+ (interactive (list current-prefix-arg nil last-nonmenu-event))
+ (save-excursion
+ (posn-set-point (event-end event))
+ (let ((ff-ignore-include ignore-include))
+ (ff-find-the-other-file in-other-window))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Support functions
@@ -413,9 +394,9 @@ If optional IN-OTHER-WINDOW is non-nil, find the file in
another window."
(message "Working...")
(setq dirs
- (if (symbolp ff-search-directories)
- (ff-list-replace-env-vars (symbol-value ff-search-directories))
- (ff-list-replace-env-vars ff-search-directories)))
+ (ff-list-replace-env-vars (if (symbolp ff-search-directories)
+ (symbol-value ff-search-directories)
+ ff-search-directories)))
(setq fname (ff-treat-as-special))
@@ -454,11 +435,10 @@ If optional IN-OTHER-WINDOW is non-nil, find the file in
another window."
;; if we have a function to generate new names,
;; invoke it with the name of the current file
(if (and (atom action) (fboundp action))
- (progn
- (setq suffixes (funcall action (ff-buffer-file-name))
- match (cons (car match) (list suffixes))
- stub nil
- default-name (car suffixes)))
+ (setq suffixes (funcall action (ff-buffer-file-name))
+ match (cons (car match) (list suffixes))
+ stub nil
+ default-name (car suffixes))
;; otherwise build our filename stub
(cond
@@ -472,7 +452,8 @@ If optional IN-OTHER-WINDOW is non-nil, find the file in
another window."
(t
(setq format (concat "\\(.+\\)" (car match)))
(string-match format fname)
- (setq stub (substring fname (match-beginning 1) (match-end 1)))
+ ;; FIXME: What if `string-match' failed?
+ (setq stub (match-string 1 fname))
))
;; if we find nothing, we should try to get a file like this one
@@ -522,89 +503,6 @@ If optional IN-OTHER-WINDOW is non-nil, find the file in
another window."
found)) ;; return buffer-name or filename
-(defun ff-other-file-name ()
- "Return name of the header or source file corresponding to the current file.
-Being on a `#include' line pulls in that file, but see the help on
-the `ff-ignore-include' variable."
-
- (let (match ;; matching regexp for this file
- suffixes ;; set of replacing regexps for the matching regexp
- action ;; function to generate the names of the other files
- fname ;; basename of this file
- pos ;; where we start matching filenames
- stub ;; name of the file without extension
- alist ;; working copy of the list of file extensions
- pathname ;; the pathname of the file or the #include line
- format ;; what we have to match
- found ;; name of the file or buffer found - nil if none
- dirs) ;; local value of ff-search-directories
-
- (message "Working...")
-
- (setq dirs
- (if (symbolp ff-search-directories)
- (ff-list-replace-env-vars (symbol-value ff-search-directories))
- (ff-list-replace-env-vars ff-search-directories)))
-
- (setq fname (ff-treat-as-special))
-
- (cond
- ((and (not ff-ignore-include) fname)
- (setq found (ff-get-file-name dirs fname nil)))
-
- ;; let's just get the corresponding file
- (t
- (setq alist (if (symbolp ff-other-file-alist)
- (symbol-value ff-other-file-alist)
- ff-other-file-alist)
- pathname (or (ff-buffer-file-name) "/none.none"))
-
- (setq fname (file-name-nondirectory pathname)
- match (car alist))
-
- ;; find the table entry corresponding to this file
- (setq pos (ff-string-match (car match) fname))
- (while (and match (if (and pos (>= pos 0)) nil (not pos)))
- (setq alist (cdr alist))
- (setq match (car alist))
- (setq pos (ff-string-match (car match) fname)))
-
- ;; no point going on if we haven't found anything
- (when match
-
- ;; otherwise, suffixes contains what we need
- (setq suffixes (car (cdr match))
- action (car (cdr match))
- found nil)
-
- ;; if we have a function to generate new names,
- ;; invoke it with the name of the current file
- (if (and (atom action) (fboundp action))
- (progn
- (setq suffixes (funcall action (ff-buffer-file-name))
- match (cons (car match) (list suffixes))
- stub nil))
-
- ;; otherwise build our filename stub
- (cond
-
- ;; get around the problem that 0 and nil both mean false!
- ((= pos 0)
- (setq format "")
- (setq stub "")
- )
-
- (t
- (setq format (concat "\\(.+\\)" (car match)))
- (string-match format fname)
- (setq stub (substring fname (match-beginning 1) (match-end 1)))
- )))
-
- ;; do the real work - find the file
- (setq found
- (ff-get-file-name dirs stub suffixes)))))
- found)) ;; return buffer-name or filename
-
(defun ff-get-file (search-dirs filename &optional suffix-list other-window)
"Find a file in the SEARCH-DIRS with the given FILENAME (or filename stub).
If (optional) SUFFIX-LIST is nil, search for FILENAME, otherwise search
@@ -709,11 +607,10 @@ name of the first file found."
;; otherwise dir matches the '/*', so search each dir separately
(progn
- (if (match-beginning 2)
- (setq rest (substring dir (match-beginning 2) (match-end 2)))
- (setq rest "")
- )
- (setq dir (substring dir (match-beginning 1) (match-end 1)))
+ (setq rest (if (match-beginning 2)
+ (match-string 2 dir)
+ ""))
+ (setq dir (match-string 1 dir))
(let ((dirlist (ff-all-dirs-under dir '("..")))
this-dir compl-dirs)
@@ -743,8 +640,8 @@ name of the first file found."
(defun ff-string-match (regexp string &optional start)
"Like `string-match', but set `case-fold-search' temporarily.
The value used comes from `ff-case-fold-search'."
- (let ((case-fold-search ff-case-fold-search))
- (if regexp
+ (if regexp
+ (let ((case-fold-search ff-case-fold-search))
(string-match regexp string start))))
(defun ff-list-replace-env-vars (search-list)
@@ -752,12 +649,12 @@ The value used comes from `ff-case-fold-search'."
(let (list
(var (car search-list)))
(while search-list
- (if (string-match "\\(.*\\)\\$[({]*\\([a-zA-Z0-9_]+\\)[)}]*\\(.*\\)" var)
+ (if (string-match "\\(.*\\)\\$[({]*\\([[:alnum:]_]+\\)[)}]*\\(.*\\)" var)
(setq var
(concat
- (substring var (match-beginning 1) (match-end 1))
- (getenv (substring var (match-beginning 2) (match-end 2)))
- (substring var (match-beginning 3) (match-end 3)))))
+ (match-string 1 var)
+ (getenv (match-string 2 var))
+ (match-string 3 var))))
(setq search-list (cdr search-list))
(setq list (cons var list))
(setq var (car search-list)))
@@ -782,11 +679,7 @@ See variable `ff-special-constructs'."
(setq match (cdr elem)))
fname)))
-(defun ff-basename (string)
- "Return the basename of pathname STRING."
- (setq string (concat "/" string))
- (string-match ".*/\\([^/]+\\)$" string)
- (setq string (substring string (match-beginning 1) (match-end 1))))
+(define-obsolete-function-alias 'ff-basename #'file-name-nondirectory "28.1")
(defun ff-all-dirs-under (here &optional exclude)
"Get all the directory files under directory HERE.
@@ -800,7 +693,7 @@ Exclude all files in the optional EXCLUDE list."
(setq file (car files))
(if (and
(file-directory-p file)
- (not (member (ff-basename file) exclude)))
+ (not (member (file-name-nondirectory file) exclude)))
(setq dirlist (cons file dirlist)))
(setq files (cdr files)))
(setq dirlist (reverse dirlist))))
@@ -820,84 +713,65 @@ or `switch-to-buffer' / `switch-to-buffer-other-window'
function pairs.
If optional NEW-FILE is t, then a special hook (`ff-file-created-hook') is
called before `ff-post-load-hook'."
(run-hooks 'ff-pre-load-hook 'ff-pre-load-hooks)
- (if (or
- (and in-other-window (not ff-always-in-other-window))
- (and (not in-other-window) ff-always-in-other-window))
- (funcall f2 file)
- (funcall f1 file))
+ (funcall (if (or
+ (and in-other-window (not ff-always-in-other-window))
+ (and (not in-other-window) ff-always-in-other-window))
+ f2 f1)
+ file)
(if new-file
(run-hooks 'ff-file-created-hook 'ff-file-created-hooks))
(run-hooks 'ff-post-load-hook 'ff-post-load-hooks))
(defun ff-find-file (file &optional in-other-window new-file)
"Like `find-file', but may show the file in another window."
- (ff-switch-file 'find-file
- 'find-file-other-window
+ (ff-switch-file #'find-file
+ #'find-file-other-window
file in-other-window new-file))
(defun ff-switch-to-buffer (buffer-or-name &optional in-other-window)
"Like `switch-to-buffer', but may show the buffer in another window."
- (ff-switch-file 'switch-to-buffer
- 'switch-to-buffer-other-window
+ (ff-switch-file #'switch-to-buffer
+ #'switch-to-buffer-other-window
buffer-or-name in-other-window nil))
;;;###autoload
-(defun ff-mouse-find-other-file (event)
- "Visit the file you click on."
- (interactive "e")
- (save-excursion
- (mouse-set-point event)
- (ff-find-other-file nil)))
+(define-obsolete-function-alias
+ 'ff-mouse-find-other-file #'ff-find-other-file "28.1")
;;;###autoload
-(defun ff-mouse-find-other-file-other-window (event)
- "Visit the file you click on in another window."
- (interactive "e")
- (save-excursion
- (mouse-set-point event)
- (ff-find-other-file t)))
+(define-obsolete-function-alias
+ 'ff-mouse-find-other-file-other-window #'ff-find-other-file-other-window
"28.1")
+;;;###autoload
+(defun ff-find-other-file-other-window (event)
+ "Visit the file you point at in another window."
+ (interactive (list last-nonmenu-event))
+ (ff-find-other-file t nil event))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This section offers an example of user defined function to select files
-(defun ff-upcase-p (string &optional start end)
- "Return t if STRING is all uppercase.
-Given START and/or END, checks between these characters."
- (let (match str)
- (if (not start)
- (setq start 0))
- (if (not end)
- (setq end (length string)))
- (if (= start end)
- (setq end (1+ end)))
- (setq str (substring string start end))
- (if (and
- (ff-string-match "[A-Z]+" str)
- (setq match (match-data))
- (= (car match) 0)
- (= (car (cdr match)) (length str)))
- t
- nil)))
+(defun ff-upcase-p (string)
+ "Return t if STRING is all uppercase."
+ ;; FIXME: Why `ff-string-match' since `[:upper:]' only makes
+ ;; sense when `case-fold-search' is nil?
+ (ff-string-match "\\`[[:upper:]]*\\'" string))
(defun ff-cc-hh-converter (arg)
"Discriminate file extensions.
Build up a new file list based possibly on part of the directory name
and the name of the file passed in."
(ff-string-match "\\(.*\\)/\\([^/]+\\)/\\([^.]+\\).\\([^/]+\\)$" arg)
- (let ((dire (if (match-beginning 2)
- (substring arg (match-beginning 2) (match-end 2)) nil))
- (file (if (match-beginning 3)
- (substring arg (match-beginning 3) (match-end 3)) nil))
- (extn (if (match-beginning 4)
- (substring arg (match-beginning 4) (match-end 4)) nil))
+ (let ((dire (match-string 2 arg))
+ (file (match-string 3 arg))
+ (extn (match-string 4 arg))
return-list)
(cond
;; fooZapJunk.cc => ZapJunk.{hh,h} or fooZapJunk.{hh,h}
((and (string= extn "cc")
- (ff-string-match "^\\([a-z]+\\)\\([A-Z].+\\)$" file))
- (let ((stub (substring file (match-beginning 2) (match-end 2))))
- (setq dire (upcase (substring file (match-beginning 1) (match-end 1))))
+ (ff-string-match "^\\([[:lower:]]+\\)\\([[:upper:]].+\\)$" file))
+ (let ((stub (match-string 2 file)))
+ (setq dire (upcase (match-string 1 file)))
(setq return-list (list (concat stub ".hh")
(concat stub ".h")
(concat file ".hh")
diff --git a/lisp/foldout.el b/lisp/foldout.el
index 2de49d2..cadf274 100644
--- a/lisp/foldout.el
+++ b/lisp/foldout.el
@@ -1,4 +1,4 @@
-;;; foldout.el --- folding extensions for outline-mode and outline-minor-mode
+;;; foldout.el --- folding extensions for outline-mode and outline-minor-mode
-*- lexical-binding: t -*-
;; Copyright (C) 1994, 2001-2021 Free Software Foundation, Inc.
@@ -33,7 +33,7 @@
;; hidden under one of these headings. Normally you'd do C-c C-e (show-entry)
;; to expose the body or C-c C-i to expose the child (level-2) headings.
;;
-;; With foldout, you do C-c C-z (foldout-zoom-subtree). This exposes the body
+;; With foldout, you do C-c C-z (`foldout-zoom-subtree'). This exposes the
body
;; and child subheadings and narrows the buffer so that only the level-1
;; heading, the body and the level-2 headings are visible. If you now want to
;; look under one of the level-2 headings, position the cursor on it and do C-c
@@ -57,7 +57,7 @@
;; zoomed-in heading. This is useful for restricting changes to a particular
;; chapter or section of your document.
;;
-;; You unzoom (exit) a fold by doing C-c C-x (foldout-exit-fold). This hides
+;; You unzoom (exit) a fold by doing C-c C-x (`foldout-exit-fold'). This hides
;; all the text and subheadings under the top-level heading and returns you to
;; the previous view of the buffer. Specifying a numeric argument exits that
;; many folds. Specifying a zero argument exits *all* folds.
@@ -216,6 +216,8 @@ An end marker of nil means the fold ends after
(point-max).")
(defvar-local foldout-mode-line-string nil
"Mode line string announcing that we are in an outline fold.")
+;; FIXME: This should be rewritten as a proper minor mode.
+
;; put our minor mode string immediately following outline-minor-mode's
(or (assq 'foldout-mode-line-string minor-mode-alist)
(let ((outl-entry (memq (assq 'outline-minor-mode minor-mode-alist)
@@ -227,17 +229,8 @@ An end marker of nil means the fold ends after
(point-max).")
(error "Can't find outline-minor-mode in minor-mode-alist"))
;; slip our fold announcement into the list
- (setcdr outl-entry (nconc foldout-entry (cdr outl-entry)))
- ))
-
-;; outline-flag-region has different `flag' values in outline.el and
-;; noutline.el for hiding and showing text.
-
-(defconst foldout-hide-flag
- (if (featurep 'noutline) t ?\^M))
+ (setcdr outl-entry (nconc foldout-entry (cdr outl-entry)))))
-(defconst foldout-show-flag
- (if (featurep 'noutline) nil ?\n))
(defun foldout-zoom-subtree (&optional exposure)
@@ -283,16 +276,14 @@ optional arg EXPOSURE \(interactively with prefix arg)
changes this:-
((> exposure-value 0)
(outline-show-children exposure-value))
(t
- (outline-show-subtree))
- )
+ (outline-show-subtree)))
;; save the location of the fold we are entering
(setq foldout-fold-list (cons (cons start-marker end-marker)
foldout-fold-list))
;; update the mode line
- (foldout-update-mode-line)
- )))
+ (foldout-update-mode-line))))
(defun foldout-exit-fold (&optional num-folds)
@@ -316,8 +307,7 @@ exited and text is left visible."
;; have we been told not to hide the fold?
((< num-folds 0)
(setq hide-fold nil
- num-folds (- num-folds)))
- )
+ num-folds (- num-folds))))
;; limit the number of folds if we've been told to exit too many
(setq num-folds (min num-folds (length foldout-fold-list)))
@@ -364,8 +354,7 @@ exited and text is left visible."
;; make sure the next heading is exposed
(if end-marker
- (outline-flag-region end-of-subtree beginning-of-heading
- foldout-show-flag)))
+ (outline-flag-region end-of-subtree beginning-of-heading nil)))
;; zap the markers so they don't slow down editing
(set-marker start-marker nil)
@@ -491,8 +480,8 @@ Signal an error if the final event isn't the same type as
the first one."
event)
(defun foldout-mouse-goto-heading (event)
- "Go to the heading where the mouse event started. Signal an error
-if the event didn't occur on a heading."
+ "Go to the heading where the mouse EVENT started.
+Signal an error if the event didn't occur on a heading."
(goto-char (posn-point (event-start event)))
(or (outline-on-heading-p)
;; outline.el sometimes treats beginning-of-buffer as a heading
@@ -514,17 +503,16 @@ M-C-down-mouse-{1,2,3}.
Valid modifiers are shift, control, meta, alt, hyper and super.")
-(if foldout-inhibit-key-bindings
- ()
- (define-key outline-mode-map "\C-c\C-z" 'foldout-zoom-subtree)
- (define-key outline-mode-map "\C-c\C-x" 'foldout-exit-fold)
+(unless foldout-inhibit-key-bindings
+ (define-key outline-mode-map "\C-c\C-z" #'foldout-zoom-subtree)
+ (define-key outline-mode-map "\C-c\C-x" #'foldout-exit-fold)
(let ((map (lookup-key outline-minor-mode-map outline-minor-mode-prefix)))
(unless map
(setq map (make-sparse-keymap))
(define-key outline-minor-mode-map outline-minor-mode-prefix map))
- (define-key map "\C-z" 'foldout-zoom-subtree)
- (define-key map "\C-x" 'foldout-exit-fold))
- (let* ((modifiers (apply 'concat
+ (define-key map "\C-z" #'foldout-zoom-subtree)
+ (define-key map "\C-x" #'foldout-exit-fold))
+ (let* ((modifiers (apply #'concat
(mapcar (lambda (modifier)
(vector
(cond
@@ -534,7 +522,7 @@ Valid modifiers are shift, control, meta, alt, hyper and
super.")
((eq modifier 'alt) ?A)
((eq modifier 'hyper) ?H)
((eq modifier 'super) ?s)
- (t (error "invalid mouse modifier %s"
+ (t (error "Invalid mouse modifier %s"
modifier)))
?-))
foldout-mouse-modifiers)))
@@ -542,14 +530,21 @@ Valid modifiers are shift, control, meta, alt, hyper and
super.")
(mouse-2 (vector (intern (concat modifiers "down-mouse-2"))))
(mouse-3 (vector (intern (concat modifiers "down-mouse-3")))))
- (define-key outline-mode-map mouse-1 'foldout-mouse-zoom)
- (define-key outline-mode-map mouse-2 'foldout-mouse-show)
- (define-key outline-mode-map mouse-3 'foldout-mouse-hide-or-exit)
+ (define-key outline-mode-map mouse-1 #'foldout-mouse-zoom)
+ (define-key outline-mode-map mouse-2 #'foldout-mouse-show)
+ (define-key outline-mode-map mouse-3 #'foldout-mouse-hide-or-exit)
+
+ (define-key outline-minor-mode-map mouse-1 #'foldout-mouse-zoom)
+ (define-key outline-minor-mode-map mouse-2 #'foldout-mouse-show)
+ (define-key outline-minor-mode-map mouse-3 #'foldout-mouse-hide-or-exit)))
+
+;; Obsolete.
+
+(defconst foldout-hide-flag t)
+(make-obsolete-variable 'foldout-hide-flag nil "28.1")
- (define-key outline-minor-mode-map mouse-1 'foldout-mouse-zoom)
- (define-key outline-minor-mode-map mouse-2 'foldout-mouse-show)
- (define-key outline-minor-mode-map mouse-3 'foldout-mouse-hide-or-exit)
- ))
+(defconst foldout-show-flag nil)
+(make-obsolete-variable 'foldout-show-flag nil "28.1")
(provide 'foldout)
diff --git a/lisp/follow.el b/lisp/follow.el
index 56f06b1..dde140d 100644
--- a/lisp/follow.el
+++ b/lisp/follow.el
@@ -1,4 +1,4 @@
-;;; follow.el --- synchronize windows showing the same buffer
+;;; follow.el --- synchronize windows showing the same buffer -*-
lexical-binding: t -*-
;; Copyright (C) 1995-1997, 1999, 2001-2021 Free Software Foundation,
;; Inc.
@@ -234,17 +234,17 @@ After that, changing the prefix key requires manipulating
keymaps."
(defvar follow-mode-map
(let ((mainmap (make-sparse-keymap))
(map (make-sparse-keymap)))
- (define-key map "\C-v" 'follow-scroll-up)
- (define-key map "\M-v" 'follow-scroll-down)
- (define-key map "v" 'follow-scroll-down)
- (define-key map "1" 'follow-delete-other-windows-and-split)
- (define-key map "b" 'follow-switch-to-buffer)
- (define-key map "\C-b" 'follow-switch-to-buffer-all)
- (define-key map "\C-l" 'follow-recenter)
- (define-key map "<" 'follow-first-window)
- (define-key map ">" 'follow-last-window)
- (define-key map "n" 'follow-next-window)
- (define-key map "p" 'follow-previous-window)
+ (define-key map "\C-v" #'follow-scroll-up)
+ (define-key map "\M-v" #'follow-scroll-down)
+ (define-key map "v" #'follow-scroll-down)
+ (define-key map "1" #'follow-delete-other-windows-and-split)
+ (define-key map "b" #'follow-switch-to-buffer)
+ (define-key map "\C-b" #'follow-switch-to-buffer-all)
+ (define-key map "\C-l" #'follow-recenter)
+ (define-key map "<" #'follow-first-window)
+ (define-key map ">" #'follow-last-window)
+ (define-key map "n" #'follow-next-window)
+ (define-key map "p" #'follow-previous-window)
(define-key mainmap follow-mode-prefix map)
@@ -253,13 +253,13 @@ After that, changing the prefix key requires manipulating
keymaps."
;; could be enhanced in Follow mode. End-of-buffer is a special
;; case since it is very simple to define and it greatly enhances
;; the look and feel of Follow mode.)
- (define-key mainmap [remap end-of-buffer] 'follow-end-of-buffer)
+ (define-key mainmap [remap end-of-buffer] #'follow-end-of-buffer)
- (define-key mainmap [remap scroll-bar-toolkit-scroll]
'follow-scroll-bar-toolkit-scroll)
- (define-key mainmap [remap scroll-bar-drag] 'follow-scroll-bar-drag)
- (define-key mainmap [remap scroll-bar-scroll-up]
'follow-scroll-bar-scroll-up)
- (define-key mainmap [remap scroll-bar-scroll-down]
'follow-scroll-bar-scroll-down)
- (define-key mainmap [remap mwheel-scroll] 'follow-mwheel-scroll)
+ (define-key mainmap [remap scroll-bar-toolkit-scroll]
#'follow-scroll-bar-toolkit-scroll)
+ (define-key mainmap [remap scroll-bar-drag] #'follow-scroll-bar-drag)
+ (define-key mainmap [remap scroll-bar-scroll-up]
#'follow-scroll-bar-scroll-up)
+ (define-key mainmap [remap scroll-bar-scroll-down]
#'follow-scroll-bar-scroll-down)
+ (define-key mainmap [remap mwheel-scroll] #'follow-mwheel-scroll)
mainmap)
"Minor mode keymap for Follow mode.")
@@ -368,7 +368,7 @@ This is typically set by explicit scrolling commands.")
(defsubst follow-debug-message (&rest args)
"Like `message', but only active when `follow-debug' is non-nil."
(if (and (boundp 'follow-debug) follow-debug)
- (apply 'message args)))
+ (apply #'message args)))
;;; Cache
@@ -1694,8 +1694,7 @@ omitted if the character after POS is fully visible;
otherwise, RTOP
and RBOT are the number of pixels off-window at the top and bottom of
the screen line (\"row\") containing POS, ROWH is the visible height
of that row, and VPOS is the row number \(zero-based)."
- (let* ((windows (follow-all-followers window))
- (last (car (last windows))))
+ (let* ((windows (follow-all-followers window)))
(when follow-start-end-invalid
(follow-redisplay windows (car windows)))
(let* ((cache (follow-windows-start-end windows))
@@ -1723,7 +1722,7 @@ zero means top of the first window in the group, negative
means
(start-end (follow-windows-start-end windows))
(rev-start-end (reverse start-end))
(lines 0)
- middle-window elt count)
+ elt count)
(select-window
(cond
((null arg)
diff --git a/lisp/font-core.el b/lisp/font-core.el
index 4b69542..db06a60 100644
--- a/lisp/font-core.el
+++ b/lisp/font-core.el
@@ -126,7 +126,6 @@ buffer local value for `font-lock-defaults', via its mode
hook.
The above is the default behavior of `font-lock-mode'; you may
specify your own function which is called when `font-lock-mode'
is toggled via `font-lock-function'."
- nil nil nil
:after-hook (font-lock-initial-fontify)
;; Don't turn on Font Lock mode if we don't have a display (we're running a
;; batch job) or if the buffer is invisible (the name starts with a space).
diff --git a/lisp/forms.el b/lisp/forms.el
index 62c4288..8696aea 100644
--- a/lisp/forms.el
+++ b/lisp/forms.el
@@ -1,7 +1,6 @@
-;;; forms.el --- Forms mode: edit a file as a form to fill in
+;;; forms.el --- Forms mode: edit a file as a form to fill in -*-
lexical-binding: t; -*-
-;; Copyright (C) 1991, 1994-1997, 2001-2021 Free Software Foundation,
-;; Inc.
+;; Copyright (C) 1991-2021 Free Software Foundation, Inc.
;; Author: Johan Vromans <jvromans@squirrel.nl>
@@ -298,7 +297,6 @@
(defcustom forms-mode-hook nil
"Hook run upon entering Forms mode."
- :group 'forms
:type 'hook)
;;; Mandatory variables - must be set by evaluating the control file.
@@ -316,7 +314,6 @@
(defcustom forms-check-number-of-fields t
"If non-nil, warn about records with wrong number of fields."
- :group 'forms
:type 'boolean)
(defvar forms-field-sep "\t"
@@ -332,13 +329,11 @@ If not nil: use this character to separate multi-line
fields (default C-k).")
(defcustom forms-forms-scroll nil
"Non-nil means replace scroll-up/down commands in Forms mode.
The replacement commands performs forms-next/prev-record."
- :group 'forms
:type 'boolean)
(defcustom forms-forms-jump nil
"Non-nil means redefine beginning/end-of-buffer in Forms mode.
The replacement commands performs forms-first/last-record."
- :group 'forms
:type 'boolean)
(defvar forms-read-file-filter nil
@@ -363,23 +358,19 @@ The contents may NOT be modified.")
(defcustom forms-use-text-properties t
"Non-nil means to use text properties. "
- :group 'forms
:type 'boolean)
(defcustom forms-insert-after nil
"Non-nil means: inserts of new records go after current record.
Also, initial position is at last record."
- :group 'forms
:type 'boolean)
(defcustom forms-ro-face 'default
"The face (a symbol) that is used to display read-only text on the screen."
- :group 'forms
:type 'face)
(defcustom forms-rw-face 'region
"The face (a symbol) that is used to display read-write text on the screen."
- :group 'forms
:type 'face)
;;; Internal variables.
@@ -767,7 +758,7 @@ Commands: Equivalent keys in
read-only mode:
;; If it is a symbol, eval it first.
(if (and (symbolp el)
(boundp el))
- (setq el (eval el)))
+ (setq el (symbol-value el)))
(cond
@@ -1261,35 +1252,35 @@ Commands: Equivalent keys in
read-only mode:
;; `forms-mode-map' is always accessible via \C-c prefix.
(setq forms-mode-map (make-keymap))
- (define-key forms-mode-map "\t" 'forms-next-field)
- (define-key forms-mode-map "\C-k" 'forms-delete-record)
- (define-key forms-mode-map "\C-q" 'forms-toggle-read-only)
- (define-key forms-mode-map "\C-o" 'forms-insert-record)
- (define-key forms-mode-map "\C-l" 'forms-jump-record)
- (define-key forms-mode-map "\C-n" 'forms-next-record)
- (define-key forms-mode-map "\C-p" 'forms-prev-record)
- (define-key forms-mode-map "\C-r" 'forms-search-backward)
- (define-key forms-mode-map "\C-s" 'forms-search-forward)
- (define-key forms-mode-map "\C-x" 'forms-exit)
- (define-key forms-mode-map "<" 'forms-first-record)
- (define-key forms-mode-map ">" 'forms-last-record)
- (define-key forms-mode-map "\C-?" 'forms-prev-record)
+ (define-key forms-mode-map "\t" #'forms-next-field)
+ (define-key forms-mode-map "\C-k" #'forms-delete-record)
+ (define-key forms-mode-map "\C-q" #'forms-toggle-read-only)
+ (define-key forms-mode-map "\C-o" #'forms-insert-record)
+ (define-key forms-mode-map "\C-l" #'forms-jump-record)
+ (define-key forms-mode-map "\C-n" #'forms-next-record)
+ (define-key forms-mode-map "\C-p" #'forms-prev-record)
+ (define-key forms-mode-map "\C-r" #'forms-search-backward)
+ (define-key forms-mode-map "\C-s" #'forms-search-forward)
+ (define-key forms-mode-map "\C-x" #'forms-exit)
+ (define-key forms-mode-map "<" #'forms-first-record)
+ (define-key forms-mode-map ">" #'forms-last-record)
+ (define-key forms-mode-map "\C-?" #'forms-prev-record)
;; `forms-mode-ro-map' replaces the local map when in read-only mode.
(setq forms-mode-ro-map (make-keymap))
(suppress-keymap forms-mode-ro-map)
(define-key forms-mode-ro-map "\C-c" forms-mode-map)
- (define-key forms-mode-ro-map "q" 'forms-toggle-read-only)
- (define-key forms-mode-ro-map "l" 'forms-jump-record)
- (define-key forms-mode-ro-map "n" 'forms-next-record)
- (define-key forms-mode-ro-map "p" 'forms-prev-record)
- (define-key forms-mode-ro-map "r" 'forms-search-backward)
- (define-key forms-mode-ro-map "s" 'forms-search-forward)
- (define-key forms-mode-ro-map "x" 'forms-exit)
- (define-key forms-mode-ro-map "<" 'forms-first-record)
- (define-key forms-mode-ro-map ">" 'forms-last-record)
- (define-key forms-mode-ro-map "?" 'describe-mode)
- (define-key forms-mode-ro-map " " 'forms-next-record)
+ (define-key forms-mode-ro-map "q" #'forms-toggle-read-only)
+ (define-key forms-mode-ro-map "l" #'forms-jump-record)
+ (define-key forms-mode-ro-map "n" #'forms-next-record)
+ (define-key forms-mode-ro-map "p" #'forms-prev-record)
+ (define-key forms-mode-ro-map "r" #'forms-search-backward)
+ (define-key forms-mode-ro-map "s" #'forms-search-forward)
+ (define-key forms-mode-ro-map "x" #'forms-exit)
+ (define-key forms-mode-ro-map "<" #'forms-first-record)
+ (define-key forms-mode-ro-map ">" #'forms-last-record)
+ (define-key forms-mode-ro-map "?" #'describe-mode)
+ (define-key forms-mode-ro-map " " #'forms-next-record)
(forms--mode-commands1 forms-mode-ro-map)
(forms--mode-menu-ro forms-mode-ro-map)
@@ -1395,13 +1386,13 @@ Commands: Equivalent keys in
read-only mode:
(defun forms--mode-commands1 (map)
"Helper routine to define keys."
- (define-key map "\t" 'forms-next-field)
- (define-key map [S-tab] 'forms-prev-field)
- (define-key map [next] 'forms-next-record)
- (define-key map [prior] 'forms-prev-record)
- (define-key map [begin] 'forms-first-record)
- (define-key map [last] 'forms-last-record)
- (define-key map [backtab] 'forms-prev-field)
+ (define-key map "\t" #'forms-next-field)
+ (define-key map [S-tab] #'forms-prev-field)
+ (define-key map [next] #'forms-next-record)
+ (define-key map [prior] #'forms-prev-record)
+ (define-key map [begin] #'forms-first-record)
+ (define-key map [last] #'forms-last-record)
+ (define-key map [backtab] #'forms-prev-field)
)
;;; Changed functions
@@ -2034,8 +2025,7 @@ Usage: (setq forms-number-of-fields
(defcustom forms--debug nil
"If non-nil, enable Forms mode debugging."
- :type 'boolean
- :group 'forms)
+ :type 'boolean)
(defun forms--debug (&rest args)
"Internal debugging routine."
@@ -2046,7 +2036,7 @@ Usage: (setq forms-number-of-fields
(if (stringp el) el
(concat (prin1-to-string el) " = "
(if (boundp el)
- (prin1-to-string (eval el))
+ (prin1-to-string (symbol-value el))
"<unbound>")
"\n"
(if (fboundp el)
diff --git a/lisp/frame.el b/lisp/frame.el
index 2b6e4a6..aff1d47 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -301,7 +301,7 @@ This function runs the abnormal hook
`move-frame-functions'."
(declare-function tool-bar-mode "tool-bar" (&optional arg))
(declare-function tool-bar-height "xdisp.c" (&optional frame pixelwise))
-(defalias 'tool-bar-lines-needed 'tool-bar-height)
+(defalias 'tool-bar-lines-needed #'tool-bar-height)
;; startup.el calls this function after loading the user's init
;; file. Now default-frame-alist and initial-frame-alist contain
@@ -615,15 +615,6 @@ there (in decreasing order of priority)."
(face-set-after-frame-default frame-initial-frame)
(setq newparms (delq new-bg newparms)))
- (when (numberp (car frame-size-history))
- (setq frame-size-history
- (cons (1- (car frame-size-history))
- (cons
- (list frame-initial-frame
- "FRAME-NOTICE-USER"
- nil newparms)
- (cdr frame-size-history)))))
-
(modify-frame-parameters frame-initial-frame newparms)))))
;; Restore the original buffer.
@@ -690,8 +681,8 @@ is not considered (see `next-frame')."
0))
(select-frame-set-input-focus (selected-frame)))
-(defalias 'next-multiframe-window 'next-window-any-frame)
-(defalias 'previous-multiframe-window 'previous-window-any-frame)
+(defalias 'next-multiframe-window #'next-window-any-frame)
+(defalias 'previous-multiframe-window #'previous-window-any-frame)
(defun window-system-for-display (display)
"Return the window system for DISPLAY.
@@ -782,7 +773,7 @@ If DISPLAY is nil, that stands for the selected frame's
display."
(format "Delete %s frames? " (length frames))
(format "Delete %s ? " (car frames))))))
(error "Abort!")
- (mapc 'delete-frame frames)
+ (mapc #'delete-frame frames)
(x-close-connection display))))
(defun make-frame-command ()
@@ -926,12 +917,6 @@ the new frame according to its own rules."
(let ((val (frame-parameter oldframe param)))
(when val (set-frame-parameter frame param val)))))
- (when (numberp (car frame-size-history))
- (setq frame-size-history
- (cons (1- (car frame-size-history))
- (cons (list frame "MAKE-FRAME")
- (cdr frame-size-history)))))
-
;; We can run `window-configuration-change-hook' for this frame now.
(frame-after-make-frame frame t)
(run-hook-with-args 'after-make-frame-functions frame)
@@ -1162,8 +1147,8 @@ e.g. (mapc \\='frame-set-background-mode (frame-list))."
:group 'faces
:set #'(lambda (var value)
(set-default var value)
- (mapc 'frame-set-background-mode (frame-list)))
- :initialize 'custom-initialize-changed
+ (mapc #'frame-set-background-mode (frame-list)))
+ :initialize #'custom-initialize-changed
:type '(choice (const dark)
(const light)
(const :tag "automatic" nil)))
@@ -1176,6 +1161,27 @@ e.g. (mapc \\='frame-set-background-mode (frame-list))."
(defvar inhibit-frame-set-background-mode nil)
+(defun frame--current-backround-mode (frame)
+ (let* ((frame-default-bg-mode (frame-terminal-default-bg-mode frame))
+ (bg-color (frame-parameter frame 'background-color))
+ (tty-type (tty-type frame))
+ (default-bg-mode
+ (if (or (window-system frame)
+ (and tty-type
+ (string-match "^\\(xterm\\|rxvt\\|dtterm\\|eterm\\)"
+ tty-type)))
+ 'light
+ 'dark)))
+ (cond (frame-default-bg-mode)
+ ((equal bg-color "unspecified-fg") ; inverted colors
+ (if (eq default-bg-mode 'light) 'dark 'light))
+ ((not (color-values bg-color frame))
+ default-bg-mode)
+ ((color-dark-p (mapcar (lambda (c) (/ c 65535.0))
+ (color-values bg-color frame)))
+ 'dark)
+ (t 'light))))
+
(defun frame-set-background-mode (frame &optional keep-face-specs)
"Set up display-dependent faces on FRAME.
Display-dependent faces are those which have different definitions
@@ -1184,30 +1190,8 @@ according to the `background-mode' and `display-type'
frame parameters.
If optional arg KEEP-FACE-SPECS is non-nil, don't recalculate
face specs for the new background mode."
(unless inhibit-frame-set-background-mode
- (let* ((frame-default-bg-mode (frame-terminal-default-bg-mode frame))
- (bg-color (frame-parameter frame 'background-color))
- (tty-type (tty-type frame))
- (default-bg-mode
- (if (or (window-system frame)
- (and tty-type
- (string-match "^\\(xterm\\|rxvt\\|dtterm\\|eterm\\)"
- tty-type)))
- 'light
- 'dark))
- (non-default-bg-mode (if (eq default-bg-mode 'light) 'dark 'light))
- (bg-mode
- (cond (frame-default-bg-mode)
- ((equal bg-color "unspecified-fg") ; inverted colors
- non-default-bg-mode)
- ((not (color-values bg-color frame))
- default-bg-mode)
- ((>= (apply '+ (color-values bg-color frame))
- ;; Just looking at the screen, colors whose
- ;; values add up to .6 of the white total
- ;; still look dark to me.
- (* (apply '+ (color-values "white" frame)) .6))
- 'light)
- (t 'dark)))
+ (let* ((bg-mode
+ (frame--current-backround-mode frame))
(display-type
(cond ((null (window-system frame))
(if (tty-display-color-p frame) 'color 'mono))
@@ -1273,6 +1257,26 @@ the `background-mode' terminal parameter."
(intern (downcase bg-resource))))
(terminal-parameter frame 'background-mode)))
+;; FIXME: This needs to be significantly improved before we can use it:
+;; - Fix the "scope" to be consistent: the code below is partly per-frame
+;; and partly all-frames :-(
+;; - Make it interact correctly with color themes (e.g. modus-themes).
+;; Maybe automatically disabling color themes that disagree with the
+;; selected value of `dark-mode'.
+;; - Check interaction with "(in|re)verse-video".
+;;
+;; (define-minor-mode dark-mode
+;; "Use light text on dark background."
+;; :global t
+;; :group 'faces
+;; (when (eq dark-mode
+;; (eq 'light (frame--current-backround-mode (selected-frame))))
+;; ;; FIXME: Change the face's SPEC instead?
+;; (set-face-attribute 'default nil
+;; :foreground (face-attribute 'default :background)
+;; :background (face-attribute 'default :foreground))
+;; (frame-set-background-mode (selected-frame))))
+
;;;; Frame configurations
@@ -1357,9 +1361,9 @@ differing font heights."
If FRAME is omitted, describe the currently selected frame."
(cdr (assq 'width (frame-parameters frame))))
-(defalias 'frame-border-width 'frame-internal-border-width)
-(defalias 'frame-pixel-width 'frame-native-width)
-(defalias 'frame-pixel-height 'frame-native-height)
+(defalias 'frame-border-width #'frame-internal-border-width)
+(defalias 'frame-pixel-width #'frame-native-width)
+(defalias 'frame-pixel-height #'frame-native-height)
(defun frame-inner-width (&optional frame)
"Return inner width of FRAME in pixels.
@@ -1676,26 +1680,104 @@ and width values are in pixels.
(defun frame--size-history (&optional frame)
"Print history of resize operations for FRAME.
-Print prettified version of `frame-size-history' into a buffer
-called *frame-size-history*. Optional argument FRAME denotes the
-frame whose history will be printed. FRAME defaults to the
-selected frame."
+This function dumps a prettified version of `frame-size-history'
+into a buffer called *frame-size-history*. The optional argument
+FRAME denotes the frame whose history will be dumped; it defaults
+to the selected frame.
+
+Storing information about resize operations is off by default.
+If you set the variable `frame-size-history' like this
+
+(setq frame-size-history '(100))
+
+then Emacs will save information about the next 100 significant
+operations affecting any frame's size in that variable. This
+function prints the entries for FRAME stored in that variable in
+a more legible way.
+
+All lines start with an indication of the requested action. An
+entry like `menu-bar-lines' or `scroll-bar-width' indicates that
+a change of the corresponding frame parameter or Lisp variable
+was requested. An entry like gui_figure_window_size indicates
+that that C function was executed, an entry like ConfigureNotify
+indicates that that event was received.
+
+In long entries, a number in parentheses displays the INHIBIT
+parameter passed to the C function adjust_frame_size. Such
+entries may also display changes of frame rectangles in a form
+like R=n1xn2~>n3xn4 where R denotes the rectangle type (TS for
+text, NS for native and IS for inner frame rectangle sizes, all
+in pixels, TC for text rectangle sizes in frame columns and
+lines), n1 and n2 denote the old width and height and n3 and n4
+the new width and height in the according units. MS stands for
+the minimum inner frame size in pixels, IH and IV, if present,
+indicate that resizing horizontally and/or vertically was
+inhibited (either by `frame-inhibit-implied-resize' or because of
+the frame's fullscreen state).
+
+Shorter entries represent C functions that process width and
+height changes of the native rectangle where PS stands for the
+frame's present pixel width and height, XS for a requested pixel
+width and height and DS for some earlier requested but so far
+delayed pixel width and height.
+
+Very short entries represent calls of C functions that do not
+directly ask for size changes but may indirectly affect the size
+of frames like calls to map a frame or change its visibility."
(let ((history (reverse frame-size-history))
- entry)
+ entry item)
(setq frame (window-normalize-frame frame))
(with-current-buffer (get-buffer-create "*frame-size-history*")
(erase-buffer)
(insert (format "Frame size history of %s\n" frame))
(while (consp (setq entry (pop history)))
- (when (eq (car entry) frame)
- (pop entry)
- (insert (format "%s" (pop entry)))
- (move-to-column 24 t)
- (while entry
- (insert (format " %s" (pop entry))))
- (insert "\n")))
- (unless frame-size-history
- (insert "Frame size history is nil.\n")))))
+ (setq item (car entry))
+ (cond
+ ((not (consp item))
+ ;; An item added quickly for debugging purposes.
+ (insert (format "%s\n" entry)))
+ ((and (eq (nth 0 item) frame) (= (nth 1 item) 1))
+ ;; Length 1 is a "plain event".
+ (insert (format "%s\n" (nth 2 item))))
+ ((and (eq (nth 0 item) frame) (= (nth 1 item) 2))
+ ;; Length 2 is an "extra" item.
+ (insert (format "%s" (nth 2 item)))
+ (setq item (nth 0 (cdr entry)))
+ (insert (format ", PS=%sx%s" (nth 0 item) (nth 1 item)))
+ (when (or (>= (nth 2 item) 0) (>= (nth 3 item) 0))
+ (insert (format ", XS=%sx%s" (nth 2 item) (nth 3 item))))
+ (setq item (nth 1 (cdr entry)))
+ (when (or (>= (nth 0 item) 0) (>= (nth 1 item) 0))
+ (insert (format ", DS=%sx%s" (nth 0 item) (nth 1 item))))
+ (insert "\n"))
+ ((and (eq (nth 0 item) frame) (= (nth 1 item) 5))
+ ;; Length 5 is an `adjust-frame-size' item.
+ (insert (format "%s (%s)" (nth 3 item) (nth 2 item)))
+ (setq item (nth 0 (cdr entry)))
+ (unless (and (= (nth 0 item) (nth 2 item))
+ (= (nth 1 item) (nth 3 item)))
+ (insert (format ", TS=%sx%s~>%sx%s"
+ (nth 0 item) (nth 1 item) (nth 2 item) (nth 3
item))))
+ (setq item (nth 1 (cdr entry)))
+ (unless (and (= (nth 0 item) (nth 2 item))
+ (= (nth 1 item) (nth 3 item)))
+ (insert (format ", TC=%sx%s~>%sx%s"
+ (nth 0 item) (nth 1 item) (nth 2 item) (nth 3
item))))
+ (setq item (nth 2 (cdr entry)))
+ (unless (and (= (nth 0 item) (nth 2 item))
+ (= (nth 1 item) (nth 3 item)))
+ (insert (format ", NS=%sx%s~>%sx%s"
+ (nth 0 item) (nth 1 item) (nth 2 item) (nth 3
item))))
+ (setq item (nth 3 (cdr entry)))
+ (unless (and (= (nth 0 item) (nth 2 item))
+ (= (nth 1 item) (nth 3 item)))
+ (insert (format ", IS=%sx%s~>%sx%s"
+ (nth 0 item) (nth 1 item) (nth 2 item) (nth 3
item))))
+ (setq item (nth 4 (cdr entry)))
+ (insert (format ", MS=%sx%s" (nth 0 item) (nth 1 item)))
+ (when (nth 2 item) (insert " IH"))
+ (when (nth 3 item) (insert " IV"))
+ (insert "\n")))))))
(declare-function x-frame-edges "xfns.c" (&optional frame type))
(declare-function w32-frame-edges "w32fns.c" (&optional frame type))
@@ -1991,9 +2073,9 @@ frame's display)."
(fboundp 'image-mask-p)
(fboundp 'image-size)))
-(defalias 'display-blink-cursor-p 'display-graphic-p)
-(defalias 'display-multi-frame-p 'display-graphic-p)
-(defalias 'display-multi-font-p 'display-graphic-p)
+(defalias 'display-blink-cursor-p #'display-graphic-p)
+(defalias 'display-multi-frame-p #'display-graphic-p)
+(defalias 'display-multi-font-p #'display-graphic-p)
(defun display-selections-p (&optional display)
"Return non-nil if DISPLAY supports selections.
@@ -2340,13 +2422,15 @@ In the 3rd, 4th, and 6th examples, the returned value
is relative to
the opposite frame edge from the edge indicated in the input spec."
(cons (car spec) (frame-geom-value-cons (car spec) (cdr spec) frame)))
-(defun delete-other-frames (&optional frame)
+(defun delete-other-frames (&optional frame iconify)
"Delete all frames on FRAME's terminal, except FRAME.
If FRAME uses another frame's minibuffer, the minibuffer frame is
left untouched. Do not delete any of FRAME's child frames. If
FRAME is a child frame, delete its siblings only. FRAME must be
-a live frame and defaults to the selected one."
- (interactive)
+a live frame and defaults to the selected one.
+If the prefix arg ICONIFY is non-nil, just iconify the frames rather than
+deleting them."
+ (interactive "i\nP")
(setq frame (window-normalize-frame frame))
(let ((minibuffer-frame (window-frame (minibuffer-window frame)))
(this (next-frame frame t))
@@ -2361,7 +2445,7 @@ a live frame and defaults to the selected one."
(and parent (not (eq (frame-parent this) parent)))
;; Do not delete a child frame of FRAME.
(eq (frame-parent this) frame))
- (delete-frame this))
+ (if iconify (iconify-frame this) (delete-frame this)))
(setq this next))
;; In a second round consider all remaining frames.
(setq this (next-frame frame t))
@@ -2373,7 +2457,7 @@ a live frame and defaults to the selected one."
(and parent (not (eq (frame-parent this) parent)))
;; Do not delete a child frame of FRAME.
(eq (frame-parent this) frame))
- (delete-frame this))
+ (if iconify (iconify-frame this) (delete-frame this)))
(setq this next))))
@@ -2399,7 +2483,7 @@ parameters `bottom-divider-width' and
`right-divider-width'."
:type '(choice (const :tag "Bottom only" bottom-only)
(const :tag "Right only" right-only)
(const :tag "Bottom and right" t))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (symbol value)
(set-default symbol value)
(when window-divider-mode
@@ -2420,7 +2504,7 @@ parameter `bottom-divider-width'."
:type '(restricted-sexp
:tag "Default width of bottom dividers"
:match-alternatives (window-divider-width-valid-p))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (symbol value)
(set-default symbol value)
(when window-divider-mode
@@ -2437,7 +2521,7 @@ parameter `right-divider-width'."
:type '(restricted-sexp
:tag "Default width of right dividers"
:match-alternatives (window-divider-width-valid-p))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (symbol value)
(set-default symbol value)
(when window-divider-mode
@@ -2714,14 +2798,14 @@ See also `toggle-frame-maximized'."
;;;; Key bindings
-(define-key ctl-x-5-map "2" 'make-frame-command)
-(define-key ctl-x-5-map "1" 'delete-other-frames)
-(define-key ctl-x-5-map "0" 'delete-frame)
-(define-key ctl-x-5-map "o" 'other-frame)
-(define-key ctl-x-5-map "5" 'other-frame-prefix)
-(define-key global-map [f11] 'toggle-frame-fullscreen)
-(define-key global-map [(meta f10)] 'toggle-frame-maximized)
-(define-key esc-map [f10] 'toggle-frame-maximized)
+(define-key ctl-x-5-map "2" #'make-frame-command)
+(define-key ctl-x-5-map "1" #'delete-other-frames)
+(define-key ctl-x-5-map "0" #'delete-frame)
+(define-key ctl-x-5-map "o" #'other-frame)
+(define-key ctl-x-5-map "5" #'other-frame-prefix)
+(define-key global-map [f11] #'toggle-frame-fullscreen)
+(define-key global-map [(meta f10)] #'toggle-frame-maximized)
+(define-key esc-map [f10] #'toggle-frame-maximized)
;; Misc.
diff --git a/lisp/generic-x.el b/lisp/generic-x.el
index 0f4e1ae..4505d85 100644
--- a/lisp/generic-x.el
+++ b/lisp/generic-x.el
@@ -32,6 +32,17 @@
;;
;; (require 'generic-x)
;;
+;; You can decide which modes to load by setting the variable
+;; `generic-extras-enable-list'. Its default value is platform-
+;; specific. The recommended way to set this variable is through
+;; customize:
+;;
+;; M-x customize-option RET generic-extras-enable-list RET
+;;
+;; This lets you select generic modes from the list of available
+;; modes. If you manually set `generic-extras-enable-list' in your
+;; .emacs, do it BEFORE loading generic-x with (require 'generic-x).
+;;
;; You can also send in new modes; if the file types are reasonably
;; common, we would like to install them.
;;
@@ -173,7 +184,88 @@ This hook will be installed if the variable
;; Other Generic modes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; If you add a generic mode to this file, put it in one of these four
+;; lists as well.
+
+(defconst generic-default-modes
+ '(apache-conf-generic-mode
+ apache-log-generic-mode
+ hosts-generic-mode
+ java-manifest-generic-mode
+ java-properties-generic-mode
+ javascript-generic-mode
+ show-tabs-generic-mode
+ vrml-generic-mode)
+ "List of generic modes that are defined by default.")
+
+(defconst generic-mswindows-modes
+ '(bat-generic-mode
+ inf-generic-mode
+ ini-generic-mode
+ rc-generic-mode
+ reg-generic-mode
+ rul-generic-mode)
+ "List of generic modes that are defined by default on MS-Windows.")
+
+(defconst generic-unix-modes
+ '(alias-generic-mode
+ ansible-inventory-generic-mode
+ etc-fstab-generic-mode
+ etc-modules-conf-generic-mode
+ etc-passwd-generic-mode
+ etc-services-generic-mode
+ etc-sudoers-generic-mode
+ fvwm-generic-mode
+ inetd-conf-generic-mode
+ mailagent-rules-generic-mode
+ mailrc-generic-mode
+ named-boot-generic-mode
+ named-database-generic-mode
+ prototype-generic-mode
+ resolve-conf-generic-mode
+ samba-generic-mode
+ x-resource-generic-mode
+ xmodmap-generic-mode)
+ "List of generic modes that are defined by default on Unix.")
+
+(defconst generic-other-modes
+ '(astap-generic-mode
+ ibis-generic-mode
+ pkginfo-generic-mode
+ spice-generic-mode)
+ "List of generic modes that are not defined by default.")
+
+(defcustom generic-extras-enable-list
+ (append generic-default-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
+directly, without using customize, you must reload generic-x to put
+your changes into effect."
+ :type (let (list)
+ (dolist (mode
+ (sort (append generic-default-modes
+ generic-mswindows-modes
+ generic-unix-modes
+ generic-other-modes
+ nil)
+ (lambda (a b)
+ (string< (symbol-name b)
+ (symbol-name a))))
+ (cons 'set list))
+ (push `(const ,mode) list)))
+ :set (lambda (s v)
+ (set-default s v)
+ (unless load-in-progress
+ (load "generic-x")))
+ :version "22.1")
+
;;; Apache
+(when (memq 'apache-conf-generic-mode generic-extras-enable-list)
+
(define-generic-mode apache-conf-generic-mode
'(?#)
nil
@@ -186,7 +278,9 @@ This hook will be installed if the variable
'((nil "^\\([-A-Za-z0-9_]+\\)" 1)
("*Directories*" "^\\s-*<Directory\\s-*\\([^>]+\\)>" 1)
("*Locations*" "^\\s-*<Location\\s-*\\([^>]+\\)>" 1)))))
- "Generic mode for Apache or HTTPD configuration files.")
+ "Generic mode for Apache or HTTPD configuration files."))
+
+(when (memq 'apache-log-generic-mode generic-extras-enable-list)
(define-generic-mode apache-log-generic-mode
nil
@@ -197,9 +291,11 @@ This hook will be installed if the variable
(2 font-lock-variable-name-face)))
'("access_log\\'")
nil
- "Generic mode for Apache log files.")
+ "Generic mode for Apache log files."))
;;; Samba
+(when (memq 'samba-generic-mode generic-extras-enable-list)
+
(define-generic-mode samba-generic-mode
'(?\; ?#)
nil
@@ -209,11 +305,13 @@ This hook will be installed if the variable
(2 font-lock-type-face)))
'("smb\\.conf\\'")
'(generic-bracket-support)
- "Generic mode for Samba configuration files.")
+ "Generic mode for Samba configuration files."))
;;; Fvwm
;; This is pretty basic. Also, modes for other window managers could
;; be defined as well.
+(when (memq 'fvwm-generic-mode generic-extras-enable-list)
+
(define-generic-mode fvwm-generic-mode
'(?#)
'("AddToMenu"
@@ -232,28 +330,33 @@ This hook will be installed if the variable
nil
'("\\.fvwmrc\\'" "\\.fvwm2rc\\'")
nil
- "Generic mode for FVWM configuration files.")
+ "Generic mode for FVWM configuration files."))
;;; X Resource
;; I'm pretty sure I've seen an actual mode to do this, but I don't
;; think it's standard with Emacs
+(when (memq 'x-resource-generic-mode generic-extras-enable-list)
+
(define-generic-mode x-resource-generic-mode
'(?!)
nil
'(("^\\([^:\n]+:\\)" 1 font-lock-variable-name-face))
'("\\.Xdefaults\\'" "\\.Xresources\\'" "\\.Xenvironment\\'" "\\.ad\\'")
nil
- "Generic mode for X Resource configuration files.")
+ "Generic mode for X Resource configuration files."))
+(if (memq 'xmodmap-generic-mode generic-extras-enable-list)
(define-generic-mode xmodmap-generic-mode
'(?!)
'("add" "clear" "keycode" "keysym" "remove" "pointer")
nil
'("[xX]modmap\\(rc\\)?\\'")
nil
- "Simple mode for xmodmap files.")
+ "Simple mode for xmodmap files."))
;;; Hosts
+(when (memq 'hosts-generic-mode generic-extras-enable-list)
+
(define-generic-mode hosts-generic-mode
'(?#)
'("localhost")
@@ -261,20 +364,27 @@ This hook will be installed if the variable
("\\<\\([0-9A-Fa-f:]+\\)\\>" 1 font-lock-constant-face))
'("[hH][oO][sS][tT][sS]\\'")
nil
- "Generic mode for HOSTS files.")
+ "Generic mode for HOSTS files."))
;;; Windows INF files
+;; If i-g-m-f-f-h is defined, then so is i-g-m.
+(declare-function ini-generic-mode "generic-x")
+
+(when (memq 'inf-generic-mode generic-extras-enable-list)
+
(define-generic-mode inf-generic-mode
'(?\;)
nil
'(("^\\(\\[.*\\]\\)" 1 font-lock-constant-face))
'("\\.[iI][nN][fF]\\'")
'(generic-bracket-support)
- "Generic mode for MS-Windows INF files.")
+ "Generic mode for MS-Windows INF files."))
;;; Windows INI files
;; Should define escape character as well!
+(when (memq 'ini-generic-mode generic-extras-enable-list)
+
(define-generic-mode ini-generic-mode
'(?\;)
nil
@@ -301,9 +411,13 @@ like an INI file. You can add this hook to
`find-file-hook'."
(goto-char (point-min))
(and (looking-at "^\\s-*\\[.*\\]")
(ini-generic-mode)))))
+(define-obsolete-function-alias 'generic-mode-ini-file-find-file-hook
+ 'ini-generic-mode-find-file-hook "28.1"))
;;; Windows REG files
;;; Unfortunately, Windows 95 and Windows NT have different REG file syntax!
+(when (memq 'reg-generic-mode generic-extras-enable-list)
+
(define-generic-mode reg-generic-mode
'(?\;)
'("key" "classes_root" "REGEDIT" "REGEDIT4")
@@ -314,11 +428,19 @@ like an INI file. You can add this hook to
`find-file-hook'."
(lambda ()
(setq imenu-generic-expression
'((nil "^\\s-*\\(.*\\)\\s-*=" 1)))))
- "Generic mode for MS-Windows Registry files.")
+ "Generic mode for MS-Windows Registry files."))
+
+(declare-function w32-shell-name "w32-fns" ())
+
+;;; DOS/Windows BAT files
+(when (memq 'bat-generic-mode generic-extras-enable-list)
+ (define-obsolete-function-alias 'bat-generic-mode 'bat-mode "24.4"))
;;; Mailagent
;; Mailagent is a Unix mail filtering program. Anyone wanna do a
;; generic mode for procmail?
+(when (memq 'mailagent-rules-generic-mode generic-extras-enable-list)
+
(define-generic-mode mailagent-rules-generic-mode
'(?#)
'("SAVE" "DELETE" "PIPE" "ANNOTATE" "REJECT")
@@ -329,9 +451,11 @@ like an INI file. You can add this hook to
`find-file-hook'."
(lambda ()
(setq imenu-generic-expression
'((nil "\\s-/\\([^/]+\\)/[i, \t\n]" 1)))))
- "Generic mode for Mailagent rules files.")
+ "Generic mode for Mailagent rules files."))
;; Solaris/Sys V prototype files
+(when (memq 'prototype-generic-mode generic-extras-enable-list)
+
(define-generic-mode prototype-generic-mode
'(?#)
nil
@@ -350,9 +474,11 @@ like an INI file. You can add this hook to
`find-file-hook'."
(2 font-lock-variable-name-face)))
'("prototype\\'")
nil
- "Generic mode for Sys V prototype files.")
+ "Generic mode for Sys V prototype files."))
;; Solaris/Sys V pkginfo files
+(when (memq 'pkginfo-generic-mode generic-extras-enable-list)
+
(define-generic-mode pkginfo-generic-mode
'(?#)
nil
@@ -361,9 +487,17 @@ like an INI file. You can add this hook to
`find-file-hook'."
(2 font-lock-variable-name-face)))
'("pkginfo\\'")
nil
- "Generic mode for Sys V pkginfo files.")
+ "Generic mode for Sys V pkginfo files."))
+
+;; Javascript mode
+;; Obsolete; defer to js-mode from js.el.
+(when (memq 'javascript-generic-mode generic-extras-enable-list)
+ (define-obsolete-function-alias 'javascript-generic-mode 'js-mode "24.3")
+ (define-obsolete-variable-alias 'javascript-generic-mode-hook 'js-mode-hook
"24.3"))
;; VRML files
+(when (memq 'vrml-generic-mode generic-extras-enable-list)
+
(define-generic-mode vrml-generic-mode
'(?#)
'("DEF"
@@ -411,9 +545,11 @@ like an INI file. You can add this hook to
`find-file-hook'."
("*Definitions*"
"DEF\\s-+\\([-A-Za-z0-9_]+\\)\\s-+\\([A-Za-z0-9]+\\)\\s-*{"
1)))))
- "Generic Mode for VRML files.")
+ "Generic Mode for VRML files."))
;; Java Manifests
+(when (memq 'java-manifest-generic-mode generic-extras-enable-list)
+
(define-generic-mode java-manifest-generic-mode
'(?#)
'("Name"
@@ -430,9 +566,11 @@ like an INI file. You can add this hook to
`find-file-hook'."
(2 font-lock-constant-face)))
'("[mM][aA][nN][iI][fF][eE][sS][tT]\\.[mM][fF]\\'")
nil
- "Generic mode for Java Manifest files.")
+ "Generic mode for Java Manifest files."))
;; Java properties files
+(when (memq 'java-properties-generic-mode generic-extras-enable-list)
+
(define-generic-mode java-properties-generic-mode
'(?! ?#)
nil
@@ -458,9 +596,11 @@ like an INI file. You can add this hook to
`find-file-hook'."
(lambda ()
(setq imenu-generic-expression
'((nil "^\\([^#! \t\n\r=:]+\\)" 1)))))
- "Generic mode for Java properties files.")
+ "Generic mode for Java properties files."))
;; C shell alias definitions
+(when (memq 'alias-generic-mode generic-extras-enable-list)
+
(define-generic-mode alias-generic-mode
'(?#)
'("alias" "unalias")
@@ -473,9 +613,11 @@ like an INI file. You can add this hook to
`find-file-hook'."
(lambda ()
(setq imenu-generic-expression
'((nil "^\\(alias\\|unalias\\)\\s-+\\([-a-zA-Z0-9_]+\\)" 2)))))
- "Generic mode for C Shell alias files.")
+ "Generic mode for C Shell alias files."))
;; Ansible inventory files
+(when (memq 'ansible-inventory-generic-mode generic-extras-enable-list)
+
(define-generic-mode ansible-inventory-generic-mode
'(?#)
nil
@@ -494,10 +636,12 @@ like an INI file. You can add this hook to
`find-file-hook'."
(setq imenu-generic-expression
'((nil "^\\s-*\\[\\(.*\\)\\]" 1)
("*Variables*" "\\s-+\\([^ =\n\r]+\\)=" 1)))))
- "Generic mode for Ansible inventory files.")
+ "Generic mode for Ansible inventory files."))
;;; Windows RC files
;; Contributed by ACorreir@pervasive-sw.com (Alfred Correira)
+(when (memq 'rc-generic-mode generic-extras-enable-list)
+
(define-generic-mode rc-generic-mode
;; '(?\/)
'("//")
@@ -577,13 +721,15 @@ like an INI file. You can add this hook to
`find-file-hook'."
'("^#[ \t]*\\(\\sw+\\)\\>[ \t]*\\(\\sw+\\)?"
(1 font-lock-constant-face)
(2 font-lock-variable-name-face nil t))))
- '("\\.[rR][cC]\\'")
- nil
- "Generic mode for MS-Windows Resource files.")
+ '("\\.[rR][cC]\\'")
+ nil
+ "Generic mode for MS-Windows Resource files."))
;; InstallShield RUL files
;; Contributed by Alfred.Correira@Pervasive.Com
;; Bugfixes by "Rolf Sandau" <Rolf.Sandau@marconi.com>
+(when (memq 'rul-generic-mode generic-extras-enable-list)
+
(eval-when-compile
;;; build the regexp strings using regexp-opt
@@ -1226,9 +1372,11 @@ like an INI file. You can add this hook to
`find-file-hook'."
> "begin" \n
> _ \n
resume:
- > "end;")
+ > "end;"))
;; Additions by ACorreir@pervasive-sw.com (Alfred Correira)
+(when (memq 'mailrc-generic-mode generic-extras-enable-list)
+
(define-generic-mode mailrc-generic-mode
'(?#)
'("alias"
@@ -1250,9 +1398,11 @@ like an INI file. You can add this hook to
`find-file-hook'."
(2 font-lock-variable-name-face)))
'("\\.mailrc\\'")
nil
- "Mode for mailrc files.")
+ "Mode for mailrc files."))
;; Inetd.conf
+(when (memq 'inetd-conf-generic-mode generic-extras-enable-list)
+
(define-generic-mode inetd-conf-generic-mode
'(?#)
'("stream"
@@ -1267,9 +1417,11 @@ like an INI file. You can add this hook to
`find-file-hook'."
(list
(lambda ()
(setq imenu-generic-expression
- '((nil "^\\([-A-Za-z0-9_]+\\)" 1))))))
+ '((nil "^\\([-A-Za-z0-9_]+\\)" 1)))))))
;; Services
+(when (memq 'etc-services-generic-mode generic-extras-enable-list)
+
(define-generic-mode etc-services-generic-mode
'(?#)
'("tcp"
@@ -1282,9 +1434,11 @@ like an INI file. You can add this hook to
`find-file-hook'."
(list
(lambda ()
(setq imenu-generic-expression
- '((nil "^\\([-A-Za-z0-9_]+\\)" 1))))))
+ '((nil "^\\([-A-Za-z0-9_]+\\)" 1)))))))
;; Password and Group files
+(when (memq 'etc-passwd-generic-mode generic-extras-enable-list)
+
(define-generic-mode etc-passwd-generic-mode
nil ;; No comment characters
'("root") ;; Only one keyword
@@ -1322,9 +1476,11 @@ like an INI file. You can add this hook to
`find-file-hook'."
(list
(lambda ()
(setq imenu-generic-expression
- '((nil "^\\([-A-Za-z0-9_]+\\):" 1))))))
+ '((nil "^\\([-A-Za-z0-9_]+\\):" 1)))))))
;; Fstab
+(when (memq 'etc-fstab-generic-mode generic-extras-enable-list)
+
(define-generic-mode etc-fstab-generic-mode
'(?#)
'("adfs"
@@ -1436,9 +1592,11 @@ like an INI file. You can add this hook to
`find-file-hook'."
(list
(lambda ()
(setq imenu-generic-expression
- '((nil "^\\([^# \t]+\\)\\s-+" 1))))))
+ '((nil "^\\([^# \t]+\\)\\s-+" 1)))))))
;; /etc/sudoers
+(when (memq 'etc-sudoers-generic-mode generic-extras-enable-list)
+
(define-generic-mode etc-sudoers-generic-mode
'(?#)
'("User_Alias" "Runas_Alias" "Host_Alias" "Cmnd_Alias"
@@ -1449,9 +1607,11 @@ like an INI file. You can add this hook to
`find-file-hook'."
("\\<\\(%[A-Za-z0-9_]+\\)\\>" 1 font-lock-variable-name-face))
'("/etc/sudoers\\'")
nil
- "Generic mode for sudoers configuration files.")
+ "Generic mode for sudoers configuration files."))
;; From Jacques Duthen <jacques.duthen@sncf.fr>
+(when (memq 'show-tabs-generic-mode generic-extras-enable-list)
+
(eval-when-compile
(defconst show-tabs-generic-mode-font-lock-defaults-1
@@ -1489,12 +1649,14 @@ like an INI file. You can add this hook to
`find-file-hook'."
nil ;; no auto-mode-alist
;; '(show-tabs-generic-mode-hook-fun)
nil
- "Generic mode to show tabs and trailing spaces.")
+ "Generic mode to show tabs and trailing spaces."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DNS modes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(when (memq 'named-boot-generic-mode generic-extras-enable-list)
+
(define-generic-mode named-boot-generic-mode
;; List of comment characters
'(?\;)
@@ -1510,7 +1672,9 @@ like an INI file. You can add this hook to
`find-file-hook'."
;; List of additional automode-alist expressions
'("/etc/named\\.boot\\'")
;; List of set up functions to call
- nil)
+ nil))
+
+(when (memq 'named-database-generic-mode generic-extras-enable-list)
(define-generic-mode named-database-generic-mode
;; List of comment characters
@@ -1531,7 +1695,9 @@ like an INI file. You can add this hook to
`find-file-hook'."
(defun named-database-print-serial ()
"Print a serial number based on the current date."
(interactive)
- (insert (format-time-string named-database-time-string)))
+ (insert (format-time-string named-database-time-string))))
+
+(when (memq 'resolve-conf-generic-mode generic-extras-enable-list)
(define-generic-mode resolve-conf-generic-mode
;; List of comment characters
@@ -1543,12 +1709,14 @@ like an INI file. You can add this hook to
`find-file-hook'."
;; List of additional auto-mode-alist expressions
'("/etc/resolve?\\.conf\\'")
;; List of set up functions to call
- nil)
+ nil))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Modes for spice and common electrical engineering circuit netlist formats
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(when (memq 'spice-generic-mode generic-extras-enable-list)
+
(define-generic-mode spice-generic-mode
nil
'("and"
@@ -1584,7 +1752,9 @@ like an INI file. You can add this hook to
`find-file-hook'."
;; Make keywords case-insensitive
(lambda ()
(setq font-lock-defaults '(generic-font-lock-keywords nil t))))
- "Generic mode for SPICE circuit netlist files.")
+ "Generic mode for SPICE circuit netlist files."))
+
+(when (memq 'ibis-generic-mode generic-extras-enable-list)
(define-generic-mode ibis-generic-mode
'(?|)
@@ -1593,7 +1763,9 @@ like an INI file. You can add this hook to
`find-file-hook'."
("\\(\\(_\\|\\w\\)+\\)\\s-*=" 1 font-lock-variable-name-face))
'("\\.[iI][bB][sS]\\'")
'(generic-bracket-support)
- "Generic mode for IBIS circuit netlist files.")
+ "Generic mode for IBIS circuit netlist files."))
+
+(when (memq 'astap-generic-mode generic-extras-enable-list)
(define-generic-mode astap-generic-mode
nil
@@ -1627,7 +1799,9 @@ like an INI file. You can add this hook to
`find-file-hook'."
;; Make keywords case-insensitive
(lambda ()
(setq font-lock-defaults '(generic-font-lock-keywords nil t))))
- "Generic mode for ASTAP circuit netlist files.")
+ "Generic mode for ASTAP circuit netlist files."))
+
+(when (memq 'etc-modules-conf-generic-mode generic-extras-enable-list)
(define-generic-mode etc-modules-conf-generic-mode
;; List of comment characters
@@ -1669,98 +1843,7 @@ like an INI file. You can add this hook to
`find-file-hook'."
;; List of additional automode-alist expressions
'("/etc/modules\\.conf" "/etc/conf\\.modules")
;; List of set up functions to call
- nil)
-
-;; Obsolete
-
-(define-obsolete-function-alias 'javascript-generic-mode #'js-mode "24.3")
-(define-obsolete-variable-alias 'javascript-generic-mode-hook 'js-mode-hook
"24.3")
-
-(define-obsolete-function-alias 'bat-generic-mode #'bat-mode "24.4")
-
-(define-obsolete-function-alias 'generic-mode-ini-file-find-file-hook
- #'ini-generic-mode-find-file-hook "28.1")
-
-(defconst generic-default-modes
- '(apache-conf-generic-mode
- apache-log-generic-mode
- hosts-generic-mode
- java-manifest-generic-mode
- java-properties-generic-mode
- javascript-generic-mode
- show-tabs-generic-mode
- vrml-generic-mode)
- "List of generic modes that are defined by default.")
-(make-obsolete-variable 'generic-default-modes "no longer used." "28.1")
-
-(defconst generic-mswindows-modes
- '(bat-generic-mode
- inf-generic-mode
- ini-generic-mode
- rc-generic-mode
- reg-generic-mode
- rul-generic-mode)
- "List of generic modes that are defined by default on MS-Windows.")
-(make-obsolete-variable 'generic-mswindows-modes "no longer used." "28.1")
-
-(defconst generic-unix-modes
- '(alias-generic-mode
- ansible-inventory-generic-mode
- etc-fstab-generic-mode
- etc-modules-conf-generic-mode
- etc-passwd-generic-mode
- etc-services-generic-mode
- etc-sudoers-generic-mode
- fvwm-generic-mode
- inetd-conf-generic-mode
- mailagent-rules-generic-mode
- mailrc-generic-mode
- named-boot-generic-mode
- named-database-generic-mode
- prototype-generic-mode
- resolve-conf-generic-mode
- samba-generic-mode
- x-resource-generic-mode
- xmodmap-generic-mode)
- "List of generic modes that are defined by default on Unix.")
-(make-obsolete-variable 'generic-unix-modes "no longer used." "28.1")
-
-(defconst generic-other-modes
- '(astap-generic-mode
- ibis-generic-mode
- pkginfo-generic-mode
- spice-generic-mode)
- "List of generic modes that are not defined by default.")
-(make-obsolete-variable 'generic-other-modes "no longer used." "28.1")
-
-(defcustom generic-extras-enable-list
- (append generic-default-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
-directly, without using customize, you must reload generic-x to put
-your changes into effect."
- :type (let (list)
- (dolist (mode
- (sort (append generic-default-modes
- generic-mswindows-modes
- generic-unix-modes
- generic-other-modes
- nil)
- (lambda (a b)
- (string< (symbol-name b)
- (symbol-name a))))
- (cons 'set list))
- (push `(const ,mode) list)))
- :set (lambda (s v)
- (set-default s v)
- (unless load-in-progress
- (load "generic-x")))
- :version "22.1")
-(make-obsolete-variable 'generic-extras-enable-list "no longer used." "28.1")
+ nil))
(provide 'generic-x)
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index c1071c1..d989a4d 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -6648,9 +6648,10 @@ not have a face in `gnus-article-boring-faces'."
(catch 'only-boring
(while (re-search-forward "\\b\\w\\w" nil t)
(forward-char -1)
- (when (not (gnus-intersection
+ (when (not (seq-intersection
(gnus-faces-at (point))
- (symbol-value 'gnus-article-boring-faces)))
+ (symbol-value 'gnus-article-boring-faces)
+ #'eq))
(throw 'only-boring nil)))
(throw 'only-boring t))))))
diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el
index 1f564f1..34947ce 100644
--- a/lisp/gnus/gnus-cite.el
+++ b/lisp/gnus/gnus-cite.el
@@ -839,7 +839,7 @@ See also the documentation for
`gnus-article-highlight-citation'."
(setq current (car loop)
loop (cdr loop))
(setcdr current
- (gnus-set-difference (cdr current) numbers)))))))))
+ (seq-difference (cdr current) numbers #'eq)))))))))
(defun gnus-cite-parse-attributions ()
(let (al-alist)
@@ -999,7 +999,7 @@ See also the documentation for
`gnus-article-highlight-citation'."
loop (cdr loop))
(if (eq current best)
()
- (setcdr current (gnus-set-difference (cdr current) numbers))
+ (setcdr current (seq-difference (cdr current) numbers #'eq))
(when (null (cdr current))
(setq gnus-cite-loose-prefix-alist
(delq current gnus-cite-loose-prefix-alist)
@@ -1134,9 +1134,7 @@ Returns nil if there is no such line before LIMIT, t
otherwise."
(define-minor-mode gnus-message-citation-mode
"Minor mode providing more font-lock support for nested citations.
When enabled, it automatically turns on `font-lock-mode'."
- nil ;; init-value
- "" ;; lighter
- nil ;; keymap
+ :lighter ""
(when (derived-mode-p 'message-mode)
;; FIXME: Use font-lock-add-keywords!
(let ((defaults (car font-lock-defaults))
diff --git a/lisp/gnus/gnus-cus.el b/lisp/gnus/gnus-cus.el
index 0852f8e..e7af94f 100644
--- a/lisp/gnus/gnus-cus.el
+++ b/lisp/gnus/gnus-cus.el
@@ -1102,8 +1102,6 @@ articles in the thread.
(widget-setup)
(buffer-enable-undo))))
-;;; The End:
-
(provide 'gnus-cus)
;;; gnus-cus.el ends here
diff --git a/lisp/gnus/gnus-diary.el b/lisp/gnus/gnus-diary.el
index 64eb639..e2cbca9 100644
--- a/lisp/gnus/gnus-diary.el
+++ b/lisp/gnus/gnus-diary.el
@@ -32,11 +32,6 @@
;; gnus-diary is a utility toolkit used on top of the nndiary back end. It is
;; now fully documented in the Gnus manual.
-
-;; Bugs / Todo:
-;; ===========
-
-
;;; Code:
(require 'nndiary)
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el
index 909391b..8c62c94 100644
--- a/lisp/gnus/gnus-group.el
+++ b/lisp/gnus/gnus-group.el
@@ -2462,7 +2462,8 @@ the ephemeral group."
(with-temp-file tmpfile
(mm-disable-multibyte)
(dolist (id ids)
- (let ((file (concat "~/.emacs.d/debbugs-cache/" id)))
+ (let ((file (expand-file-name id (locate-user-emacs-file
+ "debbugs-cache"))))
(if (and (not gnus-plugged)
(file-exists-p file))
(insert-file-contents file)
@@ -4697,20 +4698,20 @@ This command may read the active file."
(gnus-cache-open))
(funcall gnus-group-prepare-function
(or level gnus-level-subscribed)
- #'(lambda (info)
- (let ((marks (gnus-info-marks info)))
- (assq 'cache marks)))
+ (lambda (info)
+ (let ((marks (gnus-info-marks info)))
+ (assq 'cache marks)))
lowest
- #'(lambda (group)
- (or (gethash group
- gnus-cache-active-hashtb)
- ;; Cache active file might use "."
- ;; instead of ":".
- (gethash
- (mapconcat #'identity
- (split-string group ":")
- ".")
- gnus-cache-active-hashtb))))
+ (lambda (group)
+ (or (gethash group
+ gnus-cache-active-hashtb)
+ ;; Cache active file might use "."
+ ;; instead of ":".
+ (gethash
+ (mapconcat #'identity
+ (split-string group ":")
+ ".")
+ gnus-cache-active-hashtb))))
(goto-char (point-min))
(gnus-group-position-point))
@@ -4728,9 +4729,9 @@ This command may read the active file."
(gnus-cache-open))
(funcall gnus-group-prepare-function
(or level gnus-level-subscribed)
- #'(lambda (info)
- (let ((marks (gnus-info-marks info)))
- (assq 'dormant marks)))
+ (lambda (info)
+ (let ((marks (gnus-info-marks info)))
+ (assq 'dormant marks)))
lowest
'ignore)
(goto-char (point-min))
@@ -4750,9 +4751,9 @@ This command may read the active file."
(gnus-cache-open))
(funcall gnus-group-prepare-function
(or level gnus-level-subscribed)
- #'(lambda (info)
- (let ((marks (gnus-info-marks info)))
- (assq 'tick marks)))
+ (lambda (info)
+ (let ((marks (gnus-info-marks info)))
+ (assq 'tick marks)))
lowest
'ignore)
(goto-char (point-min))
diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el
index f1181d4..bac987e 100644
--- a/lisp/gnus/gnus-msg.el
+++ b/lisp/gnus/gnus-msg.el
@@ -415,11 +415,12 @@ only affect the Gcc copy, but not the original message."
gnus-article-reply)))
(,oarticle gnus-article-reply)
(,yanked gnus-article-yanked-articles)
- (,group (when gnus-article-reply
- (or (nnselect-article-group
- (or (car-safe gnus-article-reply)
- gnus-article-reply))
- gnus-newsgroup-name)))
+ (,group (if gnus-article-reply
+ (or (nnselect-article-group
+ (or (car-safe gnus-article-reply)
+ gnus-article-reply))
+ gnus-newsgroup-name)
+ gnus-newsgroup-name))
(message-header-setup-hook
(copy-sequence message-header-setup-hook))
(mbl mml-buffer-list)
diff --git a/lisp/gnus/gnus-notifications.el b/lisp/gnus/gnus-notifications.el
index a4d198b..8646904 100644
--- a/lisp/gnus/gnus-notifications.el
+++ b/lisp/gnus/gnus-notifications.el
@@ -1,4 +1,4 @@
-;; gnus-notifications.el -- Send notification on new message in Gnus -*-
lexical-binding: t; -*-
+;;; gnus-notifications.el --- Send notification on new message in Gnus -*-
lexical-binding: t; -*-
;; Copyright (C) 2012-2021 Free Software Foundation, Inc.
diff --git a/lisp/gnus/gnus-range.el b/lisp/gnus/gnus-range.el
index 6cc60cb..7d12ae9 100644
--- a/lisp/gnus/gnus-range.el
+++ b/lisp/gnus/gnus-range.el
@@ -42,13 +42,8 @@ If RANGE is a single range, return (RANGE). Otherwise,
return RANGE."
(defun gnus-set-difference (list1 list2)
"Return a list of elements of LIST1 that do not appear in LIST2."
- (let ((hash2 (make-hash-table :test 'eq))
- (result nil))
- (dolist (elt list2) (puthash elt t hash2))
- (dolist (elt list1)
- (unless (gethash elt hash2)
- (setq result (cons elt result))))
- (nreverse result)))
+ (declare (obsolete seq-difference "28.1"))
+ (seq-difference list1 list2 #'eq))
(defun gnus-range-nconcat (&rest ranges)
"Return a range comprising all the RANGES, which are pre-sorted.
@@ -179,12 +174,8 @@ Both lists have to be sorted over <."
;;;###autoload
(defun gnus-intersection (list1 list2)
- (let ((result nil))
- (while list2
- (when (memq (car list2) list1)
- (setq result (cons (car list2) result)))
- (setq list2 (cdr list2)))
- result))
+ (declare (obsolete seq-intersection "28.1"))
+ (nreverse (seq-intersection list1 list2 #'eq)))
;;;###autoload
(defun gnus-sorted-intersection (list1 list2)
diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el
index e3b9c19..0468d72 100644
--- a/lisp/gnus/gnus-registry.el
+++ b/lisp/gnus/gnus-registry.el
@@ -319,9 +319,12 @@ Encode names if ENCODE is non-nil, otherwise decode."
(setf (oref db tracked)
(append gnus-registry-track-extra
'(mark group keyword)))
- (when (not (equal old (oref db tracked)))
+ (when (not (seq-set-equal-p old (oref db tracked)))
(gnus-message 9 "Reindexing the Gnus registry (tracked change)")
- (registry-reindex db))
+ (let ((message-log-max (if (< gnus-verbose 9)
+ nil
+ message-log-max)))
+ (registry-reindex db)))
(gnus-registry--munge-group-names db)))
db)
@@ -1290,16 +1293,14 @@ from your existing entries."
(registry-reindex db)
(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)
- entry))
+ do (let ((newv (delq nil (mapcar (lambda (entry)
+ (unless (member (car entry)
extra)
+ entry))
v))))
(registry-delete db (list k) nil)
(gnus-registry-insert db k newv)))
(registry-reindex db))))
-;; TODO: a few things
-
(provide 'gnus-registry)
;;; gnus-registry.el ends here
diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el
index ce64dce..f40da9e 100644
--- a/lisp/gnus/gnus-score.el
+++ b/lisp/gnus/gnus-score.el
@@ -1182,8 +1182,8 @@ If FORMAT, also format the current score file."
(when (consp rule) ;; the rule exists
(setq rule (if (symbolp (car rule))
(format "(%S)" (car rule))
- (mapconcat #'(lambda (obj)
- (regexp-quote (format "%S" obj)))
+ (mapconcat (lambda (obj)
+ (regexp-quote (format "%S" obj)))
rule
sep)))
(goto-char (point-min))
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index c30f9a5..aa4c753 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -5676,9 +5676,9 @@ or a straight list of headers."
(or dependencies
(with-current-buffer gnus-summary-buffer
gnus-newsgroup-dependencies))))
- (delq nil (mapcar #'(lambda (header)
- (gnus-dependencies-add-header
- header dependencies force-new))
+ (delq nil (mapcar (lambda (header)
+ (gnus-dependencies-add-header
+ header dependencies force-new))
gnus-headers-retrieved-by)))))
(gnus-message 7 "Fetching headers for %s...done" gnus-newsgroup-name)))
@@ -8089,7 +8089,7 @@ Return nil if there are no unseen articles."
(defun gnus-summary-first-unseen-or-unread-subject ()
"Place the point on the subject line of the first unseen and unread article.
-If all article have been seen, on the subject line of the first unread
+If all articles have been seen, on the subject line of the first unread
article."
(interactive nil gnus-summary-mode)
(prog1
@@ -8569,8 +8569,9 @@ If UNREPLIED (the prefix), limit to unreplied articles."
(interactive "P" gnus-summary-mode)
(if unreplied
(gnus-summary-limit
- (gnus-set-difference gnus-newsgroup-articles
- gnus-newsgroup-replied))
+ (seq-difference gnus-newsgroup-articles
+ gnus-newsgroup-replied
+ #'eq))
(gnus-summary-limit gnus-newsgroup-replied))
(gnus-summary-position-point))
diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el
index bd9a1a3..ceb2ebc 100644
--- a/lisp/gnus/gnus-uu.el
+++ b/lisp/gnus/gnus-uu.el
@@ -578,8 +578,8 @@ didn't work, and overwrite existing files. Otherwise, ask
each time."
(defun gnus-new-processable (unmarkp articles)
(if unmarkp
- (gnus-intersection gnus-newsgroup-processable articles)
- (gnus-set-difference articles gnus-newsgroup-processable)))
+ (nreverse (seq-intersection gnus-newsgroup-processable articles #'eq))
+ (seq-difference articles gnus-newsgroup-processable #'eq)))
(defun gnus-uu-mark-by-regexp (regexp &optional unmark)
"Set the process mark on articles whose subjects match REGEXP.
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index 2f2b206..7de1cd1 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -4156,8 +4156,9 @@ prompt the user for the name of an NNTP server to use."
;; file.
(unless (string-match "^Gnus" gnus-version)
(load "gnus-load" nil t))
- (unless (byte-code-function-p (symbol-function 'gnus))
- (message "You should byte-compile Gnus")
+ (unless (or (byte-code-function-p (symbol-function 'gnus))
+ (subr-native-elisp-p (symbol-function 'gnus)))
+ (message "You should compile Gnus")
(sit-for 2))
(let ((gnus-action-message-log (list nil)))
(gnus-1 arg dont-connect child)
diff --git a/lisp/gnus/legacy-gnus-agent.el b/lisp/gnus/legacy-gnus-agent.el
index 091e389..4f80089 100644
--- a/lisp/gnus/legacy-gnus-agent.el
+++ b/lisp/gnus/legacy-gnus-agent.el
@@ -1,4 +1,4 @@
-;;; gnus-agent.el --- Legacy unplugged support for Gnus -*- lexical-binding:
t; -*-
+;;; legacy-gnus-agent.el --- Legacy unplugged support for Gnus -*-
lexical-binding: t; -*-
;; Copyright (C) 2004-2021 Free Software Foundation, Inc.
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index fad4ef3..02db387 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -120,12 +120,13 @@
:group 'message-buffers
:type 'integer)
-(defcustom message-send-rename-function nil
+(defcustom message-send-rename-function #'message-default-send-rename-function
"Function called to rename the buffer after sending it."
:group 'message-buffers
- :type '(choice function (const nil)))
+ :version "28.1"
+ :type 'function)
-(defcustom message-fcc-handler-function 'message-output
+(defcustom message-fcc-handler-function #'message-output
"A function called to save outgoing articles.
This function will be called with the name of the file to store the
article in. The default function is `message-output' which saves in Unix
@@ -186,22 +187,26 @@ Otherwise, most addresses look like `angles', but they
look like
(defcustom message-syntax-checks
(if message-insert-canlock '((sender . disabled)) nil)
- ;; Guess this one shouldn't be easy to customize...
"Controls what syntax checks should not be performed on outgoing posts.
To disable checking of long signatures, for instance, add
`(signature . disabled)' to this list.
Don't touch this variable unless you really know what you're doing.
-Checks include `approved', `bogus-recipient', `continuation-headers',
-`control-chars', `empty', `existing-newsgroups', `from', `illegible-text',
-`invisible-text', `long-header-lines', `long-lines', `message-id',
-`multiple-headers', `new-text', `newsgroups', `quoting-style',
-`repeated-newsgroups', `reply-to', `sender', `sendsys', `shoot',
-`shorten-followup-to', `signature', `size', `subject', `subject-cmsg'
-and `valid-newsgroups'."
- :group 'message-news
- :type '(repeat sexp)) ; Fixme: improve this
+See the Message manual for the meanings of the valid syntax check
+types."
+ :group 'message-headers
+ :link '(custom-manual "(message)Message Headers")
+ :type '(alist
+ :key-type symbol
+ :value-type (const disabled)
+ :options (approved bogus-recipient continuation-headers
+ control-chars empty existing-newsgroups from illegible-text
+ invisible-text long-header-lines long-lines message-id
+ multiple-headers new-text newgroups quoting-style
+ repeated-newsgroups reply-to sender sendsys shoot
+ shorten-followup-to signature size subject subject-cmsg
+ valid-newsgroups)))
(defcustom message-required-headers '((optional . References)
From)
@@ -418,7 +423,7 @@ you can explicitly override this setting by calling
:type 'string
:group 'message-various)
-(defcustom message-cross-post-note-function 'message-cross-post-insert-note
+(defcustom message-cross-post-note-function #'message-cross-post-insert-note
"Function to use to insert note about Crosspost or Followup-To.
The function will be called with four arguments. The function should not only
insert a note, but also ensure old notes are deleted. See the documentation
@@ -756,7 +761,7 @@ See also `send-mail-function'."
:link '(custom-manual "(message)Mail Variables")
:group 'message-mail)
-(defcustom message-send-news-function 'message-send-news
+(defcustom message-send-news-function #'message-send-news
"Function to call to send the current buffer as news.
The headers should be delimited by a line whose contents match the
variable `mail-header-separator'."
@@ -765,29 +770,32 @@ variable `mail-header-separator'."
:link '(custom-manual "(message)News Variables")
:type 'function)
-(defcustom message-reply-to-function nil
+(defcustom message-reply-to-function #'ignore
"If non-nil, function that should return a list of headers.
This function should pick out addresses from the To, Cc, and From headers
and respond with new To and Cc headers."
:group 'message-interface
:link '(custom-manual "(message)Reply")
- :type '(choice function (const nil)))
+ :version "28.1"
+ :type 'function)
-(defcustom message-wide-reply-to-function nil
+(defcustom message-wide-reply-to-function #'ignore
"If non-nil, function that should return a list of headers.
This function should pick out addresses from the To, Cc, and From headers
and respond with new To and Cc headers."
:group 'message-interface
:link '(custom-manual "(message)Wide Reply")
- :type '(choice function (const nil)))
+ :version "28.1"
+ :type 'function)
-(defcustom message-followup-to-function nil
+(defcustom message-followup-to-function #'ignore
"If non-nil, function that should return a list of headers.
This function should pick out addresses from the To, Cc, and From headers
and respond with new To and Cc headers."
:group 'message-interface
:link '(custom-manual "(message)Followup")
- :type '(choice function (const nil)))
+ :version "28.1"
+ :type 'function)
(defcustom message-extra-wide-headers nil
"If non-nil, a list of additional address headers.
@@ -1021,7 +1029,7 @@ the signature is inserted."
:version "22.1"
:group 'message-various)
-(defcustom message-citation-line-function 'message-insert-citation-line
+(defcustom message-citation-line-function #'message-insert-citation-line
"Function called to insert the \"Whomever writes:\" line.
Predefined functions include `message-insert-citation-line' and
@@ -1103,7 +1111,7 @@ Used by `message-yank-original' via `message-yank-cite'."
:link '(custom-manual "(message)Insertion Variables")
:type 'integer)
-(defcustom message-cite-function 'message-cite-original-without-signature
+(defcustom message-cite-function #'message-cite-original-without-signature
"Function for citing an original message.
Predefined functions include `message-cite-original' and
`message-cite-original-without-signature'.
@@ -1116,7 +1124,7 @@ Note that these functions use `mail-citation-hook' if
that is non-nil."
:version "22.3" ;; Gnus 5.10.12 (changed default)
:group 'message-insertion)
-(defcustom message-indent-citation-function 'message-indent-citation
+(defcustom message-indent-citation-function #'message-indent-citation
"Function for modifying a citation just inserted in the mail buffer.
This can also be a list of functions. Each function can find the
citation between (point) and (mark t). And each function should leave
@@ -2847,79 +2855,79 @@ Consider adding this function to
`message-header-setup-hook'"
(unless message-mode-map
(setq message-mode-map (make-keymap))
(set-keymap-parent message-mode-map text-mode-map)
- (define-key message-mode-map "\C-c?" 'describe-mode)
-
- (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to)
- (define-key message-mode-map "\C-c\C-f\C-o" 'message-goto-from)
- (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc)
- (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc)
- (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc)
- (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject)
- (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to)
- (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups)
- (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution)
- (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to)
- (define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to)
- (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords)
- (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary)
+ (define-key message-mode-map "\C-c?" #'describe-mode)
+
+ (define-key message-mode-map "\C-c\C-f\C-t" #'message-goto-to)
+ (define-key message-mode-map "\C-c\C-f\C-o" #'message-goto-from)
+ (define-key message-mode-map "\C-c\C-f\C-b" #'message-goto-bcc)
+ (define-key message-mode-map "\C-c\C-f\C-w" #'message-goto-fcc)
+ (define-key message-mode-map "\C-c\C-f\C-c" #'message-goto-cc)
+ (define-key message-mode-map "\C-c\C-f\C-s" #'message-goto-subject)
+ (define-key message-mode-map "\C-c\C-f\C-r" #'message-goto-reply-to)
+ (define-key message-mode-map "\C-c\C-f\C-n" #'message-goto-newsgroups)
+ (define-key message-mode-map "\C-c\C-f\C-d" #'message-goto-distribution)
+ (define-key message-mode-map "\C-c\C-f\C-f" #'message-goto-followup-to)
+ (define-key message-mode-map "\C-c\C-f\C-m" #'message-goto-mail-followup-to)
+ (define-key message-mode-map "\C-c\C-f\C-k" #'message-goto-keywords)
+ (define-key message-mode-map "\C-c\C-f\C-u" #'message-goto-summary)
(define-key message-mode-map "\C-c\C-f\C-i"
- 'message-insert-or-toggle-importance)
+ #'message-insert-or-toggle-importance)
(define-key message-mode-map "\C-c\C-f\C-a"
- 'message-generate-unsubscribed-mail-followup-to)
+ #'message-generate-unsubscribed-mail-followup-to)
;; modify headers (and insert notes in body)
- (define-key message-mode-map "\C-c\C-fs" 'message-change-subject)
+ (define-key message-mode-map "\C-c\C-fs" #'message-change-subject)
;;
- (define-key message-mode-map "\C-c\C-fx" 'message-cross-post-followup-to)
+ (define-key message-mode-map "\C-c\C-fx" #'message-cross-post-followup-to)
;; prefix+message-cross-post-followup-to = same w/o cross-post
- (define-key message-mode-map "\C-c\C-ft" 'message-reduce-to-to-cc)
- (define-key message-mode-map "\C-c\C-fa" 'message-add-archive-header)
+ (define-key message-mode-map "\C-c\C-ft" #'message-reduce-to-to-cc)
+ (define-key message-mode-map "\C-c\C-fa" #'message-add-archive-header)
;; mark inserted text
- (define-key message-mode-map "\C-c\M-m" 'message-mark-inserted-region)
- (define-key message-mode-map "\C-c\M-f" 'message-mark-insert-file)
+ (define-key message-mode-map "\C-c\M-m" #'message-mark-inserted-region)
+ (define-key message-mode-map "\C-c\M-f" #'message-mark-insert-file)
- (define-key message-mode-map "\C-c\C-b" 'message-goto-body)
- (define-key message-mode-map "\C-c\C-i" 'message-goto-signature)
+ (define-key message-mode-map "\C-c\C-b" #'message-goto-body)
+ (define-key message-mode-map "\C-c\C-i" #'message-goto-signature)
- (define-key message-mode-map "\C-c\C-t" 'message-insert-to)
- (define-key message-mode-map "\C-c\C-fw" 'message-insert-wide-reply)
- (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)
- (define-key message-mode-map "\C-c\C-l" 'message-to-list-only)
- (define-key message-mode-map "\C-c\C-f\C-e" 'message-insert-expires)
+ (define-key message-mode-map "\C-c\C-t" #'message-insert-to)
+ (define-key message-mode-map "\C-c\C-fw" #'message-insert-wide-reply)
+ (define-key message-mode-map "\C-c\C-n" #'message-insert-newsgroups)
+ (define-key message-mode-map "\C-c\C-l" #'message-to-list-only)
+ (define-key message-mode-map "\C-c\C-f\C-e" #'message-insert-expires)
- (define-key message-mode-map "\C-c\C-u" 'message-insert-or-toggle-importance)
+ (define-key message-mode-map "\C-c\C-u"
#'message-insert-or-toggle-importance)
(define-key message-mode-map "\C-c\M-n"
- 'message-insert-disposition-notification-to)
-
- (define-key message-mode-map "\C-c\C-y" 'message-yank-original)
- (define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer)
- (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message)
- (define-key message-mode-map "\C-c\C-w" 'message-insert-signature)
- (define-key message-mode-map "\C-c\M-h" 'message-insert-headers)
- (define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body)
- (define-key message-mode-map "\C-c\C-o" 'message-sort-headers)
- (define-key message-mode-map "\C-c\M-r" 'message-rename-buffer)
-
- (define-key message-mode-map "\C-c\C-c" 'message-send-and-exit)
- (define-key message-mode-map "\C-c\C-s" 'message-send)
- (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer)
- (define-key message-mode-map "\C-c\C-d" 'message-dont-send)
- (define-key message-mode-map "\C-c\n" 'gnus-delay-article)
-
- (define-key message-mode-map "\C-c\M-k" 'message-kill-address)
- (define-key message-mode-map "\C-c\C-e" 'message-elide-region)
- (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)
- (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature)
- (define-key message-mode-map "\M-\r" 'message-newline-and-reformat)
- (define-key message-mode-map [remap split-line] 'message-split-line)
-
- (define-key message-mode-map "\C-c\C-a" 'mml-attach-file)
- (define-key message-mode-map "\C-c\C-p" 'message-insert-screenshot)
-
- (define-key message-mode-map "\C-a" 'message-beginning-of-line)
- (define-key message-mode-map "\t" 'message-tab)
-
- (define-key message-mode-map "\M-n" 'message-display-abbrev))
+ #'message-insert-disposition-notification-to)
+
+ (define-key message-mode-map "\C-c\C-y" #'message-yank-original)
+ (define-key message-mode-map "\C-c\M-\C-y" #'message-yank-buffer)
+ (define-key message-mode-map "\C-c\C-q" #'message-fill-yanked-message)
+ (define-key message-mode-map "\C-c\C-w" #'message-insert-signature)
+ (define-key message-mode-map "\C-c\M-h" #'message-insert-headers)
+ (define-key message-mode-map "\C-c\C-r" #'message-caesar-buffer-body)
+ (define-key message-mode-map "\C-c\C-o" #'message-sort-headers)
+ (define-key message-mode-map "\C-c\M-r" #'message-rename-buffer)
+
+ (define-key message-mode-map "\C-c\C-c" #'message-send-and-exit)
+ (define-key message-mode-map "\C-c\C-s" #'message-send)
+ (define-key message-mode-map "\C-c\C-k" #'message-kill-buffer)
+ (define-key message-mode-map "\C-c\C-d" #'message-dont-send)
+ (define-key message-mode-map "\C-c\n" #'gnus-delay-article)
+
+ (define-key message-mode-map "\C-c\M-k" #'message-kill-address)
+ (define-key message-mode-map "\C-c\C-e" #'message-elide-region)
+ (define-key message-mode-map "\C-c\C-v" #'message-delete-not-region)
+ (define-key message-mode-map "\C-c\C-z" #'message-kill-to-signature)
+ (define-key message-mode-map "\M-\r" #'message-newline-and-reformat)
+ (define-key message-mode-map [remap split-line] #'message-split-line)
+
+ (define-key message-mode-map "\C-c\C-a" #'mml-attach-file)
+ (define-key message-mode-map "\C-c\C-p" #'message-insert-screenshot)
+
+ (define-key message-mode-map "\C-a" #'message-beginning-of-line)
+ (define-key message-mode-map "\t" #'message-tab)
+
+ (define-key message-mode-map "\M-n" #'message-display-abbrev))
(easy-menu-define
message-mode-menu message-mode-map "Message Menu."
@@ -3169,14 +3177,13 @@ Like `text-mode', but with these additional commands:
;; `electric-pair-mode', and C-M-* navigation by syntactically
;; excluding citations and other artifacts.
;;
- (setq-local syntax-propertize-function 'message--syntax-propertize)
+ (setq-local syntax-propertize-function #'message--syntax-propertize)
(setq-local parse-sexp-ignore-comments t)
(setq-local message-encoded-mail-cache nil))
(defun message-setup-fill-variables ()
"Setup message fill variables."
(setq-local fill-paragraph-function #'message-fill-paragraph)
- (make-local-variable 'adaptive-fill-first-line-regexp)
(let ((quote-prefix-regexp
;; User should change message-cite-prefix-regexp if
;; message-yank-prefix is set to an abnormal value.
@@ -3287,7 +3294,7 @@ Like `text-mode', but with these additional commands:
(push-mark)
(message-position-on-field "Summary" "Subject"))
-(define-obsolete-function-alias 'message-goto-body-1 'message-goto-body "27.1")
+(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."
@@ -6662,9 +6669,8 @@ moved to the beginning "
(not (buffer-modified-p buffer)))
(kill-buffer buffer))))
;; Rename the buffer.
- (if message-send-rename-function
- (funcall message-send-rename-function)
- (message-default-send-rename-function))
+ (funcall (or message-send-rename-function
+ #'message-default-send-rename-function))
;; Push the current buffer onto the list.
(when message-max-buffers
(setq message-buffer-list
@@ -6763,8 +6769,9 @@ are not included."
(defun message-setup-1 (headers &optional yank-action actions return-action)
(dolist (action actions)
(condition-case nil
+ ;; FIXME: Use functions rather than expressions!
(add-to-list 'message-send-actions
- `(apply ',(car action) ',(cdr action)))))
+ `(apply #',(car action) ',(cdr action)))))
(setq message-return-action return-action)
(setq message-reply-buffer
(if (and (consp yank-action)
@@ -6903,7 +6910,7 @@ are not included."
;;;###autoload
(defun message-mail (&optional to subject other-headers continue
switch-function yank-action send-actions
- return-action &rest ignored)
+ return-action &rest _)
"Start editing a mail message to be sent.
OTHER-HEADERS is an alist of header/value pairs. CONTINUE says whether
to continue editing a message already being composed. SWITCH-FUNCTION
@@ -7127,15 +7134,12 @@ want to get rid of this query permanently.")))
;; specific, and just Cc-in the rest.
(setq follow-to (list
(cons 'To
- (mapconcat
- (lambda (addr)
- (cdr addr)) recipients ", "))))
+ (mapconcat #'cdr recipients ", "))))
;; Put the first recipient in the To header.
(setq follow-to (list (cons 'To (cdr (pop recipients)))))
;; Put the rest of the recipients in Cc.
(when recipients
- (setq recipients (mapconcat
- (lambda (addr) (cdr addr)) recipients ", "))
+ (setq recipients (mapconcat #'cdr recipients ", "))
(if (string-match "^ +" recipients)
(setq recipients (substring recipients (match-end 0))))
(push (cons 'Cc recipients) follow-to)))))
@@ -7862,7 +7866,7 @@ is for the internal use."
(interactive)
(setq rmail-enable-mime-composing t)
(setq rmail-insert-mime-forwarded-message-function
- 'message-forward-rmail-make-body))
+ #'message-forward-rmail-make-body))
;;;###autoload
(defun message-resend (address)
diff --git a/lisp/gnus/mm-archive.el b/lisp/gnus/mm-archive.el
index 1ecceee..fdc83e1 100644
--- a/lisp/gnus/mm-archive.el
+++ b/lisp/gnus/mm-archive.el
@@ -108,4 +108,4 @@
(provide 'mm-archive)
-;; mm-archive.el ends here
+;;; mm-archive.el ends here
diff --git a/lisp/gnus/mm-partial.el b/lisp/gnus/mm-partial.el
index 0c25c8f..0c62805 100644
--- a/lisp/gnus/mm-partial.el
+++ b/lisp/gnus/mm-partial.el
@@ -72,14 +72,14 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing
after replacing."
id
(with-current-buffer gnus-summary-buffer
(gnus-summary-article-number))))
- #'(lambda (a b)
- (let ((anumber (string-to-number
- (cdr (assq 'number
- (cdr (mm-handle-type a))))))
- (bnumber (string-to-number
- (cdr (assq 'number
- (cdr (mm-handle-type b)))))))
- (< anumber bnumber)))))
+ (lambda (a b)
+ (let ((anumber (string-to-number
+ (cdr (assq 'number
+ (cdr (mm-handle-type a))))))
+ (bnumber (string-to-number
+ (cdr (assq 'number
+ (cdr (mm-handle-type b)))))))
+ (< anumber bnumber)))))
(setq gnus-article-mime-handles
(mm-merge-handles gnus-article-mime-handles phandles))
(with-current-buffer (generate-new-buffer " *mm*")
diff --git a/lisp/gnus/nnagent.el b/lisp/gnus/nnagent.el
index 56ca2e1..76a7e21 100644
--- a/lisp/gnus/nnagent.el
+++ b/lisp/gnus/nnagent.el
@@ -1,4 +1,3 @@
-
;;; nnagent.el --- offline backend for Gnus -*- lexical-binding: t; -*-
;; Copyright (C) 1997-2021 Free Software Foundation, Inc.
diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el
index 15003fa..adf4427 100644
--- a/lisp/gnus/nndiary.el
+++ b/lisp/gnus/nndiary.el
@@ -558,7 +558,7 @@ all. This may very well take some time.")
(nnmail-activate 'nndiary)
;; Articles not listed in active-articles are already gone,
;; so don't try to expire them.
- (setq articles (gnus-intersection articles active-articles))
+ (setq articles (nreverse (seq-intersection articles active-articles #'eq)))
(while articles
(setq article (nndiary-article-to-file (setq number (pop articles))))
(if (and (nndiary-deletable-article-p group number)
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index f06959f..8990b2b 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -1614,13 +1614,15 @@ If LIMIT, first try to limit the search to the N last
articles."
(setq start-article 1))
(let* ((unread
(gnus-compress-sequence
- (gnus-set-difference
- (gnus-set-difference
+ (seq-difference
+ (seq-difference
existing
(gnus-sorted-union
(cdr (assoc '%Seen flags))
- (cdr (assoc '%Deleted flags))))
- (cdr (assoc '%Flagged flags)))))
+ (cdr (assoc '%Deleted flags)))
+ #'eq)
+ (cdr (assoc '%Flagged flags))
+ #'eq)))
(read (gnus-range-difference
(cons start-article high) unread)))
(when (> start-article 1)
diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el
index 1daa8aa..5ac4c3a 100644
--- a/lisp/gnus/nnselect.el
+++ b/lisp/gnus/nnselect.el
@@ -100,8 +100,8 @@
(setq selection
(vconcat
(cl-map 'vector
- #'(lambda (art)
- (vector artgroup art artrsv))
+ (lambda (art)
+ (vector artgroup art artrsv))
(gnus-uncompress-sequence artseq)) selection)))
selection)))
@@ -211,12 +211,12 @@ as `(keyfunc member)' and the corresponding element is
just
#'nnselect-article-group #'nnselect-article-number))
((eq ,type 'tuple)
(nnselect-categorize ,articles
- #'(lambda (elem)
- (nnselect-article-group (car elem)))
- #'(lambda (elem)
- (cons (nnselect-article-number
- (car elem))
- (cdr elem)))))
+ (lambda (elem)
+ (nnselect-article-group (car elem)))
+ (lambda (elem)
+ (cons (nnselect-article-number
+ (car elem))
+ (cdr elem)))))
(t
(nnselect-categorize ,articles
#'nnselect-article-group
@@ -464,8 +464,8 @@ If this variable is nil, or if the provided function
returns nil,
(error "Group %s does not support article expiration" artgroup))
(unless (gnus-check-server (gnus-find-method-for-group artgroup))
(error "Couldn't open server for group %s" artgroup))
- (push (mapcar #'(lambda (art)
- (car (rassq art artids)))
+ (push (mapcar (lambda (art)
+ (car (rassq art artids)))
(let ((nnimap-expunge 'immediately))
(gnus-request-expire-articles
artlist artgroup force)))
@@ -549,8 +549,8 @@ If this variable is nil, or if the provided function
returns nil,
(gnus-add-to-range
(gnus-info-read info)
(delq nil (mapcar
- #'(lambda (art)
- (unless (memq (cdr art) unread) (car art)))
+ (lambda (art)
+ (unless (memq (cdr art) unread) (car art)))
artids))))
(pcase-dolist (`(,type . ,mark-list) marks)
(let ((mark-type (gnus-article-mark-to-type type)) new)
@@ -560,19 +560,19 @@ If this variable is nil, or if the provided function
returns nil,
(cond
((eq mark-type 'tuple)
(mapcar
- #'(lambda (id)
- (let (mark)
- (when
- (setq mark (assq (cdr id) mark-list))
- (cons (car id) (cdr mark)))))
+ (lambda (id)
+ (let (mark)
+ (when
+ (setq mark (assq (cdr id) mark-list))
+ (cons (car id) (cdr mark)))))
artids))
(t
(setq mark-list
(gnus-uncompress-range mark-list))
(mapcar
- #'(lambda (id)
- (when (memq (cdr id) mark-list)
- (car id))) artids)))))
+ (lambda (id)
+ (when (memq (cdr id) mark-list)
+ (car id))) artids)))))
(let ((previous (alist-get type newmarks)))
(if previous
(nconc previous new)
@@ -607,8 +607,8 @@ If this variable is nil, or if the provided function
returns nil,
(let ((thread
(gnus-id-to-thread (mail-header-id header))))
(when thread
- (cl-some #'(lambda (x)
- (when (and x (> x 0)) x))
+ (cl-some (lambda (x)
+ (when (and x (> x 0)) x))
(gnus-articles-in-thread thread)))))))))
;; Check if search-based thread referral is permitted, and
;; available.
@@ -642,15 +642,15 @@ If this variable is nil, or if the provided function
returns nil,
old-arts seq
headers)
(mapc
- #'(lambda (article)
- (if
- (setq seq
- (cl-position article
- gnus-newsgroup-selection :test 'equal))
- (push (1+ seq) old-arts)
- (setq gnus-newsgroup-selection
- (vconcat gnus-newsgroup-selection (vector article)))
- (cl-incf last)))
+ (lambda (article)
+ (if
+ (setq seq
+ (cl-position article
+ gnus-newsgroup-selection :test 'equal))
+ (push (1+ seq) old-arts)
+ (setq gnus-newsgroup-selection
+ (vconcat gnus-newsgroup-selection (vector article)))
+ (cl-incf last)))
new-nnselect-artlist)
(setq headers
(gnus-fetch-headers
@@ -671,9 +671,9 @@ If this variable is nil, or if the provided function
returns nil,
(when (setq new-marks
(delq nil
(mapcar
- #'(lambda (art)
- (when (memq (cdr art) marked)
- (car art)))
+ (lambda (art)
+ (when (memq (cdr art) marked)
+ (car art)))
artids)))
(nconc
(symbol-value
@@ -968,7 +968,6 @@ Pass NO-PARSE on to the search engine."
(gnus-group-make-search-group no-parse spec)))
-;; The end.
(provide 'nnselect)
;;; nnselect.el ends here
diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el
index b3b701e..03a0ff2 100644
--- a/lisp/gnus/nnvirtual.el
+++ b/lisp/gnus/nnvirtual.el
@@ -362,9 +362,9 @@ It is computed from the marks of individual component
groups.")
(dolist (group nnvirtual-component-groups)
(setq unexpired (nconc unexpired
(mapcar
- #'(lambda (article)
- (nnvirtual-reverse-map-article
- group article))
+ (lambda (article)
+ (nnvirtual-reverse-map-article
+ group article))
(gnus-uncompress-range
(gnus-group-expire-articles-1 group))))))
(sort (delq nil unexpired) #'<)))
diff --git a/lisp/gnus/spam-report.el b/lisp/gnus/spam-report.el
index 7d93f8a..a4234f8 100644
--- a/lisp/gnus/spam-report.el
+++ b/lisp/gnus/spam-report.el
@@ -378,4 +378,4 @@ Process queued spam reports."
(provide 'spam-report)
-;;; spam-report.el ends here.
+;;; spam-report.el ends here
diff --git a/lisp/gnus/spam-stat.el b/lisp/gnus/spam-stat.el
index 3e804ec..ab9be0d 100644
--- a/lisp/gnus/spam-stat.el
+++ b/lisp/gnus/spam-stat.el
@@ -492,7 +492,7 @@ Add user supplied modifications if supplied."
(let* ((probs (mapcar #'cadr spam-stat-score-data))
(prod (apply #'* probs))
(score0
- (/ prod (+ prod (apply #'* (mapcar #'(lambda (x) (- 1 x))
+ (/ prod (+ prod (apply #'* (mapcar (lambda (x) (- 1 x))
probs)))))
(score1s
(condition-case nil
diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el
index d00f0a6..3f97891 100644
--- a/lisp/gnus/spam.el
+++ b/lisp/gnus/spam.el
@@ -710,16 +710,8 @@ finds ham or spam.")
(defun spam-set-difference (list1 list2)
"Return a set difference of LIST1 and LIST2.
When either list is nil, the other is returned."
- (if (and list1 list2)
- ;; we have two non-nil lists
- (progn
- (dolist (item (append list1 list2))
- (when (and (memq item list1) (memq item list2))
- (setq list1 (delq item list1))
- (setq list2 (delq item list2))))
- (append list1 list2))
- ;; if either of the lists was nil, return the other one
- (if list1 list1 list2)))
+ (declare (obsolete seq-difference "28.1"))
+ (seq-difference list1 list2 #'eq))
(defun spam-group-ham-mark-p (group mark &optional spam)
"Checks if MARK is considered a ham mark in GROUP."
@@ -1327,7 +1319,7 @@ In the case of mover backends, checks the setting of
(new-articles (spam-list-articles
gnus-newsgroup-articles
classification))
- (changed-articles (spam-set-difference new-articles
old-articles)))
+ (changed-articles (seq-difference new-articles old-articles
#'eq)))
;; now that we have the changed articles, we go through the processors
(dolist (backend (spam-backend-list))
(let (unregister-list)
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index c27cdb5..e20a1a5 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -805,6 +805,8 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED
REAL-DEF)."
;; aliases before functions.
(aliased
(format-message "an alias for `%s'" real-def))
+ ((subr-native-elisp-p def)
+ (concat beg "native compiled Lisp function"))
((subrp def)
(concat beg (if (eq 'unevalled (cdr (subr-arity def)))
"special form"
diff --git a/lisp/help-macro.el b/lisp/help-macro.el
index 81d2383..7fe1fb6 100644
--- a/lisp/help-macro.el
+++ b/lisp/help-macro.el
@@ -59,12 +59,6 @@
;;-> (define-key c-mp "\C-h" 'help-for-empire-redistribute-map)
;;-> (define-key c-mp help-character 'help-for-empire-redistribute-map)
-;;; Change Log:
-;;
-;; 22-Jan-1991 Lynn Slater x2048
-;; Last Modified: Mon Oct 1 11:43:52 1990 #3 (Lynn Slater)
-;; documented better
-
;;; Code:
(require 'backquote)
@@ -83,7 +77,8 @@ gives the window that lists the options."
:type 'boolean
:group 'help)
-(defmacro make-help-screen (fname help-line help-text helped-map)
+(defmacro make-help-screen (fname help-line help-text helped-map
+ &optional buffer-name)
"Construct help-menu function name FNAME.
When invoked, FNAME shows HELP-LINE and reads a command using HELPED-MAP.
If the command is the help character, FNAME displays HELP-TEXT
@@ -132,7 +127,7 @@ and then returns."
(when (or (eq char ??) (eq char help-char)
(memq char help-event-list))
(setq config (current-window-configuration))
- (pop-to-buffer " *Metahelp*" nil t)
+ (pop-to-buffer (or ,buffer-name " *Metahelp*") nil t)
(and (fboundp 'make-frame)
(not (eq (window-frame)
prev-frame))
@@ -147,18 +142,23 @@ and then returns."
(setq new-minor-mode-map-alist minor-mode-map-alist))
(goto-char (point-min))
(while (or (memq char (append help-event-list
- (cons help-char '(?? ?\C-v ?\s
?\177 delete backspace vertical-scroll-bar ?\M-v))))
+ (cons help-char '( ?? ?\C-v ?\s
?\177 deletechar backspace vertical-scroll-bar ?\M-v
+ next prior
up down))))
(eq (car-safe char) 'switch-frame)
(equal key "\M-v"))
(condition-case nil
(cond
((eq (car-safe char) 'switch-frame)
(handle-switch-frame char))
- ((memq char '(?\C-v ?\s))
+ ((memq char '(?\C-v ?\s next))
(scroll-up))
- ((or (memq char '(?\177 ?\M-v delete backspace))
+ ((or (memq char '(?\177 ?\M-v deletechar backspace
prior))
(equal key "\M-v"))
- (scroll-down)))
+ (scroll-down))
+ ((memq char '(down))
+ (scroll-up 1))
+ ((memq char '(up))
+ (scroll-down 1)))
(error nil))
(let ((cursor-in-echo-area t)
(overriding-local-map local-map))
@@ -166,7 +166,12 @@ and then returns."
(format "Type one of the options listed%s: "
(if (pos-visible-in-window-p
(point-max))
- "" ", or SPACE or DEL to scroll")))
+ ""
+ (concat ", or "
+
(help--key-description-fontified "\s") ; SPC
+ " or "
+
(help--key-description-fontified "\d") ; DEL
+ " to scroll"))))
char (aref key 0)))
;; If this is a scroll bar command, just run it.
diff --git a/lisp/help.el b/lisp/help.el
index d4be9aa..85312a4 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -187,59 +187,123 @@ Do not call this in the scope of `with-help-window'."
;; So keyboard macro definitions are documented correctly
(fset 'defining-kbd-macro (symbol-function 'start-kbd-macro))
+
+;;; Help for help. (a.k.a. `C-h C-h')
+
+(defvar help-for-help-buffer-name " *Metahelp*"
+ "Name of the `help-for-help' buffer.")
+
+(defface help-for-help-header '((t :height 1.26))
+ "Face used for headers in the `help-for-help' buffer."
+ :group 'help)
+
+(defun help--for-help-make-commands (commands)
+ "Create commands for `help-for-help' screen from COMMANDS."
+ (mapconcat
+ (lambda (cmd)
+ (if (listp cmd)
+ (let ((name (car cmd)) (desc (cadr cmd)))
+ (concat
+ " "
+ (if (string-match (rx string-start "C-" word string-end) name)
+ ;; `help--key-description-fontified' would convert "C-m" to
+ ;; "RET" so we can't use it here.
+ (propertize name 'face 'help-key-binding)
+ (concat "\\[" name "]"))
+ " " ; ensure we have some whitespace before the description
+ (propertize "\t" 'display '(space :align-to 8))
+ desc))
+ ""))
+ commands "\n"))
+
+(defun help--for-help-make-sections (sections)
+ "Create sections for `help-for-help' screen from SECTIONS."
+ (mapconcat
+ (lambda (section)
+ (let ((title (car section)) (commands (cdr section)))
+ (concat
+ "\n\n"
+ (propertize title 'face 'help-for-help-header)
+ "\n\n"
+ (help--for-help-make-commands commands))))
+ sections ""))
+
(defalias 'help 'help-for-help)
(make-help-screen help-for-help
(purecopy "Type a help option: [abcCdefFgiIkKlLmnprstvw.] C-[cdefmnoptw] or
?")
- "You have typed %THIS-KEY%, the help character. Type a Help option:
-\(Use SPC or DEL to scroll through this text. Type \\<help-map>\\[help-quit]
to exit the Help command.)
-
-\\[apropos-command] PATTERN Show commands whose name matches the PATTERN (a
list of words
- or a regexp). See also \\[apropos].
-\\[describe-bindings] Display all key bindings.
-\\[describe-key-briefly] KEYS Display the command name run by the given
key sequence.
-\\[describe-coding-system] CODING Describe the given coding system, or RET
for current ones.
-\\[apropos-documentation] PATTERN Show a list of functions, variables, and
other items whose
- documentation matches the PATTERN (a list of words or a regexp).
-\\[view-echo-area-messages] Go to the *Messages* buffer which logs
echo-area messages.
-\\[describe-function] FUNCTION Display documentation for the given function.
-\\[Info-goto-emacs-command-node] COMMAND Show the Emacs manual's section
that describes the command.
-\\[describe-gnu-project] Display information about the GNU project.
-\\[view-hello-file] Display the HELLO file which illustrates various
scripts.
-\\[info] Start the Info documentation reader: read included manuals.
-\\[describe-input-method] METHOD Describe a specific input method, or RET
for current.
-\\[describe-key] KEYS Display the full documentation for the key sequence.
-\\[Info-goto-emacs-key-command-node] KEYS Show the Emacs manual's section
for the command bound to KEYS.
-\\[view-lossage] Show last 300 input keystrokes (lossage).
-\\[describe-language-environment] LANG-ENV Describe a specific language
environment, or RET for current.
-\\[describe-mode] Display documentation of current minor modes and
current major mode,
- including their special commands.
-\\[view-emacs-news] Display news of recent Emacs changes.
-\\[describe-symbol] SYMBOL Display the given function or variable's
documentation and value.
-\\[finder-by-keyword] TOPIC Find packages matching a given topic keyword.
-\\[describe-package] PACKAGE Describe the given Emacs Lisp package.
-\\[info-emacs-manual] Display the Emacs manual in Info mode.
-\\[info-display-manual] Prompt for a manual and then display it in
Info mode.
-\\[describe-syntax] Display contents of current syntax table, plus
explanations.
-\\[info-lookup-symbol] SYMBOL Show the section for the given symbol in the
Info manual
- for the programming language used in this buffer.
-\\[help-with-tutorial] Start the Emacs learn-by-doing tutorial.
-\\[describe-variable] VARIABLE Display the given variable's documentation and
value.
-\\[where-is] COMMAND Display which keystrokes invoke the given command
(where-is).
-\\[display-local-help] Display any available local help at point in
the echo area.
-
-\\[about-emacs] Information about Emacs.
-\\[describe-copying] Emacs copying permission (GNU General Public
License).
-\\[view-emacs-debugging] Instructions for debugging GNU Emacs.
-\\[view-external-packages] External packages and information about
Emacs.
-\\[view-emacs-FAQ] Emacs FAQ.
-C-m How to order printed Emacs manuals.
-C-n News of recent Emacs changes.
-\\[describe-distribution] Emacs ordering and distribution information.
-\\[view-emacs-problems] Info about known Emacs problems.
-\\[search-forward-help-for-help] Search forward \"help window\".
-\\[view-emacs-todo] Emacs TODO list.
-\\[describe-no-warranty] Information on absence of warranty for GNU
Emacs."
- help-map)
+ (concat
+ "\(Type "
+ (help--key-description-fontified "\s") ; SPC
+ " or "
+ (help--key-description-fontified "\d") ; DEL
+ " to scroll, "
+ (help--key-description-fontified "\C-s")
+ " to search, or \\<help-map>\\[help-quit] to exit.)"
+ (help--for-help-make-sections
+ `(("Commands, Keys and Functions"
+ ("describe-mode"
+ "Show help for current major and minor modes and their commands")
+ ("describe-bindings" "Show all key bindings")
+ ("describe-key" "Show help for key")
+ ("describe-key-briefly" "Show help for key briefly")
+ ("where-is" "Show which key runs a specific command")
+ ""
+ ("apropos-command"
+ "Search for commands (see also \\[apropos])")
+ ("apropos-documentation"
+ "Search documentation of functions, variables, and other items")
+ ("describe-function" "Show help for function")
+ ("describe-variable" "Show help for variable")
+ ("describe-symbol" "Show help for function or variable"))
+ ("Manuals"
+ ("info-emacs-manual" "Show Emacs manual")
+ ("Info-goto-emacs-command-node"
+ "Show Emacs manual section for command")
+ ("Info-goto-emacs-key-command-node"
+ "Show Emacs manual section for a key sequence")
+ ("info" "Show all installed manuals")
+ ("info-display-manual" "Show a specific manual")
+ ("info-lookup-symbol" "Show description of symbol in pertinent manual"))
+ ("Other Help Commands"
+ ("view-external-packages"
+ "Extending Emacs with external packages")
+ ("finder-by-keyword"
+ "Search for Emacs packages (see also \\[list-packages])")
+ ("describe-package" "Describe a specific Emacs package")
+ ""
+ ("help-with-tutorial" "Start the Emacs tutorial")
+ ("view-echo-area-messages"
+ "Show recent messages (from echo area)")
+ ("view-lossage" ,(format "Show last %d input keystrokes (lossage)"
+ (lossage-size)))
+ ("display-local-help" "Show local help at point"))
+ ("Miscellaneous"
+ ("about-emacs" "About Emacs")
+ ("view-emacs-FAQ" "Emacs FAQ")
+ ("C-n" "News of recent changes")
+ ("view-emacs-problems" "Known problems")
+ ("view-emacs-debugging" "Debugging Emacs")
+ ""
+ ("describe-gnu-project" "About the GNU project")
+ ("describe-copying"
+ "Emacs copying permission (GNU General Public License)")
+ ("describe-distribution"
+ "Emacs ordering and distribution information")
+ ("C-m" "Order printed manuals")
+ ("view-emacs-todo" "Emacs TODO")
+ ("describe-no-warranty"
+ "Information on absence of warranty"))
+ ("Internationalization and Coding Systems"
+ ("describe-input-method" "Describe input method")
+ ("describe-coding-system" "Describe coding system")
+ ("describe-language-environment"
+ "Describe language environment")
+ ("describe-syntax" "Show current syntax table")
+ ("view-hello-file"
+ "Display the HELLO file illustrating various scripts"))))
+ "\n")
+ help-map
+ help-for-help-buffer-name)
@@ -885,7 +949,7 @@ current buffer."
"Search forward \"help window\"."
(interactive)
;; Move cursor to the "help window".
- (pop-to-buffer " *Metahelp*")
+ (pop-to-buffer help-for-help-buffer-name)
;; Do incremental search forward.
(isearch-forward nil t))
@@ -1807,6 +1871,8 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1
ARG2 ...)\"."
(error "Unrecognized usage format"))
(help--make-usage-docstring 'fn arglist)))))
+(declare-function subr-native-lambda-list "data.c")
+
(defun help-function-arglist (def &optional preserve-names)
"Return a formal argument list for the function DEF.
If PRESERVE-NAMES is non-nil, return a formal arglist that uses
@@ -1822,6 +1888,10 @@ the same names as used in the original source code, when
possible."
((and (byte-code-function-p def) (listp (aref def 0))) (aref def 0))
((eq (car-safe def) 'lambda) (nth 1 def))
((eq (car-safe def) 'closure) (nth 2 def))
+ ((and (featurep 'nativecomp)
+ (subrp def)
+ (listp (subr-native-lambda-list def)))
+ (subr-native-lambda-list def))
((or (and (byte-code-function-p def) (integerp (aref def 0)))
(subrp def) (module-function-p def))
(or (when preserve-names
diff --git a/lisp/hilit-chg.el b/lisp/hilit-chg.el
index 89a1a91..3c3c407 100644
--- a/lisp/hilit-chg.el
+++ b/lisp/hilit-chg.el
@@ -1,4 +1,4 @@
-;;; hilit-chg.el --- minor mode displaying buffer changes with special face
+;;; hilit-chg.el --- minor mode displaying buffer changes with special face
-*- lexical-binding: t -*-
;; Copyright (C) 1998, 2000-2021 Free Software Foundation, Inc.
@@ -68,8 +68,7 @@
;; (defun my-highlight-changes-mode-hook ()
;; (if highlight-changes-mode
;; (add-hook 'write-file-functions 'highlight-changes-rotate-faces nil t)
-;; (remove-hook 'write-file-functions 'highlight-changes-rotate-faces t)
-;; ))
+;; (remove-hook 'write-file-functions 'highlight-changes-rotate-faces t)))
;; Automatically enabling Highlight Changes mode
@@ -114,16 +113,16 @@
;; Possible bindings:
-;; (global-set-key '[C-right] 'highlight-changes-next-change)
-;; (global-set-key '[C-left] 'highlight-changes-previous-change)
+;; (global-set-key '[C-right] #'highlight-changes-next-change)
+;; (global-set-key '[C-left] #'highlight-changes-previous-change)
;;
;; Other interactive functions (that could be bound if desired):
-;; highlight-changes-mode
-;; highlight-changes-toggle-visibility
-;; highlight-changes-remove-highlight
-;; highlight-compare-with-file
-;; highlight-compare-buffers
-;; highlight-changes-rotate-faces
+;; `highlight-changes-mode'
+;; `highlight-changes-toggle-visibility'
+;; `highlight-changes-remove-highlight'
+;; `highlight-compare-with-file'
+;; `highlight-compare-buffers'
+;; `highlight-changes-rotate-faces'
;;; Bugs:
@@ -179,7 +178,6 @@
:version "20.4"
:group 'faces)
-
;; Face information: How the changes appear.
;; Defaults for face: red foreground, no change to background,
@@ -192,22 +190,20 @@
'((((min-colors 88) (class color)) (:foreground "red1"))
(((class color)) (:foreground "red" ))
(t (:inverse-video t)))
- "Face used for highlighting changes."
- :group 'highlight-changes)
+ "Face used for highlighting changes.")
;; This looks pretty ugly, actually. Maybe the underline should be removed.
(defface highlight-changes-delete
'((((min-colors 88) (class color)) (:foreground "red1" :underline t))
(((class color)) (:foreground "red" :underline t))
(t (:inverse-video t)))
- "Face used for highlighting deletions."
- :group 'highlight-changes)
+ "Face used for highlighting deletions.")
;; A (not very good) default list of colors to rotate through.
(defcustom highlight-changes-colors
(if (eq (frame-parameter nil 'background-mode) 'light)
;; defaults for light background:
- '( "magenta" "blue" "darkgreen" "chocolate" "sienna4" "NavyBlue")
+ '("magenta" "blue" "darkgreen" "chocolate" "sienna4" "NavyBlue")
;; defaults for dark background:
'("yellow" "magenta" "blue" "maroon" "firebrick" "green4" "DarkOrchid"))
"Colors used by `highlight-changes-rotate-faces'.
@@ -218,8 +214,7 @@ This list is used if `highlight-changes-face-list' is nil,
otherwise that
variable overrides this list. If you only care about foreground
colors then use this, if you want fancier faces then set
`highlight-changes-face-list'."
- :type '(repeat color)
- :group 'highlight-changes)
+ :type '(repeat color))
;; When you invoke highlight-changes-mode, should
highlight-changes-visible-mode
;; be on or off?
@@ -230,8 +225,7 @@ colors then use this, if you want fancier faces then set
This controls the initial value of `highlight-changes-visible-mode'.
When a buffer is in Highlight Changes mode the function
`highlight-changes-visible-mode' is used to toggle the mode on or off."
- :type 'boolean
- :group 'highlight-changes)
+ :type 'boolean)
;; These are the strings displayed in the mode-line for the minor mode:
@@ -240,16 +234,14 @@ When a buffer is in Highlight Changes mode the function
This should be set to nil if no indication is desired, or to
a string with a leading space."
:type '(choice string
- (const :tag "None" nil))
- :group 'highlight-changes)
+ (const :tag "None" nil)))
(defcustom highlight-changes-invisible-string " -Chg"
"The string used when in Highlight Changes mode and changes are hidden.
This should be set to nil if no indication is desired, or to
a string with a leading space."
:type '(choice string
- (const :tag "None" nil))
- :group 'highlight-changes)
+ (const :tag "None" nil)))
(defcustom highlight-changes-global-modes t
"Determine whether a buffer is suitable for global Highlight Changes mode.
@@ -279,9 +271,7 @@ modes only."
(repeat :tag "Modes" :inline t (symbol :tag "mode")))
(function :menu-tag "determined by function"
:value buffer-file-name)
- (const :tag "none" nil)
- )
- :group 'highlight-changes)
+ (const :tag "none" nil)))
(defcustom highlight-changes-global-changes-existing-buffers nil
"If non-nil, toggling global Highlight Changes mode affects existing buffers.
@@ -290,8 +280,7 @@ created). However, if
`highlight-changes-global-changes-existing-buffers'
is non-nil, then turning on `global-highlight-changes-mode' will turn on
Highlight Changes mode in suitable buffers, and turning the mode off will
remove it from existing buffers."
- :type 'boolean
- :group 'highlight-changes)
+ :type 'boolean)
;; These are for internal use.
@@ -320,9 +309,7 @@ through various faces.
\\[highlight-compare-with-file] - mark text as changed by comparing this
buffer with the contents of a file
\\[highlight-compare-buffers] highlights differences between two buffers."
- nil ;; init-value
- hilit-chg-string ;; lighter
- nil ;; keymap
+ :lighter hilit-chg-string
(if (or (display-color-p)
(and (fboundp 'x-display-grayscale-p) (x-display-grayscale-p)))
(progn
@@ -352,13 +339,8 @@ The default value can be customized with variable
`highlight-changes-visibility-initial-state'.
This command does not itself set Highlight Changes mode."
-
- t ;; init-value
- nil ;; lighter
- nil ;; keymap
-
- (hilit-chg-update)
- )
+ :init-value t
+ (hilit-chg-update))
(defun hilit-chg-cust-fix-changes-face-list (w _wc &optional event)
@@ -371,12 +353,10 @@ This command does not itself set Highlight Changes mode."
;; faces are saved but not to the actual list itself.
(let ((old-list (widget-value w)))
(if (member 'default old-list)
- (let
- ((p (reverse old-list))
+ (let ((p (reverse old-list))
(n (length old-list))
new-name old-name
- (new-list nil)
- )
+ (new-list nil))
(while p
(setq old-name (car p))
(setq new-name (intern (format "highlight-changes-%d" n)))
@@ -396,9 +376,7 @@ This command does not itself set Highlight Changes mode."
(if (equal new-list (widget-value w))
nil ;; (message "notify: no change!")
(widget-value-set w new-list)
- (widget-setup)
- )
- )
+ (widget-setup)))
;; (message "notify: no default here!")
))
(let ((parent (widget-get w :parent)))
@@ -417,10 +395,8 @@ Otherwise, this list will be constructed when needed from
:type '(choice
(repeat
:notify hilit-chg-cust-fix-changes-face-list
- face )
- (const :tag "Derive from highlight-changes-colors" nil)
- )
- :group 'highlight-changes)
+ face)
+ (const :tag "Derive from highlight-changes-colors" nil)))
(defun hilit-chg-map-changes (func &optional start-position end-position)
@@ -446,7 +422,7 @@ An overlay from BEG to END containing a change face is added
from the information in the text property of type `hilit-chg'.
This is the opposite of `hilit-chg-hide-changes'."
- (hilit-chg-map-changes 'hilit-chg-make-ov beg end))
+ (hilit-chg-map-changes #'hilit-chg-make-ov beg end))
(defun hilit-chg-make-ov (prop start end)
@@ -467,8 +443,7 @@ This is the opposite of `hilit-chg-hide-changes'."
(overlay-put ov 'evaporate t)
;; We set the change property so we can tell this is one
;; of our overlays (so we don't delete someone else's).
- (overlay-put ov 'hilit-chg t)
- )
+ (overlay-put ov 'hilit-chg t))
(error "hilit-chg-make-ov: no face for prop: %s" prop))))
(defun hilit-chg-hide-changes (&optional beg end)
@@ -726,7 +701,7 @@ this, eval the following in the buffer to be saved:
;; remove our existing overlays
(hilit-chg-hide-changes)
;; for each change text property, increment it
- (hilit-chg-map-changes 'hilit-chg-bump-change)
+ (hilit-chg-map-changes #'hilit-chg-bump-change)
;; and display them
(hilit-chg-display-changes))
(unless modified
@@ -759,7 +734,7 @@ is non-nil."
(buf-b-read-only (with-current-buffer buf-b buffer-read-only))
temp-a temp-b)
(if (and file-a bufa-modified)
- (if (y-or-n-p (format "Save buffer %s? " buf-a))
+ (if (y-or-n-p (format "Save buffer %s? " buf-a))
(with-current-buffer buf-a
(save-buffer)
(setq bufa-modified (buffer-modified-p buf-a)))
@@ -768,7 +743,7 @@ is non-nil."
(setq temp-a (setq file-a (ediff-make-temp-file buf-a nil))))
(if (and file-b bufb-modified)
- (if (y-or-n-p (format "Save buffer %s? " buf-b))
+ (if (y-or-n-p (format "Save buffer %s? " buf-b))
(with-current-buffer buf-b
(save-buffer)
(setq bufb-modified (buffer-modified-p buf-b)))
@@ -809,12 +784,11 @@ is non-nil."
(if temp-a
(delete-file temp-a))
(if temp-b
- (delete-file temp-b)))
- ))
+ (delete-file temp-b)))))
;;;###autoload
(defun highlight-compare-buffers (buf-a buf-b)
-"Compare two buffers and highlight the differences.
+ "Compare two buffers and highlight the differences.
The default is the current buffer and the one in the next window.
@@ -835,8 +809,7 @@ changes are made, so \\[highlight-changes-next-change] and
(window-buffer (next-window)) t))))
(let ((file-a (buffer-file-name buf-a))
(file-b (buffer-file-name buf-b)))
- (highlight-markup-buffers buf-a file-a buf-b file-b)
- ))
+ (highlight-markup-buffers buf-a file-a buf-b file-b)))
;;;###autoload
(defun highlight-compare-with-file (file-b)
@@ -876,9 +849,11 @@ changes are made, so \\[highlight-changes-next-change] and
(find-file-noselect file-b))))
(highlight-markup-buffers buf-a file-a buf-b file-b (not existing-buf))
(unless existing-buf
- (kill-buffer buf-b))
- ))
+ (kill-buffer buf-b))))
+(defvar hilit-x) ; placate the byte-compiler
+(defvar hilit-y)
+(defvar hilit-e)
(defun hilit-chg-get-diff-info (buf-a file-a buf-b file-b)
;; hilit-e,x,y are set by function hilit-chg-get-diff-list-hk.
@@ -886,8 +861,7 @@ changes are made, so \\[highlight-changes-next-change] and
(ediff-setup buf-a file-a buf-b file-b
nil nil ; buf-c file-C
'(hilit-chg-get-diff-list-hk)
- (list (cons 'ediff-job-name 'something))
- )
+ (list (cons 'ediff-job-name 'something)))
(ediff-with-current-buffer hilit-e (ediff-really-quit nil))
(list hilit-x hilit-y)))
@@ -895,9 +869,6 @@ changes are made, so \\[highlight-changes-next-change] and
(defun hilit-chg-get-diff-list-hk ()
;; hilit-e/x/y are dynamically bound by hilit-chg-get-diff-info
;; which calls this function as a hook.
- (defvar hilit-x) ; placate the byte-compiler
- (defvar hilit-y)
- (defvar hilit-e)
(setq hilit-e (current-buffer))
(let ((n 0) extent p va vb a b)
(setq hilit-x nil hilit-y nil)
@@ -931,7 +902,7 @@ changes are made, so \\[highlight-changes-next-change] and
(setq extent (list (overlay-start (car p))
(overlay-end (car p))))
(setq p (cdr p))
- (setq hilit-y (append hilit-y (list extent) )))
+ (setq hilit-y (append hilit-y (list extent))))
(setq n (1+ n)));; while
;; ediff-quit doesn't work here.
;; No point in returning a value, since this is a hook function.
@@ -961,8 +932,7 @@ This is called when `global-highlight-changes-mode' is
turned on."
(and
(not (string-match "^[ *]" (buffer-name)))
(buffer-file-name))))
- (highlight-changes-mode 1))
- ))
+ (highlight-changes-mode 1))))
;;;; Desktop support.
@@ -985,8 +955,7 @@ This is called when `global-highlight-changes-mode' is
turned on."
;; (message "--- hilit-chg-debug-show ---")
;; (hilit-chg-map-changes (lambda (prop start end)
;; (message "%d-%d: %s" start end prop))
-;; beg end
-;; ))
+;; beg end))
;;
;; ================== end of debug ===============
diff --git a/lisp/hippie-exp.el b/lisp/hippie-exp.el
index 4d02023..cbb69b2 100644
--- a/lisp/hippie-exp.el
+++ b/lisp/hippie-exp.el
@@ -1,4 +1,4 @@
-;;; hippie-exp.el --- expand text trying various ways to find its expansion
+;;; hippie-exp.el --- expand text trying various ways to find its expansion
-*- lexical-binding: t; -*-
;; Copyright (C) 1992, 2001-2021 Free Software Foundation, Inc.
@@ -58,7 +58,7 @@
;; The variable `hippie-expand-dabbrev-as-symbol' controls whether
;; characters of syntax '_' is considered part of the words to expand
;; dynamically.
-;; See also the macro `make-hippie-expand-function' below.
+;; See also the function `make-hippie-expand-function' below.
;;
;; A short description of the current try-functions in this file:
;; `try-complete-file-name' : very convenient to have in any buffer,
@@ -215,50 +215,42 @@
"The list of expansion functions tried in order by `hippie-expand'.
To change the behavior of `hippie-expand', remove, change the order of,
or insert functions in this list."
- :type '(repeat function)
- :group 'hippie-expand)
+ :type '(repeat function))
(defcustom hippie-expand-verbose t
"Non-nil makes `hippie-expand' output which function it is trying."
- :type 'boolean
- :group 'hippie-expand)
+ :type 'boolean)
(defcustom hippie-expand-dabbrev-skip-space nil
"Non-nil means tolerate trailing spaces in the abbreviation to expand."
- :group 'hippie-expand
:type 'boolean)
(defcustom hippie-expand-dabbrev-as-symbol t
"Non-nil means expand as symbols, i.e. syntax `_' is considered a letter."
- :group 'hippie-expand
:type 'boolean)
(defcustom hippie-expand-no-restriction t
"Non-nil means that narrowed buffers are widened during search."
- :group 'hippie-expand
:type 'boolean)
(defcustom hippie-expand-max-buffers ()
"The maximum number of buffers (apart from the current) searched.
If nil, all buffers are searched."
:type '(choice (const :tag "All" nil)
- integer)
- :group 'hippie-expand)
+ integer))
(defcustom hippie-expand-ignore-buffers '("^ \\*.*\\*$" dired-mode)
"A list specifying which buffers not to search (if not current).
Can contain both regexps matching buffer names (as strings) and major modes
\(as atoms)."
- :type '(repeat (choice regexp (symbol :tag "Major Mode")))
- :group 'hippie-expand)
+ :type '(repeat (choice regexp (symbol :tag "Major Mode"))))
(defcustom hippie-expand-only-buffers ()
"A list specifying the only buffers to search (in addition to current).
Can contain both regexps matching buffer names (as strings) and major modes
\(as atoms). If non-nil, this variable overrides the variable
`hippie-expand-ignore-buffers'."
- :type '(repeat (choice regexp (symbol :tag "Major Mode")))
- :group 'hippie-expand)
+ :type '(repeat (choice regexp (symbol :tag "Major Mode"))))
;;;###autoload
(defun hippie-expand (arg)
@@ -407,18 +399,19 @@ undoes the expansion."
;; try-expand-line-all-buffers)))
;;
;;;###autoload
-(defmacro make-hippie-expand-function (try-list &optional verbose)
+(defun make-hippie-expand-function (try-list &optional verbose)
"Construct a function similar to `hippie-expand'.
Make it use the expansion functions in TRY-LIST. An optional second
argument VERBOSE non-nil makes the function verbose."
- `(lambda (arg)
- ,(concat
- "Try to expand text before point, using the following functions: \n"
- (mapconcat 'prin1-to-string (eval try-list) ", "))
- (interactive "P")
- (let ((hippie-expand-try-functions-list ,try-list)
- (hippie-expand-verbose ,verbose))
- (hippie-expand arg))))
+ (lambda (arg)
+ (:documentation
+ (concat
+ "Try to expand text before point, using the following functions: \n"
+ (mapconcat #'prin1-to-string try-list ", ")))
+ (interactive "P")
+ (let ((hippie-expand-try-functions-list try-list)
+ (hippie-expand-verbose verbose))
+ (hippie-expand arg))))
;;; Here follows the try-functions and their requisites:
@@ -434,7 +427,8 @@ string). It returns t if a new completion is found, nil
otherwise."
(he-init-string (he-file-name-beg) (point))
(let ((name-part (file-name-nondirectory he-search-string))
(dir-part (expand-file-name (or (file-name-directory
- he-search-string) ""))))
+ he-search-string)
+ ""))))
(if (not (he-string-member name-part he-tried-table))
(setq he-tried-table (cons name-part he-tried-table)))
(if (and (not (equal he-search-string ""))
@@ -442,7 +436,7 @@ string). It returns t if a new completion is found, nil
otherwise."
(setq he-expand-list (sort (file-name-all-completions
name-part
dir-part)
- 'string-lessp))
+ #'string-lessp))
(setq he-expand-list ())))))
(while (and he-expand-list
@@ -538,7 +532,7 @@ string). It returns t if a new completion is found, nil
otherwise."
(or (boundp sym)
(fboundp sym)
(symbol-plist sym))))
- 'string-lessp)))))
+ #'string-lessp)))))
(while (and he-expand-list
(he-string-member (car he-expand-list) he-tried-table))
(setq he-expand-list (cdr he-expand-list)))
@@ -822,9 +816,10 @@ string). It returns t if a new expansion is found, nil
otherwise."
(setq he-expand-list
(and (not (equal he-search-string ""))
(mapcar (lambda (sym)
- (if (and (boundp sym) (vectorp (eval sym)))
+ (if (and (boundp sym)
+ (abbrev-table-p (symbol-value sym)))
(abbrev-expansion (downcase he-search-string)
- (eval sym))))
+ (symbol-value sym))))
(append '(local-abbrev-table
global-abbrev-table)
abbrev-table-name-list))))))
diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el
index 0c8d534..b453061 100644
--- a/lisp/htmlfontify.el
+++ b/lisp/htmlfontify.el
@@ -523,22 +523,10 @@ therefore no longer care about) will be invalid at any
time.\n
(defvar hfy-tmpfont-stack nil
"An alist of derived fonts resulting from overlays.")
-(defconst hfy-hex-regex "[[:xdigit:]]")
-
(defconst hfy-triplet-regex
- (concat
- "\\(" hfy-hex-regex hfy-hex-regex "\\)"
- "\\(" hfy-hex-regex hfy-hex-regex "\\)"
- "\\(" hfy-hex-regex hfy-hex-regex "\\)"))
-
-(defun hfy-interq (set-a set-b)
- "Return the intersection (using `eq') of two lists SET-A and SET-B."
- (let ((sa set-a) (interq nil) (elt nil))
- (while sa
- (setq elt (car sa)
- sa (cdr sa))
- (if (memq elt set-b) (setq interq (cons elt interq))))
- interq))
+ (rx (group xdigit xdigit)
+ (group xdigit xdigit)
+ (group xdigit xdigit)))
(defun hfy-color-vals (color)
"Where COLOR is a color name or #XXXXXX style triplet, return a
@@ -887,7 +875,9 @@ See also `hfy-display-class' for details of valid values
for CLASS."
(setq score 0) (ignore "t match"))
((not (cdr (assq key face-class))) ;Neither good nor bad.
nil (ignore "non match, non collision"))
- ((setq x (hfy-interq val (cdr (assq key face-class))))
+ ((setq x (nreverse
+ (seq-intersection val (cdr (assq key
face-class))
+ #'eq)))
(setq score (+ score (length x)))
(ignore "intersection"))
(t ;; nope.
@@ -2355,6 +2345,13 @@ You may also want to set `hfy-page-header' and
`hfy-page-footer'."
(let ((file (hfy-initfile)))
(load file 'NOERROR nil nil) ))
+;; Obsolete.
+
+(defun hfy-interq (set-a set-b)
+ "Return the intersection (using `eq') of two lists SET-A and SET-B."
+ (declare (obsolete seq-intersection "28.1"))
+ (nreverse (seq-intersection set-a set-b #'eq)))
+
(provide 'htmlfontify)
;;; htmlfontify.el ends here
diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el
index 44574ab..1dc8acb 100644
--- a/lisp/ibuf-ext.el
+++ b/lisp/ibuf-ext.el
@@ -402,7 +402,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)."
- nil nil nil
+ :lighter nil
(unless (derived-mode-p 'ibuffer-mode)
(error "This buffer is not in Ibuffer mode"))
(cond (ibuffer-auto-mode
@@ -687,8 +687,8 @@ specifications with the same structure as
`ibuffer-filtering-qualifiers'."
(not
(memq nil ;; a filter will return nil if it failed
- (mapcar #'(lambda (filter)
- (ibuffer-included-in-filter-p buf filter))
+ (mapcar (lambda (filter)
+ (ibuffer-included-in-filter-p buf filter))
filters))))
(defun ibuffer-unary-operand (filter)
@@ -724,8 +724,8 @@ specification, with the same structure as an element of the
list
;; (dolist (filter-spec (cdr filter) nil)
;; (when (ibuffer-included-in-filter-p buf filter-spec)
;; (throw 'has-match t))))
- (memq t (mapcar #'(lambda (x)
- (ibuffer-included-in-filter-p buf x))
+ (memq t (mapcar (lambda (x)
+ (ibuffer-included-in-filter-p buf x))
(cdr filter))))
('and
(catch 'no-match
@@ -1589,8 +1589,8 @@ to move by. The default is `ibuffer-marked-char'."
(message "No buffers marked; use `m' to mark a buffer")
(let ((count
(ibuffer-map-marked-lines
- #'(lambda (_buf _mark)
- 'kill))))
+ (lambda (_buf _mark)
+ 'kill))))
(message "Killed %s lines" count))))
;;;###autoload
@@ -1609,8 +1609,8 @@ a prefix argument reverses the meaning of that variable."
(when current-prefix-arg
(setq only-visible (not only-visible)))
(if only-visible
- (let ((table (mapcar #'(lambda (x)
- (buffer-name (car x)))
+ (let ((table (mapcar (lambda (x)
+ (buffer-name (car x)))
(ibuffer-current-state-list))))
(when (null table)
(error "No buffers!"))
@@ -1621,10 +1621,10 @@ a prefix argument reverses the meaning of that
variable."
(let (buf-point)
;; Blindly search for our buffer: it is very likely that it is
;; not in a hidden filter group.
- (ibuffer-map-lines #'(lambda (buf _marks)
- (when (string= (buffer-name buf) name)
- (setq buf-point (point))
- nil))
+ (ibuffer-map-lines (lambda (buf _marks)
+ (when (string= (buffer-name buf) name)
+ (setq buf-point (point))
+ nil))
t nil)
(when (and
(null buf-point)
@@ -1635,10 +1635,10 @@ a prefix argument reverses the meaning of that
variable."
(dolist (group ibuffer-hidden-filter-groups)
(ibuffer-jump-to-filter-group group)
(ibuffer-toggle-filter-group)
- (ibuffer-map-lines #'(lambda (buf _marks)
- (when (string= (buffer-name buf) name)
- (setq buf-point (point))
- nil))
+ (ibuffer-map-lines (lambda (buf _marks)
+ (when (string= (buffer-name buf) name)
+ (setq buf-point (point))
+ nil))
t group)
(if buf-point
(throw 'found nil)
@@ -1775,11 +1775,11 @@ You can then feed the file name(s) to other commands
with \\[yank]."
(defun ibuffer-mark-on-buffer (func &optional ibuffer-mark-on-buffer-mark
group)
(let ((count
(ibuffer-map-lines
- #'(lambda (buf _mark)
- (when (funcall func buf)
- (ibuffer-set-mark-1 (or ibuffer-mark-on-buffer-mark
- ibuffer-marked-char))
- t))
+ (lambda (buf _mark)
+ (when (funcall func buf)
+ (ibuffer-set-mark-1 (or ibuffer-mark-on-buffer-mark
+ ibuffer-marked-char))
+ t))
nil
group)))
(ibuffer-redisplay t)
@@ -1791,8 +1791,8 @@ You can then feed the file name(s) to other commands with
\\[yank]."
"Mark all buffers whose name matches REGEXP."
(interactive "sMark by name (regexp): ")
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (string-match regexp (buffer-name buf)))))
+ (lambda (buf)
+ (string-match regexp (buffer-name buf)))))
(defun ibuffer-locked-buffer-p (&optional buf)
"Return non-nil if BUF is locked.
@@ -1816,9 +1816,9 @@ When BUF nil, default to the buffer at current line."
"Mark all buffers whose major mode matches REGEXP."
(interactive "sMark by major mode (regexp): ")
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (with-current-buffer buf
- (string-match regexp (format-mode-line mode-name nil nil buf))))))
+ (lambda (buf)
+ (with-current-buffer buf
+ (string-match regexp (format-mode-line mode-name nil nil buf))))))
;;;###autoload
(defun ibuffer-mark-by-file-name-regexp (regexp)
@@ -1840,21 +1840,21 @@ Otherwise buffers whose name matches an element of
(interactive (let ((reg (read-string "Mark by content (regexp): ")))
(list reg current-prefix-arg)))
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (let ((mode (with-current-buffer buf major-mode))
- res)
- (cond ((and (not all-buffers)
- (or
- (memq mode ibuffer-never-search-content-mode)
- (cl-dolist (x ibuffer-never-search-content-name nil)
- (when-let ((found (string-match x (buffer-name buf))))
- (cl-return found)))))
- (setq res nil))
- (t
- (with-current-buffer buf
- (save-mark-and-excursion
- (goto-char (point-min))
- (setq res (re-search-forward regexp nil t)))))) res))))
+ (lambda (buf)
+ (let ((mode (with-current-buffer buf major-mode))
+ res)
+ (cond ((and (not all-buffers)
+ (or
+ (memq mode ibuffer-never-search-content-mode)
+ (cl-dolist (x ibuffer-never-search-content-name nil)
+ (when-let ((found (string-match x (buffer-name buf))))
+ (cl-return found)))))
+ (setq res nil))
+ (t
+ (with-current-buffer buf
+ (save-mark-and-excursion
+ (goto-char (point-min))
+ (setq res (re-search-forward regexp nil t)))))) res))))
;;;###autoload
(defun ibuffer-mark-by-mode (mode)
@@ -1869,92 +1869,92 @@ Otherwise buffers whose name matches an element of
(format-prompt "Mark by major mode" default)
(ibuffer-list-buffer-modes) nil t nil nil default)))))
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (eq (buffer-local-value 'major-mode buf) mode))))
+ (lambda (buf)
+ (eq (buffer-local-value 'major-mode buf) mode))))
;;;###autoload
(defun ibuffer-mark-modified-buffers ()
"Mark all modified buffers."
(interactive)
(ibuffer-mark-on-buffer
- #'(lambda (buf) (buffer-modified-p buf))))
+ (lambda (buf) (buffer-modified-p buf))))
;;;###autoload
(defun ibuffer-mark-unsaved-buffers ()
"Mark all modified buffers that have an associated file."
(interactive)
(ibuffer-mark-on-buffer
- #'(lambda (buf) (and (buffer-local-value 'buffer-file-name buf)
- (buffer-modified-p buf)))))
+ (lambda (buf) (and (buffer-local-value 'buffer-file-name buf)
+ (buffer-modified-p buf)))))
;;;###autoload
(defun ibuffer-mark-dissociated-buffers ()
"Mark all buffers whose associated file does not exist."
(interactive)
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (with-current-buffer buf
- (or
- (and buffer-file-name
- (not (file-exists-p buffer-file-name)))
- (and (eq major-mode 'dired-mode)
- (boundp 'dired-directory)
- (stringp dired-directory)
- (not (file-exists-p (file-name-directory dired-directory)))))))))
+ (lambda (buf)
+ (with-current-buffer buf
+ (or
+ (and buffer-file-name
+ (not (file-exists-p buffer-file-name)))
+ (and (eq major-mode 'dired-mode)
+ (boundp 'dired-directory)
+ (stringp dired-directory)
+ (not (file-exists-p (file-name-directory dired-directory)))))))))
;;;###autoload
(defun ibuffer-mark-help-buffers ()
"Mark buffers whose major mode is in variable `ibuffer-help-buffer-modes'."
(interactive)
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (with-current-buffer buf
- (memq major-mode ibuffer-help-buffer-modes)))))
+ (lambda (buf)
+ (with-current-buffer buf
+ (memq major-mode ibuffer-help-buffer-modes)))))
;;;###autoload
(defun ibuffer-mark-compressed-file-buffers ()
"Mark buffers whose associated file is compressed."
(interactive)
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (with-current-buffer buf
- (and buffer-file-name
- (string-match ibuffer-compressed-file-name-regexp
- buffer-file-name))))))
+ (lambda (buf)
+ (with-current-buffer buf
+ (and buffer-file-name
+ (string-match ibuffer-compressed-file-name-regexp
+ buffer-file-name))))))
;;;###autoload
(defun ibuffer-mark-old-buffers ()
"Mark buffers which have not been viewed in `ibuffer-old-time' hours."
(interactive)
(ibuffer-mark-on-buffer
- #'(lambda (buf)
- (with-current-buffer buf
- (when buffer-display-time
- (time-less-p
- (* 60 60 ibuffer-old-time)
- (time-since buffer-display-time)))))))
+ (lambda (buf)
+ (with-current-buffer buf
+ (when buffer-display-time
+ (time-less-p
+ (* 60 60 ibuffer-old-time)
+ (time-since buffer-display-time)))))))
;;;###autoload
(defun ibuffer-mark-special-buffers ()
"Mark all buffers whose name begins and ends with `*'."
(interactive)
(ibuffer-mark-on-buffer
- #'(lambda (buf) (string-match "^\\*.+\\*$"
- (buffer-name buf)))))
+ (lambda (buf) (string-match "^\\*.+\\*$"
+ (buffer-name buf)))))
;;;###autoload
(defun ibuffer-mark-read-only-buffers ()
"Mark all read-only buffers."
(interactive)
(ibuffer-mark-on-buffer
- #'(lambda (buf) (buffer-local-value 'buffer-read-only buf))))
+ (lambda (buf) (buffer-local-value 'buffer-read-only buf))))
;;;###autoload
(defun ibuffer-mark-dired-buffers ()
"Mark all `dired' buffers."
(interactive)
(ibuffer-mark-on-buffer
- #'(lambda (buf) (eq (buffer-local-value 'major-mode buf) 'dired-mode))))
+ (lambda (buf) (eq (buffer-local-value 'major-mode buf) 'dired-mode))))
;;;###autoload
(defun ibuffer-do-occur (regexp &optional nlines)
@@ -1970,8 +1970,8 @@ defaults to one."
(let ((ibuffer-do-occur-bufs nil))
;; Accumulate a list of marked buffers
(ibuffer-map-marked-lines
- #'(lambda (buf _mark)
- (push buf ibuffer-do-occur-bufs)))
+ (lambda (buf _mark)
+ (push buf ibuffer-do-occur-bufs)))
(occur-1 regexp nlines ibuffer-do-occur-bufs)))
(provide 'ibuf-ext)
diff --git a/lisp/ibuf-macs.el b/lisp/ibuf-macs.el
index be09c65..fcc4f9e 100644
--- a/lisp/ibuf-macs.el
+++ b/lisp/ibuf-macs.el
@@ -66,8 +66,8 @@ During evaluation of body, bind `it' to the value returned by
TEST."
(ibuffer-redisplay-engine
;; Get rid of dead buffers
(delq nil
- (mapcar #'(lambda (e) (when (buffer-live-p (car e))
- e))
+ (mapcar (lambda (e) (when (buffer-live-p (car e))
+ e))
ibuffer-save-marks-tmp-mark-list)))
(ibuffer-redisplay t))))))
@@ -154,8 +154,8 @@ value if and only if `a' is \"less than\" `b'.
(ibuffer-redisplay t)
(setq ibuffer-last-sorting-mode ',name))
(push (list ',name ,description
- #'(lambda (a b)
- ,@body))
+ (lambda (a b)
+ ,@body))
ibuffer-sorting-functions-alist)
:autoload-end))
@@ -259,18 +259,18 @@ buffer object.
'ibuffer-map-deletion-lines)
(_
'ibuffer-map-marked-lines))
- #'(lambda (buf mark)
- ;; Silence warning for code that doesn't
- ;; use `mark'.
- (ignore mark)
- ,(if (eq modifier-p :maybe)
- `(let
((ibuffer-tmp-previous-buffer-modification
- (buffer-modified-p buf)))
- (prog1 ,inner-body
- (when (not (eq
ibuffer-tmp-previous-buffer-modification
- (buffer-modified-p
buf)))
- (setq ibuffer-did-modification
t))))
- inner-body)))))
+ (lambda (buf mark)
+ ;; Silence warning for code that doesn't
+ ;; use `mark'.
+ (ignore mark)
+ ,(if (eq modifier-p :maybe)
+ `(let
((ibuffer-tmp-previous-buffer-modification
+ (buffer-modified-p buf)))
+ (prog1 ,inner-body
+ (when (not (eq
ibuffer-tmp-previous-buffer-modification
+ (buffer-modified-p
buf)))
+ (setq ibuffer-did-modification
t))))
+ inner-body)))))
,finish)))
(if dangerous
`(when (ibuffer-confirm-operation-on ,active-opstring
marked-names)
diff --git a/lisp/icomplete.el b/lisp/icomplete.el
index da589c0..91bbb60 100644
--- a/lisp/icomplete.el
+++ b/lisp/icomplete.el
@@ -562,6 +562,37 @@ Usually run by inclusion in `minibuffer-setup-hook'."
(completion--cache-all-sorted-completions beg end (cons comp
all))))
finally return all)))
+(defvar icomplete-vertical-mode-minibuffer-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-n") 'icomplete-forward-completions)
+ (define-key map (kbd "C-p") 'icomplete-backward-completions)
+ map)
+ "Keymap used by `icomplete-vertical-mode' in the minibuffer.")
+
+(defun icomplete--vertical-minibuffer-setup ()
+ "Setup the minibuffer for vertical display of completion candidates."
+ (use-local-map (make-composed-keymap icomplete-vertical-mode-minibuffer-map
+ (current-local-map)))
+ (setq-local icomplete-separator "\n"
+ icomplete-hide-common-prefix nil
+ ;; Ask `icomplete-completions' to return enough completions
candidates.
+ icomplete-prospects-height 25
+ redisplay-adhoc-scroll-in-resize-mini-windows nil))
+
+;;;###autoload
+(define-minor-mode icomplete-vertical-mode
+ "Toggle vertical candidate display in `icomplete-mode' or `fido-mode'.
+
+As many completion candidates as possible are displayed, depending on
+the value of `max-mini-window-height', and the way the mini-window is
+resized depends on `resize-mini-windows'."
+ :global t
+ (remove-hook 'icomplete-minibuffer-setup-hook
+ #'icomplete--vertical-minibuffer-setup)
+ (when icomplete-vertical-mode
+ (add-hook 'icomplete-minibuffer-setup-hook
+ #'icomplete--vertical-minibuffer-setup)))
+
@@ -784,10 +815,13 @@ matches exist."
(if last (setcdr last base-size))
(if prospects
(concat determ
- "{"
- (mapconcat 'identity prospects icomplete-separator)
- (and limit (concat icomplete-separator ellipsis))
- "}")
+ (if icomplete-vertical-mode " \n" "{")
+ (mapconcat 'identity prospects (if icomplete-vertical-mode
+ "\n"
+ icomplete-separator))
+ (unless icomplete-vertical-mode
+ (concat (and limit (concat icomplete-separator ellipsis))
+ "}")))
(concat determ " [Matched]"))))))
;;; Iswitchb compatibility
@@ -803,7 +837,6 @@ matches exist."
;;;###autoload (make-obsolete 'iswitchb-mode
;;;###autoload "use `icomplete-mode' or `ido-mode' instead." "24.4"))
-;;;_* Provide
(provide 'icomplete)
;;_* Local emacs vars.
diff --git a/lisp/image-mode.el b/lisp/image-mode.el
index 2de16cb..69ef701 100644
--- a/lisp/image-mode.el
+++ b/lisp/image-mode.el
@@ -713,8 +713,7 @@ Key bindings:
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
actual image."
- nil (:eval (if image-type (format " Image[%s]" image-type) " Image"))
- image-minor-mode-map
+ :lighter (:eval (if image-type (format " Image[%s]" image-type) " Image"))
:group 'image
:version "22.1"
(if image-minor-mode
@@ -732,8 +731,9 @@ displays an image file as text."
(setq image-type previous-image-type)
;; Enable image minor mode with `C-c C-c'.
(image-minor-mode 1)
- ;; Show the image file as text.
- (image-toggle-display-text)))
+ (unless (image-get-display-property)
+ ;; Show the image file as text.
+ (image-toggle-display-text))))
(defun image-mode-as-hex ()
"Set a non-image mode as major mode in combination with image minor mode.
diff --git a/lisp/image.el b/lisp/image.el
index b802c1c..610d020 100644
--- a/lisp/image.el
+++ b/lisp/image.el
@@ -603,12 +603,16 @@ means display it in the right marginal area."
(defun insert-image (image &optional string area slice)
"Insert IMAGE into current buffer at point.
IMAGE is displayed by inserting STRING into the current buffer
-with a `display' property whose value is the image. STRING
-defaults to a single space if you omit it.
+with a `display' property whose value is the image.
+
+STRING defaults to a single space if you omit it, which means
+that the inserted image will behave as whitespace syntactically.
+
AREA is where to display the image. AREA nil or omitted means
display it in the text area, a value of `left-margin' means
display it in the left marginal area, a value of `right-margin'
means display it in the right marginal area.
+
SLICE specifies slice of IMAGE to insert. SLICE nil or omitted
means insert whole image. SLICE is a list (X Y WIDTH HEIGHT)
specifying the X and Y positions and WIDTH and HEIGHT of image area
diff --git a/lisp/info.el b/lisp/info.el
index dd7e16f..82f0eb3 100644
--- a/lisp/info.el
+++ b/lisp/info.el
@@ -1,4 +1,4 @@
-;; info.el --- Info package for Emacs -*- lexical-binding:t -*-
+;;; info.el --- Info package for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1985-1986, 1992-2021 Free Software Foundation, Inc.
@@ -916,7 +916,8 @@ find a node."
(when (and (not no-pop-to-dir)
(not Info-current-file))
(Info-directory))
- (user-error "Info file %s does not exist" filename)))
+ (user-error "Info file `%s' does not exist; consider installing it"
+ filename)))
filename))))
(defun Info-find-node (filename nodename &optional no-going-back strict-case)
diff --git a/lisp/informat.el b/lisp/informat.el
index 3da2351..bac0975 100644
--- a/lisp/informat.el
+++ b/lisp/informat.el
@@ -1,4 +1,4 @@
-;;; informat.el --- info support functions package for Emacs
+;;; informat.el --- info support functions package for Emacs -*-
lexical-binding: t; -*-
;; Copyright (C) 1986, 2001-2021 Free Software Foundation, Inc.
@@ -140,7 +140,7 @@
(or (bolp)
(newline))
(insert "\^_\f\nTag table:\n")
- (if (eq major-mode 'info-mode)
+ (if (derived-mode-p 'info-mode)
(move-marker Info-tag-table-marker (point)))
(setq tag-list (nreverse tag-list))
(while tag-list
diff --git a/lisp/international/characters.el b/lisp/international/characters.el
index c643f66..97bf31a 100644
--- a/lisp/international/characters.el
+++ b/lisp/international/characters.el
@@ -484,9 +484,9 @@ with L, LRE, or LRO Unicode bidi character type.")
(progn
(modify-syntax-entry chars syntax)
(modify-category-entry chars category))
- (mapc #'(lambda (x)
- (modify-syntax-entry x syntax)
- (modify-category-entry x category))
+ (mapc (lambda (x)
+ (modify-syntax-entry x syntax)
+ (modify-category-entry x category))
chars)))))
;; Bidi categories
@@ -1390,8 +1390,8 @@ with L, LRE, or LRO Unicode bidi character type.")
(dolist (charset-info (nthcdr 2 slot))
(let ((charset (car charset-info)))
(dolist (code-range (cdr charset-info))
- (map-charset-chars #'(lambda (range _arg)
- (set-char-table-range table range 2))
+ (map-charset-chars (lambda (range _arg)
+ (set-char-table-range table range 2))
charset nil
(car code-range) (cdr code-range)))))
(optimize-char-table table)
@@ -1417,8 +1417,8 @@ Setup char-width-table appropriate for non-CJK language
environment."
(require 'charscript))
(map-charset-chars
- #'(lambda (range _ignore)
- (set-char-table-range char-script-table range 'tibetan))
+ (lambda (range _ignore)
+ (set-char-table-range char-script-table range 'tibetan))
'tibetan)
@@ -1426,14 +1426,14 @@ Setup char-width-table appropriate for non-CJK language
environment."
(when (setq unicode-category-table
(unicode-property-table-internal 'general-category))
- (map-char-table #'(lambda (key val)
- (if val
- (cond ((or (and (/= (aref (symbol-name val) 0) ?M)
- (/= (aref (symbol-name val) 0) ?C))
- (eq val 'Zs))
- (modify-category-entry key ?.))
- ((eq val 'Mn)
- (modify-category-entry key ?^)))))
+ (map-char-table (lambda (key val)
+ (if val
+ (cond ((or (and (/= (aref (symbol-name val) 0) ?M)
+ (/= (aref (symbol-name val) 0) ?C))
+ (eq val 'Zs))
+ (modify-category-entry key ?.))
+ ((eq val 'Mn)
+ (modify-category-entry key ?^)))))
unicode-category-table))
(optimize-char-table (standard-category-table))
@@ -1524,21 +1524,21 @@ option `glyphless-char-display'."
((eq target 'format-control)
(when unicode-category-table
(map-char-table
- #'(lambda (char category)
- (if (eq category 'Cf)
- (let ((this-method method)
- from to)
- (if (consp char)
- (setq from (car char) to (cdr char))
- (setq from char to char))
- (while (<= from to)
- (when (/= from #xAD)
- (if (eq method 'acronym)
- (setq this-method
- (aref char-acronym-table from)))
- (set-char-table-range glyphless-char-display
- from this-method))
- (setq from (1+ from))))))
+ (lambda (char category)
+ (if (eq category 'Cf)
+ (let ((this-method method)
+ from to)
+ (if (consp char)
+ (setq from (car char) to (cdr char))
+ (setq from char to char))
+ (while (<= from to)
+ (when (/= from #xAD)
+ (if (eq method 'acronym)
+ (setq this-method
+ (aref char-acronym-table from)))
+ (set-char-table-range glyphless-char-display
+ from this-method))
+ (setq from (1+ from))))))
unicode-category-table)))
((eq target 'no-font)
(set-char-table-extra-slot glyphless-char-display 0 method))
diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el
index 8f0f263..3deaff9 100644
--- a/lisp/international/fontset.el
+++ b/lisp/international/fontset.el
@@ -497,37 +497,37 @@
(:registry "iso10646-1"))))
(cjk-table (make-char-table nil))
(script-coverage
- #'(lambda (script)
- (let ((coverage))
- (map-char-table
- #'(lambda (range val)
- (when (eq val script)
- (if (consp range)
- (setq range (cons (car range) (cdr range))))
- (push range coverage)))
- char-script-table)
- coverage)))
+ (lambda (script)
+ (let ((coverage))
+ (map-char-table
+ (lambda (range val)
+ (when (eq val script)
+ (if (consp range)
+ (setq range (cons (car range) (cdr range))))
+ (push range coverage)))
+ char-script-table)
+ coverage)))
(data (list (vconcat (mapcar 'car cjk))))
(i 0))
(dolist (elt cjk)
(let ((mask (ash 1 i)))
(map-charset-chars
- #'(lambda (range _arg)
- (let ((from (car range)) (to (cdr range)))
- (if (< to #x110000)
- (while (<= from to)
- (or (memq (aref char-script-table from)
- '(kana hangul han cjk-misc))
- (aset cjk-table from
- (logior (or (aref cjk-table from) 0) mask)))
- (setq from (1+ from))))))
+ (lambda (range _arg)
+ (let ((from (car range)) (to (cdr range)))
+ (if (< to #x110000)
+ (while (<= from to)
+ (or (memq (aref char-script-table from)
+ '(kana hangul han cjk-misc))
+ (aset cjk-table from
+ (logior (or (aref cjk-table from) 0) mask)))
+ (setq from (1+ from))))))
(nth 1 elt) nil (nth 2 elt) (nth 3 elt)))
(setq i (1+ i)))
(map-char-table
- #'(lambda (range val)
- (if (consp range)
- (setq range (cons (car range) (cdr range))))
- (push (cons range val) data))
+ (lambda (range val)
+ (if (consp range)
+ (setq range (cons (car range) (cdr range))))
+ (push (cons range val) data))
cjk-table)
(dolist (script scripts)
(dolist (range (funcall script-coverage (car script)))
@@ -1227,7 +1227,7 @@ Done when `mouse-set-font' is called."
(string-match "fontset-auto[0-9]+$" fontset)
(push (list (fontset-plain-name fontset) fontset) l)))
(cons "Fontset"
- (sort l #'(lambda (x y) (string< (car x) (car y)))))))
+ (sort l (lambda (x y) (string< (car x) (car y)))))))
(declare-function query-fontset "fontset.c" (pattern &optional regexpp))
diff --git a/lisp/international/ja-dic-cnv.el b/lisp/international/ja-dic-cnv.el
index 3be7849..793508ca 100644
--- a/lisp/international/ja-dic-cnv.el
+++ b/lisp/international/ja-dic-cnv.el
@@ -323,11 +323,9 @@
(insert ")\n\n")))
(defun skkdic-convert (filename &optional dirname)
- "Generate Emacs Lisp file form Japanese dictionary file FILENAME.
+ "Generate Emacs Lisp file from Japanese dictionary file FILENAME.
The format of the dictionary file should be the same as SKK dictionaries.
-Optional argument DIRNAME if specified is the directory name under which
-the generated Emacs Lisp is saved.
-The name of generated file is specified by the variable `ja-dic-filename'."
+Saves the output as `ja-dic-filename', in directory DIRNAME (if specified)."
(interactive "FSKK dictionary file: ")
(let* ((skkbuf (get-buffer-create " *skkdic-unannotated*"))
(buf (get-buffer-create "*skkdic-work*")))
diff --git a/lisp/international/latin1-disp.el
b/lisp/international/latin1-disp.el
index 4b6ef98..b3d6a63 100644
--- a/lisp/international/latin1-disp.el
+++ b/lisp/international/latin1-disp.el
@@ -186,8 +186,8 @@ character set."
'arabic-iso8859-6
(car (remq 'ascii (get-language-info language
'charset))))))
- (map-charset-chars #'(lambda (range _arg)
- (standard-display-default (car range) (cdr range)))
+ (map-charset-chars (lambda (range _arg)
+ (standard-display-default (car range) (cdr range)))
charset))
(sit-for 0))
diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el
index bf0df6f..b99db46 100644
--- a/lisp/international/mule-cmds.el
+++ b/lisp/international/mule-cmds.el
@@ -679,18 +679,18 @@ DEFAULT is the coding system to use by default in the
query."
;; ((CODING (POS . CHAR) (POS . CHAR) ...) ...)
(if unsafe
(setq unsafe
- (mapcar #'(lambda (coding)
- (cons coding
- (if (stringp from)
- (mapcar #'(lambda (pos)
- (cons pos (aref from pos)))
- (unencodable-char-position
- 0 (length from) coding
- 11 from))
- (mapcar #'(lambda (pos)
- (cons pos (char-after pos)))
- (unencodable-char-position
- from to coding 11)))))
+ (mapcar (lambda (coding)
+ (cons coding
+ (if (stringp from)
+ (mapcar (lambda (pos)
+ (cons pos (aref from pos)))
+ (unencodable-char-position
+ 0 (length from) coding
+ 11 from))
+ (mapcar (lambda (pos)
+ (cons pos (char-after pos)))
+ (unencodable-char-position
+ from to coding 11)))))
unsafe)))
(setq codings (sanitize-coding-system-list codings))
@@ -744,19 +744,19 @@ e.g., for sending an email message.\n ")
(insert (format " %s cannot encode these:" (car coding)))
(let ((i 0)
(func1
- #'(lambda (bufname pos)
- (when (buffer-live-p (get-buffer bufname))
- (pop-to-buffer bufname)
- (goto-char pos))))
+ (lambda (bufname pos)
+ (when (buffer-live-p (get-buffer bufname))
+ (pop-to-buffer bufname)
+ (goto-char pos))))
(func2
- #'(lambda (bufname pos coding)
- (when (buffer-live-p (get-buffer bufname))
- (pop-to-buffer bufname)
- (if (< (point) pos)
- (goto-char pos)
- (forward-char 1)
- (search-unencodable-char coding)
- (forward-char -1))))))
+ (lambda (bufname pos coding)
+ (when (buffer-live-p (get-buffer bufname))
+ (pop-to-buffer bufname)
+ (if (< (point) pos)
+ (goto-char pos)
+ (forward-char 1)
+ (search-unencodable-char coding)
+ (forward-char -1))))))
(dolist (elt (cdr coding))
(insert " ")
(if (stringp from)
@@ -3047,7 +3047,7 @@ on encoding."
(#x1D000 . #x1FFFF)
;; (#x20000 . #xDFFFF) CJK Ideograph Extension A, B, etc, unused
(#xE0000 . #xE01FF)))
- (gc-cons-threshold 10000000)
+ (gc-cons-threshold (max gc-cons-threshold 10000000))
(names (make-hash-table :size 42943 :test #'equal)))
(dolist (range ranges)
(let ((c (car range))
diff --git a/lisp/international/mule-diag.el b/lisp/international/mule-diag.el
index a0063c8..2d3cd25b 100644
--- a/lisp/international/mule-diag.el
+++ b/lisp/international/mule-diag.el
@@ -45,8 +45,8 @@
(define-button-type 'sort-listed-character-sets
'help-echo (purecopy "mouse-2, RET: sort on this column")
'face 'bold
- 'action #'(lambda (button)
- (sort-listed-character-sets (button-get button 'sort-key))))
+ 'action (lambda (button)
+ (sort-listed-character-sets (button-get button 'sort-key))))
(define-button-type 'list-charset-chars
:supertype 'help-xref
@@ -1172,12 +1172,12 @@ The default is 20. If LIMIT is negative, do not limit
the listing."
(if (or (vectorp elt) (listp elt))
(let ((i 0))
(catch 'tag
- (mapc #'(lambda (x)
- (setq i (1+ i))
- (when (= i limit)
- (insert " ...\n")
- (throw 'tag nil))
- (insert (format " %s\n" x)))
+ (mapc (lambda (x)
+ (setq i (1+ i))
+ (when (= i limit)
+ (insert " ...\n")
+ (throw 'tag nil))
+ (insert (format " %s\n" x)))
elt)))
(insert (format " %s\n" elt)))))))
diff --git a/lisp/international/mule.el b/lisp/international/mule.el
index 52e743e..9cd38af 100644
--- a/lisp/international/mule.el
+++ b/lisp/international/mule.el
@@ -32,7 +32,7 @@
(defconst mule-version "6.0 (HANACHIRUSATO)" "\
Version number and name of this version of MULE (multilingual environment).")
-(make-obsolete-variable 'mule-version nil "28.1")
+(make-obsolete-variable 'mule-version 'emacs-version "28.1")
(defconst mule-version-date "2003.9.1" "\
Distribution date of this version of MULE (multilingual environment).")
@@ -317,8 +317,9 @@ Return t if file exists."
(when purify-flag
(push (purecopy file) preloaded-file-list))
(unwind-protect
- (let ((load-file-name fullname)
- (set-auto-coding-for-load t)
+ (let ((load-true-file-name fullname)
+ (load-file-name fullname)
+ (set-auto-coding-for-load t)
(inhibit-file-name-operation nil))
(with-current-buffer buffer
;; So that we don't get completely screwed if the
@@ -490,27 +491,27 @@ per-character basis, this may not be accurate."
(cond
((listp cs-list)
(catch 'tag
- (mapc #'(lambda (charset)
- (if (encode-char char charset)
- (throw 'tag charset)))
+ (mapc (lambda (charset)
+ (if (encode-char char charset)
+ (throw 'tag charset)))
cs-list)
nil))
((eq cs-list 'iso-2022)
(catch 'tag2
- (mapc #'(lambda (charset)
- (if (and (plist-get (charset-plist charset)
- :iso-final-char)
- (encode-char char charset))
- (throw 'tag2 charset)))
+ (mapc (lambda (charset)
+ (if (and (plist-get (charset-plist charset)
+ :iso-final-char)
+ (encode-char char charset))
+ (throw 'tag2 charset)))
charset-list)
nil))
((eq cs-list 'emacs-mule)
(catch 'tag3
- (mapc #'(lambda (charset)
- (if (and (plist-get (charset-plist charset)
- :emacs-mule-id)
- (encode-char char charset))
- (throw 'tag3 charset)))
+ (mapc (lambda (charset)
+ (if (and (plist-get (charset-plist charset)
+ :emacs-mule-id)
+ (encode-char char charset))
+ (throw 'tag3 charset)))
charset-list)
nil)))))))))))
diff --git a/lisp/international/quail.el b/lisp/international/quail.el
index 87a9050..fff06de 100644
--- a/lisp/international/quail.el
+++ b/lisp/international/quail.el
@@ -728,9 +728,9 @@ Available types are listed in the variable
`quail-keyboard-layout-alist'."
:type (cons 'choice (mapcar (lambda (elt)
(list 'const (car elt)))
quail-keyboard-layout-alist))
- :set #'(lambda (symbol value)
- (quail-update-keyboard-layout value)
- (set symbol value)))
+ :set (lambda (symbol value)
+ (quail-update-keyboard-layout value)
+ (set symbol value)))
;;;###autoload
(defun quail-set-keyboard-layout (kbd-type)
@@ -1571,12 +1571,12 @@ with more keys."
(let (char)
(if (stringp quail-current-str)
(catch 'tag
- (mapc #'(lambda (ch)
- (when (/= (unibyte-char-to-multibyte
- (multibyte-char-to-unibyte ch))
- ch)
- (setq char ch)
- (throw 'tag nil)))
+ (mapc (lambda (ch)
+ (when (/= (unibyte-char-to-multibyte
+ (multibyte-char-to-unibyte ch))
+ ch)
+ (setq char ch)
+ (throw 'tag nil)))
quail-current-str))
(if (/= (unibyte-char-to-multibyte
(multibyte-char-to-unibyte quail-current-str))
@@ -2827,19 +2827,19 @@ If CHAR is an ASCII character and can be input by
typing itself, return t."
(key-list nil))
(if (consp decode-map)
(let ((str (string char)))
- (mapc #'(lambda (elt)
- (if (string= str (car elt))
- (setq key-list (cons (cdr elt) key-list))))
+ (mapc (lambda (elt)
+ (if (string= str (car elt))
+ (setq key-list (cons (cdr elt) key-list))))
(cdr decode-map)))
(let ((key-head (aref decode-map char)))
(if (stringp key-head)
(setq key-list (quail-find-key1
(quail-lookup-key key-head nil t)
key-head char nil))
- (mapc #'(lambda (elt)
- (setq key-list
- (quail-find-key1
- (quail-lookup-key elt nil t) elt char key-list)))
+ (mapc (lambda (elt)
+ (setq key-list
+ (quail-find-key1
+ (quail-lookup-key elt nil t) elt char key-list)))
key-head))))
(or key-list
(and (< char 128)
diff --git a/lisp/international/titdic-cnv.el b/lisp/international/titdic-cnv.el
index 64d6644..ccb4c83 100644
--- a/lisp/international/titdic-cnv.el
+++ b/lisp/international/titdic-cnv.el
@@ -781,7 +781,7 @@ To get complete usage, invoke \"emacs -batch -f
batch-titdic-convert -h\"."
(if val (setq trans (concat val trans)))
(puthash key trans table)
(forward-line 1)))
- (maphash #'(lambda (key val) (setq dic (cons (cons key val) dic)))
+ (maphash (lambda (key val) (setq dic (cons (cons key val) dic)))
table)))
(setq dic (sort dic (lambda (x y) (string< (car x ) (car y)))))
(dolist (elt dic)
@@ -931,18 +931,18 @@ method `chinese-tonepy' with which you must specify tones
by digits
(if val (setq trans (vconcat val trans)))
(puthash key trans table)
(forward-line 1))
- (maphash #'(lambda (key trans)
- (let ((len (length trans))
- i)
- (if (and (= len 1) (= (length (aref trans 0)) 1))
- (setq trans (aref trans 0))
- (setq i 0)
- (while (and (< i len)
- (= (length (aref trans i)) 1))
- (setq i (1+ i)))
- (if (= i len)
- (setq trans (mapconcat #'identity trans "")))))
- (setq dic (cons (cons key trans) dic)))
+ (maphash (lambda (key trans)
+ (let ((len (length trans))
+ i)
+ (if (and (= len 1) (= (length (aref trans 0)) 1))
+ (setq trans (aref trans 0))
+ (setq i 0)
+ (while (and (< i len)
+ (= (length (aref trans i)) 1))
+ (setq i (1+ i)))
+ (if (= i len)
+ (setq trans (mapconcat #'identity trans "")))))
+ (setq dic (cons (cons key trans) dic)))
table)))
(setq dic (sort dic (lambda (x y) (string< (car x) (car y)))))
(goto-char (point-max))
diff --git a/lisp/isearch.el b/lisp/isearch.el
index 943e24a..9f3cfd7 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -172,6 +172,29 @@ This allows you to resume earlier Isearch sessions through
the
command history."
:type 'boolean)
+(defcustom isearch-wrap-pause t
+ "Define the behavior of wrapping when there are no more matches.
+When `t' (by default), signal an error when no more matches are found.
+Then after repeating the search, wrap with `isearch-wrap-function'.
+When `no', wrap immediately after reaching the last match.
+When `no-ding', wrap immediately without flashing the screen.
+When `nil', never wrap, just stop at the last match."
+ :type '(choice (const :tag "Pause before wrapping" t)
+ (const :tag "No pause before wrapping" no)
+ (const :tag "No pause and no flashing" no-ding)
+ (const :tag "Disable wrapping" nil))
+ :version "28.1")
+
+(defcustom isearch-repeat-on-direction-change nil
+ "Whether a direction change should move to another match.
+When `nil', the default, a direction change moves point to the other
+end of the current search match.
+When `t', a direction change moves to another search match, if there
+is one."
+ :type '(choice (const :tag "Remain on the same match" nil)
+ (const :tag "Move to another match" t))
+ :version "28.1")
+
(defvar isearch-mode-hook nil
"Function(s) to call after starting up an incremental search.")
@@ -949,12 +972,13 @@ Each element is an `isearch--state' struct where the
slots are
(defvar-local isearch-mode nil) ;; Name of the minor mode, if non-nil.
(define-key global-map "\C-s" 'isearch-forward)
-(define-key esc-map "\C-s" 'isearch-forward-regexp)
+(define-key esc-map "\C-s" 'isearch-forward-regexp)
(define-key global-map "\C-r" 'isearch-backward)
-(define-key esc-map "\C-r" 'isearch-backward-regexp)
-(define-key search-map "w" 'isearch-forward-word)
-(define-key search-map "_" 'isearch-forward-symbol)
-(define-key search-map "." 'isearch-forward-symbol-at-point)
+(define-key esc-map "\C-r" 'isearch-backward-regexp)
+(define-key search-map "w" 'isearch-forward-word)
+(define-key search-map "_" 'isearch-forward-symbol)
+(define-key search-map "." 'isearch-forward-symbol-at-point)
+(define-key search-map "\M-." 'isearch-forward-thing-at-point)
;; Entry points to isearch-mode.
@@ -1134,6 +1158,42 @@ positive, or search for ARGth symbol backward if ARG is
negative."
(isearch-push-state)
(isearch-update)))))
+(defcustom isearch-forward-thing-at-point '(region url symbol sexp)
+ "A list of symbols to try to get the \"thing\" at point.
+Each element of the list should be one of the symbols supported by
+`bounds-of-thing-at-point'. This variable is used by the command
+`isearch-forward-thing-at-point' to yank the initial \"thing\"
+as text to the search string."
+ :type '(repeat (symbol :tag "Thing symbol"))
+ :version "28.1")
+
+(defun isearch-forward-thing-at-point ()
+ "Do incremental search forward for the \"thing\" found near point.
+Like ordinary incremental search except that the \"thing\" found at point
+is added to the search string initially. The \"thing\" is defined by
+`bounds-of-thing-at-point'. You can customize the variable
+`isearch-forward-thing-at-point' to define a list of symbols to try
+to find a \"thing\" at point. For example, when the list contains
+the symbol `region' and the region is active, then text from the
+active region is added to the search string."
+ (interactive)
+ (isearch-forward nil 1)
+ (let ((bounds (seq-some (lambda (thing)
+ (bounds-of-thing-at-point thing))
+ isearch-forward-thing-at-point)))
+ (cond
+ (bounds
+ (when (use-region-p)
+ (deactivate-mark))
+ (when (< (car bounds) (point))
+ (goto-char (car bounds)))
+ (isearch-yank-string
+ (buffer-substring-no-properties (car bounds) (cdr bounds))))
+ (t
+ (setq isearch-error "No thing at point")
+ (isearch-push-state)
+ (isearch-update)))))
+
;; isearch-mode only sets up incremental search for the minor mode.
;; All the work is done by the isearch-mode commands.
@@ -1314,7 +1374,8 @@ The last thing is to trigger a new round of lazy
highlighting."
;; the X coordinate it returns is 1 pixel beyond
;; the last visible one.
(>= (car visible-p)
- (* (window-max-chars-per-line) (frame-char-width))))
+ (* (window-max-chars-per-line) (frame-char-width)))
+ (< (car visible-p) 0))
(set-window-hscroll (selected-window) current-scroll))))
(if isearch-other-end
(if (< isearch-other-end (point)) ; isearch-forward?
@@ -1827,14 +1888,15 @@ Use `isearch-exit' to quit without signaling."
;; After taking the last element, adjust ring to previous one.
(isearch-ring-adjust1 nil))
;; If already have what to search for, repeat it.
- (or isearch-success
- (progn
- ;; Set isearch-wrapped before calling isearch-wrap-function
- (setq isearch-wrapped t)
- (if isearch-wrap-function
- (funcall isearch-wrap-function)
- (goto-char (if isearch-forward (point-min) (point-max)))))))
+ (unless (or isearch-success (null isearch-wrap-pause))
+ ;; Set isearch-wrapped before calling isearch-wrap-function
+ (setq isearch-wrapped t)
+ (if isearch-wrap-function
+ (funcall isearch-wrap-function)
+ (goto-char (if isearch-forward (point-min) (point-max))))))
;; C-s in reverse or C-r in forward, change direction.
+ (if (and isearch-other-end isearch-repeat-on-direction-change)
+ (goto-char isearch-other-end))
(setq isearch-forward (not isearch-forward)
isearch-success t))
@@ -1844,7 +1906,8 @@ Use `isearch-exit' to quit without signaling."
(setq isearch-success t)
;; For the case when count > 1, don't keep intermediate states
;; added to isearch-cmds by isearch-push-state in this loop.
- (let ((isearch-cmds isearch-cmds))
+ (let ((isearch-cmds isearch-cmds)
+ (was-success isearch-success))
(while (<= 0 (setq count (1- (or count 1))))
(if (and isearch-success
(equal (point) isearch-other-end)
@@ -1859,13 +1922,26 @@ Use `isearch-exit' to quit without signaling."
(forward-char (if isearch-forward 1 -1))
(isearch-search))
(isearch-search))
- (when (> count 0)
- ;; Update isearch-cmds, so if isearch-search fails later,
- ;; it can restore old successful state from isearch-cmds.
- (isearch-push-state))
- ;; Stop looping on failure.
- (when (or (not isearch-success) isearch-error)
- (setq count 0)))))
+ (when (> count 0)
+ ;; Update isearch-cmds, so if isearch-search fails later,
+ ;; it can restore old successful state from isearch-cmds.
+ (isearch-push-state))
+ (cond
+ ;; Wrap immediately and repeat the search again
+ ((memq isearch-wrap-pause '(no no-ding))
+ (if isearch-success
+ (setq was-success isearch-success)
+ ;; If failed this time after succeeding last time
+ (when was-success
+ (setq was-success nil)
+ (setq count (1+ count)) ;; Increment to force repeat
+ (setq isearch-wrapped t)
+ (if isearch-wrap-function
+ (funcall isearch-wrap-function)
+ (goto-char (if isearch-forward (point-min) (point-max)))))))
+ ;; Stop looping on failure
+ (t (when (or (not isearch-success) isearch-error)
+ (setq count 0)))))))
(isearch-push-state)
(isearch-update))
@@ -1884,10 +1960,12 @@ of the buffer, type \\[isearch-beginning-of-buffer]
with a numeric argument."
(cond ((< count 0)
(isearch-repeat-backward (abs count))
;; Reverse the direction back
- (isearch-repeat 'forward))
+ (let ((isearch-repeat-on-direction-change nil))
+ (isearch-repeat 'forward)))
(t
;; Take into account one iteration to reverse direction
- (when (not isearch-forward) (setq count (1+ count)))
+ (unless isearch-repeat-on-direction-change
+ (when (not isearch-forward) (setq count (1+ count))))
(isearch-repeat 'forward count))))
(isearch-repeat 'forward)))
@@ -1905,10 +1983,12 @@ of the buffer, type \\[isearch-end-of-buffer] with a
numeric argument."
(cond ((< count 0)
(isearch-repeat-forward (abs count))
;; Reverse the direction back
- (isearch-repeat 'backward))
+ (let ((isearch-repeat-on-direction-change nil))
+ (isearch-repeat 'backward)))
(t
;; Take into account one iteration to reverse direction
- (when isearch-forward (setq count (1+ count)))
+ (unless isearch-repeat-on-direction-change
+ (when isearch-forward (setq count (1+ count))))
(isearch-repeat 'backward count))))
(isearch-repeat 'backward)))
@@ -2519,7 +2599,9 @@ Otherwise invoke whatever the calling mouse-2 command
sequence
is bound to outside of Isearch."
(interactive "e")
(let ((w (posn-window (event-start click)))
- (binding (let ((overriding-terminal-local-map nil))
+ (binding (let ((overriding-terminal-local-map nil)
+ ;; Key search depends on mode (bug#47755)
+ (isearch-mode nil))
(key-binding (this-command-keys-vector) t))))
(if (and (window-minibuffer-p w)
(not (minibuffer-window-active-p w))) ; in echo area
@@ -3488,10 +3570,10 @@ Optional third argument, if t, means if fail just
return nil (no error).
;; stack overflow in regexp search.
(setq isearch-error (format "%s" lossage))))
- (if isearch-success
- nil
+ (unless isearch-success
;; Ding if failed this time after succeeding last time.
(and (isearch--state-success (car isearch-cmds))
+ (not (eq isearch-wrap-pause 'no-ding))
(ding))
(if (functionp (isearch--state-pop-fun (car isearch-cmds)))
(funcall (isearch--state-pop-fun (car isearch-cmds))
diff --git a/lisp/isearchb.el b/lisp/isearchb.el
index 3713879..67020b7 100644
--- a/lisp/isearchb.el
+++ b/lisp/isearchb.el
@@ -1,4 +1,4 @@
-;;; isearchb --- a marriage between iswitchb and isearch
+;;; isearchb.el --- a marriage between iswitchb and isearch -*-
lexical-binding: t -*-
;; Copyright (C) 2004-2021 Free Software Foundation, Inc.
@@ -89,13 +89,11 @@
"Number of idle seconds before isearchb turns itself off.
If nil, don't use a timeout."
:type '(choice (integer :tag "Seconds")
- (const :tag "Disable" nil))
- :group 'isearchb)
+ (const :tag "Disable" nil)))
(defcustom isearchb-show-completions t
"If non-nil, show possible completions in the minibuffer."
- :type 'boolean
- :group 'isearchb)
+ :type 'boolean)
(defvar isearchb-start-buffer nil)
(defvar isearchb-last-buffer nil)
diff --git a/lisp/jka-compr.el b/lisp/jka-compr.el
index 8aebcd0..a622364 100644
--- a/lisp/jka-compr.el
+++ b/lisp/jka-compr.el
@@ -1,7 +1,6 @@
-;;; jka-compr.el --- reading/writing/loading compressed files
+;;; jka-compr.el --- reading/writing/loading compressed files -*-
lexical-binding: t; -*-
-;; Copyright (C) 1993-1995, 1997, 1999-2021 Free Software Foundation,
-;; Inc.
+;; Copyright (C) 1993-2021 Free Software Foundation, Inc.
;; Author: Jay K. Adams <jka@ece.cmu.edu>
;; Maintainer: emacs-devel@gnu.org
@@ -120,7 +119,7 @@ data appears to be compressed already.")
(widen) (erase-buffer)
(insert (format "Error while executing \"%s %s < %s\"\n\n"
prog
- (mapconcat 'identity args " ")
+ (mapconcat #'identity args " ")
infile))
(and errfile
@@ -170,7 +169,7 @@ to keep: LEN chars starting BEG chars from the beginning."
(format
"%s %s 2> %s | \"%s\" bs=%d skip=%d %s 2> %s"
prog
- (mapconcat 'identity args " ")
+ (mapconcat #'identity args " ")
err-file
jka-compr-dd-program
jka-compr-dd-blocksize
@@ -218,7 +217,7 @@ to keep: LEN chars starting BEG chars from the beginning."
"-c"
(format "%s %s 2> %s %s"
prog
- (mapconcat 'identity args " ")
+ (mapconcat #'identity args " ")
err-file
(if (stringp output)
(concat "> " output)
@@ -227,7 +226,7 @@ to keep: LEN chars starting BEG chars from the beginning."
(jka-compr-error prog args infile message err-file))
(delete-file err-file)))
(or (eq 0
- (apply 'call-process
+ (apply #'call-process
prog infile (if (stringp output) temp output)
nil args))
(jka-compr-error prog args infile message))
@@ -622,12 +621,12 @@ There should be no more than seven characters after the
final `/'."
(substring file 0 (string-match (jka-compr-info-regexp info) file)))
file)))
-(put 'write-region 'jka-compr 'jka-compr-write-region)
-(put 'insert-file-contents 'jka-compr 'jka-compr-insert-file-contents)
-(put 'file-local-copy 'jka-compr 'jka-compr-file-local-copy)
-(put 'load 'jka-compr 'jka-compr-load)
+(put 'write-region 'jka-compr #'jka-compr-write-region)
+(put 'insert-file-contents 'jka-compr #'jka-compr-insert-file-contents)
+(put 'file-local-copy 'jka-compr #'jka-compr-file-local-copy)
+(put 'load 'jka-compr #'jka-compr-load)
(put 'byte-compiler-base-file-name 'jka-compr
- 'jka-compr-byte-compiler-base-file-name)
+ #'jka-compr-byte-compiler-base-file-name)
;;;###autoload
(defvar jka-compr-inhibit nil
@@ -649,7 +648,7 @@ It is not recommended to set this variable permanently to
anything but nil.")
;; to prevent the primitive from calling our handler again.
(defun jka-compr-run-real-handler (operation args)
(let ((inhibit-file-name-handlers
- (cons 'jka-compr-handler
+ (cons #'jka-compr-handler
(and (eq inhibit-file-name-operation operation)
inhibit-file-name-handlers)))
(inhibit-file-name-operation operation))
@@ -674,7 +673,7 @@ by `jka-compr-installed'."
(last fnha))
(while (cdr last)
- (if (eq (cdr (car (cdr last))) 'jka-compr-handler)
+ (if (eq (cdr (car (cdr last))) #'jka-compr-handler)
(setcdr last (cdr (cdr last)))
(setq last (cdr last))))
diff --git a/lisp/language/burmese.el b/lisp/language/burmese.el
index 373f25a..ade3566 100644
--- a/lisp/language/burmese.el
+++ b/lisp/language/burmese.el
@@ -55,3 +55,5 @@
(vector "." 0 #'font-shape-gstring))))
(set-char-table-range composition-function-table '(#x1000 . #x107F) elt)
(set-char-table-range composition-function-table '(#xAA60 . #xAA7B) elt))
+
+;;; burmese.el ends here
diff --git a/lisp/language/cham.el b/lisp/language/cham.el
index 3aac986..cbb3556 100644
--- a/lisp/language/cham.el
+++ b/lisp/language/cham.el
@@ -43,3 +43,5 @@ an Austronesian language spoken by some 245,000 Chams
in Vietnam and Cambodia.")))
(provide 'cham)
+
+;;; cham.el ends here
diff --git a/lisp/language/khmer.el b/lisp/language/khmer.el
index 6f08e60..471af40 100644
--- a/lisp/language/khmer.el
+++ b/lisp/language/khmer.el
@@ -35,4 +35,4 @@
(set-char-table-range composition-function-table '(#x1780 . #x17FF) val)
(set-char-table-range composition-function-table '(#x19E0 . #x19FF) val))
-;; khmer.el ends here
+;;; khmer.el ends here
diff --git a/lisp/language/sinhala.el b/lisp/language/sinhala.el
index 99a104e..89392ad 100644
--- a/lisp/language/sinhala.el
+++ b/lisp/language/sinhala.el
@@ -45,4 +45,4 @@
"[\u0D80-\u0DFF]")
0 #'font-shape-gstring)))
-;; sinhala.el ends here
+;;; sinhala.el ends here
diff --git a/lisp/language/tai-viet.el b/lisp/language/tai-viet.el
index 4549b11..366c392 100644
--- a/lisp/language/tai-viet.el
+++ b/lisp/language/tai-viet.el
@@ -56,3 +56,5 @@ The language name is spelled as \"ꪁꪫꪱꪣ ꪼꪕ\", and the script
name is
spelled as \"ꪎꪳ ꪼꪕ\".")))
(provide 'tai-viet)
+
+;;; tai-viet.el ends here
diff --git a/lisp/language/thai-word.el b/lisp/language/thai-word.el
index ff1e802..5d0389c 100644
--- a/lisp/language/thai-word.el
+++ b/lisp/language/thai-word.el
@@ -1,4 +1,4 @@
-;;; thai-word.el -- find Thai word boundaries -*- lexical-binding: t; -*-
+;;; thai-word.el --- find Thai word boundaries -*- lexical-binding: t; -*-
;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
2010, 2011
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -11074,4 +11074,4 @@ With argument, do this that many times."
;; coding: utf-8
;; End:
-;; end of thai-word.el
+;;; thai-word.el ends here
diff --git a/lisp/language/tv-util.el b/lisp/language/tv-util.el
index 1a530d3..207d76f 100644
--- a/lisp/language/tv-util.el
+++ b/lisp/language/tv-util.el
@@ -136,5 +136,6 @@
(if (looking-at tai-viet-re)
(tai-viet-compose-region from (match-end 0)))))
-;;
(provide 'tai-viet-util)
+
+;;; tv-util.el ends here
diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el
index c9210c6..412751b 100644
--- a/lisp/ldefs-boot.el
+++ b/lisp/ldefs-boot.el
@@ -477,31 +477,31 @@ With value nil, inhibit any automatic allout-mode
activation.")
(custom-autoload 'allout-auto-activation "allout" nil)
-(put 'allout-use-hanging-indents 'safe-local-variable 'booleanp)
+(put 'allout-use-hanging-indents 'safe-local-variable #'booleanp)
(put 'allout-reindent-bodies 'safe-local-variable (lambda (x) (memq x '(nil t
text force))))
-(put 'allout-show-bodies 'safe-local-variable 'booleanp)
+(put 'allout-show-bodies 'safe-local-variable #'booleanp)
-(put 'allout-header-prefix 'safe-local-variable 'stringp)
+(put 'allout-header-prefix 'safe-local-variable #'stringp)
-(put 'allout-primary-bullet 'safe-local-variable 'stringp)
+(put 'allout-primary-bullet 'safe-local-variable #'stringp)
-(put 'allout-plain-bullets-string 'safe-local-variable 'stringp)
+(put 'allout-plain-bullets-string 'safe-local-variable #'stringp)
-(put 'allout-distinctive-bullets-string 'safe-local-variable 'stringp)
+(put 'allout-distinctive-bullets-string 'safe-local-variable #'stringp)
(put 'allout-use-mode-specific-leader 'safe-local-variable (lambda (x) (or
(memq x '(t nil allout-mode-leaders comment-start)) (stringp x))))
-(put 'allout-old-style-prefixes 'safe-local-variable 'booleanp)
+(put 'allout-old-style-prefixes 'safe-local-variable #'booleanp)
-(put 'allout-stylish-prefixes 'safe-local-variable 'booleanp)
+(put 'allout-stylish-prefixes 'safe-local-variable #'booleanp)
-(put 'allout-numbered-bullet 'safe-local-variable 'string-or-null-p)
+(put 'allout-numbered-bullet 'safe-local-variable #'string-or-null-p)
-(put 'allout-file-xref-bullet 'safe-local-variable 'string-or-null-p)
+(put 'allout-file-xref-bullet 'safe-local-variable #'string-or-null-p)
-(put 'allout-presentation-padding 'safe-local-variable 'integerp)
+(put 'allout-presentation-padding 'safe-local-variable #'integerp)
(put 'allout-layout 'safe-local-variable (lambda (x) (or (numberp x) (listp x)
(memq x '(: * + -)))))
@@ -784,7 +784,7 @@ OPEN: A TOPIC that is not CLOSED, though its
OFFSPRING or BODY may be.
\(fn &optional ARG)" t nil)
-(defalias 'outlinify-sticky 'outlineify-sticky)
+(defalias 'outlinify-sticky #'outlineify-sticky)
(autoload 'outlineify-sticky "allout" "\
Activate outline mode and establish file var so it is started subsequently.
@@ -827,7 +827,7 @@ See `allout-widgets-mode' for allout widgets mode
features.")
(custom-autoload 'allout-widgets-auto-activation "allout-widgets" nil)
-(put 'allout-widgets-mode-inhibit 'safe-local-variable 'booleanp)
+(put 'allout-widgets-mode-inhibit 'safe-local-variable #'booleanp)
(autoload 'allout-widgets-mode "allout-widgets" "\
Toggle Allout Widgets mode.
@@ -1161,11 +1161,11 @@ Returns list of symbols and documentation found.
(autoload 'archive-mode "arc-mode" "\
Major mode for viewing an archive file in a dired-like way.
You can move around using the usual cursor motion commands.
-Letters no longer insert themselves.
-Type `e' to pull a file out of the archive and into its own buffer;
+Letters no longer insert themselves.\\<archive-mode-map>
+Type \\[archive-extract] to pull a file out of the archive and into its own
buffer;
or click mouse-2 on the file's line in the archive mode buffer.
-If you edit a sub-file of this archive (as with the `e' command) and
+If you edit a sub-file of this archive (as with the \\[archive-extract]
command) and
save it, the contents of that buffer will be saved back into the
archive.
@@ -1539,7 +1539,7 @@ ENTRY is the name of a password-store entry.
The key used to retrieve the password is the symbol `secret'.
The convention used as the format for a password-store file is
-the following (see http://www.passwordstore.org/#organization):
+the following (see https://www.passwordstore.org/#organization):
secret
key1: value1
@@ -1995,6 +1995,20 @@ seconds.
;;;;;; 0 0))
;;; Generated autoloads from emacs-lisp/benchmark.el
+(autoload 'benchmark-call "benchmark" "\
+Measure the run time of calling FUNC a number REPETITIONS of times.
+The result is a list (TIME GC GCTIME)
+where TIME is the total time it took, in seconds.
+GCTIME is the amount of time that was spent in the GC
+and GC is the number of times the GC was called.
+
+REPETITIONS can also be a floating point number, in which case it
+specifies a minimum number of seconds that the benchmark execution
+should take. In that case the return value is prepended with the
+number of repetitions actually used.
+
+\(fn FUNC &optional REPETITIONS)" nil nil)
+
(autoload 'benchmark-run "benchmark" "\
Time execution of FORMS.
If REPETITIONS is supplied as a number, run FORMS that many times,
@@ -2024,6 +2038,8 @@ Interactively, REPETITIONS is taken from the prefix arg,
and
the command prompts for the form to benchmark.
For non-interactive use see also `benchmark-run' and
`benchmark-run-compiled'.
+FORM can also be a function in which case we measure the time it takes
+to call it without any argument.
\(fn REPETITIONS FORM)" t nil)
@@ -2035,7 +2051,7 @@ The return value is the value of the final form in BODY.
(function-put 'benchmark-progn 'lisp-indent-function '0)
-(register-definition-prefixes "benchmark" '("benchmark-elapse"))
+(register-definition-prefixes "benchmark" '("benchmark-"))
;;;***
@@ -4794,7 +4810,7 @@ element to judge if that element should be excluded from
the list.
The buffer is left in Command History mode." t nil)
(autoload 'command-history "chistory" "\
-Examine commands from `command-history' in a buffer.
+Examine commands from variable `command-history' in a buffer.
The number of commands listed is controlled by `list-command-history-max'.
The command history is filtered by `list-command-history-filter' if non-nil.
Use \\<command-history-map>\\[command-history-repeat] to repeat the command on
the current line.
@@ -4892,8 +4908,12 @@ all methods of NAME have to use the same set of
arguments for dispatch.
Each dispatch argument and TYPE are specified in ARGS where the corresponding
formal argument appears as (VAR TYPE) rather than just VAR.
-The optional second argument QUALIFIER is a specifier that
-modifies how the method is combined with other methods, including:
+The optional EXTRA element, on the form `:extra STRING', allows
+you to add more methods for the same specializers and qualifiers.
+These are distinguished by STRING.
+
+The optional argument QUALIFIER is a specifier that modifies how
+the method is combined with other methods, including:
:before - Method will be called before the primary
:after - Method will be called after the primary
:around - Method will be called around everything else
@@ -4910,9 +4930,9 @@ method to be applicable.
The set of acceptable TYPEs (also called \"specializers\") is defined
\(and can be extended) by the various methods of `cl-generic-generalizers'.
-\(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)" nil t)
+\(fn NAME [EXTRA] [QUALIFIER] ARGS &rest [DOCSTRING] BODY)" nil t)
-(function-put 'cl-defmethod 'doc-string-elt '3)
+(function-put 'cl-defmethod 'doc-string-elt 'cl--defmethod-doc-pos)
(function-put 'cl-defmethod 'lisp-indent-function 'defun)
@@ -6769,6 +6789,8 @@ If the HANDLER returns a `dbus-error', it is propagated
as return message.
\(fn EVENT)" t nil)
+(function-put 'dbus-handle-event 'completion-predicate #'ignore)
+
(autoload 'dbus-monitor "dbus" "\
Invoke `dbus-register-monitor' interactively, and switch to the buffer.
BUS is either a Lisp keyword, `:system' or `:session', or a
@@ -10614,7 +10636,7 @@ be invoked for the values of the other parameters.
\(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK
(erc-compute-nick)) PASSWORD (FULL-NAME (erc-compute-full-name)))" t nil)
-(defalias 'erc-select 'erc)
+(defalias 'erc-select #'erc)
(autoload 'erc-tls "erc" "\
Interactively select TLS connection parameters and run ERC.
@@ -10737,7 +10759,7 @@ and how to display message.
\(fn SELECTOR &optional OUTPUT-BUFFER-NAME MESSAGE-FN)" t nil)
-(defalias 'ert 'ert-run-tests-interactively)
+(defalias 'ert #'ert-run-tests-interactively)
(autoload 'ert-describe-test "ert" "\
Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test).
@@ -11948,6 +11970,13 @@ Besides the choice of face, it is the same as
`buffer-face-mode'.
;;;***
+;;;### (autoloads nil "facemenu" "facemenu.el" (0 0 0 0))
+;;; Generated autoloads from facemenu.el
+
+(register-definition-prefixes "facemenu" '("facemenu-" "list-colors-"))
+
+;;;***
+
;;;### (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)
@@ -12212,6 +12241,8 @@ Otherwise, signal a `file-notify-error'.
\(fn OBJECT)" t nil)
+(function-put 'file-notify-handle-event 'completion-predicate #'ignore)
+
(register-definition-prefixes "filenotify" '("file-notify-"))
;;;***
@@ -12711,7 +12742,6 @@ Change the filter on a `find-lisp-find-dired' buffer to
REGEXP.
;;;### (autoloads nil "finder" "finder.el" (0 0 0 0))
;;; Generated autoloads from finder.el
-(push (purecopy '(finder 1 0)) package--builtin-versions)
(autoload 'finder-list-keywords "finder" "\
Display descriptions of the keywords in the Finder buffer." t nil)
@@ -12780,7 +12810,7 @@ lines.
(autoload 'flymake-log "flymake" "\
Log, at level LEVEL, the message MSG formatted with ARGS.
LEVEL is passed to `display-warning', which is used to display
-the warning. If this form is included in a byte-compiled file,
+the warning. If this form is included in a file,
the generated warning contains an indication of the file that
generated it.
@@ -14390,15 +14420,15 @@ If FORCE is non-nil, replace the old ones.
Minor mode for providing mailing-list commands.
If called interactively, toggle `Gnus-Mailing-List mode'. If the
-prefix argument is positive, enable the mode, and if it is zero
-or negative, disable the mode.
+prefix argument is positive, enable the mode, and if it is zero or
+negative, disable the mode.
-If called from Lisp, toggle the mode if ARG is `toggle'. Enable
-the mode if ARG is nil, omitted, or is a positive number.
-Disable the mode if ARG is a negative number.
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
-The mode's hook is called both when the mode is enabled and when
-it is disabled.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
\\{gnus-mailing-list-mode-map}
@@ -16840,7 +16870,7 @@ buffers which are visiting a file.
(autoload 'ibuffer "ibuffer" "\
Begin using Ibuffer to edit a list of buffers.
-Type `h' after entering ibuffer for more information.
+Type \\<ibuffer-mode-map>\\[describe-mode] after entering ibuffer for more
information.
All arguments are optional.
OTHER-WINDOW-P says to use another window.
@@ -17126,7 +17156,7 @@ The main features of this mode are
Use \\[idlwave-fill-paragraph] to refill a paragraph inside a
comment. The indentation of the second line of the paragraph
relative to the first will be retained. Use
- \\[idlwave-auto-fill-mode] to toggle auto-fill mode for these
+ \\[auto-fill-mode] to toggle auto-fill mode for these
comments. When the variable `idlwave-fill-comment-line-only' is
nil, code can also be auto-filled and auto-indented.
@@ -18594,25 +18624,6 @@ See Info node `(elisp)Defining Functions' for more
details.
;;;***
-;;;### (autoloads nil "inversion" "cedet/inversion.el" (0 0 0 0))
-;;; Generated autoloads from cedet/inversion.el
-(push (purecopy '(inversion 1 3)) package--builtin-versions)
-
-(autoload 'inversion-require-emacs "inversion" "\
-Declare that you need either EMACS-VER, XEMACS-VER or SXEMACS-ver.
-Only checks one based on which kind of Emacs is being run.
-
-This function is obsolete; do this instead:
- (when (version<= \"28.1\" emacs-version) ...)
-
-\(fn EMACS-VER XEMACS-VER SXEMACS-VER)" nil nil)
-
-(make-obsolete 'inversion-require-emacs 'nil '"28.1")
-
-(register-definition-prefixes "inversion" '("inversion-"))
-
-;;;***
-
;;;### (autoloads nil "isearch-x" "international/isearch-x.el" (0
;;;;;; 0 0 0))
;;; Generated autoloads from international/isearch-x.el
@@ -19540,13 +19551,13 @@ A major mode to edit GNU ld script files
;;;;;; (0 0 0 0))
;;; Generated autoloads from textmodes/less-css-mode.el
-(put 'less-css-compile-at-save 'safe-local-variable 'booleanp)
+(put 'less-css-compile-at-save 'safe-local-variable #'booleanp)
(put 'less-css-lessc-options 'safe-local-variable t)
-(put 'less-css-output-directory 'safe-local-variable 'stringp)
+(put 'less-css-output-directory 'safe-local-variable #'stringp)
-(put 'less-css-input-file-name 'safe-local-variable 'stringp)
+(put 'less-css-input-file-name 'safe-local-variable #'stringp)
(add-to-list 'auto-mode-alist '("\\.less\\'" . less-css-mode))
(autoload 'less-css-mode "less-css-mode" "\
@@ -20535,7 +20546,7 @@ Default bookmark handler for Man buffers.
;;;### (autoloads nil "map" "emacs-lisp/map.el" (0 0 0 0))
;;; Generated autoloads from emacs-lisp/map.el
-(push (purecopy '(map 2 1)) package--builtin-versions)
+(push (purecopy '(map 3 0)) package--builtin-versions)
(register-definition-prefixes "map" '("map-"))
@@ -22087,6 +22098,32 @@ QUALITY can be:
;;;### (autoloads nil "mwheel" "mwheel.el" (0 0 0 0))
;;; Generated autoloads from mwheel.el
+(defcustom mouse-wheel-mode t "\
+Non-nil if Mouse-Wheel mode is enabled.
+See the `mouse-wheel-mode' command
+for a description of this minor mode.
+Setting this variable directly does not take effect;
+either customize it (see the info node `Easy Customization')
+or call the function `mouse-wheel-mode'." :set #'custom-set-minor-mode
:initialize 'custom-initialize-delay :group 'mouse :type 'boolean)
+
+(custom-autoload 'mouse-wheel-mode "mwheel" nil)
+
+(autoload 'mouse-wheel-mode "mwheel" "\
+Toggle mouse wheel support (Mouse Wheel mode).
+
+If called interactively, toggle `Mouse-Wheel mode'. If the prefix
+argument is positive, enable the mode, and if it is zero or negative,
+disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable the
+mode if ARG is nil, omitted, or is a positive number. Disable the
+mode if ARG is a negative number.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
+
+\(fn &optional ARG)" t nil)
+
(register-definition-prefixes "mwheel" '("mouse-wheel-" "mwheel-"))
;;;***
@@ -22347,7 +22384,7 @@ gnutls-boot (as returned by `gnutls-boot-parameters').
\(fn NAME BUFFER HOST SERVICE &rest PARAMETERS)" nil nil)
-(defalias 'open-protocol-stream 'open-network-stream)
+(define-obsolete-function-alias 'open-protocol-stream #'open-network-stream
"26.1")
(register-definition-prefixes "network-stream" '("network-stream-"))
@@ -24041,6 +24078,8 @@ Turning on outline mode calls the value of
`text-mode-hook' and then of
`outline-mode-hook', if they are non-nil.
\(fn)" t nil)
+(put 'outline-minor-mode-cycle 'safe-local-variable 'booleanp)
+(put 'outline-minor-mode-highlight 'safe-local-variable 'booleanp)
(autoload 'outline-minor-mode "outline" "\
Toggle Outline minor mode.
@@ -24186,7 +24225,11 @@ directory.
(autoload 'package-install-selected-packages "package" "\
Ensure packages in `package-selected-packages' are installed.
-If some packages are not installed propose to install them." t nil)
+If some packages are not installed, propose to install them.
+If optional argument NOCONFIRM is non-nil, don't ask for
+confirmation to install packages.
+
+\(fn &optional NOCONFIRM)" t nil)
(autoload 'package-reinstall "package" "\
Reinstall package PKG.
@@ -25898,6 +25941,13 @@ Save the result in `project-list-file' if the list of
projects has changed.
\(fn PR)" nil nil)
+(autoload 'project-remove-known-project "project" "\
+Remove directory PROJECT-ROOT from the project list.
+PROJECT-ROOT is the root directory of a known project listed in
+the project list.
+
+\(fn PROJECT-ROOT)" t nil)
+
(autoload 'project-known-project-roots "project" "\
Return the list of root directories of all known projects." nil nil)
@@ -25906,19 +25956,6 @@ Execute an extended command in project root." t nil)
(function-put 'project-execute-extended-command 'interactive-only
'command-execute)
-(defvar project-switch-commands '((project-find-file "Find file")
(project-find-regexp "Find regexp") (project-dired "Dired") (project-vc-dir
"VC-Dir") (project-eshell "Eshell")) "\
-Alist mapping commands to descriptions.
-Used by `project-switch-project' to construct a dispatch menu of
-commands available upon \"switching\" to another project.
-
-Each element is of the form (COMMAND LABEL &optional KEY) where
-COMMAND is the command to run when KEY is pressed. LABEL is used
-to distinguish the menu entries in the dispatch menu. If KEY is
-absent, COMMAND must be bound in `project-prefix-map', and the
-key is looked up in that map.")
-
-(custom-autoload 'project-switch-commands "project" t)
-
(autoload 'project-switch-project "project" "\
\"Switch\" to another project by running an Emacs command.
The available commands are presented as a dispatch menu
@@ -26495,7 +26532,7 @@ Add one translation rule, KEY to TRANSLATION, in the
current Quail package.
KEY is a string meaning a sequence of keystrokes to be translated.
TRANSLATION is a character, a string, a vector, a Quail map,
a function, or a cons.
-It it is a character, it is the sole translation of KEY.
+If it is a character, it is the sole translation of KEY.
If it is a string, each character is a candidate for the translation.
If it is a vector, each element (string or character) is a candidate
for the translation.
@@ -28351,24 +28388,7 @@ For more details, see Info node `(elisp) Extending Rx'.
(function-put 'rx-define 'lisp-indent-function 'defun)
-(autoload 'rx--pcase-macroexpander "rx" "\
-A pattern that matches strings against `rx' REGEXPS in sexp form.
-REGEXPS are interpreted as in `rx'. The pattern matches any
-string that is a match for REGEXPS, as if by `string-match'.
-
-In addition to the usual `rx' syntax, REGEXPS can contain the
-following constructs:
-
- (let REF RX...) binds the symbol REF to a submatch that matches
- the regular expressions RX. REF is bound in
- CODE to the string of the submatch or nil, but
- can also be used in `backref'.
- (backref REF) matches whatever the submatch REF matched.
- REF can be a number, as usual, or a name
- introduced by a previous (let REF ...)
- construct.
-
-\(fn &rest REGEXPS)" nil nil)
+(eval-and-compile (defun rx--pcase-macroexpander (&rest regexps) "A pattern
that matches strings against `rx' REGEXPS in sexp form.\nREGEXPS are
interpreted as in `rx'. The pattern matches any\nstring that is a match for
REGEXPS, as if by `string-match'.\n\nIn addition to the usual `rx' syntax,
REGEXPS can contain the\nfollowing constructs:\n\n (let REF RX...) binds the
symbol REF to a submatch that matches\n the regular
expressions RX. REF is bound in\n [...]
(define-symbol-prop 'rx--pcase-macroexpander 'edebug-form-spec 'nil)
@@ -28863,14 +28883,6 @@ Major mode for editing Bovine grammars.
;;;***
-;;;### (autoloads nil "semantic/grammar-wy" "cedet/semantic/grammar-wy.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from cedet/semantic/grammar-wy.el
-
-(register-definition-prefixes "semantic/grammar-wy" '("semantic-grammar-wy--"))
-
-;;;***
-
;;;### (autoloads nil "semantic/java" "cedet/semantic/java.el" (0
;;;;;; 0 0 0))
;;; Generated autoloads from cedet/semantic/java.el
@@ -29500,7 +29512,7 @@ or Edit/Text Properties/Face commands.
Pages can have <a name=\"SOMENAME\">named points</a> and can link other points
to them with <a href=\"#SOMENAME\">see also somename</a>. In the same way <a
href=\"URL\">see also URL</a> where URL is a filename relative to current
-directory, or absolute as in `http://www.cs.indiana.edu/elisp/w3/docs.html'.
+directory, or absolute as in `https://www.cs.indiana.edu/elisp/w3/docs.html'.
Images in many formats can be inlined with <img src=\"URL\">.
@@ -31249,7 +31261,7 @@ Major-mode for writing SRecode macros.
\(fn)" t nil)
-(defalias 'srt-mode 'srecode-template-mode)
+(defalias 'srt-mode #'srecode-template-mode)
(register-definition-prefixes "srecode/srt-mode" '("semantic-" "srecode-"))
@@ -31811,7 +31823,7 @@ Move the point under the table as shown below.
+--------------+------+--------------------------------+
-!-
-Type M-x table-insert-row instead of \\[table-insert-row-column].
\\[table-insert-row-column] does not work
+Type \\[table-insert-row] instead of \\[table-insert-row-column].
\\[table-insert-row-column] does not work
when the point is outside of the table. This insertion at
outside of the table effectively appends a row at the end.
@@ -32108,11 +32120,11 @@ HTML:
URL `https://www.w3.org'
LaTeX:
- URL `http://www.maths.tcd.ie/~dwilkins/LaTeXPrimer/Tables.html'
+ URL `https://www.maths.tcd.ie/~dwilkins/LaTeXPrimer/Tables.html'
CALS (DocBook DTD):
- URL `http://www.oasis-open.org/html/a502.htm'
- URL
`http://www.oreilly.com/catalog/docbook/chapter/book/table.html#AEN114751'
+ URL `https://www.oasis-open.org/html/a502.htm'
+ URL
`https://www.oreilly.com/catalog/docbook/chapter/book/table.html#AEN114751'
\(fn LANGUAGE &optional DEST-BUFFER CAPTION)" t nil)
@@ -32320,12 +32332,12 @@ Connect to the Emacs talk group from the current X
display or tty frame." t nil)
(autoload 'tar-mode "tar-mode" "\
Major mode for viewing a tar file as a dired-like listing of its contents.
You can move around using the usual cursor motion commands.
-Letters no longer insert themselves.
-Type `e' to pull a file out of the tar file and into its own buffer;
+Letters no longer insert themselves.\\<tar-mode-map>
+Type \\[tar-extract] to pull a file out of the tar file and into its own
buffer;
or click mouse-2 on the file's line in the Tar mode buffer.
-Type `c' to copy an entry from the tar file into another file on disk.
+Type \\[tar-copy] to copy an entry from the tar file into another file on disk.
-If you edit a sub-file of this archive (as with the `e' command) and
+If you edit a sub-file of this archive (as with the \\[tar-extract] command)
and
save it with \\[save-buffer], the contents of that buffer will be
saved back into the tar-file buffer; in this way you can edit a file
inside of a tar archive without extracting it and re-archiving it.
@@ -32679,11 +32691,11 @@ says which mode to use.
\(fn)" t nil)
-(defalias 'TeX-mode 'tex-mode)
+(defalias 'TeX-mode #'tex-mode)
-(defalias 'plain-TeX-mode 'plain-tex-mode)
+(defalias 'plain-TeX-mode #'plain-tex-mode)
-(defalias 'LaTeX-mode 'latex-mode)
+(defalias 'LaTeX-mode #'latex-mode)
(autoload 'plain-tex-mode "tex-mode" "\
Major mode for editing files of input for plain TeX.
@@ -33339,7 +33351,11 @@ point.
\(fn &optional FORMAT HERE)" t nil)
(autoload 'emacs-init-time "time" "\
-Return a string giving the duration of the Emacs initialization." t nil)
+Return a string giving the duration of the Emacs initialization.
+FORMAT is a string to format the result, using `format'. If nil,
+the default format \"%f seconds\" is used.
+
+\(fn &optional FORMAT)" t nil)
(register-definition-prefixes "time" '("display-time-"
"legacy-style-world-list" "time--display-world-list" "world-clock-"
"zoneinfo-style-world-list"))
@@ -34025,6 +34041,13 @@ Add archive file name handler to
`file-name-handler-alist'." (when tramp-archive
;;;***
+;;;### (autoloads nil "tramp-fuse" "net/tramp-fuse.el" (0 0 0 0))
+;;; Generated autoloads from net/tramp-fuse.el
+
+(register-definition-prefixes "tramp-fuse" '("tramp-fuse-"))
+
+;;;***
+
;;;### (autoloads nil "tramp-gvfs" "net/tramp-gvfs.el" (0 0 0 0))
;;; Generated autoloads from net/tramp-gvfs.el
@@ -34062,6 +34085,13 @@ Add archive file name handler to
`file-name-handler-alist'." (when tramp-archive
;;;***
+;;;### (autoloads nil "tramp-sshfs" "net/tramp-sshfs.el" (0 0 0 0))
+;;; Generated autoloads from net/tramp-sshfs.el
+
+(register-definition-prefixes "tramp-sshfs" '("tramp-sshfs-"))
+
+;;;***
+
;;;### (autoloads nil "tramp-sudoedit" "net/tramp-sudoedit.el" (0
;;;;;; 0 0 0))
;;; Generated autoloads from net/tramp-sudoedit.el
@@ -34134,8 +34164,8 @@ resumed later.
;;;;;; 0 0))
;;; Generated autoloads from textmodes/two-column.el
(autoload '2C-command "two-column" () t 'keymap)
- (global-set-key "\C-x6" '2C-command)
- (global-set-key [f2] '2C-command)
+ (global-set-key "\C-x6" #'2C-command)
+ (global-set-key [f2] #'2C-command)
(autoload '2C-two-columns "two-column" "\
Split current window vertically for two-column editing.
@@ -35240,7 +35270,12 @@ The buffer in question is current when this function
is called.
\(fn FILENAME)" nil nil)
-(register-definition-prefixes "userlock" '("ask-user-about-" "file-"
"userlock--check-content-unchanged"))
+(autoload 'userlock--handle-unlock-error "userlock" "\
+Report an ERROR that occurred while unlocking a file.
+
+\(fn ERROR)" nil nil)
+
+(register-definition-prefixes "userlock" '("ask-user-about-" "file-"
"userlock--"))
;;;***
@@ -36027,7 +36062,7 @@ Key bindings:
;;;### (autoloads nil "verilog-mode" "progmodes/verilog-mode.el"
;;;;;; (0 0 0 0))
;;; Generated autoloads from progmodes/verilog-mode.el
-(push (purecopy '(verilog-mode 2021 2 2 263931197)) package--builtin-versions)
+(push (purecopy '(verilog-mode 2021 3 30 243771231)) package--builtin-versions)
(autoload 'verilog-mode "verilog-mode" "\
Major mode for editing Verilog code.
@@ -36782,7 +36817,7 @@ Don't change this variable directly, you must change it
by one of the
functions that enable or disable view mode.")
(autoload 'kill-buffer-if-not-modified "view" "\
-Like `kill-buffer', but does nothing if the buffer is modified.
+Like `kill-buffer', but does nothing if buffer BUF is modified.
\(fn BUF)" nil nil)
@@ -36848,7 +36883,7 @@ file: Users may suspend viewing in order to modify the
buffer.
Exiting View mode will then discard the user's edits. Setting
EXIT-ACTION to `kill-buffer-if-not-modified' avoids this.
-This function does not enable View mode if the buffer's major-mode
+This function does not enable View mode if the buffer's major mode
has a `special' mode-class, because such modes usually have their
own View-like bindings.
@@ -36870,7 +36905,7 @@ Optional argument EXIT-ACTION is either nil or a
function with buffer as
argument. This function is called when finished viewing buffer. Use
this argument instead of explicitly setting `view-exit-action'.
-This function does not enable View mode if the buffer's major-mode
+This function does not enable View mode if the buffer's major mode
has a `special' mode-class, because such modes usually have their
own View-like bindings.
@@ -36892,7 +36927,7 @@ Optional argument EXIT-ACTION is either nil or a
function with buffer as
argument. This function is called when finished viewing buffer. Use
this argument instead of explicitly setting `view-exit-action'.
-This function does not enable View mode if the buffer's major-mode
+This function does not enable View mode if the buffer's major mode
has a `special' mode-class, because such modes usually have their
own View-like bindings.
@@ -38341,15 +38376,15 @@ Zone out, completely." t nil)
;;;;;; "cedet/semantic/db-typecache.el" "cedet/semantic/db.el"
"cedet/semantic/debug.el"
;;;;;; "cedet/semantic/decorate/include.el" "cedet/semantic/decorate/mode.el"
;;;;;; "cedet/semantic/dep.el" "cedet/semantic/doc.el"
"cedet/semantic/edit.el"
-;;;;;; "cedet/semantic/find.el" "cedet/semantic/format.el"
"cedet/semantic/html.el"
-;;;;;; "cedet/semantic/ia-sb.el" "cedet/semantic/ia.el"
"cedet/semantic/idle.el"
-;;;;;; "cedet/semantic/imenu.el" "cedet/semantic/lex-spp.el"
"cedet/semantic/lex.el"
-;;;;;; "cedet/semantic/mru-bookmark.el" "cedet/semantic/scope.el"
-;;;;;; "cedet/semantic/senator.el" "cedet/semantic/sort.el"
"cedet/semantic/symref.el"
-;;;;;; "cedet/semantic/symref/cscope.el" "cedet/semantic/symref/global.el"
-;;;;;; "cedet/semantic/symref/grep.el" "cedet/semantic/symref/idutils.el"
-;;;;;; "cedet/semantic/symref/list.el" "cedet/semantic/tag-file.el"
-;;;;;; "cedet/semantic/tag-ls.el" "cedet/semantic/tag-write.el"
+;;;;;; "cedet/semantic/find.el" "cedet/semantic/format.el"
"cedet/semantic/grammar-wy.el"
+;;;;;; "cedet/semantic/html.el" "cedet/semantic/ia-sb.el"
"cedet/semantic/ia.el"
+;;;;;; "cedet/semantic/idle.el" "cedet/semantic/imenu.el"
"cedet/semantic/lex-spp.el"
+;;;;;; "cedet/semantic/lex.el" "cedet/semantic/mru-bookmark.el"
+;;;;;; "cedet/semantic/scope.el" "cedet/semantic/senator.el"
"cedet/semantic/sort.el"
+;;;;;; "cedet/semantic/symref.el" "cedet/semantic/symref/cscope.el"
+;;;;;; "cedet/semantic/symref/global.el" "cedet/semantic/symref/grep.el"
+;;;;;; "cedet/semantic/symref/idutils.el" "cedet/semantic/symref/list.el"
+;;;;;; "cedet/semantic/tag-file.el" "cedet/semantic/tag-ls.el"
"cedet/semantic/tag-write.el"
;;;;;; "cedet/semantic/tag.el" "cedet/semantic/texi.el"
"cedet/semantic/util-modes.el"
;;;;;; "cedet/semantic/wisent/java-tags.el"
"cedet/semantic/wisent/javascript.el"
;;;;;; "cedet/semantic/wisent/javat-wy.el" "cedet/semantic/wisent/js-wy.el"
@@ -38381,7 +38416,7 @@ Zone out, completely." t nil)
;;;;;; "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"
+;;;;;; "eshell/em-xtra.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"
diff --git a/lisp/leim/quail/croatian.el b/lisp/leim/quail/croatian.el
index 08f1e47..7402b81 100644
--- a/lisp/leim/quail/croatian.el
+++ b/lisp/leim/quail/croatian.el
@@ -1,4 +1,4 @@
-;;; croatian.el -- Quail package for inputting Croatian -*-coding: utf-8;
lexical-binding:t -*-
+;;; croatian.el --- Quail package for inputting Croatian -*-coding: utf-8;
lexical-binding:t -*-
;; Copyright (C) 2003-2021 Free Software Foundation, Inc.
diff --git a/lisp/leim/quail/hebrew.el b/lisp/leim/quail/hebrew.el
index fc6bb80..28b2eb3 100644
--- a/lisp/leim/quail/hebrew.el
+++ b/lisp/leim/quail/hebrew.el
@@ -1,4 +1,4 @@
-;; hebrew.el --- Quail package for inputting Hebrew characters -*- coding:
utf-8; lexical-binding: t -*-
+;;; hebrew.el --- Quail package for inputting Hebrew characters -*- coding:
utf-8; lexical-binding: t -*-
;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
;; 2008, 2009, 2010, 2011
diff --git a/lisp/leim/quail/persian.el b/lisp/leim/quail/persian.el
index 4157f88..cb1f6e3 100644
--- a/lisp/leim/quail/persian.el
+++ b/lisp/leim/quail/persian.el
@@ -1,4 +1,4 @@
-;;; persian.el --- Quail package for inputting Persian/Farsi keyboard -*-
coding: utf-8; lexical-binding: t -*-
+;;; persian.el --- Quail package for inputting Persian/Farsi keyboard -*-
coding: utf-8; lexical-binding: t -*-
;; Copyright (C) 2011-2021 Free Software Foundation, Inc.
diff --git a/lisp/linum.el b/lisp/linum.el
index f9761d2..b0281d3 100644
--- a/lisp/linum.el
+++ b/lisp/linum.el
@@ -31,9 +31,6 @@
;;; Code:
-(defconst linum-version "0.9x")
-(make-obsolete-variable 'linum-version nil "28.1")
-
(defvar-local linum-overlays nil "Overlays used in this buffer.")
(defvar-local linum-available nil "Overlays available for reuse.")
(defvar linum-before-numbering-hook nil
@@ -244,6 +241,9 @@ Linum mode is a buffer-local minor mode."
;; continue standard unloading
nil)
+(defconst linum-version "0.9x")
+(make-obsolete-variable 'linum-version 'emacs-version "28.1")
+
(provide 'linum)
;;; linum.el ends here
diff --git a/lisp/loadhist.el b/lisp/loadhist.el
index a60d6b2..0b12bda 100644
--- a/lisp/loadhist.el
+++ b/lisp/loadhist.el
@@ -1,4 +1,4 @@
-;;; loadhist.el --- lisp functions for working with feature groups
+;;; loadhist.el --- lisp functions for working with feature groups -*-
lexical-binding: t -*-
;; Copyright (C) 1995, 1998, 2000-2021 Free Software Foundation, Inc.
@@ -82,12 +82,6 @@ A library name is equivalent to the file name that
`load-library' would load."
(when (eq (car-safe x) 'require)
(push (cdr x) requires)))))
-(defsubst file-set-intersect (p q)
- "Return the set intersection of two lists."
- (let (ret)
- (dolist (x p ret)
- (when (memq x q) (push x ret)))))
-
(defun file-dependents (file)
"Return the list of loaded libraries that depend on FILE.
This can include FILE itself.
@@ -97,7 +91,7 @@ A library name is equivalent to the file name that
`load-library' would load."
(dependents nil))
(dolist (x load-history dependents)
(when (and (stringp (car x))
- (file-set-intersect provides (file-requires (car x))))
+ (seq-intersection provides (file-requires (car x)) #'eq))
(push (car x) dependents)))))
(defun read-feature (prompt &optional loaded-p)
@@ -322,6 +316,13 @@ something strange, such as redefining an Emacs function."
;; Don't return load-history, it is not useful.
nil)
+;; Obsolete.
+
+(defsubst file-set-intersect (p q)
+ "Return the set intersection of two lists."
+ (declare (obsolete seq-intersection "28.1"))
+ (nreverse (seq-intersection p q #'eq)))
+
(provide 'loadhist)
;;; loadhist.el ends here
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 4a0b8f5..c82d081 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -1,4 +1,4 @@
-;;; loadup.el --- load up standardly loaded Lisp files for Emacs
+;;; loadup.el --- load up standardly loaded Lisp files for Emacs -*-
lexical-binding: t; -*-
;; Copyright (C) 1985-1986, 1992, 1994, 2001-2021 Free Software
;; Foundation, Inc.
@@ -112,7 +112,7 @@
(if (eq t purify-flag)
;; Hash consing saved around 11% of pure space in my tests.
- (setq purify-flag (make-hash-table :test 'equal :size 80000)))
+ (setq purify-flag (make-hash-table :test #'equal :size 80000)))
(message "Using load-path %s" load-path)
@@ -134,7 +134,7 @@
;; Do it after subr, since both after-load-functions and add-hook are
;; implemented in subr.el.
-(add-hook 'after-load-functions (lambda (f) (garbage-collect)))
+(add-hook 'after-load-functions (lambda (_) (garbage-collect)))
(load "version")
@@ -151,13 +151,14 @@
;; variable its advertised default value (it starts as nil, see
;; xdisp.c).
(setq resize-mini-windows 'grow-only)
-(setq load-source-file-function 'load-with-code-conversion)
+(setq load-source-file-function #'load-with-code-conversion)
(load "files")
;; Load-time macro-expansion can only take effect after setting
;; load-source-file-function because of where it is called in lread.c.
(load "emacs-lisp/macroexp")
-(if (byte-code-function-p (symbol-function 'macroexpand-all))
+(if (or (byte-code-function-p (symbol-function 'macroexpand-all))
+ (subr-native-elisp-p (symbol-function 'macroexpand-all)))
nil
;; Since loaddefs is not yet loaded, macroexp's uses of pcase will simply
;; fail until pcase is explicitly loaded. This also means that we have to
@@ -186,7 +187,7 @@
;; In case loaddefs hasn't been generated yet.
(file-error (load "ldefs-boot.el")))
-(let ((new (make-hash-table :test 'equal)))
+(let ((new (make-hash-table :test #'equal)))
;; Now that loaddefs has populated definition-prefixes, purify its contents.
(maphash (lambda (k v) (puthash (purecopy k) (purecopy v) new))
definition-prefixes)
@@ -399,7 +400,7 @@ lost after dumping")))
emacs-repository-branch (ignore-errors
(emacs-repository-get-branch)))
;; A constant, so we shouldn't change it with `setq'.
(defconst emacs-build-number
- (if versions (1+ (apply 'max versions)) 1))))
+ (if versions (1+ (apply #'max versions)) 1))))
(message "Finding pointers to doc strings...")
@@ -429,11 +430,11 @@ lost after dumping")))
;; We keep the load-history data in PURE space.
;; Make sure that the spine of the list is not in pure space because it can
;; be destructively mutated in lread.c:build_load_history.
-(setq load-history (mapcar 'purecopy load-history))
+(setq load-history (mapcar #'purecopy load-history))
(set-buffer-modified-p nil)
-(remove-hook 'after-load-functions (lambda (f) (garbage-collect)))
+(remove-hook 'after-load-functions (lambda (_) (garbage-collect)))
(if (boundp 'load--prefer-newer)
(progn
@@ -448,6 +449,43 @@ lost after dumping")))
;; At this point, we're ready to resume undo recording for scratch.
(buffer-enable-undo "*scratch*")
+(when (featurep 'nativecomp)
+ ;; Fix the compilation unit filename to have it working when
+ ;; installed or if the source directory got moved. This is set to be
+ ;; a pair in the form of:
+ ;; (rel-filename-from-install-bin . rel-filename-from-local-bin).
+ (let ((h (make-hash-table :test #'eq))
+ (bin-dest-dir (cadr (member "--bin-dest" command-line-args)))
+ (eln-dest-dir (cadr (member "--eln-dest" command-line-args))))
+ (when (and bin-dest-dir eln-dest-dir)
+ (setq eln-dest-dir
+ (concat eln-dest-dir "native-lisp/" comp-native-version-dir "/"))
+ (mapatoms (lambda (s)
+ (let ((f (symbol-function s)))
+ (when (subr-native-elisp-p f)
+ (puthash (subr-native-comp-unit f) nil h)))))
+ (maphash (lambda (cu _)
+ (let* ((file (native-comp-unit-file cu))
+ (preloaded (equal (substring (file-name-directory file)
+ -10 -1)
+ "preloaded"))
+ (eln-dest-dir-eff (if preloaded
+ (expand-file-name "preloaded"
+ eln-dest-dir)
+ eln-dest-dir)))
+ (native-comp-unit-set-file
+ cu
+ (cons
+ ;; Relative filename from the installed binary.
+ (file-relative-name (expand-file-name
+ (file-name-nondirectory
+ file)
+ eln-dest-dir-eff)
+ bin-dest-dir)
+ ;; Relative filename from the built uninstalled binary.
+ (file-relative-name file invocation-directory)))))
+ h))))
+
(when (hash-table-p purify-flag)
(let ((strings 0)
(vectors 0)
@@ -483,6 +521,11 @@ lost after dumping")))
((equal dump-mode "bootstrap") "emacs")
((equal dump-mode "pbootstrap") "bootstrap-emacs.pdmp")
(t (error "unrecognized dump mode %s" dump-mode)))))
+ (when (and (featurep 'nativecomp)
+ (equal dump-mode "pdump"))
+ ;; Don't enable this before bootstrap is completed, as the
+ ;; compiler infrastructure may not be usable yet.
+ (setq comp-enable-subr-trampolines t))
(message "Dumping under the name %s" output)
(condition-case ()
(delete-file output)
@@ -539,8 +582,9 @@ lost after dumping")))
;; Don't keep `load-file-name' set during the top-level session!
;; Otherwise, it breaks a lot of code which does things like
;; (or load-file-name byte-compile-current-file).
+(setq load-true-file-name nil)
(setq load-file-name nil)
-(eval top-level)
+(eval top-level t)
;; Local Variables:
diff --git a/lisp/lpr.el b/lisp/lpr.el
index 012d251..29a0fd8 100644
--- a/lisp/lpr.el
+++ b/lisp/lpr.el
@@ -1,4 +1,4 @@
-;;; lpr.el --- print Emacs buffer on line printer
+;;; lpr.el --- print Emacs buffer on line printer -*- lexical-binding: t -*-
;; Copyright (C) 1985, 1988, 1992, 1994, 2001-2021 Free Software
;; Foundation, Inc.
@@ -39,12 +39,10 @@
(memq system-type '(usg-unix-v hpux))
"Non-nil if running on a system type that uses the \"lp\" command.")
-
(defgroup lpr nil
"Print Emacs buffer on line printer."
:group 'text)
-
;;;###autoload
(defcustom printer-name
(and (eq system-type 'ms-dos) "PRN")
@@ -65,8 +63,7 @@ file. If you want to discard the printed output, set this to
\"NUL\"."
:tag "Printer Name"
(const :tag "Default" nil)
;; could use string but then we lose completion for files.
- (file :tag "Name"))
- :group 'lpr)
+ (file :tag "Name")))
;;;###autoload
(defcustom lpr-switches nil
@@ -74,16 +71,14 @@ file. If you want to discard the printed output, set this
to \"NUL\"."
It is recommended to set `printer-name' instead of including an explicit
switch on this list.
See `lpr-command'."
- :type '(repeat (string :tag "Argument"))
- :group 'lpr)
+ :type '(repeat (string :tag "Argument")))
(defcustom lpr-add-switches (memq system-type '(berkeley-unix gnu/linux))
"Non-nil means construct `-T' and `-J' options for the printer program.
These are made assuming that the program is `lpr';
if you are using some other incompatible printer program,
this variable should be nil."
- :type 'boolean
- :group 'lpr)
+ :type 'boolean)
(defcustom lpr-printer-switch
(if lpr-lp-system
@@ -94,8 +89,7 @@ This switch is used in conjunction with `printer-name'."
:type '(choice :menu-tag "Printer Name Switch"
:tag "Printer Name Switch"
(const :tag "None" nil)
- (string :tag "Printer Switch"))
- :group 'lpr)
+ (string :tag "Printer Switch")))
;;;###autoload
(defcustom lpr-command
@@ -116,8 +110,7 @@ Windows NT and Novell Netware respectively) are handled
specially, using
`printer-name' as the destination for output; any other program is
treated like `lpr' except that an explicit filename is given as the last
argument."
- :type 'string
- :group 'lpr)
+ :type 'string)
;; Default is nil, because that enables us to use pr -f
;; which is more reliable than pr with no args, which is what lpr -p does.
@@ -127,22 +120,21 @@ If nil, we run `lpr-page-header-program' to make page
headings
and print the result."
:type '(choice (const nil)
(string :tag "Single argument")
- (repeat :tag "Multiple arguments" (string :tag "Argument")))
- :group 'lpr)
+ (repeat :tag "Multiple arguments" (string :tag "Argument"))))
(defcustom print-region-function
(if (memq system-type '(ms-dos windows-nt))
- #'w32-direct-print-region-function
+ (progn
+ (declare-function w32-direct-print-region-function "w32-fns")
+ #'w32-direct-print-region-function)
#'call-process-region)
"Function to call to print the region on a printer.
See definition of `print-region-1' for calling conventions."
- :type 'function
- :group 'lpr)
+ :type 'function)
(defcustom lpr-page-header-program "pr"
"Name of program for adding page headers to a file."
- :type 'string
- :group 'lpr)
+ :type 'string)
;; Berkeley systems support -F, and GNU pr supports both -f and -F,
;; So it looks like -F is a better default.
@@ -151,8 +143,7 @@ See definition of `print-region-1' for calling conventions."
If `%s' appears in any of the strings, it is substituted by the page title.
Note that for correct quoting, `%s' should normally be a separate element.
The variable `lpr-page-header-program' specifies the program to use."
- :type '(repeat string)
- :group 'lpr)
+ :type '(repeat string))
;;;###autoload
(defun lpr-buffer ()
@@ -248,7 +239,7 @@ for further customization of the printer command."
nil
;; Run a separate program to get page headers.
(let ((new-coords (print-region-new-buffer start end)))
- (apply 'call-process-region (car new-coords) (cdr new-coords)
+ (apply #'call-process-region (car new-coords) (cdr new-coords)
lpr-page-header-program t t nil
(mapcar (lambda (e) (format e name))
lpr-page-header-switches)))
@@ -270,7 +261,7 @@ for further customization of the printer command."
(let ((retval
(let ((tempbuf (current-buffer)))
(with-current-buffer buf
- (apply (or print-region-function 'call-process-region)
+ (apply (or print-region-function #'call-process-region)
start end lpr-command
nil tempbuf nil
(nconc (and name lpr-add-switches
diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el
index 3721e86..24d49ea 100644
--- a/lisp/ls-lisp.el
+++ b/lisp/ls-lisp.el
@@ -28,7 +28,7 @@
;; OVERVIEW ==========================================================
;; This file advises the function `insert-directory' to implement it
-;; directly from Emacs lisp, without running ls in a subprocess.
+;; directly from Emacs Lisp, without running ls in a subprocess.
;; This is useful if you don't have ls installed (ie, on MS Windows).
;; This function can use regexps instead of shell wildcards. If you
diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el
index 5f3d75e..14c93f2 100644
--- a/lisp/mail/emacsbug.el
+++ b/lisp/mail/emacsbug.el
@@ -309,7 +309,7 @@ usually do not have translators for other languages.\n\n")))
(lambda (var)
(let ((val (getenv var)))
(if val (insert (format " value of $%s: %s\n" var val)))))
- '("EMACSDATA" "EMACSDOC" "EMACSLOADPATH" "EMACSPATH"
+ '("EMACSDATA" "EMACSDOC" "EMACSLOADPATH" "EMACSNATIVELOADPATH" "EMACSPATH"
"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))
diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el
index 7fbdfef..88fb086 100644
--- a/lisp/mail/mail-extr.el
+++ b/lisp/mail/mail-extr.el
@@ -2236,13 +2236,13 @@ place. It affects how
`mail-extract-address-components' works."
;(let ((all nil))
-; (mapatoms #'(lambda (x)
+; (mapatoms (lambda (x)
; (if (and (boundp x)
; (string-match "^mail-extr-" (symbol-name x)))
; (setq all (cons x all)))))
; (setq all (sort all #'string-lessp))
; (cons 'setq
-; (apply 'nconc (mapcar #'(lambda (x)
+; (apply 'nconc (mapcar (lambda (x)
; (list x (symbol-value x)))
; all))))
diff --git a/lisp/mail/rmail-spam-filter.el b/lisp/mail/rmail-spam-filter.el
index d833685..fbac9e0 100644
--- a/lisp/mail/rmail-spam-filter.el
+++ b/lisp/mail/rmail-spam-filter.el
@@ -555,4 +555,4 @@ checks to see if the old format is used, and updates it if
necessary."
(provide 'rmail-spam-filter)
-;;; rmail-spam-filter ends here
+;;; rmail-spam-filter.el ends here
diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el
index c7960f8..455ae7f 100644
--- a/lisp/mail/rmail.el
+++ b/lisp/mail/rmail.el
@@ -3671,9 +3671,9 @@ If BUFFER is not swapped, yank out of its message viewer
buffer."
(push (cons "cc" cc) other-headers)
(push (cons "in-reply-to" in-reply-to) other-headers)
(setq other-headers
- (mapcar #'(lambda (elt)
- (cons (car elt) (if (stringp (cdr elt))
- (rfc2047-decode-string (cdr elt)))))
+ (mapcar (lambda (elt)
+ (cons (car elt) (if (stringp (cdr elt))
+ (rfc2047-decode-string (cdr elt)))))
other-headers))
(if (stringp to) (setq to (rfc2047-decode-string to)))
(if (stringp in-reply-to)
diff --git a/lisp/mail/rmailmm.el b/lisp/mail/rmailmm.el
index cdb994a..99bff66 100644
--- a/lisp/mail/rmailmm.el
+++ b/lisp/mail/rmailmm.el
@@ -784,9 +784,11 @@ directly."
(let ((encoding (rmail-mime-entity-transfer-encoding entity)))
(setq size (- (aref body 1) (aref body 0)))
(cond ((string= encoding "base64")
- (setq size (/ (* size 3) 4)))
+ ;; https://en.wikipedia.org/wiki/Base64#MIME
+ (setq size (* size 0.73)))
((string= encoding "quoted-printable")
- (setq size (/ (* size 7) 3)))))))
+ ;; Assume most of the text is ASCII...
+ (setq size (/ (* size 5) 7)))))))
(cond
((string-match "text/html" content-type)
@@ -1402,7 +1404,7 @@ are handled according to
`rmail-mime-media-type-handlers-alist'.
By default, this displays text and multipart messages, and offers to
download attachments as specified by `rmail-mime-attachment-dirs-alist'.
The arguments ARG and STATE have no effect in this case."
- (interactive (list current-prefix-arg nil))
+ (interactive)
(if rmail-enable-mime
(with-current-buffer rmail-buffer
(if (or (rmail-mime-message-p)
diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el
index ac5e8c3..ab58aa4 100644
--- a/lisp/mail/smtpmail.el
+++ b/lisp/mail/smtpmail.el
@@ -489,13 +489,6 @@ for `smtpmail-try-auth-method'.")
recipient
(concat recipient "@" smtpmail-sendto-domain)))
-(defun smtpmail-intersection (list1 list2)
- (let ((result nil))
- (dolist (el2 list2)
- (when (memq el2 list1)
- (push el2 result)))
- (nreverse result)))
-
(defun smtpmail-command-or-throw (process string &optional code)
(let (ret)
(smtpmail-send-command process string)
@@ -512,9 +505,10 @@ for `smtpmail-try-auth-method'.")
(if port
(format "%s" port)
"smtp"))
- (let* ((mechs (smtpmail-intersection
+ (let* ((mechs (seq-intersection
+ smtpmail-auth-supported
(cdr-safe (assoc 'auth supported-extensions))
- smtpmail-auth-supported))
+ #'eq))
(auth-source-creation-prompts
'((user . "SMTP user name for %h: ")
(secret . "SMTP password for %u@%h: ")))
@@ -1087,6 +1081,12 @@ many continuation lines."
(while (and (looking-at "^[ \t].*\n") (< (point) header-end))
(replace-match ""))))))
+;; Obsolete.
+
+(defun smtpmail-intersection (list1 list2)
+ (declare (obsolete seq-intersection "28.1"))
+ (seq-intersection list2 list1 #'eq))
+
(provide 'smtpmail)
;;; smtpmail.el ends here
diff --git a/lisp/mail/uudecode.el b/lisp/mail/uudecode.el
index fdd402e..026356e 100644
--- a/lisp/mail/uudecode.el
+++ b/lisp/mail/uudecode.el
@@ -1,4 +1,4 @@
-;;; uudecode.el -- elisp native uudecode -*- lexical-binding:t -*-
+;;; uudecode.el --- elisp native uudecode -*- lexical-binding:t -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
diff --git a/lisp/man.el b/lisp/man.el
index abb9bba..9b941a2 100644
--- a/lisp/man.el
+++ b/lisp/man.el
@@ -1503,7 +1503,9 @@ manpage command."
(quit-restore-window
(get-buffer-window Man-buffer t) 'kill)
;; Ensure that we end up in the correct window.
- (select-window (old-selected-window)))
+ (let ((old-window (old-selected-window)))
+ (when (window-live-p old-window)
+ (select-window old-window))))
(kill-buffer Man-buffer)))
(when message
diff --git a/lisp/mh-e/mh-acros.el b/lisp/mh-e/mh-acros.el
index dd953ee..8fdcf3c 100644
--- a/lisp/mh-e/mh-acros.el
+++ b/lisp/mh-e/mh-acros.el
@@ -36,8 +36,6 @@
;; because it's pointless to compile a file full of macros. But we
;; kept the name.
-;;; Change Log:
-
;;; Code:
(require 'cl-lib)
diff --git a/lisp/mh-e/mh-alias.el b/lisp/mh-e/mh-alias.el
index 67c019a..415e984 100644
--- a/lisp/mh-e/mh-alias.el
+++ b/lisp/mh-e/mh-alias.el
@@ -24,8 +24,6 @@
;;; Commentary:
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
diff --git a/lisp/mh-e/mh-buffers.el b/lisp/mh-e/mh-buffers.el
index a32f61c..ef21fdb 100644
--- a/lisp/mh-e/mh-buffers.el
+++ b/lisp/mh-e/mh-buffers.el
@@ -24,8 +24,6 @@
;;; Commentary:
-;;; Change Log:
-
;;; Code:
;; The names of ephemeral buffers have a " *mh-" prefix (so that they
diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el
index c1cd6c1..b64bbfb 100644
--- a/lisp/mh-e/mh-comp.el
+++ b/lisp/mh-e/mh-comp.el
@@ -29,8 +29,6 @@
;; that are used to send the mail. Other that those, functions that
;; are needed in mh-letter.el should be found there.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
diff --git a/lisp/mh-e/mh-compat.el b/lisp/mh-e/mh-compat.el
index 0363c5a..ade80e8 100644
--- a/lisp/mh-e/mh-compat.el
+++ b/lisp/mh-e/mh-compat.el
@@ -23,8 +23,6 @@
;;; Commentary:
-;;; Change Log:
-
;;; Code:
;; This is a good place to gather code that is used for compatibility
diff --git a/lisp/mh-e/mh-folder.el b/lisp/mh-e/mh-folder.el
index 2e28806..ce77f9c 100644
--- a/lisp/mh-e/mh-folder.el
+++ b/lisp/mh-e/mh-folder.el
@@ -25,8 +25,6 @@
;; Mode for browsing folders
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
diff --git a/lisp/mh-e/mh-funcs.el b/lisp/mh-e/mh-funcs.el
index 38ba431..0e5ffc9 100644
--- a/lisp/mh-e/mh-funcs.el
+++ b/lisp/mh-e/mh-funcs.el
@@ -30,8 +30,6 @@
;; small support routines are needed, place them with the function;
;; otherwise, create a separate section for them.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
diff --git a/lisp/mh-e/mh-gnus.el b/lisp/mh-e/mh-gnus.el
index ac46cc6..cc60f7b 100644
--- a/lisp/mh-e/mh-gnus.el
+++ b/lisp/mh-e/mh-gnus.el
@@ -24,8 +24,6 @@
;;; Commentary:
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
diff --git a/lisp/mh-e/mh-identity.el b/lisp/mh-e/mh-identity.el
index aeab049..ceede0d 100644
--- a/lisp/mh-e/mh-identity.el
+++ b/lisp/mh-e/mh-identity.el
@@ -33,8 +33,6 @@
;; in MH-Letter mode. The command `mh-insert-identity' can be used
;; to manually insert an identity.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
diff --git a/lisp/mh-e/mh-inc.el b/lisp/mh-e/mh-inc.el
index 6a29195..83cfe4f 100644
--- a/lisp/mh-e/mh-inc.el
+++ b/lisp/mh-e/mh-inc.el
@@ -28,8 +28,6 @@
;; inc can also be used to incorporate mail from multiple spool files
;; into separate folders. See "C-h v mh-inc-spool-list".
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
diff --git a/lisp/mh-e/mh-junk.el b/lisp/mh-e/mh-junk.el
index 5a40794..e50bf8d 100644
--- a/lisp/mh-e/mh-junk.el
+++ b/lisp/mh-e/mh-junk.el
@@ -26,8 +26,6 @@
;; Spam handling in MH-E.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
diff --git a/lisp/mh-e/mh-letter.el b/lisp/mh-e/mh-letter.el
index 5979018..ae5b80d 100644
--- a/lisp/mh-e/mh-letter.el
+++ b/lisp/mh-e/mh-letter.el
@@ -31,8 +31,6 @@
;; mh-utils.el. That will help prevent the loading of this file until
;; a message is actually composed.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
diff --git a/lisp/mh-e/mh-limit.el b/lisp/mh-e/mh-limit.el
index 08f1b40..39cf7c5 100644
--- a/lisp/mh-e/mh-limit.el
+++ b/lisp/mh-e/mh-limit.el
@@ -25,8 +25,6 @@
;; "Poor man's threading" by psg.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el
index fec2293..ef70252 100644
--- a/lisp/mh-e/mh-mime.el
+++ b/lisp/mh-e/mh-mime.el
@@ -36,8 +36,6 @@
;; MIME option to mh-forward command to move to content-description
;; insertion point.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
diff --git a/lisp/mh-e/mh-print.el b/lisp/mh-e/mh-print.el
index d084cf6..2074ff6 100644
--- a/lisp/mh-e/mh-print.el
+++ b/lisp/mh-e/mh-print.el
@@ -24,8 +24,6 @@
;;; Commentary:
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
diff --git a/lisp/mh-e/mh-scan.el b/lisp/mh-e/mh-scan.el
index f00ab22..1504979 100644
--- a/lisp/mh-e/mh-scan.el
+++ b/lisp/mh-e/mh-scan.el
@@ -27,8 +27,6 @@
;; This file contains constants and a few functions for interpreting
;; scan lines.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
diff --git a/lisp/mh-e/mh-search.el b/lisp/mh-e/mh-search.el
index aece03e..b3a250b 100644
--- a/lisp/mh-e/mh-search.el
+++ b/lisp/mh-e/mh-search.el
@@ -1,4 +1,4 @@
-;;; mh-search --- MH-Search mode -*- lexical-binding: t; -*-
+;;; mh-search.el --- MH-Search mode -*- lexical-binding: t; -*-
;; Copyright (C) 1993, 1995, 2001-2021 Free Software Foundation, Inc.
@@ -39,8 +39,6 @@
;; documentation will direct you to the specific instructions for
;; your particular searcher.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -274,23 +272,23 @@ folder containing the index search results."
t)))
;; Copy the search results over.
- (maphash #'(lambda (folder msgs)
- (let ((cur (car (mh-translate-range folder "cur")))
- (msgs (sort (cl-loop
- for msg being the hash-keys of msgs
- collect msg)
- #'<)))
- (mh-exec-cmd "refile" msgs "-src" folder
- "-link" index-folder)
- ;; Restore cur to old value, that refile changed
- (when cur
- (mh-exec-cmd-quiet nil "mark" folder "-add" "-zero"
- "-sequence"
- "cur" (format "%s" cur)))
- (cl-loop for msg in msgs
- do (cl-incf result-count)
- (setf (gethash result-count origin-map)
- (cons folder msg)))))
+ (maphash (lambda (folder msgs)
+ (let ((cur (car (mh-translate-range folder "cur")))
+ (msgs (sort (cl-loop
+ for msg being the hash-keys of msgs
+ collect msg)
+ #'<)))
+ (mh-exec-cmd "refile" msgs "-src" folder
+ "-link" index-folder)
+ ;; Restore cur to old value, that refile changed
+ (when cur
+ (mh-exec-cmd-quiet nil "mark" folder "-add" "-zero"
+ "-sequence"
+ "cur" (format "%s" cur)))
+ (cl-loop for msg in msgs
+ do (cl-incf result-count)
+ (setf (gethash result-count origin-map)
+ (cons folder msg)))))
folder-results-map)
;; Vist the results folder.
@@ -1136,10 +1134,10 @@ REGEXP-LIST is an alist of fields and values."
((atom (cadr expr)) `(or (and ,expr)))
((eq (caadr expr) 'not) (mh-mairix-convert-to-sop* (cadadr expr)))
((eq (caadr expr) 'and) (mh-mairix-convert-to-sop*
- `(or ,@(mapcar #'(lambda (x) `(not ,x))
+ `(or ,@(mapcar (lambda (x) `(not ,x))
(cdadr expr)))))
((eq (caadr expr) 'or) (mh-mairix-convert-to-sop*
- `(and ,@(mapcar #'(lambda (x) `(not ,x))
+ `(and ,@(mapcar (lambda (x) `(not ,x))
(cdadr expr)))))
(t (error "Unreachable: %s" expr))))
@@ -1620,7 +1618,7 @@ garbled."
(cl-loop for seq in seq-list
do (apply #'mh-exec-cmd "mark" mh-current-folder
"-sequence" (symbol-name (car seq)) "-add"
- (mapcar #'(lambda (x) (format "%s" x)) (cdr seq))))))
+ (mapcar (lambda (x) (format "%s" x)) (cdr seq))))))
;;;###mh-autoload
(defun mh-create-sequence-map (seq-list)
@@ -1945,4 +1943,4 @@ folder buffer."
;; sentence-end-double-space: nil
;; End:
-;;; mh-search ends here
+;;; mh-search.el ends here
diff --git a/lisp/mh-e/mh-seq.el b/lisp/mh-e/mh-seq.el
index 9b9675c..9cdf39f 100644
--- a/lisp/mh-e/mh-seq.el
+++ b/lisp/mh-e/mh-seq.el
@@ -26,8 +26,6 @@
;; Sequences are stored in the alist `mh-seq-list' in the form:
;; ((seq-name msgs ...) (seq-name msgs ...) ...)
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
diff --git a/lisp/mh-e/mh-show.el b/lisp/mh-e/mh-show.el
index cb9819f..aa97f5c 100644
--- a/lisp/mh-e/mh-show.el
+++ b/lisp/mh-e/mh-show.el
@@ -26,8 +26,6 @@
;; Mode for showing messages.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -187,7 +185,7 @@ Sets the current buffer to the show buffer."
(set-buffer folder)
;; When Gnus uses external displayers it has to keep handles longer. So
;; we will delete these handles when mh-quit is called on the folder. It
- ;; would be nicer if there are weak pointers in emacs lisp, then we could
+ ;; would be nicer if there are weak pointers in Emacs Lisp, then we could
;; get the garbage collector to do this for us.
(unless (mh-buffer-data)
(setf (mh-buffer-data) (mh-make-buffer-data)))
diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el
index b2deacf..3af840c 100644
--- a/lisp/mh-e/mh-speed.el
+++ b/lisp/mh-e/mh-speed.el
@@ -26,8 +26,6 @@
;; Future versions should only use flists.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
diff --git a/lisp/mh-e/mh-thread.el b/lisp/mh-e/mh-thread.el
index a7878aa..89b0dbd 100644
--- a/lisp/mh-e/mh-thread.el
+++ b/lisp/mh-e/mh-thread.el
@@ -69,8 +69,6 @@
;; (5) Better canonicalizing for message identifier and subject
;; strings.
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -233,7 +231,7 @@ sibling."
(push index msg-list)))
(forward-line))
(mh-scan-folder mh-current-folder
- (mapcar #'(lambda (x) (format "%s" x))
+ (mapcar (lambda (x) (format "%s" x))
(mh-coalesce-msg-list msg-list))
t))
(when mh-index-data
@@ -591,7 +589,7 @@ Only information about messages in MSG-LIST are added to
the tree."
#'call-process (expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil
"-width" "10000" "-format"
"%(msg)\n%{message-id}\n%{references}\n%{in-reply-to}\n%{subject}\n"
- folder (mapcar #'(lambda (x) (format "%s" x)) msg-list)))
+ folder (mapcar (lambda (x) (format "%s" x)) msg-list)))
(goto-char (point-min))
(let ((roots ())
(case-fold-search t))
@@ -635,9 +633,9 @@ Only information about messages in MSG-LIST are added to
the tree."
(mh-thread-remove-parent-link id)
(mh-thread-add-link (car ancestors) id)))
(mh-thread-add-link (car ancestors) (cadr ancestors)))))))
- (maphash #'(lambda (_k v)
- (when (null (mh-container-parent v))
- (push v roots)))
+ (maphash (lambda (_k v)
+ (when (null (mh-container-parent v))
+ (push v roots)))
mh-thread-id-table)
(setq roots (mh-thread-prune-containers roots))
(prog1 (setq roots (mh-thread-group-by-subject roots))
@@ -720,25 +718,25 @@ For now it will take the last string inside angles."
mh-thread-history)
(mh-thread-remove-parent-link node)))))
(let ((results ()))
- (maphash #'(lambda (_k v)
- (when (and (null (mh-container-parent v))
- (gethash (mh-message-id (mh-container-message v))
- mh-thread-id-index-map))
- (push v results)))
+ (maphash (lambda (_k v)
+ (when (and (null (mh-container-parent v))
+ (gethash (mh-message-id (mh-container-message v))
+ mh-thread-id-index-map))
+ (push v results)))
mh-thread-id-table)
(mh-thread-sort-containers results))))
(defun mh-thread-sort-containers (containers)
"Sort a list of message CONTAINERS to be in ascending order wrt index."
(sort containers
- #'(lambda (x y)
- (when (and (mh-container-message x) (mh-container-message y))
- (let* ((id-x (mh-message-id (mh-container-message x)))
- (id-y (mh-message-id (mh-container-message y)))
- (index-x (gethash id-x mh-thread-id-index-map))
- (index-y (gethash id-y mh-thread-id-index-map)))
- (and (integerp index-x) (integerp index-y)
- (< index-x index-y)))))))
+ (lambda (x y)
+ (when (and (mh-container-message x) (mh-container-message y))
+ (let* ((id-x (mh-message-id (mh-container-message x)))
+ (id-y (mh-message-id (mh-container-message y)))
+ (index-x (gethash id-x mh-thread-id-index-map))
+ (index-y (gethash id-y mh-thread-id-index-map)))
+ (and (integerp index-x) (integerp index-y)
+ (< index-x index-y)))))))
(defvar mh-thread-last-ancestor)
diff --git a/lisp/mh-e/mh-tool-bar.el b/lisp/mh-e/mh-tool-bar.el
index 40a430b..94aa8dd 100644
--- a/lisp/mh-e/mh-tool-bar.el
+++ b/lisp/mh-e/mh-tool-bar.el
@@ -24,8 +24,6 @@
;;; Commentary:
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el
index be66e62..8e900dc 100644
--- a/lisp/mh-e/mh-utils.el
+++ b/lisp/mh-e/mh-utils.el
@@ -24,8 +24,6 @@
;;; Commentary:
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
@@ -544,8 +542,8 @@ nested folders within them."
(mh-sub-folders-actual folder)))
(t match))))
(if add-trailing-slash-flag
- (mapcar #'(lambda (x)
- (if (cdr x) (cons (concat (car x) "/") (cdr x)) x))
+ (mapcar (lambda (x)
+ (if (cdr x) (cons (concat (car x) "/") (cdr x)) x))
sub-folders)
sub-folders)))
diff --git a/lisp/mh-e/mh-xface.el b/lisp/mh-e/mh-xface.el
index 0b53829..d4d5c5c 100644
--- a/lisp/mh-e/mh-xface.el
+++ b/lisp/mh-e/mh-xface.el
@@ -23,8 +23,6 @@
;;; Commentary:
-;;; Change Log:
-
;;; Code:
(require 'mh-e)
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 5f59467..2400624 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -122,10 +122,10 @@ This metadata is an alist. Currently understood keys are:
returns a string to append to STRING.
- `affixation-function': function to prepend/append a prefix/suffix to
entries. Takes one argument (COMPLETIONS) and should return a list
- of completions with a list of either two elements: completion
- and suffix, or three elements: completion, its prefix
- and suffix. This function takes priority over `annotation-function'
- when both are provided, so only this function is used.
+ of annotated completions. The elements of the list must be
+ three-element lists: completion, its prefix and suffix. This
+ function takes priority over `annotation-function' when both are
+ provided, so only this function is used.
- `display-sort-function': function to sort entries in *Completions*.
Takes one argument (COMPLETIONS) and should return a new list
of completions. Can operate destructively.
@@ -271,7 +271,7 @@ the form (concat S2 S)."
(let* ((str (if (string-prefix-p s1 string completion-ignore-case)
(concat s2 (substring string (length s1)))))
(res (if str (complete-with-action action table str pred))))
- (when res
+ (when (or res (eq (car-safe action) 'boundaries))
(cond
((eq (car-safe action) 'boundaries)
(let ((beg (or (and (eq (car-safe res) 'boundaries) (cadr res)) 0)))
@@ -488,8 +488,17 @@ for use at QPOS."
(qsuffix (cdr action))
(ufull (if (zerop (length qsuffix)) ustring
(funcall unquote (concat string qsuffix))))
- (_ (cl-assert (string-prefix-p ustring ufull)))
- (usuffix (substring ufull (length ustring)))
+ ;; If (not (string-prefix-p ustring ufull)) we have a problem:
+ ;; unquoting the qfull gives something "unrelated" to ustring.
+ ;; E.g. "~/" and "/" where "~//" gets unquoted to just "/" (see
+ ;; bug#47678).
+ ;; In that case we can't even tell if we're right before the
+ ;; "/" or right after it (aka if this "/" is from qstring or
+ ;; from qsuffix), thus which usuffix to use is very unclear.
+ (usuffix (if (string-prefix-p ustring ufull)
+ (substring ufull (length ustring))
+ ;; FIXME: Maybe "" is preferable/safer?
+ qsuffix))
(boundaries (completion-boundaries ustring table pred usuffix))
(qlboundary (car (funcall requote (car boundaries) string)))
(qrboundary (if (zerop (cdr boundaries)) 0 ;Common case.
@@ -1346,6 +1355,52 @@ scroll the window of possible completions."
(if (eq (car bounds) base) md-at-point
(completion-metadata (substring string 0 base) table pred))))
+(defun minibuffer--sort-by-key (elems keyfun)
+ "Return ELEMS sorted by increasing value of their KEYFUN.
+KEYFUN takes an element of ELEMS and should return a numerical value."
+ (mapcar #'cdr
+ (sort (mapcar (lambda (x) (cons (funcall keyfun x) x)) elems)
+ #'car-less-than-car)))
+
+(defun minibuffer--sort-by-position (hist elems)
+ "Sort ELEMS by their position in HIST."
+ (let ((hash (make-hash-table :test #'equal :size (length hist)))
+ (index 0))
+ ;; Record positions in hash
+ (dolist (c hist)
+ (unless (gethash c hash)
+ (puthash c index hash))
+ (cl-incf index))
+ (minibuffer--sort-by-key
+ elems (lambda (x) (gethash x hash most-positive-fixnum)))))
+
+(defun minibuffer--sort-by-length-alpha (elems)
+ "Sort ELEMS first by length, then alphabetically."
+ (sort elems (lambda (c1 c2)
+ (or (< (length c1) (length c2))
+ (and (= (length c1) (length c2))
+ (string< c1 c2))))))
+
+(defun minibuffer--sort-preprocess-history (base)
+ "Preprocess history.
+Remove completion BASE prefix string from history elements."
+ (let* ((def (if (stringp minibuffer-default)
+ minibuffer-default
+ (car-safe minibuffer-default)))
+ (hist (and (not (eq minibuffer-history-variable t))
+ (symbol-value minibuffer-history-variable)))
+ (base-size (length base)))
+ ;; Default comes first.
+ (setq hist (if def (cons def hist) hist))
+ ;; Drop base string from the history elements.
+ (if (= base-size 0)
+ hist
+ (delq nil (mapcar
+ (lambda (c)
+ (when (string-prefix-p base c)
+ (substring c base-size)))
+ hist)))))
+
(defun completion-all-sorted-completions (&optional start end)
(or completion-all-sorted-completions
(let* ((start (or start (minibuffer-prompt-end)))
@@ -1375,23 +1430,18 @@ scroll the window of possible completions."
(setq all (delete-dups all))
(setq last (last all))
- (cond
- (sort-fun
- (setq all (funcall sort-fun all)))
- (t
- ;; Prefer shorter completions, by default.
- (setq all (sort all (lambda (c1 c2) (< (length c1) (length c2)))))
- (if (minibufferp)
- ;; Prefer recently used completions and put the default, if
- ;; it exists, on top.
- (let ((hist (symbol-value minibuffer-history-variable)))
- (setq all
- (sort all
- (lambda (c1 c2)
- (cond ((equal c1 minibuffer-default) t)
- ((equal c2 minibuffer-default) nil)
- (t (> (length (member c1 hist))
- (length (member c2 hist))))))))))))
+ (if sort-fun
+ (setq all (funcall sort-fun all))
+ ;; Sort first by length and alphabetically.
+ (setq all (minibuffer--sort-by-length-alpha all))
+ ;; Sort by history position, put the default, if it
+ ;; exists, on top.
+ (when (minibufferp)
+ (setq all (minibuffer--sort-by-position
+ (minibuffer--sort-preprocess-history
+ (substring string 0 base-size))
+ all))))
+
;; Cache the result. This is not just for speed, but also so that
;; repeated calls to minibuffer-force-complete can cycle through
;; all possibilities.
@@ -1414,7 +1464,7 @@ scroll the window of possible completions."
;; test-completion, then we shouldn't exit, but that should be rare.
(lambda ()
(if minibuffer--require-match
- (minibuffer-message "Incomplete")
+ (completion--message "Incomplete")
;; If a match is not required, exit after all.
(exit-minibuffer)))))
@@ -1922,11 +1972,11 @@ These include:
`:affixation-function': Function to prepend/append a prefix/suffix to
completions. The function must accept one argument, a list of
- completions, and return a list where each element is a list of
- either two elements: a completion, and a suffix, or
- three elements: a completion, a prefix and a suffix.
- This function takes priority over `:annotation-function'
- when both are provided, so only this function is used.
+ completions, and return a list of annotated completions. The
+ elements of the list must be three-element lists: completion, its
+ prefix and suffix. This function takes priority over
+ `:annotation-function' when both are provided, so only this
+ function is used.
`:exit-function': Function to run after completion is performed.
@@ -1999,7 +2049,7 @@ variables.")
;; the sole completion, then hide (previous&stale) completions.
(minibuffer-hide-completions)
(ding)
- (minibuffer-message
+ (completion--message
(if completions "Sole completion" "No completions")))
(let* ((last (last completions))
@@ -2435,10 +2485,33 @@ with `minibuffer-local-must-match-map'.")
(defvar minibuffer-local-filename-must-match-map (make-sparse-keymap))
(make-obsolete-variable 'minibuffer-local-filename-must-match-map nil "24.1")
-(let ((map minibuffer-local-ns-map))
- (define-key map " " 'exit-minibuffer)
- (define-key map "\t" 'exit-minibuffer)
- (define-key map "?" 'self-insert-and-exit))
+(defvar minibuffer-local-ns-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map minibuffer-local-map)
+ (define-key map " " #'exit-minibuffer)
+ (define-key map "\t" #'exit-minibuffer)
+ (define-key map "?" #'self-insert-and-exit)
+ map)
+ "Local keymap for the minibuffer when spaces are not allowed.")
+
+(defun read-no-blanks-input (prompt &optional initial inherit-input-method)
+ "Read a string from the terminal, not allowing blanks.
+Prompt with PROMPT. Whitespace terminates the input. If INITIAL is
+non-nil, it should be a string, which is used as initial input, with
+point positioned at the end, so that SPACE will accept the input.
+\(Actually, INITIAL can also be a cons of a string and an integer.
+Such values are treated as in `read-from-minibuffer', but are normally
+not useful in this function.)
+
+Third arg INHERIT-INPUT-METHOD, if non-nil, means the minibuffer inherits
+the current input method and the setting of`enable-multibyte-characters'.
+
+If `inhibit-interaction' is non-nil, this function will signal an
+`inhibited-interaction' error."
+ (read-from-minibuffer prompt initial minibuffer-local-ns-map
+ nil minibuffer-history nil inherit-input-method))
+
+;;; Major modes for the minibuffer
(defvar minibuffer-inactive-mode-map
(let ((map (make-keymap)))
@@ -2465,6 +2538,18 @@ not active.")
"Major mode to use in the minibuffer when it is not active.
This is only used when the minibuffer area has no active minibuffer.")
+(defvaralias 'minibuffer-mode-map 'minibuffer-local-map)
+
+(define-derived-mode minibuffer-mode nil "Minibuffer"
+ "Major mode used for active minibuffers.
+
+For customizing this mode, it is better to use
+`minibuffer-setup-hook' and `minibuffer-exit-hook' rather than
+the mode hook of this mode."
+ :syntax-table nil
+ :abbrev-table nil
+ :interactive nil)
+
;;; Completion tables.
(defun minibuffer--double-dollars (str)
diff --git a/lisp/misearch.el b/lisp/misearch.el
index 668c711..335efb9 100644
--- a/lisp/misearch.el
+++ b/lisp/misearch.el
@@ -1,4 +1,4 @@
-;;; misearch.el --- isearch extensions for multi-buffer search
+;;; misearch.el --- isearch extensions for multi-buffer search -*-
lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@@ -28,6 +28,8 @@
;;; Code:
+(require 'cl-lib)
+
;;; Search multiple buffers
;;;###autoload (add-hook 'isearch-mode-hook 'multi-isearch-setup)
@@ -40,8 +42,7 @@
(defcustom multi-isearch-search t
"Non-nil enables searching multiple related buffers, in certain modes."
:type 'boolean
- :version "23.1"
- :group 'multi-isearch)
+ :version "23.1")
(defcustom multi-isearch-pause t
"A choice defining where to pause the search.
@@ -53,8 +54,7 @@ If t, pause in all buffers that contain the search string."
(const :tag "Don't pause" nil)
(const :tag "Only in initial buffer" initial)
(const :tag "All buffers" t))
- :version "23.1"
- :group 'multi-isearch)
+ :version "23.1")
;;;###autoload
(defvar multi-isearch-next-buffer-function nil
@@ -119,10 +119,10 @@ Intended to be added to `isearch-mode-hook'."
(default-value 'isearch-wrap-function)
multi-isearch-orig-push-state
(default-value 'isearch-push-state-function))
- (setq-default isearch-search-fun-function 'multi-isearch-search-fun
- isearch-wrap-function 'multi-isearch-wrap
- isearch-push-state-function 'multi-isearch-push-state)
- (add-hook 'isearch-mode-end-hook 'multi-isearch-end)))
+ (setq-default isearch-search-fun-function #'multi-isearch-search-fun
+ isearch-wrap-function #'multi-isearch-wrap
+ isearch-push-state-function #'multi-isearch-push-state)
+ (add-hook 'isearch-mode-end-hook #'multi-isearch-end)))
(defun multi-isearch-end ()
"Clean up the multi-buffer search after terminating isearch."
@@ -133,7 +133,7 @@ Intended to be added to `isearch-mode-hook'."
(setq-default isearch-search-fun-function multi-isearch-orig-search-fun
isearch-wrap-function multi-isearch-orig-wrap
isearch-push-state-function multi-isearch-orig-push-state)
- (remove-hook 'isearch-mode-end-hook 'multi-isearch-end))
+ (remove-hook 'isearch-mode-end-hook #'multi-isearch-end))
(defun multi-isearch-search-fun ()
"Return the proper search function, for isearch in multiple buffers."
@@ -206,7 +206,7 @@ search status stack."
(multi-isearch-pop-state cmd ,(current-buffer))))
(defun multi-isearch-pop-state (_cmd buffer)
- "Restore the multiple buffers search state.
+ "Restore the multiple buffers search state in BUFFER.
Switch to the buffer restored from the search status stack."
(unless (equal buffer (current-buffer))
(switch-to-buffer (setq multi-isearch-current-buffer buffer))))
@@ -238,7 +238,7 @@ set in `multi-isearch-buffers' or
`multi-isearch-buffers-regexp'."
(while (not (string-equal
(setq buf (read-buffer (multi-occur--prompt) nil t))
""))
- (add-to-list 'bufs buf)
+ (cl-pushnew buf bufs :test #'equal)
(setq ido-ignore-item-temp-list bufs))
(nreverse bufs)))
@@ -322,7 +322,7 @@ Every next/previous file in the defined sequence is visited
by
default-directory
default-directory))
default-directory))
- (add-to-list 'files file))
+ (cl-pushnew file files :test #'equal))
(nreverse files)))
;; A regexp is not the same thing as a file glob - does this matter?
@@ -381,7 +381,7 @@ whose file names match the specified wildcard."
(defun multi-isearch-unload-function ()
"Remove autoloaded variables from `unload-function-defs-list'.
Also prevent the feature from being reloaded via `isearch-mode-hook'."
- (remove-hook 'isearch-mode-hook 'multi-isearch-setup)
+ (remove-hook 'isearch-mode-hook #'multi-isearch-setup)
(let ((defs (list (car unload-function-defs-list)))
(auto '(multi-isearch-next-buffer-function
multi-isearch-next-buffer-current-function
@@ -395,7 +395,7 @@ Also prevent the feature from being reloaded via
`isearch-mode-hook'."
;; .
nil))
-(defalias 'misearch-unload-function 'multi-isearch-unload-function)
+(defalias 'misearch-unload-function #'multi-isearch-unload-function)
(provide 'multi-isearch)
diff --git a/lisp/mpc.el b/lisp/mpc.el
index 827f8aa..f730275 100644
--- a/lisp/mpc.el
+++ b/lisp/mpc.el
@@ -129,12 +129,10 @@
"Return L1 after removing all elements not found in L2.
If SELECTFUN is non-nil, elements aren't compared directly, but instead
they are passed through SELECTFUN before comparison."
- (let ((res ()))
- (if selectfun (setq l2 (mapcar selectfun l2)))
- (dolist (elem l1)
- (when (member (if selectfun (funcall selectfun elem) elem) l2)
- (push elem res)))
- (nreverse res)))
+ (when selectfun
+ (setq l1 (mapcar selectfun l1))
+ (setq l2 (mapcar selectfun l2)))
+ (seq-intersection l1 l2))
(defun mpc-event-set-point (event)
(condition-case nil (posn-set-point (event-end event))
@@ -185,7 +183,7 @@ numerically rather than lexicographically."
(abs res))
res))))))))
-(define-obsolete-function-alias 'mpc-string-prefix-p 'string-prefix-p "24.3")
+(define-obsolete-function-alias 'mpc-string-prefix-p #'string-prefix-p "24.3")
;; This can speed up mpc--song-search significantly. The table may grow
;; very large, tho. It's only bounded by the fact that it gets flushed
@@ -293,11 +291,11 @@ defaults to 6600 and HOST defaults to localhost."
(let ((plist (process-plist mpc-proc)))
(while plist (process-put proc (pop plist) (pop plist)))))
(mpc-proc-buffer proc 'mpd-commands (current-buffer))
- (process-put proc 'callback 'ignore)
+ (process-put proc 'callback #'ignore)
(process-put proc 'ready nil)
(clrhash mpc--find-memoize)
- (set-process-filter proc 'mpc--proc-filter)
- (set-process-sentinel proc 'ignore)
+ (set-process-filter proc #'mpc--proc-filter)
+ (set-process-sentinel proc #'ignore)
(set-process-query-on-exit-flag proc nil)
;; This may be called within a process filter ;-(
(with-local-quit (mpc-proc-sync proc))
@@ -378,7 +376,7 @@ which will be concatenated with proper quoting before
passing them to MPD."
(mpc--debug "Send \"%s\"" cmd)
(process-send-string
proc (concat (if (stringp cmd) cmd
- (mapconcat 'mpc--proc-quote-string cmd " "))
+ (mapconcat #'mpc--proc-quote-string cmd " "))
"\n")))
(if callback
;; (let ((buf (current-buffer)))
@@ -390,7 +388,7 @@ which will be concatenated with proper quoting before
passing them to MPD."
;; (set-buffer buf)))))
)
;; If `callback' is nil, we're executing synchronously.
- (process-put proc 'callback 'ignore)
+ (process-put proc 'callback #'ignore)
;; This returns the process's buffer.
(mpc-proc-sync proc)))))
@@ -400,7 +398,7 @@ which will be concatenated with proper quoting before
passing them to MPD."
(concat "command_list_begin\n"
(mapconcat (lambda (cmd)
(if (stringp cmd) cmd
- (mapconcat 'mpc--proc-quote-string cmd " ")))
+ (mapconcat #'mpc--proc-quote-string cmd " ")))
cmds
"\n")
"\ncommand_list_end"))
@@ -490,9 +488,9 @@ to call FUN for any change whatsoever.")
(defvar mpc--status-timer nil)
(defun mpc--status-timer-start ()
- (add-hook 'pre-command-hook 'mpc--status-timer-stop)
+ (add-hook 'pre-command-hook #'mpc--status-timer-stop)
(unless mpc--status-timer
- (setq mpc--status-timer (run-with-timer 1 1 'mpc--status-timer-run))))
+ (setq mpc--status-timer (run-with-timer 1 1 #'mpc--status-timer-run))))
(defun mpc--status-timer-stop ()
(when mpc--status-timer
(cancel-timer mpc--status-timer)
@@ -512,7 +510,7 @@ to call FUN for any change whatsoever.")
;; Turn it off even if we'll start it again, in case it changes the delay.
(cancel-timer mpc--status-idle-timer))
(setq mpc--status-idle-timer
- (run-with-idle-timer 1 t 'mpc--status-idle-timer-run))
+ (run-with-idle-timer 1 t #'mpc--status-idle-timer-run))
;; Typically, the idle timer is started from the mpc--status-callback,
;; which is run asynchronously while we're already idle (we typically
;; just started idling), so the timer itself will only be run the next
@@ -527,7 +525,7 @@ to call FUN for any change whatsoever.")
(unless really
;; We don't completely stop the timer, so that if some other MPD
;; client starts playback, we may get a chance to notice it.
- (run-with-idle-timer 10 t 'mpc--status-idle-timer-run))))
+ (run-with-idle-timer 10 t #'mpc--status-idle-timer-run))))
(defun mpc--status-idle-timer-run ()
(mpc--status-timer-start)
(mpc--status-timer-run))
@@ -598,7 +596,7 @@ Any call to `mpc-status-refresh' may cause it to be
restarted."
;; (dotimes (i (string-to-number pos)) (mpc--queue-pop))
;; (mpc-proc-cmd (mpc-proc-cmd-list
;; (make-list (string-to-number pos) "delete 0"))
-;; 'ignore)
+;; #'ignore)
;; (if (not (equal (cdr (assq 'file mpc-status))
;; (mpc--queue-head)))
;; (message "MPC's queue is out of sync"))))))
@@ -685,7 +683,7 @@ The songs are returned as alists."
(let ((plsongs (mpc-cmd-find 'Playlist pl)))
(if (not (mpc-cmd-special-tag-p other-tag))
(when (member (cons other-tag value)
- (apply 'append plsongs))
+ (apply #'append plsongs))
(push pl pls))
;; Problem N°2: we compute the intersection whereas all
;; we care about is whether it's empty. So we could
@@ -696,15 +694,15 @@ The songs are returned as alists."
;; good enough because this is only used with "search", which
;; doesn't pay attention to playlists and URLs anyway.
(let* ((osongs (mpc-cmd-find other-tag value))
- (ofiles (mpc-assq-all 'file (apply 'append osongs)))
- (plfiles (mpc-assq-all 'file (apply 'append plsongs))))
- (when (mpc-intersection plfiles ofiles)
+ (ofiles (mpc-assq-all 'file (apply #'append osongs)))
+ (plfiles (mpc-assq-all 'file (apply #'append plsongs))))
+ (when (seq-intersection plfiles ofiles)
(push pl pls)))))))
pls))
((eq tag 'Directory)
(if (null other-tag)
- (apply 'nconc
+ (apply #'nconc
(mpc-assq-all 'directory
(mpc-proc-buf-to-alist
(mpc-proc-cmd "lsinfo")))
@@ -727,7 +725,7 @@ The songs are returned as alists."
;; If there's an other-tag, then just extract the dir info from the
;; list of other-tag's songs.
(let* ((other-songs (mpc-cmd-find other-tag value))
- (files (mpc-assq-all 'file (apply 'append other-songs)))
+ (files (mpc-assq-all 'file (apply #'append other-songs)))
(dirs '()))
(dolist (file files)
(let ((dir (file-name-directory file)))
@@ -761,7 +759,7 @@ The songs are returned as alists."
((null other-tag)
(condition-case nil
- (mapcar 'cdr (mpc-proc-cmd-to-alist (list "list" (symbol-name tag))))
+ (mapcar #'cdr (mpc-proc-cmd-to-alist (list "list" (symbol-name tag))))
(mpc-proc-error
;; If `tag' is not one of the expected tags, MPD burps about not
;; having the relevant table.
@@ -772,7 +770,7 @@ The songs are returned as alists."
(condition-case nil
(if (mpc-cmd-special-tag-p other-tag)
(signal 'mpc-proc-error "Not implemented")
- (mapcar 'cdr
+ (mapcar #'cdr
(mpc-proc-cmd-to-alist
(list "list" (symbol-name tag)
(symbol-name other-tag) value))))
@@ -783,7 +781,7 @@ The songs are returned as alists."
(mpc-assq-all tag
;; Don't use `nconc' now that mpc-cmd-find may
;; return a memoized result.
- (apply 'append other-songs))))))))
+ (apply #'append other-songs))))))))
(defun mpc-cmd-stop (&optional callback)
(mpc-proc-cmd "stop" callback))
@@ -849,7 +847,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
;; Sort them from last to first, so the renumbering
;; caused by the earlier deletions don't affect
;; later ones.
- (sort (copy-sequence song-poss) '>))))
+ (sort (copy-sequence song-poss) #'>))))
(if (stringp playlist)
(puthash (cons 'Playlist playlist) nil mpc--find-memoize)))
@@ -873,7 +871,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
;; Sort them from last to first, so the renumbering
;; caused by the earlier deletions affect
;; later ones a bit less.
- (sort (copy-sequence song-poss) '>))))
+ (sort (copy-sequence song-poss) #'>))))
(if (stringp playlist)
(puthash (cons 'Playlist playlist) nil mpc--find-memoize))))
@@ -884,7 +882,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
(unless callback (mpc-proc-sync))))
(defun mpc-cmd-tagtypes ()
- (mapcar 'cdr (mpc-proc-cmd-to-alist "tagtypes")))
+ (mapcar #'cdr (mpc-proc-cmd-to-alist "tagtypes")))
;; This was never integrated into MPD.
;; (defun mpc-cmd-download (file)
@@ -1000,7 +998,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
(cond
((>= col 0) (insert str))
(t (insert (substring str (min (length str) (- col))))))))
- (pred nil))
+ (pred #'always))
(while (string-match
"%\\(?:%\\|\\(-\\)?\\([0-9]+\\)?{\\([[:alpha:]][[:alnum:]]*\\)\\(?:-\\([^}]+\\)\\)?}\\)"
format-spec pos)
(let ((pre-text (substring format-spec pos (match-beginning 0))))
(funcall insert pre-text)
@@ -1019,7 +1017,7 @@ If PLAYLIST is t or nil or missing, use the main
playlist."
(pcase tag
((or 'Time 'Duration)
(let ((time (cdr (or (assq 'time info) (assq 'Time
info)))))
- (setq pred (list nil)) ;Just assume it's never eq.
+ (setq pred #'ignore) ;Just assume it's never eq.
(when time
(mpc-secs-to-time (if (and (eq tag 'Duration)
(string-match ":" time))
@@ -1028,7 +1026,11 @@ If PLAYLIST is t or nil or missing, use the main
playlist."
('Cover
(let ((dir (file-name-directory (cdr (assq 'file info)))))
;; (debug)
- (push `(equal ',dir (file-name-directory (cdr (assq
'file info)))) pred)
+ (setq pred
+ (lambda (info)
+ (and (funcall pred info)
+ (equal dir (file-name-directory
+ (cdr (assq 'file info)))))))
(if-let* ((covers '(".folder.png" "cover.jpg"
"folder.jpg"))
(cover (cl-loop for file in (directory-files
(mpc-file-local-copy dir))
if (member (downcase file)
covers)
@@ -1045,7 +1047,7 @@ If PLAYLIST is t or nil or missing, use the main
playlist."
(setq size nil)
(propertize dir 'display image))
;; Make sure we return something on which we can
- ;; place the `mpc-pred' property, as
+ ;; place the `mpc--uptodate-p' property, as
;; a negative-cache. We could also use
;; a default cover.
(progn (setq size nil) " "))))
@@ -1054,7 +1056,10 @@ If PLAYLIST is t or nil or missing, use the main
playlist."
;; than the URL in `file'. Pretend it's in `Title'.
(when (and (null val) (eq tag 'Title))
(setq val (cdr (assq 'file info))))
- (push `(equal ',val (cdr (assq ',tag info))) pred)
+ (setq pred
+ (lambda (info)
+ (and (funcall pred info)
+ (equal val (cdr (assq ',tag info))))))
(cond
((not (and (eq tag 'Date) (stringp val))) val)
;; For "date", only keep the year!
@@ -1082,11 +1087,11 @@ If PLAYLIST is t or nil or missing, use the main
playlist."
'follow-link t
'keymap `(keymap
(mouse-2
- . (lambda ()
- (interactive)
- (mpc-constraints-push
'noerror)
- (mpc-constraints-restore
- ',(list (list tag
text)))))))))
+ . ,(lambda ()
+ (interactive)
+ (mpc-constraints-push
'noerror)
+ (mpc-constraints-restore
+ ',(list (list tag
text)))))))))
(funcall insert
(concat (when size
(propertize " " 'display
@@ -1099,35 +1104,34 @@ If PLAYLIST is t or nil or missing, use the main
playlist."
(if (null size) (setq col (+ col textwidth postwidth))
(insert space)
(setq col (+ col size))))))
- (put-text-property start (point) 'mpc-pred
- `(lambda (info) (and ,@(nreverse pred))))))
+ (put-text-property start (point) 'mpc--uptodate-p pred)))
;;; The actual UI code ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar mpc-mode-map
(let ((map (make-sparse-keymap)))
- ;; (define-key map "\e" 'mpc-stop)
- (define-key map "q" 'mpc-quit)
- (define-key map "\r" 'mpc-select)
- (define-key map [(shift return)] 'mpc-select-toggle)
- (define-key map [mouse-2] 'mpc-select)
- (define-key map [S-mouse-2] 'mpc-select-extend)
- (define-key map [C-mouse-2] 'mpc-select-toggle)
- (define-key map [drag-mouse-2] 'mpc-drag-n-drop)
+ ;; (define-key map "\e" #'mpc-stop)
+ (define-key map "q" #'mpc-quit)
+ (define-key map "\r" #'mpc-select)
+ (define-key map [(shift return)] #'mpc-select-toggle)
+ (define-key map [mouse-2] #'mpc-select)
+ (define-key map [S-mouse-2] #'mpc-select-extend)
+ (define-key map [C-mouse-2] #'mpc-select-toggle)
+ (define-key map [drag-mouse-2] #'mpc-drag-n-drop)
;; We use `always' because a binding to t is like a binding to nil.
(define-key map [follow-link] :always)
;; But follow-link doesn't apply blindly to header-line and
;; mode-line clicks.
- (define-key map [header-line follow-link] 'ignore)
- (define-key map [mode-line follow-link] 'ignore)
+ (define-key map [header-line follow-link] #'ignore)
+ (define-key map [mode-line follow-link] #'ignore)
;; Doesn't work because the first click changes the buffer, so the second
;; is applied elsewhere :-(
- ;; (define-key map [(double mouse-2)] 'mpc-play-at-point)
- (define-key map "p" 'mpc-pause)
- (define-key map "s" 'mpc-toggle-play)
- (define-key map ">" 'mpc-next)
- (define-key map "<" 'mpc-prev)
- (define-key map "g" 'mpc-seek-current)
+ ;; (define-key map [(double mouse-2)] #'mpc-play-at-point)
+ (define-key map "p" #'mpc-pause)
+ (define-key map "s" #'mpc-toggle-play)
+ (define-key map ">" #'mpc-next)
+ (define-key map "<" #'mpc-prev)
+ (define-key map "g" #'mpc-seek-current)
map))
(easy-menu-define mpc-mode-menu mpc-mode-map
@@ -1219,7 +1223,7 @@ If PLAYLIST is t or nil or missing, use the main
playlist."
(when (assq 'file mpc-status)
(let ((inhibit-read-only t))
(dolist (spec mpc-status-buffer-format)
- (let ((pred (get-text-property (point) 'mpc-pred)))
+ (let ((pred (get-text-property (point) 'mpc--uptodate-p)))
(if (and pred (funcall pred mpc-status))
(forward-line)
(delete-region (point) (line-beginning-position 2))
@@ -1279,7 +1283,7 @@ If PLAYLIST is t or nil or missing, use the main
playlist."
;; Restore the selection. I.e. move the overlays back to their
;; corresponding location. Actually which overlay is used for what
;; doesn't matter.
- (mapc 'delete-overlay mpc-select)
+ (mapc #'delete-overlay mpc-select)
(setq mpc-select nil)
(dolist (elem selection)
;; After an update, some elements may have disappeared.
@@ -1304,7 +1308,7 @@ If PLAYLIST is t or nil or missing, use the main
playlist."
(interactive (list last-nonmenu-event))
(mpc-event-set-point event)
(if (and (bolp) (eobp)) (forward-line -1))
- (mapc 'delete-overlay mpc-select)
+ (mapc #'delete-overlay mpc-select)
(setq mpc-select nil)
(if (mpc-tagbrowser-all-p)
nil
@@ -1664,12 +1668,12 @@ Return non-nil if a selection was deactivated."
;; (unless (equal constraints mpc-constraints)
;; (setq-local mpc-constraints constraints)
(dolist (cst constraints)
- (let ((vals (apply 'mpc-union
+ (let ((vals (apply #'mpc-union
(mapcar (lambda (val)
(mpc-cmd-list mpc-tag (car cst) val))
(cdr cst)))))
(setq active
- (if (listp active) (mpc-intersection active vals) vals))))
+ (if (listp active) (seq-intersection active vals) vals))))
(when (listp active)
;; Remove the selections if they are all in conflict with
@@ -1683,7 +1687,7 @@ Return non-nil if a selection was deactivated."
(setq mpc--changed-selection t))
(unless nodeactivate
(setq selection nil)
- (mapc 'delete-overlay mpc-select)
+ (mapc #'delete-overlay mpc-select)
(setq mpc-select nil)
(mpc-tagbrowser-all-select))))
@@ -1728,7 +1732,7 @@ Return non-nil if a selection was deactivated."
(defvar mpc-tagbrowser-dir-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map mpc-tagbrowser-mode-map)
- (define-key map [?\M-\C-m] 'mpc-tagbrowser-dir-toggle)
+ (define-key map [?\M-\C-m] #'mpc-tagbrowser-dir-toggle)
map))
;; (defvar mpc-tagbrowser-dir-keywords
@@ -1840,12 +1844,12 @@ A value of t means the main playlist.")
(let ((map (make-sparse-keymap)))
;; Bind the up-events rather than the down-event, so the
;; `message' isn't canceled by the subsequent up-event binding.
- (define-key map [down-mouse-1] 'ignore)
- (define-key map [mouse-1] 'mpc-volume-mouse-set)
- (define-key map [header-line mouse-1] 'mpc-volume-mouse-set)
- (define-key map [header-line down-mouse-1] 'ignore)
- (define-key map [mode-line mouse-1] 'mpc-volume-mouse-set)
- (define-key map [mode-line down-mouse-1] 'ignore)
+ (define-key map [down-mouse-1] #'ignore)
+ (define-key map [mouse-1] #'mpc-volume-mouse-set)
+ (define-key map [header-line mouse-1] #'mpc-volume-mouse-set)
+ (define-key map [header-line down-mouse-1] #'ignore)
+ (define-key map [mode-line mouse-1] #'mpc-volume-mouse-set)
+ (define-key map [mode-line down-mouse-1] #'ignore)
map))
(defvar mpc-volume nil) (put 'mpc-volume 'risky-local-variable t)
@@ -1878,7 +1882,7 @@ A value of t means the main playlist.")
(progn
(message "MPD volume already at %s%%" newvol)
(ding))
- (mpc-proc-cmd (list "setvol" newvol) 'mpc-status-refresh)
+ (mpc-proc-cmd (list "setvol" newvol) #'mpc-status-refresh)
(message "Set MPD volume to %s%%" newvol))))
(defun mpc-volume-widget (vol &optional size)
@@ -1915,7 +1919,7 @@ A value of t means the main playlist.")
(defvar mpc-songs-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map [remap mpc-select] 'mpc-songs-jump-to)
+ (define-key map [remap mpc-select] #'mpc-songs-jump-to)
map))
(defvar mpc-songpointer-set-visible nil)
@@ -1963,7 +1967,7 @@ This is used so that they can be compared with `eq',
which is needed for
(setq mpc-songs-playlist (cadr cst)))
;; We don't do anything really special here for playlists,
;; because it's unclear what's a correct "union" of playlists.
- (let ((vals (apply 'mpc-union
+ (let ((vals (apply #'mpc-union
(mapcar (lambda (val)
(mpc-cmd-find (car cst) val))
(cdr cst)))))
@@ -2337,7 +2341,7 @@ This is used so that they can be compared with `eq',
which is needed for
"Quit Music Player Daemon."
(interactive)
(let* ((proc mpc-proc)
- (bufs (mapcar 'cdr (if proc (process-get proc 'buffers))))
+ (bufs (mapcar #'cdr (if proc (process-get proc 'buffers))))
(wins (mapcar (lambda (buf) (get-buffer-window buf 0)) bufs))
(song-buf (mpc-songs-buf))
frames)
@@ -2358,7 +2362,7 @@ This is used so that they can be compared with `eq',
which is needed for
(unless (memq (window-buffer win) bufs) (setq delete nil)))
(if delete (ignore-errors (delete-frame frame))))))
;; Then kill the buffers.
- (mapc 'kill-buffer bufs)
+ (mapc #'kill-buffer bufs)
(mpc-status-stop)
(if proc (delete-process proc))))
@@ -2521,7 +2525,7 @@ If stopped, start playback."
(setq mpc-last-seek-time
(cons currenttime (setq time (+ time step))))
(mpc-proc-cmd (list "seekid" songid time)
- 'mpc-status-refresh))))
+ #'mpc-status-refresh))))
(let ((status (mpc-cmd-status)))
(let* ((songid (cdr (assq 'songid status)))
(time (if songid (string-to-number
@@ -2531,7 +2535,7 @@ If stopped, start playback."
(lambda ()
(mpc-proc-cmd (list "seekid" songid
(setq time (+ time step)))
- 'mpc-status-refresh)))))
+ #'mpc-status-refresh)))))
(while (mouse-movement-p
(event-basic-type (setq event (read-event)))))
(cancel-timer timer)))))))
@@ -2586,7 +2590,7 @@ If stopped, start playback."
((and (>= songtime songduration) mpc--faster-toggle-forward)
;; Skip to the beginning of the next song.
(if (not (equal (cdr (assq 'state mpc-status)) "play"))
- (mpc-proc-cmd "next" 'mpc-status-refresh)
+ (mpc-proc-cmd "next" #'mpc-status-refresh)
;; If we're playing, this is done automatically, so we
;; don't need to do anything, or rather we *shouldn't*
;; do anything otherwise there's a race condition where
@@ -2618,7 +2622,7 @@ If stopped, start playback."
(condition-case nil
(mpc-proc-cmd
(list "seekid" songid songtime)
- 'mpc-status-refresh)
+ #'mpc-status-refresh)
(mpc-proc-error (mpc-status-refresh)))))))))))
(setq mpc--faster-toggle-forward (> step 0))
(funcall fun) ;Initialize values.
@@ -2702,7 +2706,7 @@ If stopped, start playback."
(error "Not a playlist")
(buffer-substring (line-beginning-position)
(line-end-position)))))
- (mpc-cmd-add (mapcar 'car songs) playlist)
+ (mpc-cmd-add (mapcar #'car songs) playlist)
(message "Added %d songs to %s" (length songs) playlist)
(if (member playlist
(cdr (assq 'Playlist (mpc-constraints-get-current))))
@@ -2714,7 +2718,7 @@ If stopped, start playback."
((eq start-buf end-buf)
;; Moving songs within the shown playlist.
(let ((dest-pos (get-text-property (point) 'mpc-file-pos)))
- (mpc-cmd-move (mapcar 'cdr songs) dest-pos mpc-songs-playlist)
+ (mpc-cmd-move (mapcar #'cdr songs) dest-pos mpc-songs-playlist)
(message "Moved %d songs" (length songs))))
(t
;; Adding songs to the shown playlist.
@@ -2725,10 +2729,10 @@ If stopped, start playback."
;; MPD's protocol does not let us add songs at a particular
;; position in a playlist, so we first have to add them to the
;; end, and then move them to their final destination.
- (mpc-cmd-add (mapcar 'car songs) mpc-songs-playlist)
+ (mpc-cmd-add (mapcar #'car songs) mpc-songs-playlist)
(mpc-cmd-move (let ((poss '()))
(dotimes (i (length songs))
- (push (+ i (length pl)) poss))
+ (push (+ i (length pl)) poss))
(nreverse poss))
dest-pos mpc-songs-playlist)
(message "Added %d songs" (length songs)))))
diff --git a/lisp/msb.el b/lisp/msb.el
index 14209d9..1064f94 100644
--- a/lisp/msb.el
+++ b/lisp/msb.el
@@ -1,4 +1,4 @@
-;;; msb.el --- customizable buffer-selection with multiple menus
+;;; msb.el --- customizable buffer-selection with multiple menus -*-
lexical-binding: t; -*-
;; Copyright (C) 1993-1995, 1997-2021 Free Software Foundation, Inc.
@@ -252,14 +252,12 @@ error every time you do \\[msb]."
:type `(choice (const :tag "long" :value ,msb--very-many-menus)
(const :tag "short" :value ,msb--few-menus)
(sexp :tag "user"))
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(defcustom msb-modes-key 4000
"The sort key for files sorted by mode."
:type 'integer
- :set 'msb-custom-set
- :group 'msb
+ :set #'msb-custom-set
:version "20.3")
(defcustom msb-separator-diff 100
@@ -267,8 +265,7 @@ error every time you do \\[msb]."
The separators will appear between all menus that have a sorting key
that differs by this value or more."
:type '(choice integer (const nil))
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(defvar msb-files-by-directory-sort-key 0
"The sort key for files sorted by directory.")
@@ -278,8 +275,7 @@ that differs by this value or more."
If this variable is set to 15 for instance, then the submenu will be
split up in minor parts, 15 items each. A value of nil means no limit."
:type '(choice integer (const nil))
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(defcustom msb-max-file-menu-items 10
"The maximum number of items from different directories.
@@ -293,27 +289,23 @@ them together.
If the value is not a number, then the value 10 is used."
:type 'integer
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(defcustom msb-most-recently-used-sort-key -1010
"Where should the menu with the most recently used buffers be placed?"
:type 'integer
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(defcustom msb-display-most-recently-used 15
"How many buffers should be in the most-recently-used menu.
No buffers at all if less than 1 or nil (or any non-number)."
:type 'integer
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(defcustom msb-most-recently-used-title "Most recently used (%d)"
"The title for the most-recently-used menu."
:type 'string
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(defvar msb-horizontal-shift-function (lambda () 0)
"Function that specifies how many pixels to shift the top menu leftwards.")
@@ -323,8 +315,7 @@ No buffers at all if less than 1 or nil (or any
non-number)."
Non-nil means that the buffer menu should include buffers that have
names that starts with a space character."
:type 'boolean
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(defvar msb-item-handling-function 'msb-item-handler
"The appearance of a buffer menu.
@@ -354,15 +345,13 @@ Set this to nil or t if you don't want any sorting
(faster)."
:type '(choice (const msb-sort-by-name)
(const :tag "Newest first" t)
(const :tag "Oldest first" nil))
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(defcustom msb-files-by-directory nil
"Non-nil means that files should be sorted by directory.
This is instead of the groups in `msb-menu-cond'."
:type 'boolean
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(define-obsolete-variable-alias 'msb-after-load-hooks
'msb-after-load-hook "24.1")
@@ -370,8 +359,7 @@ This is instead of the groups in `msb-menu-cond'."
(defcustom msb-after-load-hook nil
"Hook run after the msb package has been loaded."
:type 'hook
- :set 'msb-custom-set
- :group 'msb)
+ :set #'msb-custom-set)
(make-obsolete-variable 'msb-after-load-hook
"use `with-eval-after-load' instead." "28.1")
@@ -458,10 +446,10 @@ An item look like (NAME . BUFFER)."
;;;
;;; msb
-;;;
-;;; This function can be used instead of (mouse-buffer-menu EVENT)
-;;; function in "mouse.el".
-;;;
+;;
+;; This function can be used instead of (mouse-buffer-menu EVENT)
+;; function in "mouse.el".
+;;
(defun msb (event)
"Pop up several menus of buffers for selection with the mouse.
This command switches buffers in the window that you clicked on, and
@@ -707,7 +695,7 @@ See `msb-menu-cond' for a description of its elements."
(cl-loop for fi
across function-info-vector
if (and (setq result
- (eval (aref fi 1))) ;Test CONDITION
+ (eval (aref fi 1) t)) ;Test CONDITION
(not (and (eq result 'no-multi)
multi-flag))
(progn (when (eq result 'multi)
@@ -727,12 +715,11 @@ All side-effects. Adds an element of form (BUFFER-TITLE
. BUFFER)
to the buffer-list variable in FUNCTION-INFO."
(let ((list-symbol (aref function-info 0))) ;BUFFER-LIST-VARIABLE
;; Here comes the hairy side-effect!
- (set list-symbol
- (cons (cons (funcall (aref function-info 4) ;ITEM-HANDLER
- buffer
- max-buffer-name-length)
- buffer)
- (eval list-symbol)))))
+ (push (cons (funcall (aref function-info 4) ;ITEM-HANDLER
+ buffer
+ max-buffer-name-length)
+ buffer)
+ (symbol-value list-symbol))))
(defsubst msb--choose-menu (buffer function-info-vector max-buffer-name-length)
"Select the appropriate menu for BUFFER."
@@ -754,7 +741,7 @@ to the buffer-list variable in FUNCTION-INFO."
(defun msb--create-sort-item (function-info)
"Return (SORT-KEY TITLE . BUFFER-LIST) or nil if the buffer-list is empty."
- (let ((buffer-list (eval (aref function-info 0))))
+ (let ((buffer-list (symbol-value (aref function-info 0))))
(when buffer-list
(let ((sorter (aref function-info 5)) ;SORTER
(sort-key (aref function-info 2))) ;MENU-SORT-KEY
@@ -925,7 +912,7 @@ It takes the form ((TITLE . BUFFER-LIST)...)."
for value = (msb--create-sort-item elt)
if value collect value))))
(setq menu
- (mapcar 'cdr ;Remove the SORT-KEY
+ (mapcar #'cdr ;Remove the SORT-KEY
;; Sort the menus - not the items.
(msb--add-separators
(sort
@@ -1113,8 +1100,8 @@ variable `msb-menu-cond'."
(nconc
(list (frame-parameter frame 'name)
(frame-parameter frame 'name))
- `(lambda ()
- (interactive) (menu-bar-select-frame ,frame))))
+ (lambda ()
+ (interactive) (menu-bar-select-frame frame))))
frames)))))
(setcdr global-buffers-menu-map
(if (and buffers-menu frames-menu)
@@ -1128,7 +1115,7 @@ variable `msb-menu-cond'."
;; C-down-mouse-1).
(defvar msb-mode-map
(let ((map (make-sparse-keymap "Msb")))
- (define-key map [remap mouse-buffer-menu] 'msb)
+ (define-key map [remap mouse-buffer-menu] #'msb)
map))
;;;###autoload
@@ -1137,14 +1124,14 @@ variable `msb-menu-cond'."
This mode overrides the binding(s) of `mouse-buffer-menu' to provide a
different buffer menu using the function `msb'."
- :global t :group 'msb
+ :global t
(if msb-mode
(progn
- (add-hook 'menu-bar-update-hook 'msb-menu-bar-update-buffers)
- (remove-hook 'menu-bar-update-hook 'menu-bar-update-buffers)
+ (add-hook 'menu-bar-update-hook #'msb-menu-bar-update-buffers)
+ (remove-hook 'menu-bar-update-hook #'menu-bar-update-buffers)
(msb-menu-bar-update-buffers t))
- (remove-hook 'menu-bar-update-hook 'msb-menu-bar-update-buffers)
- (add-hook 'menu-bar-update-hook 'menu-bar-update-buffers)
+ (remove-hook 'menu-bar-update-hook #'msb-menu-bar-update-buffers)
+ (add-hook 'menu-bar-update-hook #'menu-bar-update-buffers)
(menu-bar-update-buffers t)))
(defun msb-unload-function ()
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el
index 86b5d44..04ea809 100644
--- a/lisp/net/ange-ftp.el
+++ b/lisp/net/ange-ftp.el
@@ -6258,10 +6258,6 @@ be recognized automatically (they are all valid BS2000
hosts too)."
;; ange-ftp-bs2000-file-name-as-directory
;; ange-ftp-bs2000-make-compressed-filename
;; ange-ftp-bs2000-file-name-sans-versions
-
-;;;; ------------------------------------------------------------
-;;;; Finally provide package.
-;;;; ------------------------------------------------------------
(provide 'ange-ftp)
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index 32fe857..eec3ec7 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -987,6 +987,7 @@ the like."
(define-key map "F" 'eww-toggle-fonts)
(define-key map "D" 'eww-toggle-paragraph-direction)
(define-key map [(meta C)] 'eww-toggle-colors)
+ (define-key map [(meta I)] 'eww-toggle-images)
(define-key map "b" 'eww-add-bookmark)
(define-key map "B" 'eww-list-bookmarks)
@@ -1015,6 +1016,7 @@ the like."
["List cookies" url-cookie-list t]
["Toggle fonts" eww-toggle-fonts t]
["Toggle colors" eww-toggle-colors t]
+ ["Toggle images" eww-toggle-images t]
["Character Encoding" eww-set-character-encoding]
["Toggle Paragraph Direction" eww-toggle-paragraph-direction]))
map))
@@ -1893,6 +1895,14 @@ If CHARSET is nil then use UTF-8."
"off"))
(eww-reload))
+(defun eww-toggle-images ()
+ "Toggle whether or not to display images."
+ (interactive nil eww-mode)
+ (setq shr-inhibit-images (not shr-inhibit-images))
+ (eww-reload)
+ (message "Images are now %s"
+ (if shr-inhibit-images "off" "on")))
+
;;; Bookmarks code
(defvar eww-bookmarks nil)
diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el
index 683abaa..43dd9dc 100644
--- a/lisp/net/gnutls.el
+++ b/lisp/net/gnutls.el
@@ -336,8 +336,8 @@ defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT."
t)
;; if a list, look for hostname matches
((listp gnutls-verify-error)
- (cadr (cl-find-if #'(lambda (x)
- (string-match (car x)
hostname))
+ (cadr (cl-find-if (lambda (x)
+ (string-match (car x)
hostname))
gnutls-verify-error)))
;; else it's nil
(t nil))))
diff --git a/lisp/net/goto-addr.el b/lisp/net/goto-addr.el
index af12f69..8992ef7 100644
--- a/lisp/net/goto-addr.el
+++ b/lisp/net/goto-addr.el
@@ -263,9 +263,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."
- nil
- ""
- nil
+ :lighter ""
(if goto-address-mode
(jit-lock-register #'goto-address-fontify-region)
(jit-lock-unregister #'goto-address-fontify-region)
@@ -285,9 +283,7 @@ Also fontifies the buffer appropriately (see
`goto-address-fontify-p' and
;;;###autoload
(define-minor-mode goto-address-prog-mode
"Like `goto-address-mode', but only for comments and strings."
- nil
- ""
- nil
+ :lighter ""
(if goto-address-prog-mode
(jit-lock-register #'goto-address-fontify-region)
(jit-lock-unregister #'goto-address-fontify-region)
diff --git a/lisp/net/imap.el b/lisp/net/imap.el
index 052ef29..d29584e 100644
--- a/lisp/net/imap.el
+++ b/lisp/net/imap.el
@@ -737,9 +737,9 @@ sure of changing the value of `foo'."
:end-of-command "\r\n"
:success "^1 OK "
:starttls-function
- #'(lambda (capabilities)
- (when (string-match-p "STARTTLS" capabilities)
- "1 STARTTLS\r\n"))))
+ (lambda (capabilities)
+ (when (string-match-p "STARTTLS" capabilities)
+ "1 STARTTLS\r\n"))))
done)
(when process
(imap-log buffer)
diff --git a/lisp/net/net-utils.el b/lisp/net/net-utils.el
index 3a561a0..24f2aba 100644
--- a/lisp/net/net-utils.el
+++ b/lisp/net/net-utils.el
@@ -857,9 +857,14 @@ and `network-connection-service-alist', which see."
;; FIXME: modern whois clients include a much better tld <-> whois server
;; list, Emacs should probably avoid specifying the server as the client
;; will DTRT anyway... -rfr
+;; I'm not sure about the above FIXME. It seems to me that we should
+;; just check the Root Zone Database maintained at:
+;; https://www.iana.org/domains/root/db
+;; For example: whois -h whois.iana.org .se | grep whois
(defcustom whois-server-tld
- '(("rs.internic.net" . "com")
- ("whois.publicinterestregistry.net" . "org")
+ '(("whois.verisign-grs.com" . "com")
+ ("whois.verisign-grs.com" . "net")
+ ("whois.pir.org" . "org")
("whois.ripe.net" . "be")
("whois.ripe.net" . "de")
("whois.ripe.net" . "dk")
@@ -867,10 +872,13 @@ and `network-connection-service-alist', which see."
("whois.ripe.net" . "fi")
("whois.ripe.net" . "fr")
("whois.ripe.net" . "uk")
+ ("whois.iis.se" . "se")
+ ("whois.iis.nu" . "nu")
("whois.apnic.net" . "au")
("whois.apnic.net" . "ch")
("whois.apnic.net" . "hk")
("whois.apnic.net" . "jp")
+ ("whois.eu" . "eu")
("whois.nic.gov" . "gov")
("whois.nic.mil" . "mil"))
"Alist to map top level domains to whois servers."
diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el
index 1d3a5e0..e623dab 100644
--- a/lisp/net/newst-backend.el
+++ b/lisp/net/newst-backend.el
@@ -1680,6 +1680,7 @@ Sat, 07 Sep 2002 00:00:01 GMT
nil))))
nil))
+;; FIXME: Can this be replaced by seq-intersection?
(defun newsticker--lists-intersect-p (list1 list2)
"Return t if LIST1 and LIST2 share elements."
(let ((result nil))
diff --git a/lisp/net/newst-ticker.el b/lisp/net/newst-ticker.el
index 2f76470..8cfafb5 100644
--- a/lisp/net/newst-ticker.el
+++ b/lisp/net/newst-ticker.el
@@ -1,4 +1,4 @@
-;; newst-ticker.el --- mode line ticker for newsticker. -*- lexical-binding:
t; -*-
+;;; newst-ticker.el --- mode line ticker for newsticker. -*- lexical-binding:
t; -*-
;; Copyright (C) 2003-2021 Free Software Foundation, Inc.
diff --git a/lisp/net/newst-treeview.el b/lisp/net/newst-treeview.el
index 29c92d5..d524e6d 100644
--- a/lisp/net/newst-treeview.el
+++ b/lisp/net/newst-treeview.el
@@ -31,10 +31,6 @@
;; See newsticker.el
;; ======================================================================
-;;; History:
-;;
-
-;; ======================================================================
;;; Code:
(require 'cl-lib)
(require 'newst-reader)
diff --git a/lisp/net/pop3.el b/lisp/net/pop3.el
index dcac36f..cb49f75 100644
--- a/lisp/net/pop3.el
+++ b/lisp/net/pop3.el
@@ -725,9 +725,9 @@ Otherwise, return the size of the message-id MSG."
(setq pop3-read-point (point-marker))
(goto-char (match-beginning 0))
(setq end (point-marker))
- (mapcar #'(lambda (s) (let ((split (split-string s " ")))
- (cons (string-to-number (nth 0 split))
- (string-to-number (nth 1 split)))))
+ (mapcar (lambda (s) (let ((split (split-string s " ")))
+ (cons (string-to-number (nth 0 split))
+ (string-to-number (nth 1 split)))))
(split-string (buffer-substring start end) "\r\n" t)))))))
(defun pop3-retr (process msg crashbuf)
diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el
index 938fadf..7251640 100644
--- a/lisp/net/rcirc.el
+++ b/lisp/net/rcirc.el
@@ -196,7 +196,7 @@ If nil, no maximum is applied."
Uninteresting lines are those whose responses are listed in
`rcirc-omit-responses'."
- nil " Omit" nil
+ :lighter " Omit"
(if rcirc-omit-mode
(progn
(add-to-invisibility-spec '(rcirc-omit . nil))
@@ -1166,9 +1166,10 @@ If ALL is non-nil, update prompts in all IRC buffers."
(or (eq (aref target 0) ?#)
(eq (aref target 0) ?&))))
-(defcustom rcirc-log-directory "~/.emacs.d/rcirc-log"
+(defcustom rcirc-log-directory (locate-user-emacs-file "rcirc-log")
"Directory to keep IRC logfiles."
- :type 'directory)
+ :type 'directory
+ :version "28.1")
(defcustom rcirc-log-flag nil
"Non-nil means log IRC activity to disk.
@@ -1359,9 +1360,7 @@ Create the buffer if it doesn't exist."
(define-minor-mode rcirc-multiline-minor-mode
"Minor mode for editing multiple lines in rcirc."
- :init-value nil
:lighter " rcirc-mline"
- :keymap rcirc-multiline-minor-mode-map
:global nil
(setq fill-column rcirc-max-message-length))
@@ -1863,9 +1862,6 @@ 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."
- :init-value nil
- :lighter ""
- :keymap rcirc-track-minor-mode-map
:global t
(or global-mode-string (setq global-mode-string '("")))
;; toggle the mode-line channel indicator
diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el
index 94db318..4102b9d 100644
--- a/lisp/net/secrets.el
+++ b/lisp/net/secrets.el
@@ -957,3 +957,5 @@ to their attributes."
;; * Check, whether the dh-ietf1024-aes128-cbc-pkcs7 algorithm can be
;; used for the transfer of the secrets. Currently, we use the
;; plain algorithm.
+
+;;; secrets.el ends here
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index c122a19..cbdeb65 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -183,8 +183,10 @@ temporarily blinks with this face."
"Face for <abbr> elements."
:version "27.1")
-(defvar shr-inhibit-images nil
- "If non-nil, inhibit loading images.")
+(defcustom shr-inhibit-images nil
+ "If non-nil, inhibit loading images."
+ :version "28.1"
+ :type 'boolean)
(defvar shr-external-rendering-functions nil
"Alist of tag/function pairs used to alter how shr renders certain tags.
@@ -313,6 +315,12 @@ DOM should be a parse tree as generated by
(* (frame-char-width) 2))
1))))
(max-specpdl-size max-specpdl-size)
+ ;; `bidi-display-reordering' is supposed to be only used for
+ ;; debugging purposes, but Shr's naïve filling algorithm
+ ;; cannot cope with the complexity of RTL text in an LTR
+ ;; paragraph, when a long line has been continued, and for
+ ;; most scripts the character metrics don't change when they
+ ;; are reordered, so... this is the best we could do :-(
bidi-display-reordering)
;; Adjust for max width specification.
(when (and shr-max-width
diff --git a/lisp/net/sieve-manage.el b/lisp/net/sieve-manage.el
index c4d6ec4..5dad5f4 100644
--- a/lisp/net/sieve-manage.el
+++ b/lisp/net/sieve-manage.el
@@ -580,4 +580,4 @@ to local variable `sieve-manage-capability'."
(provide 'sieve-manage)
-;; sieve-manage.el ends here
+;;; sieve-manage.el ends here
diff --git a/lisp/net/sieve-mode.el b/lisp/net/sieve-mode.el
index 966f0f0..0e8fdc0 100644
--- a/lisp/net/sieve-mode.el
+++ b/lisp/net/sieve-mode.el
@@ -206,4 +206,4 @@ Turning on Sieve mode runs `sieve-mode-hook'."
(provide 'sieve-mode)
-;; sieve-mode.el ends here
+;;; sieve-mode.el ends here
diff --git a/lisp/net/sieve.el b/lisp/net/sieve.el
index 595d633..6d571a0 100644
--- a/lisp/net/sieve.el
+++ b/lisp/net/sieve.el
@@ -379,4 +379,4 @@ Used to bracket operations which move point in the
sieve-buffer."
(provide 'sieve)
-;; sieve.el ends here
+;;; sieve.el ends here
diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
index 0bbd927..61c40ff 100644
--- a/lisp/net/tramp-archive.el
+++ b/lisp/net/tramp-archive.el
@@ -628,10 +628,8 @@ offered."
(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)))))
+ (when visit (setq buffer-file-name filename))
+ (cons (expand-file-name filename) (cdr result))))
(defun tramp-archive-handle-load
(file &optional noerror nomessage nosuffix must-suffix)
diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el
index d208f0e..a3cf6f3 100644
--- a/lisp/net/tramp-cmds.el
+++ b/lisp/net/tramp-cmds.el
@@ -472,6 +472,49 @@ For details, see `tramp-rename-files'."
(function-put
#'tramp-rename-these-files 'completion-predicate #'tramp-command-completion-p)
+;; This function takes action since Emacs 28.1, when
+;; `read-extended-command-predicate' is set to
+;; `command-completion-default-include-p'.
+;;;###tramp-autoload
+(defun tramp-recompile-elpa-command-completion-p (_symbol _buffer)
+ "A predicate for `tramp-recompile-elpa'.
+It is completed by \"M-x TAB\" only if package.el is loaded, and
+Tramp is an installed ELPA package."
+ ;; We cannot apply `package-installed-p', this would also return the
+ ;; builtin package.
+ (and (assq 'tramp (bound-and-true-p package-alist))
+ (tramp-compat-funcall 'package--user-installed-p 'tramp)))
+
+;;;###tramp-autoload
+(defun tramp-recompile-elpa ()
+ "Recompile the installed Tramp ELPA package.
+This is needed if there are compatibility problems."
+ ;; (declare (completion tramp-recompile-elpa-command-completion-p))
+ (interactive)
+ ;; We expect just one Tramp package is installed.
+ (when-let
+ ((dir (tramp-compat-funcall
+ 'package-desc-dir
+ (car (alist-get 'tramp (bound-and-true-p package-alist))))))
+ (dolist (elc (directory-files dir 'full "\\.elc$"))
+ (delete-file elc))
+ (with-current-buffer (get-buffer-create byte-compile-log-buffer)
+ (let ((inhibit-read-only t))
+ (compilation-mode)
+ (goto-char (point-max))
+ (insert "\f\n")
+ (call-process
+ (expand-file-name invocation-name invocation-directory) nil t t
+ "-Q" "-batch" "-L" dir
+ "--eval" (format "(byte-recompile-directory %S 0 t)" dir))
+ (message "Package `tramp' recompiled.")))))
+
+;; Starting with Emacs 28.1, this can be replaced by the "(declare ...)" form.
+;;;###tramp-autoload
+(function-put
+ #'tramp-recompile-elpa 'completion-predicate
+ #'tramp-recompile-elpa-command-completion-p)
+
;; Tramp version is useful in a number of situations.
;;;###tramp-autoload
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 1764f2e..b51ba11 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -103,12 +103,12 @@ detected as prompt when being sent on echoing hosts,
therefore.")
(defconst tramp-end-of-heredoc (md5 tramp-end-of-output)
"String used to recognize end of heredoc strings.")
-(defcustom tramp-use-ssh-controlmaster-options t
+(defcustom tramp-use-ssh-controlmaster-options (not (eq system-type
'windows-nt))
"Whether to use `tramp-ssh-controlmaster-options'.
Set it to nil, if you use Control* or Proxy* options in your ssh
configuration."
:group 'tramp
- :version "24.4"
+ :version "28.1"
:type 'boolean)
(defvar tramp-ssh-controlmaster-options nil
@@ -169,7 +169,8 @@ The string is used in `tramp-methods'.")
(tramp-login-program "ssh")
(tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
("-e" "none") ("-t" "-t")
- ("-o" "RemoteCommand='%l'")
("%h")))
+ ("-o" "RemoteCommand=\"%l\"")
+ ("%h")))
(tramp-async-args (("-q")))
(tramp-remote-shell ,tramp-default-remote-shell)
(tramp-remote-shell-login ("-l"))
@@ -225,7 +226,8 @@ The string is used in `tramp-methods'.")
(tramp-login-program "ssh")
(tramp-login-args (("-l" "%u") ("-p" "%p") ("%c")
("-e" "none") ("-t" "-t")
- ("-o" "RemoteCommand='%l'")
("%h")))
+ ("-o" "RemoteCommand=\"%l\"")
+ ("%h")))
(tramp-async-args (("-q")))
(tramp-remote-shell ,tramp-default-remote-shell)
(tramp-remote-shell-login ("-l"))
@@ -399,16 +401,34 @@ The string is used in `tramp-methods'.")
;;;###tramp-autoload
(defconst tramp-completion-function-alist-ssh
- '((tramp-parse-rhosts "/etc/hosts.equiv")
+ `((tramp-parse-rhosts "/etc/hosts.equiv")
(tramp-parse-rhosts "/etc/shosts.equiv")
- (tramp-parse-shosts "/etc/ssh_known_hosts")
- (tramp-parse-sconfig "/etc/ssh_config")
+ ;; On W32 systems, the ssh directory is located somewhere else.
+ (tramp-parse-shosts ,(expand-file-name
+ "ssh/ssh_known_hosts"
+ (or (and (eq system-type 'windows-nt)
+ (getenv "ProgramData"))
+ "/etc/")))
+ (tramp-parse-sconfig ,(expand-file-name
+ "ssh/ssh_config"
+ (or (and (eq system-type 'windows-nt)
+ (getenv "ProgramData"))
+ "/etc/")))
(tramp-parse-shostkeys "/etc/ssh2/hostkeys")
(tramp-parse-sknownhosts "/etc/ssh2/knownhosts")
(tramp-parse-rhosts "~/.rhosts")
(tramp-parse-rhosts "~/.shosts")
- (tramp-parse-shosts "~/.ssh/known_hosts")
- (tramp-parse-sconfig "~/.ssh/config")
+ ;; On W32 systems, the .ssh directory is located somewhere else.
+ (tramp-parse-shosts ,(expand-file-name
+ ".ssh/known_hosts"
+ (or (and (eq system-type 'windows-nt)
+ (getenv "USERPROFILE"))
+ "~/")))
+ (tramp-parse-sconfig ,(expand-file-name
+ ".ssh/config"
+ (or (and (eq system-type 'windows-nt)
+ (getenv "USERPROFILE"))
+ "~/")))
(tramp-parse-shostkeys "~/.ssh2/hostkeys")
(tramp-parse-sknownhosts "~/.ssh2/knownhosts"))
"Default list of (FUNCTION FILE) pairs to be examined for ssh methods.")
@@ -431,7 +451,7 @@ The string is used in `tramp-methods'.")
;;;###tramp-autoload
(defconst tramp-completion-function-alist-putty
`((tramp-parse-putty
- ,(if (memq system-type '(windows-nt))
+ ,(if (eq system-type 'windows-nt)
"HKEY_CURRENT_USER\\Software\\SimonTatham\\PuTTY\\Sessions"
"~/.putty/sessions")))
"Default list of (FUNCTION REGISTRY) pairs to be examined for putty
sessions.")
@@ -941,7 +961,7 @@ Format specifiers \"%s\" are replaced before the script is
used.")
(file-name-directory . tramp-handle-file-name-directory)
(file-name-nondirectory . tramp-handle-file-name-nondirectory)
;; `file-name-sans-versions' performed by default handler.
- (file-newer-than-file-p . tramp-sh-handle-file-newer-than-file-p)
+ (file-newer-than-file-p . tramp-handle-file-newer-than-file-p)
(file-notify-add-watch . tramp-sh-handle-file-notify-add-watch)
(file-notify-rm-watch . tramp-handle-file-notify-rm-watch)
(file-notify-valid-p . tramp-handle-file-notify-valid-p)
@@ -1549,49 +1569,6 @@ ID-FORMAT valid values are `string' and `integer'."
(or (tramp-check-cached-permissions v ?r)
(tramp-run-test "-r" filename)))))
-;; When the remote shell is started, it looks for a shell which groks
-;; tilde expansion. Here, we assume that all shells which grok tilde
-;; expansion will also provide a `test' command which groks `-nt' (for
-;; newer than). If this breaks, tell me about it and I'll try to do
-;; something smarter about it.
-(defun tramp-sh-handle-file-newer-than-file-p (file1 file2)
- "Like `file-newer-than-file-p' for Tramp files."
- (cond ((not (file-exists-p file1)) nil)
- ((not (file-exists-p file2)) t)
- (t ;; We are sure both files exist at this point. We try to
- ;; get the mtime of both files. If they are not equal to
- ;; the "dont-know" value, then we subtract the times and
- ;; obtain the result.
- (let ((fa1 (file-attributes file1))
- (fa2 (file-attributes file2)))
- (if (and
- (not
- (tramp-compat-time-equal-p
- (tramp-compat-file-attribute-modification-time fa1)
- tramp-time-dont-know))
- (not
- (tramp-compat-time-equal-p
- (tramp-compat-file-attribute-modification-time fa2)
- tramp-time-dont-know)))
- (time-less-p
- (tramp-compat-file-attribute-modification-time fa2)
- (tramp-compat-file-attribute-modification-time fa1))
- ;; If one of them is the dont-know value, then we can
- ;; still try to run a shell command on the remote host.
- ;; However, this only works if both files are Tramp
- ;; files and both have the same method, same user, same
- ;; host.
- (unless (tramp-equal-remote file1 file2)
- (with-parsed-tramp-file-name
- (if (tramp-tramp-file-p file1) file1 file2) nil
- (tramp-error
- v 'file-error
- "Files %s and %s must have same method, user, host"
- file1 file2)))
- (with-parsed-tramp-file-name file1 nil
- (tramp-run-test2
- (tramp-get-test-nt-command v) file1 file2)))))))
-
;; Functions implemented using the basic functions above.
(defun tramp-sh-handle-file-directory-p (filename)
@@ -2241,7 +2218,7 @@ The method used must be an out-of-band method."
(t2 (tramp-tramp-file-p newname))
(orig-vec (tramp-dissect-file-name (if t1 filename newname)))
copy-program copy-args copy-env copy-keep-date listener spec
- options source target remote-copy-program remote-copy-args)
+ options source target remote-copy-program remote-copy-args p)
(with-parsed-tramp-file-name (if t1 filename newname) nil
(if (and t1 t2)
@@ -2276,10 +2253,10 @@ The method used must be an out-of-band method."
#'identity)
(if t1
(tramp-make-copy-program-file-name v)
- (tramp-unquote-shell-quote-argument filename)))
+ (tramp-compat-file-name-unquote filename)))
target (if t2
(tramp-make-copy-program-file-name v)
- (tramp-unquote-shell-quote-argument newname)))
+ (tramp-compat-file-name-unquote newname)))
;; Check for user. There might be an interactive setting.
(setq user (or (tramp-file-name-user v)
@@ -2311,6 +2288,13 @@ The method used must be an out-of-band method."
;; keep-date argument is non-nil), or a replacement for
;; the whole keep-date sublist.
(delete " " (apply #'tramp-expand-args v 'tramp-copy-args spec))
+ ;; `tramp-ssh-controlmaster-options' is a string instead
+ ;; of a list. Unflatten it.
+ copy-args
+ (tramp-compat-flatten-tree
+ (mapcar
+ (lambda (x) (if (string-match-p " " x) (split-string x) x))
+ copy-args))
copy-env (apply #'tramp-expand-args v 'tramp-copy-env spec)
remote-copy-program
(tramp-get-method-parameter v 'tramp-remote-copy-program)
@@ -2372,31 +2356,26 @@ The method used must be an out-of-band method."
copy-args
(if remote-copy-program
(list (if t1 (concat ">" target) (concat "<" source)))
- (list source target))))
-
- ;; Use an asynchronous process. By this, password can
- ;; be handled. We don't set a timeout, because the
- ;; copying of large files can last longer than 60 secs.
- (let* ((command
- (mapconcat
- #'identity (append (list copy-program) copy-args)
- " "))
- (p (let ((default-directory
- (tramp-compat-temporary-file-directory)))
- (start-process-shell-command
- (tramp-get-connection-name v)
- (tramp-get-connection-buffer v)
- command))))
- (tramp-message orig-vec 6 "%s" command)
- (process-put p 'vector orig-vec)
- (process-put p 'adjust-window-size-function #'ignore)
- (set-process-query-on-exit-flag p nil)
-
- ;; We must adapt `tramp-local-end-of-line' for
- ;; sending the password.
- (let ((tramp-local-end-of-line tramp-rsh-end-of-line))
- (tramp-process-actions
- p v nil tramp-actions-copy-out-of-band))))
+ (list source target)))
+ ;; Use an asynchronous process. By this, password
+ ;; can be handled. We don't set a timeout, because
+ ;; the copying of large files can last longer than 60
+ ;; secs.
+ p (apply
+ #'start-process
+ (tramp-get-connection-name v)
+ (tramp-get-connection-buffer v)
+ copy-program copy-args))
+ (tramp-message orig-vec 6 "%s" (string-join (process-command p)
" "))
+ (process-put p 'vector orig-vec)
+ (process-put p 'adjust-window-size-function #'ignore)
+ (set-process-query-on-exit-flag p nil)
+
+ ;; We must adapt `tramp-local-end-of-line' for
+ ;; sending the password.
+ (let ((tramp-local-end-of-line tramp-rsh-end-of-line))
+ (tramp-process-actions
+ p v nil tramp-actions-copy-out-of-band)))
;; Reset the transfer process properties.
(tramp-flush-connection-property v "process-name")
@@ -2584,12 +2563,9 @@ The method used must be an out-of-band method."
(save-restriction
(narrow-to-region beg-marker end-marker)
;; Check for "--dired" output.
- (forward-line -2)
- (when (looking-at-p "//SUBDIRED//")
- (forward-line -1))
- (when (looking-at "//DIRED//\\s-+")
- (let ((beg (match-end 0))
- (end (point-at-eol)))
+ (when (re-search-backward "^//DIRED//\\s-+\\(.+\\)$" nil 'noerror)
+ (let ((beg (match-beginning 1))
+ (end (match-end 0)))
;; Now read the numeric positions of file names.
(goto-char beg)
(while (< (point) end)
@@ -2599,7 +2575,7 @@ The method used must be an out-of-band method."
;; End is followed by \n or by " -> ".
(put-text-property start end 'dired-filename t))))))
;; Remove trailing lines.
- (goto-char (point-at-bol))
+ (beginning-of-line)
(while (looking-at "//")
(forward-line 1)
(delete-region (match-beginning 0) (point))))
@@ -2947,15 +2923,19 @@ alternative implementation will be used."
;; until the process is deleted.
(when (bufferp stderr)
(with-current-buffer stderr
- (insert-file-contents-literally remote-tmpstderr))
+ ;; There's a mysterious error, see
+ ;; <https://github.com/joaotavora/eglot/issues/662>.
+ (ignore-errors
+ (insert-file-contents-literally
remote-tmpstderr)))
;; Delete tmpstderr file.
(add-function
:after (process-sentinel p)
(lambda (_proc _msg)
(when (file-exists-p remote-tmpstderr)
(with-current-buffer stderr
- (insert-file-contents-literally
- remote-tmpstderr nil nil nil 'replace))
+ (ignore-errors
+ (insert-file-contents-literally
+ remote-tmpstderr nil nil nil 'replace)))
(delete-file remote-tmpstderr)))))
;; Return process.
p)))
@@ -3728,7 +3708,8 @@ Fall back to normal file name handler if no Tramp handler
exists."
(remote-prefix
(with-current-buffer (process-buffer proc)
(file-remote-p default-directory)))
- (rest-string (process-get proc 'rest-string)))
+ (rest-string (process-get proc 'rest-string))
+ pos)
(when rest-string
(tramp-message proc 10 "Previous string:\n%s" rest-string))
(tramp-message proc 6 "%S\n%s" proc string)
@@ -3750,23 +3731,27 @@ Fall back to normal file name handler if no Tramp
handler exists."
;; Determine monitor name.
(unless (tramp-connection-property-p proc "gio-file-monitor")
- (cond
- ;; We have seen this only on cygwin gio, which uses the
- ;; GPollFileMonitor.
- ((string-match
- "Can't find module 'help' specified in GIO_USE_FILE_MONITOR" string)
- (tramp-set-connection-property
- proc "gio-file-monitor" 'GPollFileMonitor))
- ;; TODO: What happens, if several monitor names are reported?
- ((string-match "\
+ (tramp-set-connection-property
+ proc "gio-file-monitor"
+ (cond
+ ;; We have seen this on cygwin gio and on emba. Let's make
+ ;; some assumptions.
+ ((string-match
+ "Can't find module 'help' specified in GIO_USE_FILE_MONITOR"
string)
+ (setq pos (match-end 0))
+ (cond
+ ((getenv "EMACS_EMBA_CI") 'GInotifyFileMonitor)
+ ((eq system-type 'cygwin) 'GPollFileMonitor)
+ (t nil)))
+ ;; TODO: What happens, if several monitor names are reported?
+ ((string-match "\
Supported arguments for GIO_USE_FILE_MONITOR environment variable:
\\s-*\\([[:alpha:]]+\\) - 20" string)
- (tramp-set-connection-property
- proc "gio-file-monitor"
+ (setq pos (match-end 0))
(intern
- (format "G%sFileMonitor" (capitalize (match-string 1 string))))))
- (t (throw 'doesnt-work nil)))
- (setq string (replace-match "" nil nil string)))
+ (format "G%sFileMonitor" (capitalize (match-string 1 string)))))
+ (t (setq pos (length string)) nil)))
+ (setq string (substring string pos)))
;; Delete empty lines.
(setq string (tramp-compat-string-replace "\n\n" "\n" string))
@@ -3800,6 +3785,8 @@ Supported arguments for GIO_USE_FILE_MONITOR environment
variable:
`(file-notify ,object file-notify-callback))))))
;; Save rest of the string.
+ (while (string-match "^\n" string)
+ (setq string (replace-match "" nil nil 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)))
@@ -3949,24 +3936,6 @@ Returns the exit code of the `test' program."
switch
(tramp-shell-quote-argument localname)))))
-(defun tramp-run-test2 (format-string file1 file2)
- "Run `test'-like program on the remote system, given FILE1, FILE2.
-FORMAT-STRING contains the program name, switches, and place holders.
-Returns the exit code of the `test' program. Barfs if the methods,
-hosts, or files, disagree."
- (unless (tramp-equal-remote file1 file2)
- (with-parsed-tramp-file-name (if (tramp-tramp-file-p file1) file1 file2)
nil
- (tramp-error
- v 'file-error
- "tramp-run-test2 only implemented for same method, user, host")))
- (with-parsed-tramp-file-name file1 v1
- (with-parsed-tramp-file-name file1 v2
- (tramp-send-command-and-check
- v1
- (format format-string
- (tramp-shell-quote-argument v1-localname)
- (tramp-shell-quote-argument v2-localname))))))
-
(defconst tramp-sunos-unames (regexp-opt '("SunOS 5.10" "SunOS 5.11"))
"Regexp to determine remote SunOS.")
@@ -4972,11 +4941,7 @@ connection if a previous connection has died for some
reason."
?h (or l-host "") ?u (or l-user "") ?p (or l-port "")
?c (format-spec options (format-spec-make ?t tmpfile))
?l (concat remote-shell " " extra-args " -i"))
- ;; Local shell could be a Windows COMSPEC. It
- ;; doesn't know the ";" syntax, but we must
- ;; exit always for `start-file-process'. It
- ;; could also be a restricted shell, which does
- ;; not allow "exec".
+ ;; A restricted shell does not allow "exec".
(when r-shell '("&&" "exit" "||" "exit")))
" "))
@@ -5264,15 +5229,17 @@ Return ATTR."
(directory-file-name (tramp-file-name-unquote-localname vec))))
(when (string-match-p tramp-ipv6-regexp host)
(setq host (format "[%s]" host)))
+ ;; This does not work yet for MS Windows scp, if there are
+ ;; characters to be quoted. Win32 OpenSSH 7.9 is said to support
+ ;; this, see
+ ;;
<https://github.com/PowerShell/Win32-OpenSSH/releases/tag/v7.9.0.0p1-Beta>
(unless (string-match-p "ftp$" method)
(setq localname (tramp-shell-quote-argument localname)))
(cond
((tramp-get-method-parameter vec 'tramp-remote-copy-program)
localname)
- ((not (zerop (length user)))
- (format
- "%s@%s:%s" user host (tramp-unquote-shell-quote-argument localname)))
- (t (format "%s:%s" host (tramp-unquote-shell-quote-argument
localname))))))
+ ((zerop (length user)) (format "%s:%s" host localname))
+ (t (format "%s@%s:%s" user host localname)))))
(defun tramp-method-out-of-band-p (vec size)
"Return t if this is an out-of-band method, nil otherwise."
@@ -5523,15 +5490,15 @@ Nonexistent directories are removed from spec."
;; Check whether stat(1) returns usable syntax. "%s" does not
;; work on older AIX systems. Recent GNU stat versions
;; (8.24?) use shell quoted format for "%N", we check the
- ;; boundaries "`" and "'", therefore. See Bug#23422 in
- ;; coreutils. Since GNU stat 8.26, environment variable
- ;; QUOTING_STYLE is supported.
+ ;; boundaries "`" and "'" and their localized variants,
+ ;; therefore. See Bug#23422 in coreutils. Since GNU stat
+ ;; 8.26, environment variable QUOTING_STYLE is supported.
(when result
(setq result (concat "env QUOTING_STYLE=locale " result)
tmp (tramp-send-command-and-read
vec (format "%s -c '(\"%%N\" %%s)' /" result) 'noerror))
(unless (and (listp tmp) (stringp (car tmp))
- (string-match-p "^\\(`/'\\|‘/’\\)$" (car tmp))
+ (string-match-p "^[\"`‘„”«「]/[\"'’“”»」]$" (car tmp))
(integerp (cadr tmp)))
(setq result nil)))
result))))
@@ -5825,7 +5792,7 @@ function cell is returned to be applied on a buffer."
;; slashes as directory separators.
(cond
((and (string-match-p "local" prop)
- (memq system-type '(windows-nt)))
+ (eq system-type 'windows-nt))
"(%s | \"%s\")")
((string-match-p "local" prop) "(%s | %s)")
(t "(%s | %s >%%s)"))
@@ -5836,7 +5803,7 @@ function cell is returned to be applied on a buffer."
;; the pipe symbol be quoted if they use forward
;; slashes as directory separators.
(if (and (string-match-p "local" prop)
- (memq system-type '(windows-nt)))
+ (eq system-type 'windows-nt))
"(%s <%%s | \"%s\")"
"(%s <%%s | %s)")
compress coding))
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 8141f02..015f458 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -64,6 +64,10 @@
(declare-function netrc-parse "netrc")
(defvar auto-save-file-name-transforms)
+;; Reload `tramp-compat' when we reload `tramp-autoloads' of the GNU ELPA
package.
+;;;###autoload (when (featurep 'tramp-compat)
+;;;###autoload (load "tramp-compat" 'noerror 'nomessage))
+
;;; User Customizable Internal Variables:
(defgroup tramp nil
@@ -354,12 +358,13 @@ Notes:
All these arguments can be overwritten by connection properties.
See Info node `(tramp) Predefined connection information'.
-When using `su' or `sudo' the phrase \"open connection to a remote
-host\" sounds strange, but it is used nevertheless, for consistency.
-No connection is opened to a remote host, but `su' or `sudo' is
-started on the local host. You should specify a remote host
-`localhost' or the name of the local host. Another host name is
-useful only in combination with `tramp-default-proxies-alist'.")
+When using `su', `sudo' or `doas' the phrase \"open connection to
+a remote host\" sounds strange, but it is used nevertheless, for
+consistency. No connection is opened to a remote host, but `su',
+`sudo' or `doas' is started on the local host. You should
+specify a remote host `localhost' or the name of the local host.
+Another host name is useful only in combination with
+`tramp-default-proxies-alist'.")
(defcustom tramp-default-method
;; An external copy method seems to be preferred, because it performs
@@ -487,7 +492,7 @@ interpreted as a regular expression which always matches."
;; either lower case or upper case letters. See
;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=38079#20>.
(defcustom tramp-restricted-shell-hosts-alist
- (when (memq system-type '(windows-nt))
+ (when (eq system-type 'windows-nt)
(list (format "\\`\\(%s\\|%s\\)\\'"
(regexp-quote (downcase tramp-system-name))
(regexp-quote (upcase tramp-system-name)))))
@@ -557,7 +562,7 @@ usually suffice.")
the remote shell.")
(defcustom tramp-local-end-of-line
- (if (memq system-type '(windows-nt)) "\r\n" "\n")
+ (if (eq system-type 'windows-nt) "\r\n" "\n")
"String used for end of line in local processes."
:version "24.1"
:type 'string)
@@ -1077,7 +1082,13 @@ initial value is overwritten by the car of
`tramp-file-name-structure'.")
(defconst tramp-completion-file-name-regexp-default
(concat
- "\\`/\\("
+ "\\`"
+ ;; `file-name-completion' uses absolute paths for matching. This
+ ;; means that on W32 systems, something like "/ssh:host:~/path"
+ ;; becomes "c:/ssh:host:~/path". See also `tramp-drop-volume-letter'.
+ (when (eq system-type 'windows-nt)
+ "\\(?:[[:alpha:]]:\\)?")
+ "/\\("
;; Optional multi hop.
"\\([^/|:]+:[^/|:]*|\\)*"
;; Last hop.
@@ -1096,7 +1107,13 @@ On W32 systems, the volume letter must be ignored.")
(defconst tramp-completion-file-name-regexp-simplified
(concat
- "\\`/\\("
+ "\\`"
+ ;; Allow the volume letter at the beginning of the path. See the
+ ;; comment in `tramp-completion-file-name-regexp-default' for more
+ ;; details.
+ (when (eq system-type 'windows-nt)
+ "\\(?:[[:alpha:]]:\\)?")
+ "/\\("
;; Optional multi hop.
"\\([^/|:]*|\\)*"
;; Last hop.
@@ -1112,7 +1129,14 @@ See `tramp-file-name-structure' for more explanations.
On W32 systems, the volume letter must be ignored.")
(defconst tramp-completion-file-name-regexp-separate
- "\\`/\\(\\[[^]]*\\)?\\'"
+ (concat
+ "\\`"
+ ;; Allow the volume letter at the beginning of the path. See the
+ ;; comment in `tramp-completion-file-name-regexp-default' for more
+ ;; details.
+ (when (eq system-type 'windows-nt)
+ "\\(?:[[:alpha:]]:\\)?")
+ "/\\(\\[[^]]*\\)?\\'")
"Value for `tramp-completion-file-name-regexp' for separate remoting.
See `tramp-file-name-structure' for more explanations.")
@@ -1808,6 +1832,7 @@ The outline level is equal to the verbosity of the Tramp
message."
"Get the debug buffer for VEC."
(with-current-buffer (get-buffer-create (tramp-debug-buffer-name vec))
(when (bobp)
+ (set-buffer-file-coding-system 'utf-8)
(setq buffer-undo-list t)
;; Activate `outline-mode'. This runs `text-mode-hook' and
;; `outline-mode-hook'. We must prevent that local processes
@@ -1848,7 +1873,7 @@ ARGUMENTS to actually emit the message (if applicable)."
(when (bobp)
(insert
(format
- ";; Emacs: %s Tramp: %s -*- mode: outline; -*-"
+ ";; Emacs: %s Tramp: %s -*- mode: outline; coding: utf-8; -*-"
emacs-version tramp-version))
(when (>= tramp-verbose 10)
(let ((tramp-verbose 0))
@@ -2167,14 +2192,15 @@ without a visible progress reporter."
FILE must be a local file name on a connection identified via VEC."
(declare (indent 3) (debug t))
`(if (file-name-absolute-p ,file)
- (let ((value (tramp-get-file-property ,vec ,file ,property 'undef)))
- (when (eq value 'undef)
- ;; We cannot pass @body as parameter to
- ;; `tramp-set-file-property' because it mangles our
- ;; debug messages.
- (setq value (progn ,@body))
- (tramp-set-file-property ,vec ,file ,property value))
- value)
+ (let ((value (tramp-get-file-property
+ ,vec ,file ,property tramp-cache-undefined)))
+ (when (eq value tramp-cache-undefined)
+ ;; We cannot pass @body as parameter to
+ ;; `tramp-set-file-property' because it mangles our debug
+ ;; messages.
+ (setq value (progn ,@body))
+ (tramp-set-file-property ,vec ,file ,property value))
+ value)
,@body))
(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-file-property\\>"))
@@ -2182,14 +2208,15 @@ FILE must be a local file name on a connection
identified via VEC."
(defmacro with-tramp-connection-property (key property &rest body)
"Check in Tramp for property PROPERTY, otherwise execute BODY and set."
(declare (indent 2) (debug t))
- `(let ((value (tramp-get-connection-property ,key ,property 'undef)))
- (when (eq value 'undef)
- ;; We cannot pass ,@body as parameter to
- ;; `tramp-set-connection-property' because it mangles our debug
- ;; messages.
- (setq value (progn ,@body))
- (tramp-set-connection-property ,key ,property value))
- value))
+ `(let ((value (tramp-get-connection-property
+ ,key ,property tramp-cache-undefined)))
+ (when (eq value tramp-cache-undefined)
+ ;; We cannot pass ,@body as parameter to
+ ;; `tramp-set-connection-property' because it mangles our debug
+ ;; messages.
+ (setq value (progn ,@body))
+ (tramp-set-connection-property ,key ,property value))
+ value))
(font-lock-add-keywords
'emacs-lisp-mode '("\\<with-tramp-connection-property\\>"))
@@ -2543,7 +2570,9 @@ Falls back to normal file name handler if no Tramp file
name handler exists."
(tramp-unload-file-name-handlers)
(when tramp-mode
;; We cannot use `tramp-compat-temporary-file-directory' here due
- ;; to autoload.
+ ;; to autoload. When installing Tramp's GNU ELPA package, there
+ ;; might be an older, incompatible version active. We try to
+ ;; overload this.
(let ((default-directory temporary-file-directory))
(load "tramp" 'noerror 'nomessage)))
(apply operation args)))
@@ -3117,7 +3146,7 @@ User may be nil."
(defun tramp-parse-putty (registry-or-dirname)
"Return a list of (user host) tuples allowed to access.
User is always nil."
- (if (memq system-type '(windows-nt))
+ (if (eq system-type 'windows-nt)
(with-tramp-connection-property nil "parse-putty"
(with-temp-buffer
(when (zerop (tramp-call-process
@@ -3692,21 +3721,19 @@ User is always nil."
(signal (car err) (cdr err))))))
;; Save exit.
- (progn
- (when visit
- (setq buffer-file-name filename
- buffer-read-only (not (file-writable-p filename)))
- (set-visited-file-modtime)
- (set-buffer-modified-p nil))
- (when (and (stringp local-copy)
- (or remote-copy (null tramp-temp-buffer-file-name)))
- (delete-file local-copy))
- (when (stringp remote-copy)
- (delete-file (tramp-make-tramp-file-name v remote-copy 'nohop)))))
+ (when visit
+ (setq buffer-file-name filename
+ buffer-read-only (not (file-writable-p filename)))
+ (set-visited-file-modtime)
+ (set-buffer-modified-p nil))
+ (when (and (stringp local-copy)
+ (or remote-copy (null tramp-temp-buffer-file-name)))
+ (delete-file local-copy))
+ (when (stringp remote-copy)
+ (delete-file (tramp-make-tramp-file-name v remote-copy 'nohop))))
;; Result.
- (list (expand-file-name filename)
- (cadr result)))))
+ (cons (expand-file-name filename) (cdr result)))))
(defun tramp-handle-load (file &optional noerror nomessage nosuffix
must-suffix)
"Like `load' for Tramp files."
@@ -3867,8 +3894,7 @@ substitution. SPEC-LIST is a list of char/value pairs
used for
(or (not (stringp stderr)) (not (tramp-tramp-file-p stderr))))))
(defun tramp-handle-make-process (&rest args)
- "An alternative `make-process' implementation for Tramp files.
-It does not support `:stderr'."
+ "An alternative `make-process' implementation for Tramp files."
(when args
(with-parsed-tramp-file-name (expand-file-name default-directory) nil
(let ((default-directory (tramp-compat-temporary-file-directory))
@@ -4969,7 +4995,7 @@ VEC is used for tracing."
(let ((candidates '("en_US.utf8" "C.utf8" "en_US.UTF-8"))
locale)
(with-temp-buffer
- (unless (or (memq system-type '(windows-nt))
+ (unless (or (eq system-type 'windows-nt)
(not (zerop (tramp-call-process
nil "locale" nil t nil "-a"))))
(while candidates
@@ -5060,7 +5086,7 @@ ID-FORMAT valid values are `string' and `integer'."
(or (when-let
((handler
(find-file-name-handler
- (tramp-make-tramp-file-name vec) 'tramp-get-remote-uid)))
+ (tramp-make-tramp-file-name vec) 'tramp-get-remote-gid)))
(funcall handler #'tramp-get-remote-gid vec id-format))
;; Ensure there is a valid result.
(and (equal id-format 'integer) tramp-unknown-id-integer)
diff --git a/lisp/notifications.el b/lisp/notifications.el
index b439d82..ebd74dd 100644
--- a/lisp/notifications.el
+++ b/lisp/notifications.el
@@ -420,3 +420,5 @@ version this library is compliant with."
notifications-get-server-information-method)))
(provide 'notifications)
+
+;;; notifications.el ends here
diff --git a/lisp/nxml/rng-cmpct.el b/lisp/nxml/rng-cmpct.el
index 3d4b9f8..1314ade 100644
--- a/lisp/nxml/rng-cmpct.el
+++ b/lisp/nxml/rng-cmpct.el
@@ -922,4 +922,4 @@ Current token after parse is token following ]."
(provide 'rng-cmpct)
-;;; rng-cmpct.el
+;;; rng-cmpct.el ends here
diff --git a/lisp/nxml/rng-loc.el b/lisp/nxml/rng-loc.el
index d5a608d..a38da79 100644
--- a/lisp/nxml/rng-loc.el
+++ b/lisp/nxml/rng-loc.el
@@ -182,7 +182,7 @@ If TYPE-ID is non-nil, then locate the schema for this
TYPE-ID."
(while files
(setq type-ids (rng-possible-type-ids-using (car files) type-ids))
(setq files (cdr files)))
- (rng-uniquify-equal (sort type-ids 'string<))))
+ (seq-uniq (sort type-ids 'string<))))
(defun rng-locate-schema-file-using (files)
"Locate a schema using the schema locating files FILES.
diff --git a/lisp/nxml/rng-match.el b/lisp/nxml/rng-match.el
index 4fc6727..7a2739c 100644
--- a/lisp/nxml/rng-match.el
+++ b/lisp/nxml/rng-match.el
@@ -472,7 +472,7 @@ list is nullable and whose cdr is the normalized list."
(cons nullable
(if sorted
head
- (rng-uniquify-eq (sort head 'rng-compare-ipattern))))))
+ (seq-uniq (sort head 'rng-compare-ipattern) #'eq)))))
(defun rng-compare-ipattern (p1 p2)
(< (rng--ipattern-index p1)
diff --git a/lisp/nxml/rng-nxml.el b/lisp/nxml/rng-nxml.el
index 7ea6fb2..33768a4 100644
--- a/lisp/nxml/rng-nxml.el
+++ b/lisp/nxml/rng-nxml.el
@@ -522,7 +522,7 @@ set `xmltok-dtd'. Returns the position of the end of the
token."
(unless attribute-flag
(setcdr ns-prefixes (cons nil (cdr ns-prefixes))))))
(setq iter (cdr iter)))
- (rng-uniquify-equal
+ (seq-uniq
(sort (apply #'append
(cons extra-strings
(mapcar (lambda (name)
diff --git a/lisp/nxml/rng-util.el b/lisp/nxml/rng-util.el
index a20e950..67e2ee9 100644
--- a/lisp/nxml/rng-util.el
+++ b/lisp/nxml/rng-util.el
@@ -36,26 +36,6 @@
(defconst rng-builtin-datatypes-uri (rng-make-datatypes-uri ""))
-(defun rng-uniquify-eq (list)
- "Destructively remove `eq' duplicates from LIST."
- (and list
- (let ((head list))
- (while (cdr head)
- (if (eq (car head) (cadr head))
- (setcdr head (cddr head)))
- (setq head (cdr head)))
- list)))
-
-(defun rng-uniquify-equal (list)
- "Destructively remove `equal' duplicates from LIST."
- (and list
- (let ((head list))
- (while (cdr head)
- (if (equal (car head) (cadr head))
- (setcdr head (cddr head)))
- (setq head (cdr head)))
- list)))
-
(defun rng-blank-p (str) (string-match "\\`[ \t\n\r]*\\'" str))
(defun rng-substq (new old list)
@@ -104,6 +84,14 @@ LIST is not modified."
(define-error 'rng-error nil)
+;; Obsolete.
+
+(defun rng-uniquify-eq (list)
+ (declare (obsolete seq-uniq "28.1"))
+ (seq-uniq list #'eq))
+
+(define-obsolete-function-alias 'rng-uniquify-equal #'seq-uniq "28.1")
+
(provide 'rng-util)
;;; rng-util.el ends here
diff --git a/lisp/nxml/xmltok.el b/lisp/nxml/xmltok.el
index 8f89598..9824eeb 100644
--- a/lisp/nxml/xmltok.el
+++ b/lisp/nxml/xmltok.el
@@ -324,8 +324,8 @@ and VALUE-END, otherwise a STRING giving the value."
(setq strs (cons (car arg) strs))
(setq names (cons (cdr arg) names)))
(setq args (cdr args))))
- (cons (apply 'concat (nreverse strs))
- (apply 'append (nreverse names))))))
+ (cons (apply #'concat (nreverse strs))
+ (apply #'append (nreverse names))))))
(eval-when-compile
;; Make a symbolic group named NAME from the regexp R.
@@ -338,7 +338,7 @@ and VALUE-END, otherwise a STRING giving the value."
(cons (concat "\\(" (car ,sym) "\\)") (cons ',name (cdr ,sym)))))))
(defun xmltok-p (&rest r) (xmltok+ "\\(?:"
- (apply 'xmltok+ r)
+ (apply #'xmltok+ r)
"\\)"))
;; Get the group index of ELEM in a LIST of symbols.
@@ -372,22 +372,23 @@ and VALUE-END, otherwise a STRING giving the value."
(defmacro xmltok-defregexp (sym r)
`(defalias ',sym
(let ((r ,r))
- `(macro lambda (action &optional group-name)
- (cond ((eq action 'regexp)
- ,(car r))
- ((or (eq action 'start) (eq action 'beginning))
- (list 'match-beginning (xmltok-get-index group-name
- ',(cdr r))))
- ((eq action 'end)
- (list 'match-end (xmltok-get-index group-name
- ',(cdr r))))
- ((eq action 'string)
- (list 'match-string
- (xmltok-get-index group-name ',(cdr r))))
- ((eq action 'string-no-properties)
- (list 'match-string-no-properties
- (xmltok-get-index group-name ',(cdr r))))
- (t (error "Invalid action: %s" action))))))))
+ `(macro
+ . ,(lambda (action &optional group-name)
+ (cond ((eq action 'regexp)
+ (car r))
+ ((or (eq action 'start) (eq action 'beginning))
+ (list 'match-beginning (xmltok-get-index group-name
+ (cdr r))))
+ ((eq action 'end)
+ (list 'match-end (xmltok-get-index group-name
+ (cdr r))))
+ ((eq action 'string)
+ (list 'match-string
+ (xmltok-get-index group-name (cdr r))))
+ ((eq action 'string-no-properties)
+ (list 'match-string-no-properties
+ (xmltok-get-index group-name (cdr r))))
+ (t (error "Invalid action: %s" action)))))))))
(eval-when-compile
@@ -878,7 +879,7 @@ and VALUE-END, otherwise a STRING giving the value."
(cons " " value-parts)))))
(< (point) end))))
(when well-formed
- (aset att 5 (apply 'concat (nreverse value-parts))))
+ (aset att 5 (apply #'concat (nreverse value-parts))))
(aset att 6 (nreverse refs))))
(defun xmltok-scan-after-amp (entity-handler)
@@ -1333,7 +1334,7 @@ If LIMIT is non-nil, then do not consider characters
beyond LIMIT."
t))))
(if (not well-formed)
nil
- (apply 'concat
+ (apply #'concat
(nreverse (cons (buffer-substring-no-properties start lim)
value-parts))))))
@@ -1358,7 +1359,7 @@ If LIMIT is non-nil, then do not consider characters
beyond LIMIT."
(defun xmltok-require-next-token (&rest types)
(xmltok-next-prolog-token)
- (apply 'xmltok-require-token types))
+ (apply #'xmltok-require-token types))
(defun xmltok-require-token (&rest types)
;; XXX Generate a more helpful error message
diff --git a/lisp/obsolete/fast-lock.el b/lisp/obsolete/fast-lock.el
index baed8be..960233d 100644
--- a/lisp/obsolete/fast-lock.el
+++ b/lisp/obsolete/fast-lock.el
@@ -752,8 +752,6 @@ See `fast-lock-get-face-properties'."
(unless (assq 'fast-lock-mode minor-mode-alist)
(setq minor-mode-alist (append minor-mode-alist '((fast-lock-mode nil)))))
-;; Provide ourselves:
-
(provide 'fast-lock)
;;; fast-lock.el ends here
diff --git a/lisp/obsolete/info-edit.el b/lisp/obsolete/info-edit.el
index c53616d..1995897 100644
--- a/lisp/obsolete/info-edit.el
+++ b/lisp/obsolete/info-edit.el
@@ -1,4 +1,4 @@
-;; info-edit.el --- Editing info files -*- lexical-binding:t -*-
+;;; info-edit.el --- Editing info files -*- lexical-binding:t -*-
;; Copyright (C) 1985-1986, 1992-2021 Free Software Foundation, Inc.
diff --git a/lisp/obsolete/iswitchb.el b/lisp/obsolete/iswitchb.el
index 7ffee76..a630baf 100644
--- a/lisp/obsolete/iswitchb.el
+++ b/lisp/obsolete/iswitchb.el
@@ -1336,7 +1336,7 @@ See the variable `iswitchb-case' for details."
Iswitchb mode is a global minor mode that enables switching
between buffers using substrings. See `iswitchb' for details."
- nil nil iswitchb-global-map :global t
+ :keymap iswitchb-global-map :global t
(if iswitchb-mode
(add-hook 'minibuffer-setup-hook #'iswitchb-minibuffer-setup)
(remove-hook 'minibuffer-setup-hook #'iswitchb-minibuffer-setup)))
diff --git a/lisp/obsolete/lazy-lock.el b/lisp/obsolete/lazy-lock.el
index 34bf85f..13f14aa 100644
--- a/lisp/obsolete/lazy-lock.el
+++ b/lisp/obsolete/lazy-lock.el
@@ -1016,8 +1016,6 @@ verbosity is controlled via the variable
`lazy-lock-stealth-verbose'."
(unless (assq 'lazy-lock-mode minor-mode-alist)
(setq minor-mode-alist (append minor-mode-alist '((lazy-lock-mode nil)))))
-;; Provide ourselves:
-
(provide 'lazy-lock)
;; Local Variables:
diff --git a/lisp/obsolete/nnir.el b/lisp/obsolete/nnir.el
index f2ea5c6..40a8ec5 100644
--- a/lisp/obsolete/nnir.el
+++ b/lisp/obsolete/nnir.el
@@ -1339,7 +1339,6 @@ Query for the specs, or use SPECS."
(define-obsolete-function-alias 'nnir-get-active #'gnus-server-get-active
"28.1")
-;; The end.
(provide 'nnir)
;;; nnir.el ends here
diff --git a/lisp/obsolete/old-emacs-lock.el b/lisp/obsolete/old-emacs-lock.el
index 90ff93e..ce4c60e 100644
--- a/lisp/obsolete/old-emacs-lock.el
+++ b/lisp/obsolete/old-emacs-lock.el
@@ -1,4 +1,4 @@
-;;; emacs-lock.el --- prevents you from exiting Emacs if a buffer is locked
-*- lexical-binding: t; -*-
+;;; old-emacs-lock.el --- prevents you from exiting Emacs if a buffer is
locked -*- lexical-binding: t; -*-
;; Copyright (C) 1994, 1997, 2001-2021 Free Software Foundation, Inc.
@@ -99,4 +99,4 @@ If the buffer is locked, signal error and display its name."
(provide 'emacs-lock)
-;;; emacs-lock.el ends here
+;;; old-emacs-lock.el ends here
diff --git a/lisp/obsolete/otodo-mode.el b/lisp/obsolete/otodo-mode.el
index add17b2..47f5089 100644
--- a/lisp/obsolete/otodo-mode.el
+++ b/lisp/obsolete/otodo-mode.el
@@ -1,4 +1,4 @@
-;;; todo-mode.el --- major mode for editing TODO list files -*-
lexical-binding: t; -*-
+;;; otodo-mode.el --- major mode for editing TODO list files -*-
lexical-binding: t; -*-
;; Copyright (C) 1997, 1999, 2001-2021 Free Software Foundation, Inc.
@@ -963,4 +963,4 @@ If INCLUDE-SEP is non-nil, return point after the
separator."
(provide 'todo-mode)
-;;; todo-mode.el ends here
+;;; otodo-mode.el ends here
diff --git a/lisp/obsolete/pc-select.el b/lisp/obsolete/pc-select.el
index 5982875..f999f50 100644
--- a/lisp/obsolete/pc-select.el
+++ b/lisp/obsolete/pc-select.el
@@ -314,8 +314,6 @@ but before calling PC Selection mode):
C-BACKSPACE backward-kill-word
M-BACKSPACE undo"
;; FIXME: bring pc-bindings-mode here ?
- nil nil nil
-
:global t
(if pc-selection-mode
diff --git a/lisp/obsolete/sb-image.el b/lisp/obsolete/sb-image.el
index e9a507f..fc9e03e 100644
--- a/lisp/obsolete/sb-image.el
+++ b/lisp/obsolete/sb-image.el
@@ -1,4 +1,4 @@
-;;; sb-image --- Image management for speedbar -*- lexical-binding: t; -*-
+;;; sb-image.el --- Image management for speedbar -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2003, 2005-2019, 2021 Free Software Foundation,
;; Inc.
diff --git a/lisp/obsolete/sregex.el b/lisp/obsolete/sregex.el
index 96d6b7a..371dcbf 100644
--- a/lisp/obsolete/sregex.el
+++ b/lisp/obsolete/sregex.el
@@ -208,7 +208,7 @@
;; This is a "trapdoor" for including ordinary regular expression
;; strings in the result. Some regular expressions are clearer when
;; written the old way: "[a-z]" vs. (sregexq (char (?a . ?z))), for
-;; instance. However, see the note under "Bugs," below.
+;; instance.
;; Each CHAR-CLAUSE that is passed to (char ...) and (not-char ...)
;; has one of the following forms:
@@ -236,8 +236,6 @@
;; - add support for non-greedy operators *? and +?
;; - bug: (sregexq (opt (opt ?a))) returns "a??" which is a non-greedy "a?"
-;;; Bugs:
-
;;; Code:
(eval-when-compile (require 'cl-lib))
diff --git a/lisp/obsolete/tpu-mapper.el b/lisp/obsolete/tpu-mapper.el
index d23068a..5ae0a65 100644
--- a/lisp/obsolete/tpu-mapper.el
+++ b/lisp/obsolete/tpu-mapper.el
@@ -69,7 +69,7 @@
;;;###autoload
(defun tpu-mapper ()
- "Create an Emacs lisp file defining the TPU-edt keypad for X-windows.
+ "Create an Emacs Lisp file defining the TPU-edt keypad for X-windows.
This command displays an instruction screen showing the TPU-edt keypad
and asks you to press the TPU-edt editing keys. It uses the keys you
diff --git a/lisp/org/ob-hledger.el b/lisp/org/ob-hledger.el
index 3d2f46c..48dcb8c 100644
--- a/lisp/org/ob-hledger.el
+++ b/lisp/org/ob-hledger.el
@@ -1,4 +1,4 @@
-;; ob-hledger.el --- Babel Functions for hledger -*- lexical-binding: t;
-*-
+;;; ob-hledger.el --- Babel Functions for hledger -*- lexical-binding: t;
-*-
;; Copyright (C) 2010-2021 Free Software Foundation, Inc.
diff --git a/lisp/org/ob-mscgen.el b/lisp/org/ob-mscgen.el
index 999d4f4..79c9f87 100644
--- a/lisp/org/ob-mscgen.el
+++ b/lisp/org/ob-mscgen.el
@@ -1,4 +1,4 @@
-;;; ob-msc.el --- Babel Functions for Mscgen -*- lexical-binding: t;
-*-
+;;; ob-mscgen.el --- Babel Functions for Mscgen -*- lexical-binding:
t; -*-
;; Copyright (C) 2010-2021 Free Software Foundation, Inc.
@@ -78,4 +78,4 @@ mscgen supported formats."
(provide 'ob-mscgen)
-;;; ob-msc.el ends here
+;;; ob-mscgen.el ends here
diff --git a/lisp/org/ol-eshell.el b/lisp/org/ol-eshell.el
index 769e7ee..8920e0a 100644
--- a/lisp/org/ol-eshell.el
+++ b/lisp/org/ol-eshell.el
@@ -1,4 +1,4 @@
-;;; ol-eshell.el - Links to Working Directories in Eshell -*- lexical-binding:
t; -*-
+;;; ol-eshell.el --- Links to Working Directories in Eshell -*-
lexical-binding: t; -*-
;; Copyright (C) 2011-2021 Free Software Foundation, Inc.
diff --git a/lisp/org/org-capture.el b/lisp/org/org-capture.el
index f40f2b3..7ae8fae 100644
--- a/lisp/org/org-capture.el
+++ b/lisp/org/org-capture.el
@@ -521,7 +521,7 @@ for a capture buffer.")
"Minor mode for special key bindings in a capture buffer.
Turning on this mode runs the normal hook `org-capture-mode-hook'."
- nil " Cap" org-capture-mode-map
+ :lighter " Cap"
(setq-local
header-line-format
(substitute-command-keys
diff --git a/lisp/org/org-ctags.el b/lisp/org/org-ctags.el
index 1fca873..dc2b3be 100644
--- a/lisp/org/org-ctags.el
+++ b/lisp/org/org-ctags.el
@@ -1,5 +1,5 @@
-;;; org-ctags.el - Integrate Emacs "tags" Facility with Org -*-
lexical-binding: t; -*-
-;;
+;;; org-ctags.el --- Integrate Emacs "tags" Facility with Org -*-
lexical-binding: t; -*-
+
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
;; Author: Paul Sexton <eeeickythump@gmail.com>
diff --git a/lisp/org/org-indent.el b/lisp/org/org-indent.el
index c6bf416..3475cad 100644
--- a/lisp/org/org-indent.el
+++ b/lisp/org/org-indent.el
@@ -167,7 +167,7 @@ properties, after each buffer modification, on the modified
zone.
The process is synchronous. Though, initial indentation of
buffer, which can take a few seconds on large buffers, is done
during idle time."
- nil " Ind" nil
+ :lighter " Ind"
(cond
(org-indent-mode
;; mode was turned on.
diff --git a/lisp/org/org-list.el b/lisp/org/org-list.el
index 39122e7..f97164e 100644
--- a/lisp/org/org-list.el
+++ b/lisp/org/org-list.el
@@ -2304,7 +2304,7 @@ is an integer, 0 means `-', 1 means `+' etc. If WHICH is
;;;###autoload
(define-minor-mode org-list-checkbox-radio-mode
"When turned on, use list checkboxes as radio buttons."
- nil " CheckBoxRadio" nil
+ :lighter " CheckBoxRadio"
(unless (eq major-mode 'org-mode)
(user-error "Cannot turn this mode outside org-mode buffers")))
diff --git a/lisp/org/org-src.el b/lisp/org/org-src.el
index 20acee4..cabedec 100644
--- a/lisp/org/org-src.el
+++ b/lisp/org/org-src.el
@@ -682,7 +682,7 @@ This minor mode is turned on in two situations:
\\{org-src-mode-map}
See also `org-src-mode-hook'."
- nil " OrgSrc" nil
+ :lighter " OrgSrc"
(when org-edit-src-persistent-message
(setq header-line-format
(substitute-command-keys
diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el
index 1248efa..0e93fb2 100644
--- a/lisp/org/org-table.el
+++ b/lisp/org/org-table.el
@@ -495,7 +495,7 @@ This may be useful when columns have been shrunk."
;;;###autoload
(define-minor-mode org-table-header-line-mode
"Display the first row of the table at point in the header line."
- nil " TblHeader" nil
+ :lighter " TblHeader"
(unless (eq major-mode 'org-mode)
(user-error "Cannot turn org table header mode outside org-mode buffers"))
(if org-table-header-line-mode
@@ -1976,7 +1976,7 @@ lines."
When this mode is active, the field editor window will always show the
current field. The mode exits automatically when the cursor leaves the
table (but see `org-table-exit-follow-field-mode-when-leaving-table')."
- nil " TblFollow" nil
+ :lighter " TblFollow"
(if org-table-follow-field-mode
(add-hook 'post-command-hook 'org-table-follow-fields-with-editor
'append 'local)
@@ -5149,7 +5149,7 @@ When LOCAL is non-nil, show references for the table at
point."
;;;###autoload
(define-minor-mode orgtbl-mode
"The Org mode table editor as a minor mode for use in other modes."
- :lighter " OrgTbl" :keymap orgtbl-mode-map
+ :lighter " OrgTbl"
(org-load-modules-maybe)
(cond
((derived-mode-p 'org-mode)
diff --git a/lisp/org/org.el b/lisp/org/org.el
index cebe173..f560c65 100644
--- a/lisp/org/org.el
+++ b/lisp/org/org.el
@@ -15584,7 +15584,7 @@ When a buffer is unmodified, it is just killed. When
modified, it is saved
This mode supports entering LaTeX environment and math in LaTeX fragments
in Org mode.
\\{org-cdlatex-mode-map}"
- nil " OCDL" nil
+ :lighter " OCDL"
(when org-cdlatex-mode
(require 'cdlatex)
(run-hooks 'cdlatex-mode-hook)
diff --git a/lisp/org/ox-beamer.el b/lisp/org/ox-beamer.el
index 1a1732b..6ed95e8 100644
--- a/lisp/org/ox-beamer.el
+++ b/lisp/org/ox-beamer.el
@@ -895,14 +895,16 @@ holding export options."
;;; Minor Mode
-(defvar org-beamer-mode-map (make-sparse-keymap)
+(defvar org-beamer-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-c\C-b" 'org-beamer-select-environment)
+ map)
"The keymap for `org-beamer-mode'.")
-(define-key org-beamer-mode-map "\C-c\C-b" 'org-beamer-select-environment)
;;;###autoload
(define-minor-mode org-beamer-mode
"Support for editing Beamer oriented Org mode files."
- nil " Bm" 'org-beamer-mode-map)
+ :lighter " Bm")
(when (fboundp 'font-lock-add-keywords)
(font-lock-add-keywords
diff --git a/lisp/org/ox-man.el b/lisp/org/ox-man.el
index 6cace7e..27d2ded 100644
--- a/lisp/org/ox-man.el
+++ b/lisp/org/ox-man.el
@@ -1,4 +1,4 @@
-;; ox-man.el --- Man Back-End for Org Export Engine -*- lexical-binding: t; -*-
+;;; ox-man.el --- Man Back-End for Org Export Engine -*- lexical-binding: t;
-*-
;; Copyright (C) 2011-2021 Free Software Foundation, Inc.
diff --git a/lisp/outline.el b/lisp/outline.el
index 79029a6..fa7c1a2 100644
--- a/lisp/outline.el
+++ b/lisp/outline.el
@@ -374,8 +374,9 @@ faces to major mode's faces."
"Toggle Outline minor mode.
See the command `outline-mode' for more information on this mode."
- nil " Outl" (list (cons [menu-bar] outline-minor-mode-menu-bar-map)
- (cons outline-minor-mode-prefix outline-mode-prefix-map))
+ :lighter " Outl"
+ :keymap (list (cons [menu-bar] outline-minor-mode-menu-bar-map)
+ (cons outline-minor-mode-prefix outline-mode-prefix-map))
(if outline-minor-mode
(progn
(when (or outline-minor-mode-cycle outline-minor-mode-highlight)
@@ -1273,6 +1274,45 @@ Return either 'hide-all, 'headings-only, or 'show-all."
(setq outline--cycle-buffer-state 'show-all)
(message "Show all")))))
+(defvar outline-navigation-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-b") #'outline-backward-same-level)
+ (define-key map (kbd "b") #'outline-backward-same-level)
+ (define-key map (kbd "C-f") #'outline-forward-same-level)
+ (define-key map (kbd "f") #'outline-forward-same-level)
+ (define-key map (kbd "C-n") #'outline-next-visible-heading)
+ (define-key map (kbd "n") #'outline-next-visible-heading)
+ (define-key map (kbd "C-p") #'outline-previous-visible-heading)
+ (define-key map (kbd "p") #'outline-previous-visible-heading)
+ (define-key map (kbd "C-u") #'outline-up-heading)
+ (define-key map (kbd "u") #'outline-up-heading)
+ map))
+
+(dolist (command '(outline-backward-same-level
+ outline-forward-same-level
+ outline-next-visible-heading
+ outline-previous-visible-heading
+ outline-up-heading))
+ (put command 'repeat-map 'outline-navigation-repeat-map))
+
+(defvar outline-editing-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "C-v") #'outline-move-subtree-down)
+ (define-key map (kbd "v") #'outline-move-subtree-down)
+ (define-key map (kbd "C-^") #'outline-move-subtree-up)
+ (define-key map (kbd "^") #'outline-move-subtree-up)
+ (define-key map (kbd "C->") #'outline-demote)
+ (define-key map (kbd ">") #'outline-demote)
+ (define-key map (kbd "C-<") #'outline-promote)
+ (define-key map (kbd "<") #'outline-promote)
+ map))
+
+(dolist (command '(outline-move-subtree-down
+ outline-move-subtree-up
+ outline-demote
+ outline-promote))
+ (put command 'repeat-map 'outline-editing-repeat-map))
+
(provide 'outline)
(provide 'noutline)
diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el
index b648ecf..64acc41 100644
--- a/lisp/pcomplete.el
+++ b/lisp/pcomplete.el
@@ -1260,18 +1260,9 @@ If specific documentation can't be given, be generic."
(defun pcomplete-uniquify-list (l)
"Sort and remove multiples in L."
- (setq l (sort l 'string-lessp))
- (let ((m l))
- (while m
- (while (and (cdr m)
- (string= (car m)
- (cadr m)))
- (setcdr m (cddr m)))
- (setq m (cdr m))))
- l)
-(define-obsolete-function-alias
- 'pcomplete-uniqify-list
- 'pcomplete-uniquify-list "27.1")
+ (setq l (sort l #'string-lessp))
+ (seq-uniq 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."
@@ -1320,18 +1311,6 @@ If specific documentation can't be given, be generic."
(pcomplete-read-hosts pcomplete-hosts-file 'pcomplete--host-name-cache
'pcomplete--host-name-cache-timestamp)))
-;; create a set of aliases which allow completion functions to be not
-;; quite so verbose
-
-;;; jww (1999-10-20): are these a good idea?
-;; (defalias 'pc-here 'pcomplete-here)
-;; (defalias 'pc-test 'pcomplete-test)
-;; (defalias 'pc-opt 'pcomplete-opt)
-;; (defalias 'pc-match 'pcomplete-match)
-;; (defalias 'pc-match-string 'pcomplete-match-string)
-;; (defalias 'pc-match-beginning 'pcomplete-match-beginning)
-;; (defalias 'pc-match-end 'pcomplete-match-end)
-
(provide 'pcomplete)
;;; pcomplete.el ends here
diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el
index 68dc0fb..78b8259 100644
--- a/lisp/pixel-scroll.el
+++ b/lisp/pixel-scroll.el
@@ -1,4 +1,4 @@
-;;; pixel-scroll.el --- Scroll a line smoothly
+;;; pixel-scroll.el --- Scroll a line smoothly -*- lexical-binding: t -*-
;; Copyright (C) 2017-2021 Free Software Foundation, Inc.
;; Author: Tak Kunihiro <tkk@misasa.okayama-u.ac.jp>
@@ -124,7 +124,7 @@ This is an alternative of `scroll-up'. Scope moves
downward."
(or arg (setq arg 1))
(if (pixel-scroll-in-rush-p)
(scroll-up arg)
- (dotimes (ii arg) ; move scope downward
+ (dotimes (_ arg) ; move scope downward
(let ((amt (if pixel-resolution-fine-flag
(if (integerp pixel-resolution-fine-flag)
pixel-resolution-fine-flag
@@ -145,7 +145,7 @@ This is and alternative of `scroll-down'. Scope moves
upward."
(or arg (setq arg 1))
(if (pixel-scroll-in-rush-p)
(scroll-down arg)
- (dotimes (ii arg)
+ (dotimes (_ arg)
(let ((amt (if pixel-resolution-fine-flag
(if (integerp pixel-resolution-fine-flag)
pixel-resolution-fine-flag
@@ -244,7 +244,7 @@ that was scrolled."
(dst (* line height)) ; goal @25 @25 @92
(delta (- dst src))) ; pixels to be scrolled 25 17 4
(pixel--whistlestop-pixel-up (1- delta)) ; until one less @24 @24 @91
- (dotimes (ii line)
+ (dotimes (_ line)
;; On horizontal scrolling, move cursor.
(when (> (window-hscroll) 0)
(vertical-motion 1))
diff --git a/lisp/play/bubbles.el b/lisp/play/bubbles.el
index 50f65a1..e695a75 100644
--- a/lisp/play/bubbles.el
+++ b/lisp/play/bubbles.el
@@ -72,9 +72,6 @@
;;; Code:
-(defconst bubbles-version "0.5" "Version number of bubbles.el.")
-(make-obsolete-variable 'bubbles-version nil "28.1")
-
(require 'gamegrid)
;; User options
@@ -1405,6 +1402,11 @@ Return t if new char is non-empty."
(forward-char 1)))
(put-text-property (point-min) (point-max) 'pointer 'arrow)))))
+;; Obsolete.
+
+(defconst bubbles-version "0.5" "Version number of bubbles.el.")
+(make-obsolete-variable 'bubbles-version 'emacs-version "28.1")
+
(provide 'bubbles)
;;; bubbles.el ends here
diff --git a/lisp/printing.el b/lisp/printing.el
index b9a2e33..5c7da96 100644
--- a/lisp/printing.el
+++ b/lisp/printing.el
@@ -4775,13 +4775,13 @@ If menu binding was not done, calls `pr-menu-bind'."
(defun pr-menu-create (name alist var-sym fun entry index)
(cons name
(mapcar
- #'(lambda (elt)
- (let ((sym (car elt)))
- (vector
- (symbol-name sym)
- `(,fun ',sym nil ',entry ',index)
- :style 'radio
- :selected `(eq ,var-sym ',sym))))
+ (lambda (elt)
+ (let ((sym (car elt)))
+ (vector
+ (symbol-name sym)
+ `(,fun ',sym nil ',entry ',index)
+ :style 'radio
+ :selected `(eq ,var-sym ',sym))))
alist)))
@@ -4883,23 +4883,23 @@ If menu binding was not done, calls `pr-menu-bind'."
(cons inherits old)))))
(mapc
(cond ((not local) ; global settings
- #'(lambda (option)
- (let ((var-sym (car option)))
- (or (eq var-sym 'inherits-from:)
- (set var-sym (eval (cdr option)))))))
+ (lambda (option)
+ (let ((var-sym (car option)))
+ (or (eq var-sym 'inherits-from:)
+ (set var-sym (eval (cdr option)))))))
(kill ; local settings with killing
- #'(lambda (option)
- (let ((var-sym (car option)))
- (unless (eq var-sym 'inherits-from:)
- (setq local-list (cons var-sym local-list))
- (set (make-local-variable var-sym)
- (eval (cdr option)))))))
+ (lambda (option)
+ (let ((var-sym (car option)))
+ (unless (eq var-sym 'inherits-from:)
+ (setq local-list (cons var-sym local-list))
+ (set (make-local-variable var-sym)
+ (eval (cdr option)))))))
(t ; local settings without killing
- #'(lambda (option)
- (let ((var-sym (car option)))
- (or (eq var-sym 'inherits-from:)
- (set (make-local-variable var-sym)
- (eval (cdr option))))))))
+ (lambda (option)
+ (let ((var-sym (car option)))
+ (or (eq var-sym 'inherits-from:)
+ (set (make-local-variable var-sym)
+ (eval (cdr option))))))))
(nthcdr 3 setting))
local-list))))
@@ -5077,9 +5077,9 @@ If menu binding was not done, calls `pr-menu-bind'."
(defun pr-complete-alist (prompt alist default)
- (let ((collection (mapcar #'(lambda (elt)
- (setq elt (car elt))
- (cons (symbol-name elt) elt))
+ (let ((collection (mapcar (lambda (elt)
+ (setq elt (car elt))
+ (cons (symbol-name elt) elt))
alist)))
(cdr (assoc (completing-read (concat prompt ": ")
collection nil t
@@ -5413,19 +5413,19 @@ If menu binding was not done, calls `pr-menu-bind'."
(defun pr-file-list (dir file-regexp fun)
- (mapcar #'(lambda (file)
- (and (or pr-list-directory
- (not (file-directory-p file)))
- (let ((buffer (pr-find-buffer-visiting file))
- pop-up-windows
- pop-up-frames)
- (and (or buffer
- (file-readable-p file))
- (with-current-buffer (or buffer
- (find-file-noselect file))
- (funcall fun)
- (or buffer
- (kill-buffer (current-buffer))))))))
+ (mapcar (lambda (file)
+ (and (or pr-list-directory
+ (not (file-directory-p file)))
+ (let ((buffer (pr-find-buffer-visiting file))
+ pop-up-windows
+ pop-up-frames)
+ (and (or buffer
+ (file-readable-p file))
+ (with-current-buffer (or buffer
+ (find-file-noselect file))
+ (funcall fun)
+ (or buffer
+ (kill-buffer (current-buffer))))))))
(directory-files dir t file-regexp)))
@@ -5438,10 +5438,10 @@ If menu binding was not done, calls `pr-menu-bind'."
(pr-delete-file-if-exists (setq filename (expand-file-name filename)))
(let ((pr-spool-p t))
(pr-file-list dir file-regexp
- #'(lambda ()
- (if (pr-auto-mode-p)
- (pr-ps-mode n-up filename)
- (pr-text2ps 'buffer n-up filename)))))
+ (lambda ()
+ (if (pr-auto-mode-p)
+ (pr-ps-mode n-up filename)
+ (pr-text2ps 'buffer n-up filename)))))
(or pr-spool-p
(pr-despool-print filename)))
@@ -5672,44 +5672,44 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(pr-insert-checkbox
"\n "
'pr-i-region
- #'(lambda (widget &rest _ignore)
- (let ((region-p (pr-interface-save
- (ps-mark-active-p))))
- (cond ((null (widget-value widget)) ; widget is nil
- (setq pr-i-region nil))
- (region-p ; widget is true and there is a region
- (setq pr-i-region t)
- (widget-value-set widget t)
- (widget-setup)) ; MUST be called after widget-value-set
- (t ; widget is true and there is no region
- (ding)
- (message "There is no region active")
- (setq pr-i-region nil)
- (widget-value-set widget nil)
- (widget-setup))))) ; MUST be called after widget-value-set
+ (lambda (widget &rest _ignore)
+ (let ((region-p (pr-interface-save
+ (ps-mark-active-p))))
+ (cond ((null (widget-value widget)) ; widget is nil
+ (setq pr-i-region nil))
+ (region-p ; widget is true and there is a region
+ (setq pr-i-region t)
+ (widget-value-set widget t)
+ (widget-setup)) ; MUST be called after widget-value-set
+ (t ; widget is true and there is no region
+ (ding)
+ (message "There is no region active")
+ (setq pr-i-region nil)
+ (widget-value-set widget nil)
+ (widget-setup))))) ; MUST be called after widget-value-set
" Region"))
;; 1a. Buffer: Mode
(put 'pr-i-mode 'pr-widget
(pr-insert-checkbox
" "
'pr-i-mode
- #'(lambda (widget &rest _ignore)
- (let ((mode-p (pr-interface-save
- (pr-mode-alist-p))))
- (cond
- ((null (widget-value widget)) ; widget is nil
- (setq pr-i-mode nil))
- (mode-p ; widget is true and there is a `mode'
- (setq pr-i-mode t)
- (widget-value-set widget t)
- (widget-setup)) ; MUST be called after widget-value-set
- (t ; widget is true and there is no `mode'
- (ding)
- (message
- "This buffer isn't in a mode that printing treats specially.")
- (setq pr-i-mode nil)
- (widget-value-set widget nil)
- (widget-setup))))) ; MUST be called after widget-value-set
+ (lambda (widget &rest _ignore)
+ (let ((mode-p (pr-interface-save
+ (pr-mode-alist-p))))
+ (cond
+ ((null (widget-value widget)) ; widget is nil
+ (setq pr-i-mode nil))
+ (mode-p ; widget is true and there is a `mode'
+ (setq pr-i-mode t)
+ (widget-value-set widget t)
+ (widget-setup)) ; MUST be called after widget-value-set
+ (t ; widget is true and there is no `mode'
+ (ding)
+ (message
+ "This buffer isn't in a mode that printing treats specially.")
+ (setq pr-i-mode nil)
+ (widget-value-set widget nil)
+ (widget-setup))))) ; MUST be called after widget-value-set
" Mode\n"))
;; 1b. Directory:
@@ -5769,14 +5769,14 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(pr-insert-checkbox
" "
'pr-i-despool
- #'(lambda (widget &rest _ignore)
- (if pr-spool-p
- (setq pr-i-despool (not pr-i-despool))
- (ding)
- (message "Can despool only when spooling is actually selected")
- (setq pr-i-despool nil))
- (widget-value-set widget pr-i-despool)
- (widget-setup)) ; MUST be called after widget-value-set
+ (lambda (widget &rest _ignore)
+ (if pr-spool-p
+ (setq pr-i-despool (not pr-i-despool))
+ (ding)
+ (message "Can despool only when spooling is actually selected")
+ (setq pr-i-despool nil))
+ (widget-value-set widget pr-i-despool)
+ (widget-setup)) ; MUST be called after widget-value-set
" Despool "))
;; 2. PostScript Printer: Preview Print Quit
(pr-insert-button 'pr-interface-preview "Preview" " ")
@@ -5835,9 +5835,9 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
;; 4. Settings:
;; 4. Settings: Landscape Auto Region Verbose
(pr-insert-checkbox "\n\n " 'ps-landscape-mode
- #'(lambda (&rest _ignore)
- (setq ps-landscape-mode (not ps-landscape-mode)
- pr-file-landscape ps-landscape-mode))
+ (lambda (&rest _ignore)
+ (setq ps-landscape-mode (not ps-landscape-mode)
+ pr-file-landscape ps-landscape-mode))
" Landscape ")
(pr-insert-toggle 'pr-auto-region " Auto Region ")
(pr-insert-toggle 'pr-buffer-verbose " Verbose\n ")
@@ -5857,28 +5857,28 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(pr-insert-toggle 'ps-zebra-stripes " Zebra Stripes")
(pr-insert-checkbox " "
'pr-spool-p
- #'(lambda (&rest _ignore)
- (setq pr-spool-p (not pr-spool-p))
- (unless pr-spool-p
- (setq pr-i-despool nil)
- (pr-update-checkbox 'pr-i-despool)))
+ (lambda (&rest _ignore)
+ (setq pr-spool-p (not pr-spool-p))
+ (unless pr-spool-p
+ (setq pr-i-despool nil)
+ (pr-update-checkbox 'pr-i-despool)))
" Spool Buffer")
;; 4. Settings: Duplex Print with faces
(pr-insert-checkbox "\n "
'ps-spool-duplex
- #'(lambda (&rest _ignore)
- (setq ps-spool-duplex (not ps-spool-duplex)
- pr-file-duplex ps-spool-duplex))
+ (lambda (&rest _ignore)
+ (setq ps-spool-duplex (not ps-spool-duplex)
+ pr-file-duplex ps-spool-duplex))
" Duplex ")
(pr-insert-toggle 'pr-faces-p " Print with faces")
;; 4. Settings: Tumble Print via Ghostscript
(pr-insert-checkbox "\n "
'ps-spool-tumble
- #'(lambda (&rest _ignore)
- (setq ps-spool-tumble (not ps-spool-tumble)
- pr-file-tumble ps-spool-tumble))
+ (lambda (&rest _ignore)
+ (setq ps-spool-tumble (not ps-spool-tumble)
+ pr-file-tumble ps-spool-tumble))
" Tumble ")
(pr-insert-toggle 'pr-print-using-ghostscript " Print via Ghostscript\n ")
@@ -5886,11 +5886,11 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(pr-insert-toggle 'ps-print-upside-down " Upside-Down")
(pr-insert-italic "\n\nSelect Pages : " 2 14)
(pr-insert-menu "Page Parity" 'ps-even-or-odd-pages
- (mapcar #'(lambda (alist)
- (list 'choice-item
- :format "%[%t%]"
- :tag (cdr alist)
- :value (car alist)))
+ (mapcar (lambda (alist)
+ (list 'choice-item
+ :format "%[%t%]"
+ :tag (cdr alist)
+ :value (car alist)))
pr-even-or-odd-alist)))
@@ -5898,7 +5898,7 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
;; 5. Customize:
(pr-insert-italic "\n\nCustomize : " 2 11)
(pr-insert-button 'pr-customize "printing" " ")
- (pr-insert-button #'(lambda (&rest _ignore) (ps-print-customize))
+ (pr-insert-button (lambda (&rest _ignore) (ps-print-customize))
"ps-print" " ")
(pr-insert-button 'lpr-customize "lpr"))
@@ -6207,18 +6207,18 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(defun pr-choice-alist (alist)
- (let ((max (apply #'max (mapcar #'(lambda (alist)
- (length (symbol-name (car alist))))
+ (let ((max (apply #'max (mapcar (lambda (alist)
+ (length (symbol-name (car alist))))
alist))))
- (mapcar #'(lambda (alist)
- (let* ((sym (car alist))
- (name (symbol-name sym)))
- (list
- 'choice-item
- :format "%[%t%]"
- :tag (concat name
- (make-string (- max (length name)) ?_))
- :value sym)))
+ (mapcar (lambda (alist)
+ (let* ((sym (car alist))
+ (name (symbol-name sym)))
+ (list
+ 'choice-item
+ :format "%[%t%]"
+ :tag (concat name
+ (make-string (- max (length name)) ?_))
+ :value sym)))
alist)))
@@ -6227,5 +6227,4 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order."
(provide 'printing)
-
;;; printing.el ends here
diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el
index 4d4becf..0c5837c 100644
--- a/lisp/progmodes/bug-reference.el
+++ b/lisp/progmodes/bug-reference.el
@@ -1,4 +1,4 @@
-;; bug-reference.el --- buttonize bug references -*- lexical-binding: t; -*-
+;;; bug-reference.el --- buttonize bug references -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@@ -440,9 +440,6 @@ and set it if applicable."
;;;###autoload
(define-minor-mode bug-reference-mode
"Toggle hyperlinking bug references in the buffer (Bug Reference mode)."
- nil
- ""
- nil
:after-hook (bug-reference--run-auto-setup)
(if bug-reference-mode
(jit-lock-register #'bug-reference-fontify)
@@ -454,9 +451,6 @@ and set it if applicable."
;;;###autoload
(define-minor-mode bug-reference-prog-mode
"Like `bug-reference-mode', but only buttonize in comments and strings."
- nil
- ""
- nil
:after-hook (bug-reference--run-auto-setup)
(if bug-reference-prog-mode
(jit-lock-register #'bug-reference-fontify)
diff --git a/lisp/progmodes/cc-align.el b/lisp/progmodes/cc-align.el
index 51d51de..9234d0b 100644
--- a/lisp/progmodes/cc-align.el
+++ b/lisp/progmodes/cc-align.el
@@ -1,4 +1,4 @@
-;;; cc-align.el --- custom indentation functions for CC Mode
+;;; cc-align.el --- custom indentation functions for CC Mode -*-
lexical-binding: t -*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
@@ -44,6 +44,9 @@
(cc-require 'cc-vars)
(cc-require 'cc-engine)
+(defvar c-syntactic-context)
+(defvar c-syntactic-element)
+
;; Standard line-up functions
;;
diff --git a/lisp/progmodes/cc-awk.el b/lisp/progmodes/cc-awk.el
index 3228944..334e821 100644
--- a/lisp/progmodes/cc-awk.el
+++ b/lisp/progmodes/cc-awk.el
@@ -1,4 +1,4 @@
-;;; cc-awk.el --- AWK specific code within cc-mode.
+;;; cc-awk.el --- AWK specific code within cc-mode. -*- lexical-binding: t -*-
;; Copyright (C) 1988, 1994, 1996, 2000-2021 Free Software Foundation,
;; Inc.
@@ -1227,4 +1227,4 @@ comment at the start of cc-engine.el for more info."
;; indent-tabs-mode: t
;; tab-width: 8
;; End:
-;;; awk-mode.el ends here
+;;; cc-awk.el ends here
diff --git a/lisp/progmodes/cc-bytecomp.el b/lisp/progmodes/cc-bytecomp.el
index 3f7caf3..edbac64 100644
--- a/lisp/progmodes/cc-bytecomp.el
+++ b/lisp/progmodes/cc-bytecomp.el
@@ -1,4 +1,4 @@
-;;; cc-bytecomp.el --- compile time setup for proper compilation
+;;; cc-bytecomp.el --- compile time setup for proper compilation -*-
lexical-binding: t -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
@@ -85,8 +85,8 @@
(defvar cc-bytecomp-environment-set nil)
-(defmacro cc-bytecomp-debug-msg (&rest args)
- (ignore args)
+(defmacro cc-bytecomp-debug-msg (&rest _args) ; Change to ARGS when needed.
+ ;; (declare (debug t))
;;`(message ,@args)
)
@@ -97,6 +97,8 @@
;; compilation can trigger loading (various `require' type forms)
;; and loading can trigger compilation (the package manager does
;; this). We walk the lisp stack if necessary.
+ ;; Never native compile to allow cc-defs.el:2345 hack.
+ (declare (speed -1))
(cond
((and load-in-progress
(boundp 'byte-compile-dest-file)
@@ -108,14 +110,15 @@
(memq (cadr elt)
'(load require
byte-compile-file byte-recompile-directory
- batch-byte-compile)))))
+ batch-byte-compile batch-native-compile)))))
(setq n (1+ n)))
(cond
((memq (cadr elt) '(load require))
'loading)
((memq (cadr elt) '(byte-compile-file
byte-recompile-directory
- batch-byte-compile))
+ batch-byte-compile
+ batch-native-compile))
'compiling)
(t ; Can't happen.
(message "cc-bytecomp-compiling-or-loading: System flags spuriously
set")
@@ -284,7 +287,9 @@ perhaps a `cc-bytecomp-restore-environment' is forgotten
somewhere"))
(cons cc-file cc-bytecomp-loaded-files))
(cc-bytecomp-debug-msg
"cc-bytecomp-load: Loading %S" cc-file)
- (load cc-file nil t t)
+ ;; native-comp may async compile also intalled el.gz
+ ;; files therefore we may have to load here other el.gz.
+ (load cc-part nil t)
(cc-bytecomp-debug-msg
"cc-bytecomp-load: Loaded %S" cc-file)))
(cc-bytecomp-setup-environment)
@@ -297,6 +302,7 @@ during compilation, but compile in a `require'. Don't use
within
Having cyclic cc-require's will result in infinite recursion. That's
somewhat intentional."
+ (declare (debug t))
`(progn
(eval-when-compile
(cc-bytecomp-load (symbol-name ,cc-part)))
@@ -309,6 +315,7 @@ time, (ii) generate code to load the file at load time.
CC-PART will normally be a quoted name such as \\='cc-fix.
CONDITION should not be quoted."
+ (declare (debug t))
(if (eval condition)
(progn
(cc-bytecomp-load (symbol-name (eval cc-part)))
@@ -323,6 +330,7 @@ after the loading of FILE.
CC-PART will normally be a quoted name such as \\='cc-fix. FILE
should be a string. CONDITION should not be quoted."
+ (declare (debug t))
(if (eval condition)
(progn
(cc-bytecomp-load (symbol-name (eval cc-part)))
@@ -333,6 +341,7 @@ should be a string. CONDITION should not be quoted."
(defmacro cc-provide (feature)
"A replacement for the `provide' form that restores the environment
after the compilation. Don't use within `eval-when-compile'."
+ (declare (debug t))
`(progn
(eval-when-compile (cc-bytecomp-restore-environment))
(provide ,feature)))
@@ -344,6 +353,7 @@ during compilation. Don't use outside `eval-when-compile'
or
Having cyclic cc-load's will result in infinite recursion. That's
somewhat intentional."
+ (declare (debug t))
`(or (and (featurep 'cc-bytecomp)
(cc-bytecomp-load ,cc-part))
(load ,cc-part nil t nil)))
@@ -352,6 +362,7 @@ somewhat intentional."
"Force loading of the corresponding .el file in the current directory
during compilation, but do a compile time `require' otherwise. Don't
use within `eval-when-compile'."
+ (declare (debug t))
`(eval-when-compile
(if (and (fboundp 'cc-bytecomp-is-compiling)
(cc-bytecomp-is-compiling))
@@ -363,6 +374,7 @@ use within `eval-when-compile'."
"Do a `require' of an external package.
This restores and sets up the compilation environment before and
afterwards. Don't use within `eval-when-compile'."
+ (declare (debug t))
`(progn
(eval-when-compile (cc-bytecomp-restore-environment))
(require ,feature)
@@ -371,6 +383,7 @@ afterwards. Don't use within `eval-when-compile'."
(defmacro cc-bytecomp-defvar (var)
"Binds the symbol as a variable during compilation of the file,
to silence the byte compiler. Don't use within `eval-when-compile'."
+ (declare (debug nil))
`(eval-when-compile
(if (boundp ',var)
(cc-bytecomp-debug-msg
@@ -398,6 +411,7 @@ definition. That means that this macro will not shut up
warnings
about incorrect number of arguments. It's dangerous to try to replace
existing functions since the byte compiler might need the definition
at compile time, e.g. for macros and inline functions."
+ (declare (debug nil))
`(eval-when-compile
(if (fboundp ',fun)
(cc-bytecomp-debug-msg
@@ -419,6 +433,7 @@ at compile time, e.g. for macros and inline functions."
(defmacro cc-bytecomp-put (symbol propname value)
"Set a property on a symbol during compilation (and evaluation) of
the file. Don't use outside `eval-when-compile'."
+ (declare (debug t))
`(eval-when-compile
(if (not (assoc (cons ,symbol ,propname) cc-bytecomp-original-properties))
(progn
@@ -439,6 +454,7 @@ the file. Don't use outside `eval-when-compile'."
the compilation. This is the same as using `boundp' but additionally
exclude any variables that have been bound during compilation with
`cc-bytecomp-defvar'."
+ (declare (debug t))
(if (and (cc-bytecomp-is-compiling)
(memq (car (cdr symbol)) cc-bytecomp-unbound-variables))
nil
@@ -449,6 +465,7 @@ exclude any variables that have been bound during
compilation with
the compilation. This is the same as using `fboundp' but additionally
exclude any functions that have been bound during compilation with
`cc-bytecomp-defun'."
+ (declare (debug t))
(let (fun-elem)
(if (and (cc-bytecomp-is-compiling)
(setq fun-elem (assq (car (cdr symbol))
diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el
index 1754436..bdfdf17 100644
--- a/lisp/progmodes/cc-cmds.el
+++ b/lisp/progmodes/cc-cmds.el
@@ -1,4 +1,4 @@
-;;; cc-cmds.el --- user level commands for CC Mode
+;;; cc-cmds.el --- user level commands for CC Mode -*- lexical-binding: t -*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
@@ -49,12 +49,11 @@
; which looks at this.
(cc-bytecomp-defun electric-pair-post-self-insert-function)
(cc-bytecomp-defvar c-indent-to-body-directives)
+(defvar c-syntactic-context)
;; Indentation / Display syntax functions
(defvar c-fix-backslashes t)
-(defvar c-syntactic-context)
-
(defun c-indent-line (&optional syntax quiet ignore-point-pos)
"Indent the current line according to the syntactic context,
if `c-syntactic-indentation' is non-nil. Optional SYNTAX is the
@@ -1220,9 +1219,9 @@ numeric argument is supplied, or the point is inside a
literal."
(self-insert-command (prefix-numeric-value arg)))
(setq final-pos (point))
-;;;; 2010-01-31: There used to be code here to put a syntax-table text
-;;;; property on the new < or > and its mate (if any) when they are template
-;;;; parens. This is now done in an after-change function.
+;;;; 2010-01-31: There used to be code here to put a syntax-table text
+;;;; property on the new < or > and its mate (if any) when they are template
+;;;; parens. This is now done in an after-change function.
(when (and (not arg) (not literal))
;; Have we got a delimiter on a #include directive?
@@ -1640,7 +1639,7 @@ No indentation or other \"electric\" behavior is
performed."
;; This function might do hidden buffer changes.
(save-excursion
(let* (knr-start knr-res
- decl-result brace-decl-p
+ decl-result
(start (point))
(paren-state (c-parse-state))
(least-enclosing (c-least-enclosing-brace paren-state)))
@@ -1670,12 +1669,19 @@ No indentation or other \"electric\" behavior is
performed."
(not (looking-at c-defun-type-name-decl-key))))))
'at-function-end)
(t
+ ;; Kluge so that c-beginning-of-decl-1 won't go back if we're already
+ ;; at a declaration.
+ (if (or (and (eolp) (not (eobp))) ; EOL is matched by "\\s>"
+ (not (c-looking-at-non-alphnumspace)))
+ (forward-char))
+
(if (and least-enclosing
(eq (char-after least-enclosing) ?\())
(c-go-list-forward least-enclosing))
(c-forward-syntactic-ws)
(setq knr-start (point))
- (if (c-syntactic-re-search-forward "{" nil t t)
+ (if (and (c-syntactic-re-search-forward "[;{]" nil t t)
+ (eq (char-before) ?\{))
(progn
(backward-char)
(cond
@@ -1689,19 +1695,27 @@ No indentation or other \"electric\" behavior is
performed."
((and knr-res
(goto-char knr-res)
(c-backward-syntactic-ws))) ; Always returns nil.
- ((and (eq (char-before) ?\))
- (c-go-list-backward))
- (c-syntactic-skip-backward "^;" start t)
- (if (eq (point) start)
- (if (progn (c-backward-syntactic-ws)
- (memq (char-before) '(?\; ?} nil)))
- (if (progn (c-forward-syntactic-ws)
- (eq (point) start))
- 'at-header
- 'outwith-function)
- 'in-header)
- 'outwith-function))
- (t 'outwith-function)))
+ (t
+ (when (eq (char-before) ?\))
+ ;; The `c-go-list-backward' is a precaution against
+ ;; `c-beginning-of-decl-1' spuriously finding a C++ lambda
+ ;; function inside the parentheses.
+ (c-go-list-backward))
+ (setq decl-result
+ (car (c-beginning-of-decl-1
+ (and least-enclosing
+ (c-safe-position
+ least-enclosing paren-state)))))
+ (cond
+ ((> (point) start)
+ 'outwith-function)
+ ((eq decl-result 'same)
+ (if (eq (point) start)
+ 'at-header
+ 'in-header))
+ (t (error
+ "c-where-wrt-brace-construct: c-beginning-of-decl-1
returned %s"
+ decl-result))))))
'outwith-function))))))
(defun c-backward-to-nth-BOF-{ (n where)
@@ -1810,15 +1824,18 @@ No indentation or other \"electric\" behavior is
performed."
nil)))
(eval-and-compile
- (defmacro c-while-widening-to-decl-block (condition)
+ (defmacro c-while-widening-to-decl-block (condition &optional no-where)
;; Repeatedly evaluate CONDITION until it returns nil. After each
;; evaluation, if `c-defun-tactic' is set appropriately, widen to innards
;; of the next enclosing declaration block (e.g. namespace, class), or the
;; buffer's original restriction.
;;
+ ;; If NO-WHERE is non-nil, don't compile in a `(setq where ....)'.
+ ;;
;; This is a very special purpose macro, which assumes the existence of
;; several variables. It is for use only in c-beginning-of-defun and
;; c-end-of-defun.
+ (declare (debug t))
`(while
(and ,condition
(eq c-defun-tactic 'go-outward)
@@ -1826,7 +1843,8 @@ No indentation or other \"electric\" behavior is
performed."
(setq paren-state (c-whack-state-after lim paren-state))
(setq lim (c-widen-to-enclosing-decl-scope
paren-state orig-point-min orig-point-max))
- (setq where 'in-block))))
+ ,@(if (not no-where)
+ `((setq where 'in-block))))))
(def-edebug-spec c-while-widening-to-decl-block t)
@@ -2307,11 +2325,11 @@ with a brace block, at the outermost level of nesting."
(c-save-buffer-state ((paren-state (c-parse-state))
(orig-point-min (point-min))
(orig-point-max (point-max))
- lim name limits where)
+ lim name limits)
(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))))
+ (c-while-widening-to-decl-block (not (setq name (c-defun-name-1))) t)
(when name
(setq limits (c-declaration-limits-1 near))
(cons name limits)))
@@ -2927,10 +2945,13 @@ function does not require the declaration to contain a
brace block."
(c-looking-at-special-brace-list)))
(or allow-early-stop (/= here last))
(save-excursion ; Is this a check that we're NOT at top level?
-;;;; NO! This seems to check that (i) EITHER we're at the top level; OR (ii)
The next enclosing
-;;;; level of bracketing is a '{'. HMM. Doesn't seem to make sense.
-;;;; 2003/8/8 This might have something to do with the GCC extension
"Statement Expressions", e.g.
-;;;; while ({stmt1 ; stmt2 ; exp ;}). This form excludes such Statement
Expressions.
+;;;; NO! This seems to check that (i) EITHER we're at the top level;
+;;;; OR (ii) The next enclosing level of bracketing is a '{'. HMM.
+;;;; Doesn't seem to make sense.
+;;;; 2003/8/8 This might have something to do with the GCC extension
+;;;; "Statement Expressions", e.g.
+;;;; while ({stmt1 ; stmt2 ; exp ;}).
+;;;; This form excludes such Statement Expressions.
(or (not (c-safe (up-list -1) t))
(= (char-after) ?{))))
(goto-char last)
diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el
index 536e676..4f79fa9 100644
--- a/lisp/progmodes/cc-defs.el
+++ b/lisp/progmodes/cc-defs.el
@@ -1,4 +1,4 @@
-;;; cc-defs.el --- compile time definitions for CC Mode
+;;; cc-defs.el --- compile time definitions for CC Mode -*- lexical-binding: t
-*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
@@ -125,7 +125,7 @@ The result of the body appears to the compiler as a quoted
constant.
This variant works around bugs in `eval-when-compile' in various
\(X)Emacs versions. See cc-defs.el for details."
-
+ (declare (indent 0) (debug t))
(if c-inside-eval-when-compile
;; XEmacs 21.4.6 has a bug in `eval-when-compile' in that it
;; evaluates its body at macro expansion time if it's nested
@@ -170,9 +170,7 @@ This variant works around bugs in `eval-when-compile' in
various
;; constant that we eval. That otoh introduce a problem in
;; that a returned lambda expression doesn't get byte
;; compiled (even if `function' is used).
- (eval '(let ((c-inside-eval-when-compile t)) ,@body)))))
-
- (put 'cc-eval-when-compile 'lisp-indent-hook 0))
+ (eval '(let ((c-inside-eval-when-compile t)) ,@body))))))
;;; Macros.
@@ -181,6 +179,7 @@ This variant works around bugs in `eval-when-compile' in
various
;; between the host [X]Emacsen."
;; The motivation for this macro is to avoid the irritating message
;; "function `mapcan' from cl package called at runtime" produced by Emacs.
+ (declare (debug t))
(cond
((and (fboundp 'mapcan)
(subrp (symbol-function 'mapcan)))
@@ -196,18 +195,21 @@ This variant works around bugs in `eval-when-compile' in
various
(defmacro c--set-difference (liszt1 liszt2 &rest other-args)
;; Macro to smooth out the renaming of `set-difference' in Emacs 24.3.
+ (declare (debug (form form &rest [symbolp form])))
(if (eq c--cl-library 'cl-lib)
`(cl-set-difference ,liszt1 ,liszt2 ,@other-args)
`(set-difference ,liszt1 ,liszt2 ,@other-args)))
(defmacro c--intersection (liszt1 liszt2 &rest other-args)
;; Macro to smooth out the renaming of `intersection' in Emacs 24.3.
+ (declare (debug (form form &rest [symbolp form])))
(if (eq c--cl-library 'cl-lib)
`(cl-intersection ,liszt1 ,liszt2 ,@other-args)
`(intersection ,liszt1 ,liszt2 ,@other-args)))
(eval-and-compile
(defmacro c--macroexpand-all (form &optional environment)
+ (declare (debug t))
;; Macro to smooth out the renaming of `cl-macroexpand-all' in Emacs 24.3.
(if (fboundp 'macroexpand-all)
`(macroexpand-all ,form ,environment)
@@ -215,6 +217,7 @@ This variant works around bugs in `eval-when-compile' in
various
(defmacro c--delete-duplicates (cl-seq &rest cl-keys)
;; Macro to smooth out the renaming of `delete-duplicates' in Emacs 24.3.
+ (declare (debug (form &rest [symbolp form])))
(if (eq c--cl-library 'cl-lib)
`(cl-delete-duplicates ,cl-seq ,@cl-keys)
`(delete-duplicates ,cl-seq ,@cl-keys))))
@@ -222,6 +225,7 @@ This variant works around bugs in `eval-when-compile' in
various
(defmacro c-font-lock-flush (beg end)
"Declare the region BEG...END's fontification as out-of-date.
On XEmacs and older Emacsen, this refontifies that region immediately."
+ (declare (debug t))
(if (fboundp 'font-lock-flush)
`(font-lock-flush ,beg ,end)
`(font-lock-fontify-region ,beg ,end)))
@@ -249,6 +253,7 @@ one of the following symbols:
If the referenced position doesn't exist, the closest accessible point
to it is returned. This function does not modify the point or the mark."
+ (declare (debug t))
(if (eq (car-safe position) 'quote)
(let ((position (eval position)))
(cond
@@ -417,6 +422,7 @@ to it is returned. This function does not modify the point
or the mark."
(defmacro c-is-escaped (pos)
;; Are there an odd number of backslashes before POS?
+ (declare (debug t))
`(save-excursion
(goto-char ,pos)
(not (zerop (logand (skip-chars-backward "\\\\") 1)))))
@@ -424,6 +430,7 @@ to it is returned. This function does not modify the point
or the mark."
(defmacro c-will-be-escaped (pos beg end)
;; Will the character after POS be escaped after the removal of (BEG END)?
;; It is assumed that (>= POS END).
+ (declare (debug t))
`(save-excursion
(let ((-end- ,end)
count)
@@ -436,6 +443,7 @@ to it is returned. This function does not modify the point
or the mark."
(defmacro c-will-be-unescaped (beg)
;; Would the character after BEG be unescaped?
+ (declare (debug t))
`(save-excursion
(let (count)
(goto-char ,beg)
@@ -446,6 +454,7 @@ to it is returned. This function does not modify the point
or the mark."
(defmacro c-next-single-property-change (position prop &optional object limit)
;; See the doc string for either of the defuns expanded to.
+ (declare (debug t))
(if (and c-use-extents
(fboundp 'next-single-char-property-change))
;; XEmacs >= 2005-01-25
@@ -455,6 +464,7 @@ to it is returned. This function does not modify the point
or the mark."
(defmacro c-previous-single-property-change (position prop &optional object
limit)
;; See the doc string for either of the defuns expanded to.
+ (declare (debug t))
(if (and c-use-extents
(fboundp 'previous-single-char-property-change))
;; XEmacs >= 2005-01-25
@@ -474,6 +484,7 @@ to it is returned. This function does not modify the point
or the mark."
(defmacro c-set-region-active (activate)
;; Activate the region if ACTIVE is non-nil, deactivate it
;; otherwise. Covers the differences between Emacs and XEmacs.
+ (declare (debug t))
(if (fboundp 'zmacs-activate-region)
;; XEmacs.
`(if ,activate
@@ -483,6 +494,7 @@ to it is returned. This function does not modify the point
or the mark."
`(setq mark-active ,activate)))
(defmacro c-set-keymap-parent (map parent)
+ (declare (debug t))
(cond
;; XEmacs
((cc-bytecomp-fboundp 'set-keymap-parents)
@@ -495,6 +507,7 @@ to it is returned. This function does not modify the point
or the mark."
(defmacro c-delete-and-extract-region (start end)
"Delete the text between START and END and return it."
+ (declare (debug t))
(if (cc-bytecomp-fboundp 'delete-and-extract-region)
;; Emacs 21.1 and later
`(delete-and-extract-region ,start ,end)
@@ -505,15 +518,16 @@ to it is returned. This function does not modify the
point or the mark."
(defmacro c-safe (&rest body)
;; safely execute BODY, return nil if an error occurred
+ (declare (indent 0) (debug t))
`(condition-case nil
(progn ,@body)
(error nil)))
-(put 'c-safe 'lisp-indent-function 0)
(defmacro c-int-to-char (integer)
;; In Emacs, a character is an integer. In XEmacs, a character is a
;; type distinct from an integer. Sometimes we need to convert integers to
;; characters. `c-int-to-char' makes this conversion, if necessary.
+ (declare (debug t))
(if (fboundp 'int-to-char)
`(int-to-char ,integer)
integer))
@@ -521,6 +535,7 @@ to it is returned. This function does not modify the point
or the mark."
(defmacro c-characterp (arg)
;; Return t when ARG is a character (XEmacs) or integer (Emacs), otherwise
;; return nil.
+ (declare (debug t))
(if (integerp ?c)
`(integerp ,arg)
`(characterp ,arg)))
@@ -567,6 +582,7 @@ to it is returned. This function does not modify the point
or the mark."
;; string opener, or after the introductory R of one. The match data is
;; overwritten. On success the opener's identifier will be (match-string
;; 1). Text properties on any characters are ignored.
+ (declare (debug t))
(if pos
`(save-excursion
(goto-char ,pos)
@@ -628,6 +644,7 @@ If BODY makes a change that unconditionally is undone then
wrap this
macro inside `c-save-buffer-state'. That way the change can be done
even when the buffer is read-only, and without interference from
various buffer change hooks."
+ (declare (indent 0) (debug t))
`(let (-tnt-chng-keep
-tnt-chng-state)
(unwind-protect
@@ -638,7 +655,6 @@ various buffer change hooks."
-tnt-chng-state (c-tnt-chng-record-state)
-tnt-chng-keep (progn ,@body))
(c-tnt-chng-cleanup -tnt-chng-keep -tnt-chng-state))))
-(put 'c-tentative-buffer-changes 'lisp-indent-function 0)
(defun c-tnt-chng-record-state ()
;; Used internally in `c-tentative-buffer-changes'.
@@ -696,6 +712,7 @@ on the wrong side of LIMIT, it stays unchanged.
Note that this function might do hidden buffer changes. See the
comment at the start of cc-engine.el for more info."
+ (declare (debug t))
(if limit
`(when (< (point) (or ,limit (point-max)))
(save-restriction
@@ -717,6 +734,7 @@ starts on the wrong side of LIMIT, it stays unchanged.
Note that this function might do hidden buffer changes. See the
comment at the start of cc-engine.el for more info."
+ (declare (debug t))
(if limit
`(when (> (point) (or ,limit (point-min)))
(save-restriction
@@ -733,11 +751,13 @@ This is like `forward-sexp' except that it isn't
interactive and does
not do any user friendly adjustments of the point and that it isn't
susceptible to user configurations such as disabling of signals in
certain situations."
+ (declare (debug t))
(or count (setq count 1))
`(goto-char (scan-sexps (point) ,count)))
(defmacro c-backward-sexp (&optional count)
"See `c-forward-sexp' and reverse directions."
+ (declare (debug t))
(or count (setq count 1))
`(c-forward-sexp ,(if (numberp count) (- count) `(- ,count))))
@@ -747,6 +767,7 @@ for unbalanced parens.
A limit for the search may be given. FROM is assumed to be on the
right side of it."
+ (declare (debug t))
(let ((res (if (featurep 'xemacs)
`(scan-lists ,from ,count ,depth nil t)
`(c-safe (scan-lists ,from ,count ,depth)))))
@@ -774,6 +795,7 @@ leave point unmoved.
A LIMIT for the search may be given. The start position is assumed to be
before it."
+ (declare (debug t))
`(let ((dest (c-safe-scan-lists ,(or pos '(point)) 1 0 ,limit)))
(when dest (goto-char dest) dest)))
@@ -784,6 +806,7 @@ leave point unmoved.
A LIMIT for the search may be given. The start position is assumed to be
after it."
+ (declare (debug t))
`(let ((dest (c-safe-scan-lists ,(or pos '(point)) -1 0 ,limit)))
(when dest (goto-char dest) dest)))
@@ -793,6 +816,7 @@ or nil if no such position exists. The point is used if
POS is left out.
A limit for the search may be given. The start position is assumed to
be before it."
+ (declare (debug t))
`(c-safe-scan-lists ,(or pos '(point)) 1 1 ,limit))
(defmacro c-up-list-backward (&optional pos limit)
@@ -801,6 +825,7 @@ or nil if no such position exists. The point is used if
POS is left out.
A limit for the search may be given. The start position is assumed to
be after it."
+ (declare (debug t))
`(c-safe-scan-lists ,(or pos '(point)) -1 1 ,limit))
(defmacro c-down-list-forward (&optional pos limit)
@@ -809,6 +834,7 @@ or nil if no such position exists. The point is used if
POS is left out.
A limit for the search may be given. The start position is assumed to
be before it."
+ (declare (debug t))
`(c-safe-scan-lists ,(or pos '(point)) 1 -1 ,limit))
(defmacro c-down-list-backward (&optional pos limit)
@@ -817,6 +843,7 @@ or nil if no such position exists. The point is used if
POS is left out.
A limit for the search may be given. The start position is assumed to
be after it."
+ (declare (debug t))
`(c-safe-scan-lists ,(or pos '(point)) -1 -1 ,limit))
(defmacro c-go-up-list-forward (&optional pos limit)
@@ -826,6 +853,7 @@ position exists, otherwise nil is returned and the point
isn't moved.
A limit for the search may be given. The start position is assumed to
be before it."
+ (declare (debug t))
`(let ((dest (c-up-list-forward ,pos ,limit)))
(when dest (goto-char dest) t)))
@@ -836,6 +864,7 @@ position exists, otherwise nil is returned and the point
isn't moved.
A limit for the search may be given. The start position is assumed to
be after it."
+ (declare (debug t))
`(let ((dest (c-up-list-backward ,pos ,limit)))
(when dest (goto-char dest) t)))
@@ -846,6 +875,7 @@ exists, otherwise nil is returned and the point isn't moved.
A limit for the search may be given. The start position is assumed to
be before it."
+ (declare (debug t))
`(let ((dest (c-down-list-forward ,pos ,limit)))
(when dest (goto-char dest) t)))
@@ -856,6 +886,7 @@ exists, otherwise nil is returned and the point isn't moved.
A limit for the search may be given. The start position is assumed to
be after it."
+ (declare (debug t))
`(let ((dest (c-down-list-backward ,pos ,limit)))
(when dest (goto-char dest) t)))
@@ -967,6 +998,7 @@ be after it."
;; point)? Always returns nil for languages which don't have Virtual
;; semicolons.
;; This macro might do hidden buffer changes.
+ (declare (debug t))
`(if c-at-vsemi-p-fn
(funcall c-at-vsemi-p-fn ,@(if pos `(,pos)))))
@@ -984,6 +1016,7 @@ be after it."
(defmacro c-benign-error (format &rest args)
;; Formats an error message for the echo area and dings, i.e. like
;; `error' but doesn't abort.
+ (declare (debug t))
`(progn
(message ,format ,@args)
(ding)))
@@ -993,18 +1026,19 @@ be after it."
;; way to execute code.
;; Maintainers' note: If TABLE is `c++-template-syntax-table', DON'T call
;; any forms inside this that call `c-parse-state'. !!!!
+ (declare (indent 1) (debug t))
`(let ((c-with-syntax-table-orig-table (syntax-table)))
(unwind-protect
(progn
(set-syntax-table ,table)
,@code)
(set-syntax-table c-with-syntax-table-orig-table))))
-(put 'c-with-syntax-table 'lisp-indent-function 1)
(defmacro c-skip-ws-forward (&optional limit)
"Skip over any whitespace following point.
This function skips over horizontal and vertical whitespace and line
continuations."
+ (declare (debug t))
(if limit
`(let ((limit (or ,limit (point-max))))
(while (progn
@@ -1026,6 +1060,7 @@ continuations."
"Skip over any whitespace preceding point.
This function skips over horizontal and vertical whitespace and line
continuations."
+ (declare (debug t))
(if limit
`(let ((limit (or ,limit (point-min))))
(while (progn
@@ -1048,6 +1083,7 @@ continuations."
"Return non-nil if the current CC Mode major mode is MODE.
MODE is either a mode symbol or a list of mode symbols."
+ (declare (debug t))
(if c-langs-are-parametric
;; Inside a `c-lang-defconst'.
`(c-lang-major-mode-is ,mode)
@@ -1130,6 +1166,7 @@ MODE is either a mode symbol or a list of mode symbols."
;; 21) then it's assumed that the property is present on it.
;;
;; This macro does a hidden buffer change.
+ (declare (debug t))
(setq property (eval property))
(if (or c-use-extents
(not (cc-bytecomp-boundp 'text-property-default-nonsticky)))
@@ -1147,6 +1184,7 @@ MODE is either a mode symbol or a list of mode symbols."
;; Get the value of the given property on the character at POS if
;; it's been put there by `c-put-char-property'. PROPERTY is
;; assumed to be constant.
+ (declare (debug t))
(setq property (eval property))
(if c-use-extents
;; XEmacs.
@@ -1177,6 +1215,7 @@ MODE is either a mode symbol or a list of mode symbols."
;; constant.
;;
;; This macro does a hidden buffer change.
+ (declare (debug t))
(setq property (eval property))
(cond (c-use-extents
;; XEmacs.
@@ -1199,6 +1238,7 @@ MODE is either a mode symbol or a list of mode symbols."
;; Return the first position in the range [FROM to) where the text property
;; PROPERTY is set, or `most-positive-fixnum' if there is no such position.
;; PROPERTY should be a quoted constant.
+ (declare (debug t))
`(let ((-from- ,from) (-to- ,to) pos)
(cond
((and (< -from- -to-)
@@ -1220,6 +1260,7 @@ MODE is either a mode symbol or a list of mode symbols."
;; `syntax-table'.
;;
;; This macro does hidden buffer changes.
+ (declare (debug t))
(setq property (eval property))
(if c-use-extents
;; XEmacs.
@@ -1239,6 +1280,7 @@ MODE is either a mode symbol or a list of mode symbols."
(defmacro c-clear-syn-tab-properties (from to)
;; Remove all occurrences of the `syntax-table' and `c-fl-syn-tab' text
;; properties between FROM and TO.
+ (declare (debug t))
`(let ((-from- ,from) (-to- ,to))
(when (and
c-min-syn-tab-mkr c-max-syn-tab-mkr
@@ -1260,6 +1302,7 @@ LIMIT bounds the search. The comparison is done with
`equal'.
Leave point just after the character, and set the match data on
this character, and return point. If VALUE isn't found, Return
nil; point is then left undefined."
+ (declare (debug t))
`(let ((place (point)))
(while
(and
@@ -1279,6 +1322,7 @@ LIMIT bounds the search. The comparison is done with
`equal'.
Leave point just before the character, set the match data on this
character, and return point. If VALUE isn't found, Return nil;
point is then left undefined."
+ (declare (debug t))
`(let ((place (point)))
(while
(and
@@ -1322,6 +1366,7 @@ been put there by c-put-char-property. POINT remains
unchanged."
which have the value VALUE, as tested by `equal'. These
properties are assumed to be over individual characters, having
been put there by c-put-char-property. POINT remains unchanged."
+ (declare (debug t))
(if c-use-extents
;; XEmacs
`(let ((-property- ,property))
@@ -1342,6 +1387,7 @@ PROPERTY must be a constant.
Leave point just after the character, and set the match data on
this character, and return point. If the search fails, return
nil; point is then left undefined."
+ (declare (debug t))
`(let ((char-skip (concat "^" (char-to-string ,char)))
(-limit- (or ,limit (point-max)))
(-value- ,value))
@@ -1365,6 +1411,7 @@ PROPERTY must be a constant.
Leave point just before the character, and set the match data on
this character, and return point. If the search fails, return
nil; point is then left undefined."
+ (declare (debug t))
`(let ((char-skip (concat "^" (char-to-string ,char)))
(-limit- (or ,limit (point-min)))
(-value- ,value))
@@ -1388,6 +1435,7 @@ PROPERTY must be a constant.
Leave point just after the character, and set the match data on
this character, and return point. If the search fails, return
nil; point is then left undefined."
+ (declare (debug t))
`(let ((char-skip (concat "^" (char-to-string ,char)))
(-limit- (or ,limit (point-max)))
(-value- ,value))
@@ -1436,6 +1484,7 @@ by `equal'. These properties are assumed to be over
individual
characters, having been put there by c-put-char-property. POINT
remains unchanged. Return the position of the first removed
property, or nil."
+ (declare (debug t))
(if c-use-extents
;; XEmacs
`(let ((-property- ,property)
@@ -1459,6 +1508,7 @@ property, or nil."
;; `c-put-char-property' must be a constant.
"Put the text property PROPERTY with value VALUE on characters
with value CHAR in the region [FROM to)."
+ (declare (debug t))
`(let ((skip-string (concat "^" (list ,char)))
(-to- ,to))
(save-excursion
@@ -1481,6 +1531,7 @@ with value CHAR in the region [FROM to)."
;; Put an overlay/extent covering the given range in the current
;; buffer. It's currently undefined whether it's front/end sticky
;; or not. The overlay/extent object is returned.
+ (declare (debug t))
(if (cc-bytecomp-fboundp 'make-overlay)
;; Emacs.
`(let ((ol (make-overlay ,from ,to)))
@@ -1494,6 +1545,7 @@ with value CHAR in the region [FROM to)."
(defmacro c-delete-overlay (overlay)
;; Deletes an overlay/extent object previously retrieved using
;; `c-put-overlay'.
+ (declare (debug t))
(if (cc-bytecomp-fboundp 'make-overlay)
;; Emacs.
`(delete-overlay ,overlay)
@@ -1501,80 +1553,6 @@ with value CHAR in the region [FROM to)."
`(delete-extent ,overlay)))
-;; Make edebug understand the macros.
-;(eval-after-load "edebug" ; 2006-07-09: def-edebug-spec is now in subr.el.
-; '(progn
-(def-edebug-spec cc-eval-when-compile (&rest def-form))
-(def-edebug-spec c-font-lock-flush t)
-(def-edebug-spec c--mapcan t)
-(def-edebug-spec c--set-difference (form form &rest [symbolp form]))
-(def-edebug-spec c--intersection (form form &rest [symbolp form]))
-(def-edebug-spec c--delete-duplicates (form &rest [symbolp form]))
-(def-edebug-spec c-point t)
-(def-edebug-spec c-is-escaped t)
-(def-edebug-spec c-will-be-escaped t)
-(def-edebug-spec c-next-single-property-change t)
-(def-edebug-spec c-delete-and-extract-region t)
-(def-edebug-spec c-set-region-active t)
-(def-edebug-spec c-set-keymap-parent t)
-(def-edebug-spec c-safe t)
-(def-edebug-spec c-int-to-char t)
-(def-edebug-spec c-characterp t)
-(def-edebug-spec c-save-buffer-state let*)
-(def-edebug-spec c-tentative-buffer-changes t)
-(def-edebug-spec c-forward-syntactic-ws t)
-(def-edebug-spec c-backward-syntactic-ws t)
-(def-edebug-spec c-forward-sexp t)
-(def-edebug-spec c-backward-sexp t)
-(def-edebug-spec c-safe-scan-lists t)
-(def-edebug-spec c-go-list-forward t)
-(def-edebug-spec c-go-list-backward t)
-(def-edebug-spec c-up-list-forward t)
-(def-edebug-spec c-up-list-backward t)
-(def-edebug-spec c-down-list-forward t)
-(def-edebug-spec c-down-list-backward t)
-(def-edebug-spec c-go-up-list-forward t)
-(def-edebug-spec c-go-up-list-backward t)
-(def-edebug-spec c-go-down-list-forward t)
-(def-edebug-spec c-go-down-list-backward t)
-(def-edebug-spec c-at-vsemi-p t)
-(def-edebug-spec c-add-syntax t)
-(def-edebug-spec c-add-class-syntax t)
-(def-edebug-spec c-benign-error t)
-(def-edebug-spec c-with-syntax-table t)
-(def-edebug-spec c-skip-ws-forward t)
-(def-edebug-spec c-skip-ws-backward t)
-(def-edebug-spec c-major-mode-is t)
-(def-edebug-spec c-search-forward-char-property t)
-(def-edebug-spec c-search-backward-char-property t)
-(def-edebug-spec c-put-char-property t)
-(def-edebug-spec c-put-syn-tab t)
-(def-edebug-spec c-get-char-property t)
-(def-edebug-spec c-clear-char-property t)
-(def-edebug-spec c-clear-syn-tab t)
-;;(def-edebug-spec c-min-property-position nil) ; invoked only by macros
-(def-edebug-spec c-min-property-position t) ; Now invoked from functions
(2019-07)
-(def-edebug-spec c-clear-char-property-with-value t)
-(def-edebug-spec c-clear-char-property-with-value-on-char t)
-(def-edebug-spec c-put-char-properties-on-char t)
-(def-edebug-spec c-clear-char-properties t)
-(def-edebug-spec c-clear-syn-tab-properties t)
-(def-edebug-spec c-with-extended-string-fences (form form body))
-(def-edebug-spec c-put-overlay t)
-(def-edebug-spec c-delete-overlay t)
-(def-edebug-spec c-mark-<-as-paren t)
-(def-edebug-spec c-mark->-as-paren t)
-(def-edebug-spec c-unmark-<->-as-paren t)
-(def-edebug-spec c-with-<->-as-parens-suppressed (body))
-(def-edebug-spec c-self-bind-state-cache (body))
-(def-edebug-spec c-sc-scan-lists-no-category+1+1 t)
-(def-edebug-spec c-sc-scan-lists-no-category+1-1 t)
-(def-edebug-spec c-sc-scan-lists-no-category-1+1 t)
-(def-edebug-spec c-sc-scan-lists-no-category-1-1 t)
-(def-edebug-spec c-sc-scan-lists t)
-(def-edebug-spec c-sc-parse-partial-sexp t);))
-
-
;;; Functions.
;; Note: All these after the macros, to be on safe side in avoiding
@@ -1604,6 +1582,7 @@ with value CHAR in the region [FROM to)."
;; indirection through the `category' text property. This allows us to
;; toggle the property in all template brackets simultaneously and
;; cheaply. We use this, for instance, in `c-parse-state'.
+ (declare (debug t))
(if c-use-category
`(c-put-char-property ,pos 'category 'c-<-as-paren-syntax)
`(c-put-char-property ,pos 'syntax-table c-<-as-paren-syntax)))
@@ -1618,6 +1597,7 @@ with value CHAR in the region [FROM to)."
;; indirection through the `category' text property. This allows us to
;; toggle the property in all template brackets simultaneously and
;; cheaply. We use this, for instance, in `c-parse-state'.
+ (declare (debug t))
(if c-use-category
`(c-put-char-property ,pos 'category 'c->-as-paren-syntax)
`(c-put-char-property ,pos 'syntax-table c->-as-paren-syntax)))
@@ -1631,6 +1611,7 @@ with value CHAR in the region [FROM to)."
;; indirection through the `category' text property. This allows us to
;; toggle the property in all template brackets simultaneously and
;; cheaply. We use this, for instance, in `c-parse-state'.
+ (declare (debug t))
`(c-clear-char-property ,pos ,(if c-use-category ''category ''syntax-table)))
(defsubst c-suppress-<->-as-parens ()
@@ -1651,50 +1632,13 @@ with value CHAR in the region [FROM to)."
;; Like progn, except that the paren property is suppressed on all
;; template brackets whilst they are running. This macro does a hidden
;; buffer change.
+ (declare (debug (body)))
`(unwind-protect
(progn
(c-suppress-<->-as-parens)
,@forms)
(c-restore-<->-as-parens)))
-;;;;;;;;;;;;;;;
-
-(defmacro c-self-bind-state-cache (&rest forms)
- ;; Bind the state cache to itself and execute the FORMS. Return the result
- ;; of the last FORM executed. It is assumed that no buffer changes will
- ;; happen in FORMS, and no hidden buffer changes which could affect the
- ;; parsing will be made by FORMS.
- `(let* ((c-state-cache (copy-tree c-state-cache))
- (c-state-cache-good-pos c-state-cache-good-pos)
- ;(c-state-nonlit-pos-cache (copy-tree c-state-nonlit-pos-cache))
- ;(c-state-nonlit-pos-cache-limit c-state-nonlit-pos-cache-limit)
- ;(c-state-semi-nonlit-pos-cache (copy-tree
c-state-semi-nonlit-pos-cache))
- ;(c-state-semi-nonlit-pos-cache-limit c-state-semi-nonlit-pos-cache)
- (c-state-brace-pair-desert (copy-tree c-state-brace-pair-desert))
- (c-state-point-min c-state-point-min)
- (c-state-point-min-lit-type c-state-point-min-lit-type)
- (c-state-point-min-lit-start c-state-point-min-lit-start)
- (c-state-min-scan-pos c-state-min-scan-pos)
- (c-state-old-cpp-beg-marker (if (markerp c-state-old-cpp-beg-marker)
- (copy-marker
c-state-old-cpp-beg-marker)
- c-state-old-cpp-beg-marker))
- (c-state-old-cpp-beg (if (markerp c-state-old-cpp-beg)
- c-state-old-cpp-beg-marker
- c-state-old-cpp-beg))
- (c-state-old-cpp-end-marker (if (markerp c-state-old-cpp-end-marker)
- (copy-marker
c-state-old-cpp-end-marker)
- c-state-old-cpp-end-marker))
- (c-state-old-cpp-end (if (markerp c-state-old-cpp-end)
- c-state-old-cpp-end-marker
- c-state-old-cpp-end))
- (c-parse-state-state c-parse-state-state))
- (prog1
- (progn ,@forms)
- (if (markerp c-state-old-cpp-beg-marker)
- (move-marker c-state-old-cpp-beg-marker nil))
- (if (markerp c-state-old-cpp-end-marker)
- (move-marker c-state-old-cpp-end-marker nil)))))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The following macros are to be used only in `c-parse-state' and its
;; subroutines. Their main purpose is to simplify the handling of C++/Java
@@ -1708,6 +1652,7 @@ with value CHAR in the region [FROM to)."
;; Do a (scan-lists FROM 1 1). Any finishing position which either (i) is
;; determined by and angle bracket; or (ii) is inside a macro whose start
;; isn't POINT-MACRO-START doesn't count as a finishing position.
+ (declare (debug t))
`(let ((here (point))
(pos (scan-lists ,from 1 1)))
(while (eq (char-before pos) ?>)
@@ -1718,6 +1663,7 @@ with value CHAR in the region [FROM to)."
;; Do a (scan-lists FROM 1 -1). Any finishing position which either (i) is
;; determined by an angle bracket; or (ii) is inside a macro whose start
;; isn't POINT-MACRO-START doesn't count as a finishing position.
+ (declare (debug t))
`(let ((here (point))
(pos (scan-lists ,from 1 -1)))
(while (eq (char-before pos) ?<)
@@ -1729,6 +1675,7 @@ with value CHAR in the region [FROM to)."
;; Do a (scan-lists FROM -1 1). Any finishing position which either (i) is
;; determined by and angle bracket; or (ii) is inside a macro whose start
;; isn't POINT-MACRO-START doesn't count as a finishing position.
+ (declare (debug t))
`(let ((here (point))
(pos (scan-lists ,from -1 1)))
(while (eq (char-after pos) ?<)
@@ -1739,6 +1686,7 @@ with value CHAR in the region [FROM to)."
;; Do a (scan-lists FROM -1 -1). Any finishing position which either (i) is
;; determined by and angle bracket; or (ii) is inside a macro whose start
;; isn't POINT-MACRO-START doesn't count as a finishing position.
+ (declare (debug t))
`(let ((here (point))
(pos (scan-lists ,from -1 -1)))
(while (eq (char-after pos) ?>)
@@ -1747,6 +1695,7 @@ with value CHAR in the region [FROM to)."
pos))
(defmacro c-sc-scan-lists (from count depth)
+ (declare (debug t))
(if c-use-category
`(scan-lists ,from ,count ,depth)
(cond
@@ -1794,6 +1743,7 @@ with value CHAR in the region [FROM to)."
(defmacro c-sc-parse-partial-sexp (from to &optional targetdepth stopbefore
oldstate)
+ (declare (debug t))
(if c-use-category
`(parse-partial-sexp ,from ,to ,targetdepth ,stopbefore ,oldstate)
`(c-sc-parse-partial-sexp-no-category ,from ,to ,targetdepth ,stopbefore
@@ -2354,6 +2304,7 @@ system."
"Can be used inside a VAL in `c-lang-defconst' to evaluate FORM
immediately, i.e. at the same time as the `c-lang-defconst' form
itself is evaluated."
+ (declare (debug t))
;; Evaluate at macro expansion time, i.e. in the
;; `c--macroexpand-all' inside `c-lang-defconst'.
(eval form))
@@ -2396,7 +2347,8 @@ one `c-lang-defconst' for each NAME is permitted per
file. If there
already is one it will be completely replaced; the value in the
earlier definition will not affect `c-lang-const' on the same
constant. A file is identified by its base name."
-
+ (declare (indent 1)
+ (debug (&define name [&optional stringp] [&rest sexp def-form])))
(let* ((sym (intern (symbol-name name) c-lang-constants))
;; Make `c-lang-const' expand to a straightforward call to
;; `c-get-lang-constant' in `c--macroexpand-all' below.
@@ -2487,12 +2439,6 @@ constant. A file is identified by its base name."
(c-define-lang-constant ',name ,bindings
,@(and pre-files `(',pre-files))))))
-(put 'c-lang-defconst 'lisp-indent-function 1)
-;(eval-after-load "edebug" ; 2006-07-09: def-edebug-spec is now in subr.el.
-; '
-(def-edebug-spec c-lang-defconst
- (&define name [&optional stringp] [&rest sexp def-form]))
-
(defun c-define-lang-constant (name bindings &optional pre-files)
;; Used by `c-lang-defconst'.
@@ -2548,6 +2494,7 @@ LANG is the name of the language, i.e. the mode name
without the
language. NAME and LANG are not evaluated so they should not be
quoted."
+ (declare (debug (name &optional symbolp)))
(or (symbolp name)
(error "Not a symbol: %S" name))
(or (symbolp lang)
diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el
index cc9833a..622d951 100644
--- a/lisp/progmodes/cc-engine.el
+++ b/lisp/progmodes/cc-engine.el
@@ -1,4 +1,4 @@
-;;; cc-engine.el --- core syntax guessing engine for CC mode -*- coding: utf-8
-*-
+;;; cc-engine.el --- core syntax guessing engine for CC mode -*-
lexical-binding:t; coding: utf-8 -*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
@@ -163,6 +163,8 @@
(defvar c-doc-line-join-re)
(defvar c-doc-bright-comment-start-re)
(defvar c-doc-line-join-end-ch)
+(defvar c-syntactic-context)
+(defvar c-syntactic-element)
(cc-bytecomp-defvar c-min-syn-tab-mkr)
(cc-bytecomp-defvar c-max-syn-tab-mkr)
(cc-bytecomp-defun c-clear-syn-tab)
@@ -735,6 +737,7 @@ comment at the start of cc-engine.el for more info."
'(setq stack (cons (cons state saved-pos)
stack)))
(defmacro c-bos-pop-state (&optional do-if-done)
+ (declare (debug t))
`(if (setq state (car (car stack))
saved-pos (cdr (car stack))
stack (cdr stack))
@@ -759,6 +762,7 @@ comment at the start of cc-engine.el for more info."
(goto-char pos)
(setq sym nil)))
(defmacro c-bos-save-error-info (missing got)
+ (declare (debug t))
`(setq saved-pos (vector pos ,missing ,got)))
(defmacro c-bos-report-error ()
'(unless noerror
@@ -1869,51 +1873,51 @@ comment at the start of cc-engine.el for more info."
; (setq in-face (point)))
; (not (eobp)))))))
-(defmacro c-debug-sws-msg (&rest args)
- (ignore args)
+(defmacro c-debug-sws-msg (&rest _args)
+ ;; (declare (debug t))
;;`(message ,@args)
)
(defmacro c-put-is-sws (beg end)
;; This macro does a hidden buffer change.
+ (declare (debug t))
`(let ((beg ,beg) (end ,end))
(put-text-property beg end 'c-is-sws t)
,@(when (facep 'c-debug-is-sws-face)
'((c-debug-add-face beg end 'c-debug-is-sws-face)))))
-(def-edebug-spec c-put-is-sws t)
(defmacro c-put-in-sws (beg end)
;; This macro does a hidden buffer change.
+ (declare (debug t))
`(let ((beg ,beg) (end ,end))
(put-text-property beg end 'c-in-sws t)
,@(when (facep 'c-debug-is-sws-face)
'((c-debug-add-face beg end 'c-debug-in-sws-face)))))
-(def-edebug-spec c-put-in-sws t)
(defmacro c-remove-is-sws (beg end)
;; This macro does a hidden buffer change.
+ (declare (debug t))
`(let ((beg ,beg) (end ,end))
(remove-text-properties beg end '(c-is-sws nil))
,@(when (facep 'c-debug-is-sws-face)
'((c-debug-remove-face beg end 'c-debug-is-sws-face)))))
-(def-edebug-spec c-remove-is-sws t)
(defmacro c-remove-in-sws (beg end)
;; This macro does a hidden buffer change.
+ (declare (debug t))
`(let ((beg ,beg) (end ,end))
(remove-text-properties beg end '(c-in-sws nil))
,@(when (facep 'c-debug-is-sws-face)
'((c-debug-remove-face beg end 'c-debug-in-sws-face)))))
-(def-edebug-spec c-remove-in-sws t)
(defmacro c-remove-is-and-in-sws (beg end)
;; This macro does a hidden buffer change.
+ (declare (debug t))
`(let ((beg ,beg) (end ,end))
(remove-text-properties beg end '(c-is-sws nil c-in-sws nil))
,@(when (facep 'c-debug-is-sws-face)
'((c-debug-remove-face beg end 'c-debug-is-sws-face)
(c-debug-remove-face beg end 'c-debug-in-sws-face)))))
-(def-edebug-spec c-remove-is-and-in-sws t)
;; The type of literal position `end' is in a `before-change-functions'
;; function - one of `c', `c++', `pound', `noise', `attribute' or nil (but NOT
@@ -2717,9 +2721,9 @@ comment at the start of cc-engine.el for more info."
;; two char construct (such as a comment opener or an escaped character).)
(if (and (consp elt) (>= (length elt) 3))
;; Inside a string or comment
- (let ((depth 0) (containing nil) (last nil)
+ (let ((depth 0) (containing nil)
in-string in-comment
- (min-depth 0) com-style com-str-start (intermediate nil)
+ (min-depth 0) com-style com-str-start
(char-1 (nth 3 elt)) ; first char of poss. 2-char construct
(pos (car elt))
(type (cadr elt)))
@@ -2736,14 +2740,13 @@ comment at the start of cc-engine.el for more info."
(1- pos)
pos))
(if (memq 'pps-extended-state c-emacs-features)
- (list depth containing last
+ (list depth containing nil
in-string in-comment nil
min-depth com-style com-str-start
- intermediate nil)
- (list depth containing last
+ nil nil)
+ (list depth containing nil
in-string in-comment nil
- min-depth com-style com-str-start
- intermediate)))
+ min-depth com-style com-str-start nil)))
;; Not in a string or comment.
(if (memq 'pps-extended-state c-emacs-features)
@@ -3516,6 +3519,7 @@ mhtml-mode."
(defmacro c-state-cache-top-lparen (&optional cache)
;; Return the address of the top left brace/bracket/paren recorded in CACHE
;; (default `c-state-cache') (or nil).
+ (declare (debug t))
(let ((cash (or cache 'c-state-cache)))
`(if (consp (car ,cash))
(caar ,cash)
@@ -3524,6 +3528,7 @@ mhtml-mode."
(defmacro c-state-cache-top-paren (&optional cache)
;; Return the address of the latest brace/bracket/paren (whether left or
;; right) recorded in CACHE (default `c-state-cache') or nil.
+ (declare (debug t))
(let ((cash (or cache 'c-state-cache)))
`(if (consp (car ,cash))
(cdar ,cash)
@@ -3532,6 +3537,7 @@ mhtml-mode."
(defmacro c-state-cache-after-top-paren (&optional cache)
;; Return the position just after the latest brace/bracket/paren (whether
;; left or right) recorded in CACHE (default `c-state-cache') or nil.
+ (declare (debug t))
(let ((cash (or cache 'c-state-cache)))
`(if (consp (car ,cash))
(cdar ,cash)
@@ -4486,6 +4492,7 @@ mhtml-mode."
(defmacro c-state-maybe-marker (place marker)
;; If PLACE is non-nil, return a marker marking it, otherwise nil.
;; We (re)use MARKER.
+ (declare (debug (form symbolp)))
`(let ((-place- ,place))
(and -place-
(or ,marker (setq ,marker (make-marker)))
@@ -5972,6 +5979,7 @@ comment at the start of cc-engine.el for more info."
; spots and the preceding token end.")
(defmacro c-debug-put-decl-spot-faces (match-pos decl-pos)
+ (declare (debug t))
(when (facep 'c-debug-decl-spot-face)
`(c-save-buffer-state ((match-pos ,match-pos) (decl-pos ,decl-pos))
(c-debug-add-face (max match-pos (point-min)) decl-pos
@@ -5979,6 +5987,7 @@ comment at the start of cc-engine.el for more info."
(c-debug-add-face decl-pos (min (1+ decl-pos) (point-max))
'c-debug-decl-spot-face))))
(defmacro c-debug-remove-decl-spot-faces (beg end)
+ (declare (debug t))
(when (facep 'c-debug-decl-spot-face)
`(c-save-buffer-state ()
(c-debug-remove-face ,beg ,end 'c-debug-decl-spot-face)
@@ -7773,6 +7782,7 @@ comment at the start of cc-engine.el for more info."
(defvar c-last-identifier-range nil)
(defmacro c-record-type-id (range)
+ (declare (debug t))
(if (eq (car-safe range) 'cons)
;; Always true.
`(setq c-record-type-identifiers
@@ -7783,6 +7793,7 @@ comment at the start of cc-engine.el for more info."
(cons range c-record-type-identifiers))))))
(defmacro c-record-ref-id (range)
+ (declare (debug t))
(if (eq (car-safe range) 'cons)
;; Always true.
`(setq c-record-ref-identifiers
@@ -7808,6 +7819,7 @@ comment at the start of cc-engine.el for more info."
;; if TYPE is 'type or as a reference if TYPE is 'ref.
;;
;; This macro might do hidden buffer changes.
+ (declare (debug t))
`(let (res)
(setq c-last-identifier-range nil)
(while (if (setq res ,(if (eq type 'type)
@@ -7832,6 +7844,7 @@ comment at the start of cc-engine.el for more info."
;; `c-forward-keyword-prefixed-id'.
;;
;; This macro might do hidden buffer changes.
+ (declare (debug t))
`(while (and (progn
,(when update-safe-pos
'(setq safe-pos (point)))
@@ -8775,6 +8788,7 @@ comment at the start of cc-engine.el for more info."
(defmacro c-pull-open-brace (ps)
;; Pull the next open brace from PS (which has the form of paren-state),
;; skipping over any brace pairs. Returns NIL when PS is exhausted.
+ (declare (debug (symbolp)))
`(progn
(while (consp (car ,ps))
(setq ,ps (cdr ,ps)))
@@ -8890,6 +8904,7 @@ comment at the start of cc-engine.el for more info."
;; a comma. If either of <symbol> or bracketed <expression> is missing,
;; throw nil to 'level. If the terminating } or ) is unmatched, throw nil
;; to 'done. This is not a general purpose macro!
+ (declare (debug t))
`(while (eq (char-before) ?,)
(backward-char)
(c-backward-syntactic-ws ,limit)
@@ -9283,6 +9298,7 @@ This function might do hidden buffer changes."
;; sometimes consumes the identifier in the declaration as a type.
;; This is used to "backtrack" and make the last type be treated as
;; an identifier instead.
+ (declare (debug nil))
`(progn
,(unless short
;; These identifiers are bound only in the inner let.
@@ -14686,18 +14702,6 @@ Cannot combine absolute offsets %S and %S in `add'
method"
indent)))
-(def-edebug-spec c-bos-pop-state t)
-(def-edebug-spec c-bos-save-error-info t)
-(def-edebug-spec c-state-cache-top-lparen t)
-(def-edebug-spec c-state-cache-top-paren t)
-(def-edebug-spec c-state-cache-after-top-paren t)
-(def-edebug-spec c-state-maybe-marker (form symbolp))
-(def-edebug-spec c-record-type-id t)
-(def-edebug-spec c-record-ref-id t)
-(def-edebug-spec c-forward-keyword-prefixed-id t)
-(def-edebug-spec c-forward-id-comma-list t)
-(def-edebug-spec c-pull-open-brace (symbolp))
-
(cc-provide 'cc-engine)
;; Local Variables:
diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el
index 4e28376..a7c8712 100644
--- a/lisp/progmodes/cc-fonts.el
+++ b/lisp/progmodes/cc-fonts.el
@@ -1,4 +1,4 @@
-;;; cc-fonts.el --- font lock support for CC Mode
+;;; cc-fonts.el --- font lock support for CC Mode -*- lexical-binding: t -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -218,6 +218,7 @@
;; incorrectly.
;;
;; This function does a hidden buffer change.
+ (declare (debug t))
(if (fboundp 'font-lock-set-face)
;; Note: This function has no docstring in XEmacs so it might be
;; considered internal.
@@ -228,6 +229,7 @@
;; This is the inverse of `c-put-font-lock-face'.
;;
;; This function does a hidden buffer change.
+ (declare (debug t))
(if (fboundp 'font-lock-remove-face)
`(font-lock-remove-face ,from ,to)
`(remove-text-properties ,from ,to '(face nil))))
@@ -238,11 +240,13 @@
;; region should include them.
;;
;; This function does a hidden buffer change.
+ (declare (debug t))
(if (featurep 'xemacs)
`(c-put-font-lock-face (1+ ,from) (1- ,to) 'font-lock-string-face)
`(c-put-font-lock-face ,from ,to 'font-lock-string-face)))
(defmacro c-fontify-types-and-refs (varlist &rest body)
+ (declare (indent 1) (debug let*))
;; Like `let', but additionally activates `c-record-type-identifiers'
;; and `c-record-ref-identifiers', and fontifies the recorded ranges
;; accordingly on exit.
@@ -253,7 +257,6 @@
,@varlist)
(prog1 (progn ,@body)
(c-fontify-recorded-types-and-refs))))
- (put 'c-fontify-types-and-refs 'lisp-indent-function 1)
(defun c-skip-comments-and-strings (limit)
;; If the point is within a region fontified as a comment or
@@ -482,20 +485,7 @@
;; In the next form, check that point hasn't been moved beyond
;; `limit' in any of the above stanzas.
,(c-make-font-lock-search-form (car normal) (cdr normal) t)
- nil))))
-
-; (eval-after-load "edebug" ; 2006-07-09: def-edebug-spec is now in subr.el.
-; '(progn
-(def-edebug-spec c-put-font-lock-face t)
-(def-edebug-spec c-remove-font-lock-face t)
-(def-edebug-spec c-put-font-lock-string-face t)
- (def-edebug-spec c-fontify-types-and-refs let*)
- (def-edebug-spec c-make-syntactic-matcher t)
- ;; If there are literal quoted or backquoted highlight specs in
- ;; the call to `c-make-font-lock-search-function' then let's
- ;; instrument the forms in them.
- (def-edebug-spec c-make-font-lock-search-function
- (form &rest &or ("quote" (&rest form)) ("`" (&rest form)) form)));))
+ nil)))))
(defun c-fontify-recorded-types-and-refs ()
;; Convert the ranges recorded on `c-record-type-identifiers' and
@@ -1679,9 +1669,7 @@ casts and declarations are fontified. Used on level 2
and higher."
c-recognize-knr-p) ; Strictly speaking, bogus, but it
; speeds up lisp.h tremendously.
(save-excursion
- (when (not (c-back-over-member-initializers
- (max (- (point) 2000) (point-min)))) ; c-determine-limit
- ; is too slow, here.
+ (when (not (c-back-over-member-initializers decl-search-lim))
(unless (or (eobp)
(looking-at "\\s(\\|\\s)"))
(forward-char))
@@ -2287,7 +2275,7 @@ need for `c-font-lock-extra-types'.")
;; font-lock-keyword-face. It always returns NIL to inhibit this and
;; prevent a repeat invocation. See elisp/lispref page "Search-based
;; fontification".
- (let (pos after-name)
+ (let (pos)
(while (c-syntactic-re-search-forward c-using-key limit 'end)
(while ; Do one declarator of a comma separated list, each time around.
(progn
@@ -2295,7 +2283,6 @@ need for `c-font-lock-extra-types'.")
(setq pos (point)) ; token after "using".
(when (and (c-on-identifier)
(c-forward-name))
- (setq after-name (point))
(cond
((eq (char-after) ?=) ; using foo = <type-id>;
(goto-char pos)
@@ -2305,7 +2292,8 @@ need for `c-font-lock-extra-types'.")
(c-go-up-list-backward)
(eq (char-after) ?{)
(eq (car (c-beginning-of-decl-1
- (c-determine-limit 1000))) 'same)
+ (c-determine-limit 1000)))
+ 'same)
(looking-at c-colon-type-list-re)))
;; Inherited protected member: leave unfontified
)
@@ -2712,6 +2700,7 @@ need for `pike-font-lock-extra-types'.")
(defmacro c-set-doc-comment-re-element (suffix)
;; Set the variable `c-doc-line-join-re' to a buffer local value suitable
;; for the current doc comment style, or kill the local value.
+ (declare (debug t))
(let ((var (intern (concat "c-doc" suffix))))
`(let* ((styles (c-get-doc-comment-style))
elts)
@@ -2738,6 +2727,7 @@ need for `pike-font-lock-extra-types'.")
(defmacro c-set-doc-comment-char-list (suffix)
;; Set the variable 'c-doc-<suffix>' to the list of *-<suffix>, which must
;; be characters, and * represents the doc comment style.
+ (declare (debug t))
(let ((var (intern (concat "c-doc" suffix))))
`(let* ((styles (c-get-doc-comment-style))
elts)
@@ -2783,7 +2773,7 @@ need for `pike-font-lock-extra-types'.")
;; is used as a flag in other code to skip comments.
;;
;; This function might do hidden buffer changes.
-
+ (declare (indent 2))
(let (comment-beg region-beg)
(if (memq (get-text-property (point) 'face)
'(font-lock-comment-face font-lock-comment-delimiter-face))
@@ -2866,7 +2856,6 @@ need for `pike-font-lock-extra-types'.")
(goto-char region-end)))))
nil)
-(put 'c-font-lock-doc-comments 'lisp-indent-function 2)
(defun c-find-invalid-doc-markup (regexp limit)
;; Used to fontify invalid markup in doc comments after the correct
diff --git a/lisp/progmodes/cc-guess.el b/lisp/progmodes/cc-guess.el
index 1b852ec..9c88c14 100644
--- a/lisp/progmodes/cc-guess.el
+++ b/lisp/progmodes/cc-guess.el
@@ -1,4 +1,4 @@
-;;; cc-guess.el --- guess indentation values by scanning existing code
+;;; cc-guess.el --- guess indentation values by scanning existing code -*-
lexical-binding: t -*-
;; Copyright (C) 1985, 1987, 1992-2006, 2011-2021 Free Software
;; Foundation, Inc.
@@ -58,7 +58,7 @@
;;
;; If you want to reuse the guessed style in future emacs sessions,
;; you may want to put it to your .emacs. `c-guess-view' is for
-;; you. It emits emacs lisp code which defines the last guessed
+;; you. It emits Emacs Lisp code which defines the last guessed
;; style, in a temporary buffer. You can put the emitted code into
;; your .emacs. This command was suggested by Alan Mackenzie.
@@ -527,7 +527,7 @@ is called with one argument, the guessed style."
(cdr needs-markers)))))
(defun c-guess-view (&optional with-name)
- "Emit emacs lisp code which defines the last guessed style.
+ "Emit Emacs Lisp code which defines the last guessed style.
So you can put the code into .emacs if you prefer the
guessed code.
\"STYLE NAME HERE\" is used as the name for the style in the
diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el
index fa4e730..f664849 100644
--- a/lisp/progmodes/cc-langs.el
+++ b/lisp/progmodes/cc-langs.el
@@ -1,4 +1,4 @@
-;;; cc-langs.el --- language specific settings for CC Mode -*- coding: utf-8
-*-
+;;; cc-langs.el --- language specific settings for CC Mode -*-
lexical-binding: t; coding: utf-8 -*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
@@ -159,7 +159,9 @@ evaluated and bound to VAR when the result from the macro
`c-lang-const' is typically used in VAL to get the right value for the
language being initialized, and such calls will be macro expanded to
the evaluated constant value at compile time."
-
+ (declare (indent defun)
+ (debug (&define name def-form
+ &optional &or ("quote" symbolp) stringp)))
(when (and (not doc)
(eq (car-safe val) 'c-lang-const)
(eq (nth 1 val) var)
@@ -191,6 +193,7 @@ Emacs variable like `comment-start'.
`c-lang-const' is typically used in VAL to get the right value for the
language being initialized, and such calls will be macro expanded to
the evaluated constant value at compile time."
+ (declare (debug (&define name def-form)))
(let ((elem (assq var (cdr c-emacs-variable-inits))))
(if elem
(setcdr elem (list val)) ; Maybe remove "list", sometime. 2006-07-19
@@ -200,13 +203,6 @@ the evaluated constant value at compile time."
;; Return the symbol, like the other def* forms.
`',var)
-(put 'c-lang-defvar 'lisp-indent-function 'defun)
-; (eval-after-load "edebug" ; 2006-07-09: def-edebug-spec is now in subr.el.
-; '
-(def-edebug-spec c-lang-defvar
- (&define name def-form &optional &or ("quote" symbolp) stringp))
-(def-edebug-spec c-lang-setvar (&define name def-form))
-
;; Suppress "might not be defined at runtime" warning.
;; This file is only used when compiling other cc files.
(declare-function cl-delete-duplicates "cl-seq" (cl-seq &rest cl-keys))
@@ -337,7 +333,8 @@ the evaluated constant value at compile time."
This includes setting \\=' and \" as string delimiters, and setting up
the comment syntax to handle both line style \"//\" and block style
\"/*\" \"*/\" comments."
-
+ ;; Never native compile to allow cc-mode.el:467 hack.
+ (declare (speed -1))
(modify-syntax-entry ?_ "_" table)
(modify-syntax-entry ?\\ "\\" table)
(modify-syntax-entry ?+ "." table)
@@ -378,12 +375,14 @@ The syntax tables aren't stored directly since they're
quite large."
(let ((table (make-syntax-table)))
(c-populate-syntax-table table)
;; Mode specific syntaxes.
- ,(cond ((or (c-major-mode-is 'objc-mode) (c-major-mode-is 'java-mode))
+ ,(cond ((c-major-mode-is 'objc-mode)
;; Let '@' be part of symbols in ObjC to cope with
;; its compiler directives as single keyword tokens.
;; This is then necessary since it's assumed that
;; every keyword is a single symbol.
'(modify-syntax-entry ?@ "_" table))
+ ((c-major-mode-is 'java-mode)
+ '(modify-syntax-entry ?@ "'" table))
((c-major-mode-is 'pike-mode)
'(modify-syntax-entry ?@ "." table)))
table)))
@@ -579,14 +578,12 @@ don't have EOL terminated statements. "
(c-lang-defvar c-at-vsemi-p-fn (c-lang-const c-at-vsemi-p-fn))
(c-lang-defconst c-vsemi-status-unknown-p-fn
- "Contains a predicate regarding the presence of virtual semicolons.
-More precisely, the function answers the question, \"are we unsure whether a
-virtual semicolon exists on this line?\". The (admittedly kludgy) purpose of
-such a function is to prevent an infinite recursion in
-`c-beginning-of-statement-1' when point starts at a `while' token. The
function
-MUST NOT UNDER ANY CIRCUMSTANCES call `c-beginning-of-statement-1', even
-indirectly. This variable contains nil for languages which don't have EOL
-terminated statements."
+ "A function \"are we unsure whether there is a virtual semicolon on this
line?\".
+The (admittedly kludgy) purpose of such a function is to prevent an infinite
+recursion in c-beginning-of-statement-1 when point starts at a `while' token.
+The function MUST NOT UNDER ANY CIRCUMSTANCES call
`c-beginning-of-statement-1',
+even indirectly. This variable contains nil for languages which don't have
+EOL terminated statements."
t nil
(c c++ objc) 'c-macro-vsemi-status-unknown-p
awk 'c-awk-vsemi-status-unknown-p)
@@ -4093,6 +4090,7 @@ accomplish that conveniently."
This macro is expanded at compile time to a form tailored for the mode
in question, so MODE must be a constant. Therefore MODE is not
evaluated and should not be quoted."
+ (declare (debug nil))
`(funcall ,(c-make-init-lang-vars-fun mode)))
diff --git a/lisp/progmodes/cc-menus.el b/lisp/progmodes/cc-menus.el
index 0ff6efb..a099ec1 100644
--- a/lisp/progmodes/cc-menus.el
+++ b/lisp/progmodes/cc-menus.el
@@ -1,4 +1,4 @@
-;;; cc-menus.el --- imenu support for CC Mode
+;;; cc-menus.el --- imenu support for CC Mode -*- lexical-binding: t -*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el
index cfb23d0..a8f1662 100644
--- a/lisp/progmodes/cc-mode.el
+++ b/lisp/progmodes/cc-mode.el
@@ -1,4 +1,4 @@
-;;; cc-mode.el --- major mode for editing C and similar languages
+;;; cc-mode.el --- major mode for editing C and similar languages -*-
lexical-binding: t -*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
@@ -969,6 +969,7 @@ Note that the style variables are always made local to the
buffer."
(defmacro c-run-mode-hooks (&rest hooks)
;; Emacs 21.1 has introduced a system with delayed mode hooks that
;; requires the use of the new function `run-mode-hooks'.
+ (declare (debug t))
(if (cc-bytecomp-fboundp 'run-mode-hooks)
`(run-mode-hooks ,@hooks)
`(progn ,@(mapcar (lambda (hook) `(run-hooks ,hook)) hooks))))
@@ -2503,6 +2504,7 @@ This function is called from `c-common-init', once per
mode initialization."
;; Emacs < 22 and XEmacs
(defmacro c-advise-fl-for-region (function)
+ (declare (debug t))
`(defadvice ,function (before get-awk-region activate)
;; Make sure that any string/regexp is completely font-locked.
(when c-buffer-is-cc-mode
diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el
index aec259f..8514434 100644
--- a/lisp/progmodes/cc-styles.el
+++ b/lisp/progmodes/cc-styles.el
@@ -1,4 +1,4 @@
-;;; cc-styles.el --- support for styles in CC Mode
+;;; cc-styles.el --- support for styles in CC Mode -*- lexical-binding: t -*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
@@ -374,7 +374,7 @@ in this way.
If DONT-OVERRIDE is t, style variables that already have values (i.e., whose
values are not the symbol `set-from-style') will not be overridden. CC Mode
calls c-set-style internally in this way whilst initializing a buffer; if
-cc-set-style is called like this from anywhere else, it will usually behave as
+c-set-style is called like this from anywhere else, it will usually behave as
a null operation."
(interactive
(list (let ((completion-ignore-case t)
@@ -464,7 +464,7 @@ STYLE using `c-set-style' if the optional SET-P flag is
non-nil."
offset))
;;;###autoload
-(defun c-set-offset (symbol offset &optional ignored)
+(defun c-set-offset (symbol offset &optional _ignored)
"Change the value of a syntactic element symbol in `c-offsets-alist'.
SYMBOL is the syntactic element symbol to change and OFFSET is the new
offset for that syntactic element. The optional argument is not used
@@ -476,8 +476,8 @@ and exists only for compatibility reasons."
(if current-prefix-arg " or add" "")
": ")
(mapcar
- #'(lambda (langelem)
- (cons (format "%s" (car langelem)) nil))
+ (lambda (langelem)
+ (cons (format "%s" (car langelem)) nil))
(get 'c-offsets-alist 'c-stylevar-fallback))
nil (not current-prefix-arg)
;; initial contents tries to be the last element
diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el
index 88ee092..b33fea0 100644
--- a/lisp/progmodes/cc-vars.el
+++ b/lisp/progmodes/cc-vars.el
@@ -1,4 +1,4 @@
-;;; cc-vars.el --- user customization variables for CC Mode
+;;; cc-vars.el --- user customization variables for CC Mode -*-
lexical-binding: t -*-
;; Copyright (C) 1985, 1987, 1992-2021 Free Software Foundation, Inc.
@@ -42,6 +42,9 @@
(cc-require 'cc-defs)
+(defvar c-syntactic-context)
+(defvar c-syntactic-element)
+
(cc-eval-when-compile
(require 'custom)
(require 'widget))
diff --git a/lisp/progmodes/cfengine.el b/lisp/progmodes/cfengine.el
index 472788d..4649e50 100644
--- a/lisp/progmodes/cfengine.el
+++ b/lisp/progmodes/cfengine.el
@@ -1,4 +1,4 @@
-;;; cfengine.el --- mode for editing Cfengine files
+;;; cfengine.el --- mode for editing Cfengine files -*- lexical-binding: t;
-*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -1440,7 +1440,7 @@ to the action header."
(cfengine3-mode)
(cfengine2-mode)))
-(defalias 'cfengine-mode 'cfengine3-mode)
+(defalias 'cfengine-mode #'cfengine3-mode)
(provide 'cfengine3)
(provide 'cfengine)
diff --git a/lisp/progmodes/cmacexp.el b/lisp/progmodes/cmacexp.el
index 820867a..edcd88c 100644
--- a/lisp/progmodes/cmacexp.el
+++ b/lisp/progmodes/cmacexp.el
@@ -1,7 +1,6 @@
-;;; cmacexp.el --- expand C macros in a region
+;;; cmacexp.el --- expand C macros in a region -*- lexical-binding: t -*-
-;; Copyright (C) 1992, 1994, 1996, 2000-2021 Free Software Foundation,
-;; Inc.
+;; Copyright (C) 1992-2021 Free Software Foundation, Inc.
;; Author: Francesco Potortì <pot@gnu.org>
;; Adapted-By: ESR
@@ -33,20 +32,20 @@
;; USAGE =============================================================
-;; In C mode C-C C-e is bound to c-macro-expand. The result of the
+;; In C mode C-c C-e is bound to `c-macro-expand'. The result of the
;; expansion is put in a separate buffer. A user option allows the
;; window displaying the buffer to be optimally sized.
;;
-;; When called with a C-u prefix, c-macro-expand replaces the selected
+;; When called with a C-u prefix, `c-macro-expand' replaces the selected
;; region with the expansion. Both the preprocessor name and the
-;; initial flag can be set by the user. If c-macro-prompt-flag is set
+;; initial flag can be set by the user. If `c-macro-prompt-flag' is set
;; to a non-nil value the user is offered to change the options to the
-;; preprocessor each time c-macro-expand is invoked. Preprocessor
-;; arguments default to the last ones entered. If c-macro-prompt-flag
+;; preprocessor each time `c-macro-expand' is invoked. Preprocessor
+;; arguments default to the last ones entered. If `c-macro-prompt-flag'
;; is nil, one must use M-x set-variable to set a different value for
-;; c-macro-cppflags.
+;; `c-macro-cppflags'.
-;; A c-macro-expansion function is provided for non-interactive use.
+;; A `c-macro-expansion' function is provided for non-interactive use.
;; INSTALLATION ======================================================
@@ -54,18 +53,22 @@
;; If you want the *Macroexpansion* window to be not higher than
;; necessary:
-;;(setq c-macro-shrink-window-flag t)
+;;
+;; (setq c-macro-shrink-window-flag t)
;;
;; If you use a preprocessor other than /lib/cpp (be careful to set a
;; -C option or equivalent in order to make the preprocessor not to
;; strip the comments):
-;;(setq c-macro-preprocessor "gpp -C")
+;;
+;; (setq c-macro-preprocessor "gpp -C")
;;
;; If you often use a particular set of flags:
-;;(setq c-macro-cppflags "-I /usr/include/local -DDEBUG"
+;;
+;; (setq c-macro-cppflags "-I /usr/include/local -DDEBUG"
;;
;; If you want the "Preprocessor arguments: " prompt:
-;;(setq c-macro-prompt-flag t)
+;;
+;; (setq c-macro-prompt-flag t)
;; BUG REPORTS =======================================================
@@ -87,16 +90,12 @@
(require 'cc-mode)
-(provide 'cmacexp)
-
(defvar msdos-shells)
-
(defgroup c-macro nil
"Expand C macros in a region."
:group 'c)
-
(defcustom c-macro-shrink-window-flag nil
"Non-nil means shrink the *Macroexpansion* window to fit its contents."
:type 'boolean)
@@ -392,4 +391,6 @@ Optional arg DISPLAY non-nil means show messages in the
echo area."
;; Cleanup.
(kill-buffer outbuf))))
+(provide 'cmacexp)
+
;;; cmacexp.el ends here
diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index 7612f8d..bff3e60 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -2224,7 +2224,7 @@ Help message may be switched off by setting
`cperl-message-electric-keyword'
to nil."
(let ((beg (point-at-bol)))
(and (save-excursion
- (backward-sexp 1)
+ (skip-chars-backward "[:alpha:]")
(cperl-after-expr-p nil "{;:"))
(save-excursion
(not
@@ -3608,7 +3608,8 @@ the sections using `cperl-pod-head-face',
`cperl-pod-face',
;; 1+6+2+1+1+6+1+1+1=20 extra () before this:
"\\|"
"\\\\\\(['`\"($]\\)") ; BACKWACKED something-hairy
- ""))))
+ "")))
+ warning-message)
(unwind-protect
(progn
(save-excursion
@@ -3671,7 +3672,7 @@ the sections using `cperl-pod-head-face',
`cperl-pod-face',
(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")
+ (setq warning-message "=cut is not preceded by a POD
section")
(or (car err-l) (setcar err-l (point))))
(beginning-of-line)
@@ -3686,7 +3687,7 @@ the sections using `cperl-pod-head-face',
`cperl-pod-face',
(goto-char b)
(if (re-search-forward "\n=\\(cut\\|end\\)\\>"
stop-point 'toend)
(progn
- (message "=cut is not preceded by an empty line")
+ (setq warning-message "=cut is not preceded by an
empty line")
(setq b1 t)
(or (car err-l) (setcar err-l b))))))
(beginning-of-line 2) ; An empty line after =cut is not POD!
@@ -3829,7 +3830,8 @@ the sections using `cperl-pod-head-face',
`cperl-pod-face',
(progn ; Pretend we matched at the end
(goto-char (point-max))
(re-search-forward "\\'")
- (message "End of here-document `%s' not found." tag)
+ (setq warning-message
+ (format "End of here-document `%s' not found."
tag))
(or (car err-l) (setcar err-l b))))
(if cperl-pod-here-fontify
(progn
@@ -3906,7 +3908,8 @@ the sections using `cperl-pod-head-face',
`cperl-pod-face',
'face font-lock-string-face)
(cperl-commentify (point) (+ (point) 2) nil)
(cperl-put-do-not-fontify (point) (+ (point) 2) t))
- (message "End of format `%s' not found." name)
+ (setq warning-message
+ (format "End of format `%s' not found." name))
(or (car err-l) (setcar err-l b)))
(forward-line)
(if (> (point) max)
@@ -4426,8 +4429,9 @@ the sections using `cperl-pod-head-face',
`cperl-pod-face',
REx-subgr-end argument) ; continue
(setq argument nil)))
(and argument
- (message "Couldn't find end of charclass in
a REx, pos=%s"
- REx-subgr-start))
+ (setq warning-message
+ (format "Couldn't find end of
charclass in a REx, pos=%s"
+ REx-subgr-start)))
(setq argument (1- (point)))
(goto-char REx-subgr-end)
(cperl-highlight-charclass
@@ -4483,7 +4487,8 @@ the sections using `cperl-pod-head-face',
`cperl-pod-face',
(setq qtag "Can't find })")))
(progn
(goto-char (1- e))
- (message "%s" qtag))
+ (setq warning-message
+ (format "%s" qtag)))
(cperl-postpone-fontification
(1- tag) (1- (point))
'face font-lock-variable-name-face)
@@ -4512,9 +4517,9 @@ the sections using `cperl-pod-head-face',
`cperl-pod-face',
;; (1- e) 'toend)
(search-forward ")" (1- e) 'toend)
;;)
- (message
- "Couldn't find end of (?#...)-comment in a REx,
pos=%s"
- REx-subgr-start))))
+ (setq warning-message
+ (format "Couldn't find end of
(?#...)-comment in a REx, pos=%s"
+ REx-subgr-start)))))
(if (>= (point) e)
(goto-char (1- e)))
(cond
@@ -4592,8 +4597,8 @@ the sections using `cperl-pod-head-face',
`cperl-pod-face',
(if (> (point) stop-point)
(progn
(if end
- (message "Garbage after __END__/__DATA__ ignored")
- (message "Unbalanced syntax found while scanning")
+ (setq warning-message "Garbage after __END__/__DATA__
ignored")
+ (setq warning-message "Unbalanced syntax found while
scanning")
(or (car err-l) (setcar err-l b)))
(goto-char stop-point))))
(setq cperl-syntax-state (cons state-point state)
@@ -4612,6 +4617,7 @@ the sections using `cperl-pod-head-face',
`cperl-pod-face',
;; cperl-mode-syntax-table.
;; (set-syntax-table cperl-mode-syntax-table)
)
+ (when warning-message (message warning-message))
(list (car err-l) overshoot)))
(defun cperl-find-pods-heres-region (min max)
diff --git a/lisp/progmodes/cwarn.el b/lisp/progmodes/cwarn.el
index 63b344b..7fd592f 100644
--- a/lisp/progmodes/cwarn.el
+++ b/lisp/progmodes/cwarn.el
@@ -1,4 +1,4 @@
-;;; cwarn.el --- highlight suspicious C and C++ constructions
+;;; cwarn.el --- highlight suspicious C and C++ constructions -*-
lexical-binding: t -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
diff --git a/lisp/progmodes/dcl-mode.el b/lisp/progmodes/dcl-mode.el
index 14eefdc..ed024f2 100644
--- a/lisp/progmodes/dcl-mode.el
+++ b/lisp/progmodes/dcl-mode.el
@@ -1,4 +1,4 @@
-;;; dcl-mode.el --- major mode for editing DCL command files
+;;; dcl-mode.el --- major mode for editing DCL command files -*-
lexical-binding: t; -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
@@ -23,9 +23,11 @@
;;; Commentary:
-;; DCL mode is a package for editing DCL command files. It helps you
-;; indent lines, add leading `$' and trailing `-', move around in the
-;; code and insert lexical functions.
+;; DCL mode is a package for editing
+;; [DCL](https://en.wikipedia.org/wiki/DIGITAL_Command_Language)
+;; command files.
+;; It helps you indent lines, add leading `$' and trailing `-', move
+;; around in the code and insert lexical functions.
;;
;; Type `C-h m' when you are editing a .COM file to get more
;; information about this mode.
@@ -270,22 +272,22 @@ See `imenu-generic-expression' for details."
(defvar dcl-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\e\n" 'dcl-split-line)
- (define-key map "\e\t" 'tempo-complete-tag)
- (define-key map "\e^" 'dcl-delete-indentation)
- (define-key map "\em" 'dcl-back-to-indentation)
- (define-key map "\ee" 'dcl-forward-command)
- (define-key map "\ea" 'dcl-backward-command)
- (define-key map "\e\C-q" 'dcl-indent-command)
- (define-key map "\t" 'dcl-tab)
- (define-key map ":" 'dcl-electric-character)
- (define-key map "F" 'dcl-electric-character)
- (define-key map "f" 'dcl-electric-character)
- (define-key map "E" 'dcl-electric-character)
- (define-key map "e" 'dcl-electric-character)
- (define-key map "\C-c\C-o" 'dcl-set-option)
- (define-key map "\C-c\C-f" 'tempo-forward-mark)
- (define-key map "\C-c\C-b" 'tempo-backward-mark)
+ (define-key map "\e\n" #'dcl-split-line)
+ (define-key map "\e\t" #'tempo-complete-tag)
+ (define-key map "\e^" #'dcl-delete-indentation)
+ (define-key map "\em" #'dcl-back-to-indentation)
+ (define-key map "\ee" #'dcl-forward-command)
+ (define-key map "\ea" #'dcl-backward-command)
+ (define-key map "\e\C-q" #'dcl-indent-command)
+ (define-key map "\t" #'dcl-tab)
+ (define-key map ":" #'dcl-electric-character)
+ (define-key map "F" #'dcl-electric-character)
+ (define-key map "f" #'dcl-electric-character)
+ (define-key map "E" #'dcl-electric-character)
+ (define-key map "e" #'dcl-electric-character)
+ (define-key map "\C-c\C-o" #'dcl-set-option)
+ (define-key map "\C-c\C-f" #'tempo-forward-mark)
+ (define-key map "\C-c\C-b" #'tempo-backward-mark)
map)
"Keymap used in DCL-mode buffers.")
@@ -533,7 +535,7 @@ $
There is some minimal font-lock support (see vars
`dcl-font-lock-defaults' and `dcl-font-lock-keywords')."
- (setq-local indent-line-function 'dcl-indent-line)
+ (setq-local indent-line-function #'dcl-indent-line)
(setq-local comment-start "!")
(setq-local comment-end "")
(setq-local comment-multi-line nil)
@@ -547,7 +549,7 @@ There is some minimal font-lock support (see vars
(setq imenu-generic-expression dcl-imenu-generic-expression)
(setq imenu-case-fold-search t)
- (setq imenu-create-index-function 'dcl-imenu-create-index-function)
+ (setq imenu-create-index-function #'dcl-imenu-create-index-function)
(make-local-variable 'dcl-comment-line-regexp)
(make-local-variable 'dcl-block-begin-regexp)
@@ -1391,7 +1393,7 @@ regexps in `dcl-electric-reindent-regexps'."
(let ((case-fold-search t))
;; There must be a better way than (memq t ...).
;; (apply 'or ...) didn't work
- (if (memq t (mapcar 'dcl-was-looking-at dcl-electric-reindent-regexps))
+ (if (memq t (mapcar #'dcl-was-looking-at dcl-electric-reindent-regexps))
(dcl-indent-line)))))
@@ -1567,7 +1569,7 @@ Must return a string."
((fboundp action)
(funcall action option-assoc))
((eq action 'toggle)
- (not (eval option)))
+ (not (symbol-value option)))
((eq action 'curval)
(cond ((or (stringp (symbol-value option))
(numberp (symbol-value option)))
@@ -1735,7 +1737,7 @@ Set or update the value of VAR in the current buffers
(setq continue nil)
(beginning-of-line)
(insert (concat prefix-string (symbol-name var) ": "
- (prin1-to-string (eval var)) " "
+ (prin1-to-string (symbol-value var)) " "
suffix-string "\n")))
;; Is it the variable we are looking for?
(if (eq var found-var)
@@ -1748,7 +1750,7 @@ Set or update the value of VAR in the current buffers
(delete-region (point) (progn (read (current-buffer))
(point)))
(insert " ")
- (prin1 (eval var) (current-buffer))
+ (prin1 (symbol-value var) (current-buffer))
(skip-chars-backward "\n")
(skip-chars-forward " \t")
(or (if suffix (looking-at suffix) (eolp))
@@ -1781,7 +1783,7 @@ Set or update the value of VAR in the current buffers
(concat " " comment-end))))))
(insert (concat def-prefix "Local variables:" def-suffix "\n"))
(insert (concat def-prefix (symbol-name var) ": "
- (prin1-to-string (eval var)) def-suffix "\n"))
+ (prin1-to-string (symbol-value var)) def-suffix "\n"))
(insert (concat def-prefix "end:" def-suffix)))
)))
@@ -1815,7 +1817,8 @@ still be present in the `Local Variables:' section with
its old value."
(option-name (symbol-name option)))
(if (and (string-equal "dcl-"
(substring option-name 0 4))
- (not (equal (default-value option) (eval option))))
+ (not (equal (default-value option)
+ (symbol-value option))))
(dcl-save-local-variable option "$! "))))
dcl-option-alist))
diff --git a/lisp/progmodes/ebnf-yac.el b/lisp/progmodes/ebnf-yac.el
index 5abf1de..816cc43 100644
--- a/lisp/progmodes/ebnf-yac.el
+++ b/lisp/progmodes/ebnf-yac.el
@@ -271,13 +271,13 @@
(let ((table (make-vector 256 'error)))
;; upper & lower case letters:
(mapc
- #'(lambda (char)
- (aset table char 'non-terminal))
+ (lambda (char)
+ (aset table char 'non-terminal))
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
;; printable characters:
(mapc
- #'(lambda (char)
- (aset table char 'character))
+ (lambda (char)
+ (aset table char 'character))
"!#$&()*+-.0123456789=?@[\\]^_`~")
;; Override space characters:
(aset table ?\n 'space) ; [NL] linefeed
diff --git a/lisp/progmodes/ebnf2ps.el b/lisp/progmodes/ebnf2ps.el
index 7092d2c..a00440d 100644
--- a/lisp/progmodes/ebnf2ps.el
+++ b/lisp/progmodes/ebnf2ps.el
@@ -4398,8 +4398,8 @@ end
(defun ebnf-format-float (&rest floats)
(mapconcat
- #'(lambda (float)
- (format ebnf-format-float float))
+ (lambda (float)
+ (format ebnf-format-float float))
floats
" "))
@@ -4959,8 +4959,8 @@ killed after process termination."
(defvar ebnf-map-name
(let ((map (make-vector 256 ?\_)))
- (mapc #'(lambda (char)
- (aset map char char))
+ (mapc (lambda (char)
+ (aset map char char))
(concat "#$%&+-.0123456789=?@~"
"ABCDEFGHIJKLMNOPQRSTUVWXYZ"
"abcdefghijklmnopqrstuvwxyz"))
diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el
index cafdb3b..7524c28 100644
--- a/lisp/progmodes/ebrowse.el
+++ b/lisp/progmodes/ebrowse.el
@@ -794,7 +794,7 @@ and TREE is a list of `ebrowse-ts' structures forming the
class tree."
(ebrowse-hs-version header) ebrowse-version-string))
;; Read Lisp objects. Temporarily increase `gc-cons-threshold' to
;; prevent a GC that would not free any memory.
- (let ((gc-cons-threshold 2000000))
+ (let ((gc-cons-threshold (max gc-cons-threshold 2000000)))
(while (not (progn (skip-chars-forward " \t\n") (eobp)))
(let* ((root (read (current-buffer)))
(old-root-ptr (ebrowse-class-in-tree root tree)))
diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el
index 8ade718..a690d4b 100644
--- a/lisp/progmodes/elisp-mode.el
+++ b/lisp/progmodes/elisp-mode.el
@@ -160,19 +160,35 @@ All commands in `lisp-mode-shared-map' are inherited by
this map.")
(byte-compile-file buffer-file-name)
(error "The buffer must be saved in a file first")))
-(defun emacs-lisp-byte-compile-and-load ()
- "Byte-compile the current file (if it has changed), then load compiled code."
- (interactive nil emacs-lisp-mode)
+(defun emacs-lisp--before-compile-buffer ()
+ "Make sure the buffer is saved before compiling."
(or buffer-file-name
(error "The buffer must be saved in a file first"))
- (require 'bytecomp)
;; Recompile if file or buffer has changed since last compilation.
(if (and (buffer-modified-p)
(y-or-n-p (format "Save buffer %s first? " (buffer-name))))
- (save-buffer))
+ (save-buffer)))
+
+(defun emacs-lisp-byte-compile-and-load ()
+ "Byte-compile the current file (if it has changed), then load compiled code."
+ (interactive nil emacs-lisp-mode)
+ (emacs-lisp--before-compile-buffer)
+ (require 'bytecomp)
(byte-recompile-file buffer-file-name nil 0)
(load buffer-file-name))
+(declare-function native-compile "comp")
+(defun emacs-lisp-native-compile-and-load ()
+ "Native-compile synchronously the current file (if it has changed).
+Load the compiled code when finished.
+
+Use `emacs-lisp-byte-compile-and-load' in combination with
+`comp-deferred-compilation' set to `t' to achieve asynchronous
+native compilation."
+ (interactive nil emacs-lisp-mode)
+ (emacs-lisp--before-compile-buffer)
+ (load (native-compile buffer-file-name)))
+
(defun emacs-lisp-macroexpand ()
"Macroexpand the form after point.
Comments in the form will be lost."
@@ -496,7 +512,7 @@ functions are annotated with \"<f>\" via the
(end
(unless (or (eq beg (point-max))
(member (char-syntax (char-after beg))
- '(?\s ?\" ?\( ?\))))
+ '(?\" ?\()))
(condition-case nil
(save-excursion
(goto-char beg)
diff --git a/lisp/progmodes/executable.el b/lisp/progmodes/executable.el
index 85e9b4b..0d8b09c 100644
--- a/lisp/progmodes/executable.el
+++ b/lisp/progmodes/executable.el
@@ -1,4 +1,4 @@
-;;; executable.el --- base functionality for executable interpreter scripts
+;;; executable.el --- base functionality for executable interpreter scripts
-*- lexical-binding: t -*-
;; Copyright (C) 1994-1996, 2000-2021 Free Software Foundation, Inc.
diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el
index 8481a27..e10602a 100644
--- a/lisp/progmodes/flymake.el
+++ b/lisp/progmodes/flymake.el
@@ -741,7 +741,10 @@ 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))))
+ first-report)
+ (unless state
+ (error "Can't find state for %s in `flymake--backend-state'" backend))
+ (setf first-report (not (flymake--backend-state-reported-p state)))
(setf (flymake--backend-state-reported-p state) t)
(let (expected-token
new-diags)
diff --git a/lisp/progmodes/glasses.el b/lisp/progmodes/glasses.el
index a0f5d36..cd92175 100644
--- a/lisp/progmodes/glasses.el
+++ b/lisp/progmodes/glasses.el
@@ -321,10 +321,6 @@ separators (like underscores) at places they belong to."
(remove-hook 'write-file-functions
'glasses-convert-to-unreadable t)))))
-
-;;; Announce
-
(provide 'glasses)
-
;;; glasses.el ends here
diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el
index 8c9a1b5..e9fbcbb 100644
--- a/lisp/progmodes/grep.el
+++ b/lisp/progmodes/grep.el
@@ -1134,13 +1134,13 @@ command before it's run."
(and grep-find-ignored-files
(concat " --exclude="
(mapconcat
- #'(lambda (ignore)
- (cond ((stringp ignore)
- (shell-quote-argument ignore))
- ((consp ignore)
- (and (funcall (car ignore) dir)
- (shell-quote-argument
- (cdr ignore))))))
+ (lambda (ignore)
+ (cond ((stringp ignore)
+ (shell-quote-argument ignore))
+ ((consp ignore)
+ (and (funcall (car ignore) dir)
+ (shell-quote-argument
+ (cdr ignore))))))
grep-find-ignored-files
" --exclude=")))
(and (eq grep-use-directories-skip t)
@@ -1274,13 +1274,13 @@ command before it's run."
;; we should use shell-quote-argument here
" -name "
(mapconcat
- #'(lambda (ignore)
- (cond ((stringp ignore)
- (shell-quote-argument ignore))
- ((consp ignore)
- (and (funcall (car ignore) dir)
- (shell-quote-argument
- (cdr ignore))))))
+ (lambda (ignore)
+ (cond ((stringp ignore)
+ (shell-quote-argument ignore))
+ ((consp ignore)
+ (and (funcall (car ignore) dir)
+ (shell-quote-argument
+ (cdr ignore))))))
grep-find-ignored-files
" -o -name ")
" "
diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el
index b105cba..a37477d 100644
--- a/lisp/progmodes/gud.el
+++ b/lisp/progmodes/gud.el
@@ -293,6 +293,10 @@ Used to gray out relevant toolbar icons.")
(tool-bar-local-item-from-menu
(car x) (cdr x) map gud-minor-mode-map))))
+(defvar gud-repeat-map (make-sparse-keymap)
+ "Keymap to repeat gud stepping instructions `C-x C-a C-n n n'.
+Used in `repeat-mode'.")
+
(defun gud-file-name (f)
"Transform a relative file name to an absolute file name.
Uses `gud-<MINOR-MODE>-directories' to find the source files."
@@ -784,6 +788,17 @@ the buffer in which this command was invoked."
(gud-def gud-until "until %l" "\C-u" "Continue to current line.")
(gud-def gud-run "run" nil "Run the program.")
+ (dolist (cmd '(("n" . gud-next)
+ ("s" . gud-step)
+ ("i" . gud-stepi)
+ ("c" . gud-cont)
+ ("l" . gud-refresh)
+ ("f" . gud-finish)
+ ("<" . gud-up)
+ (">" . gud-down)))
+ (define-key gud-repeat-map (car cmd) (cdr cmd))
+ (put (cdr cmd) 'repeat-map 'gud-repeat-map))
+
(add-hook 'completion-at-point-functions #'gud-gdb-completion-at-point
nil 'local)
(setq-local gud-gdb-completion-function 'gud-gdb-completions)
diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el
index 6f1a878..0d9b4b7 100644
--- a/lisp/progmodes/hideif.el
+++ b/lisp/progmodes/hideif.el
@@ -1600,7 +1600,7 @@ not be expanded."
(result (funcall hide-ifdef-evaluator expr))
(exprstring (replace-regexp-in-string
;; Trim off leading/trailing whites
- "^[ \t]*\\([^ \t]+\\)[ \t]*" "\\1"
+ "^[ \t]*\\|[ \t]*$" ""
(replace-regexp-in-string
"\\(//.*\\)" "" ; Trim off end-of-line comments
(buffer-substring-no-properties start end)))))
diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el
index 134a6c6..ad8feb9 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. -*-
lexical-binding:t -*-
+;;; idlw-shell.el --- run IDL as an inferior process of Emacs. -*-
lexical-binding:t -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el
index f53f3f3..b55a98a 100644
--- a/lisp/progmodes/idlwave.el
+++ b/lisp/progmodes/idlwave.el
@@ -1,4 +1,4 @@
-;; idlwave.el --- IDL editing mode for GNU Emacs -*- lexical-binding: t; -*-
+;;; idlwave.el --- IDL editing mode for GNU Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -7601,15 +7601,6 @@ associated TAG, if any."
(put-text-property (match-beginning 0) (match-end 0)
'face 'font-lock-string-face))))))
-(defun idlwave-uniquify (list)
- (let ((ht (make-hash-table :size (length list) :test 'equal)))
- (delq nil
- (mapcar (lambda (x)
- (unless (gethash x ht)
- (puthash x t ht)
- x))
- list))))
-
(defun idlwave-after-successful-completion (type slash &optional verify)
"Add `=' or `(' after successful completion of keyword and function.
Restore the pre-completion window configuration if possible."
@@ -9101,6 +9092,9 @@ This function was written since `list-abbrevs' looks
terrible for IDLWAVE mode."
;; Run the hook
(run-hooks 'idlwave-load-hook)
+;; Obsolete.
+(define-obsolete-function-alias 'idlwave-uniquify #'seq-uniq "28.1")
+
(provide 'idlwave)
;;; idlwave.el ends here
diff --git a/lisp/progmodes/inf-lisp.el b/lisp/progmodes/inf-lisp.el
index af6ccce..0a72ae9 100644
--- a/lisp/progmodes/inf-lisp.el
+++ b/lisp/progmodes/inf-lisp.el
@@ -1,7 +1,6 @@
-;;; inf-lisp.el --- an inferior-lisp mode
+;;; inf-lisp.el --- an inferior-lisp mode -*- lexical-binding: t -*-
-;; Copyright (C) 1988, 1993-1994, 2001-2021 Free Software Foundation,
-;; Inc.
+;; Copyright (C) 1988-2021 Free Software Foundation, Inc.
;; Author: Olin Shivers <shivers@cs.cmu.edu>
;; Keywords: processes, lisp
@@ -23,13 +22,13 @@
;;; Commentary:
-;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88
+;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88
;; This file defines a lisp-in-a-buffer package (inferior-lisp mode)
;; built on top of comint mode. This version is more featureful,
;; robust, and uniform than the Emacs 18 version. The key bindings are
;; also more compatible with the bindings of Hemlock and Zwei (the
-;; Lisp Machine emacs).
+;; Lisp Machine Emacs).
;; Since this mode is built on top of the general command-interpreter-in-
;; a-buffer mode (comint mode), it shares a common base functionality,
@@ -40,19 +39,19 @@
;; the hooks available for customizing it, see the file comint.el.
;; For further information on inferior-lisp mode, see the comments below.
-;; Needs fixin:
+;; Needs fixing:
;; The load-file/compile-file default mechanism could be smarter -- it
;; doesn't know about the relationship between filename extensions and
-;; whether the file is source or executable. If you compile foo.lisp
+;; whether the file is source or executable. If you compile foo.lisp
;; with compile-file, then the next load-file should use foo.bin for
-;; the default, not foo.lisp. This is tricky to do right, particularly
+;; the default, not foo.lisp. This is tricky to do right, particularly
;; because the extension for executable files varies so much (.o, .bin,
;; .lbin, .mo, .vo, .ao, ...).
;;
;; It would be nice if inferior-lisp (and inferior scheme, T, ...) modes
;; had a verbose minor mode wherein sending or compiling defuns, etc.
;; would be reflected in the transcript with suitable comments, e.g.
-;; ";;; redefining fact". Several ways to do this. Which is right?
+;; ";;; redefining fact". Several ways to do this. Which is right?
;;
;; When sending text from a source file to a subprocess, the process-mark can
;; move off the window, so you can lose sight of the process interactions.
@@ -81,19 +80,19 @@ mode. Default is whitespace followed by 0 or 1
single-letter colon-keyword
(defvar inferior-lisp-mode-map
(let ((map (copy-keymap comint-mode-map)))
(set-keymap-parent map lisp-mode-shared-map)
- (define-key map "\C-x\C-e" 'lisp-eval-last-sexp)
- (define-key map "\C-c\C-l" 'lisp-load-file)
- (define-key map "\C-c\C-k" 'lisp-compile-file)
- (define-key map "\C-c\C-a" 'lisp-show-arglist)
- (define-key map "\C-c\C-d" 'lisp-describe-sym)
- (define-key map "\C-c\C-f" 'lisp-show-function-documentation)
- (define-key map "\C-c\C-v" 'lisp-show-variable-documentation)
+ (define-key map "\C-x\C-e" #'lisp-eval-last-sexp)
+ (define-key map "\C-c\C-l" #'lisp-load-file)
+ (define-key map "\C-c\C-k" #'lisp-compile-file)
+ (define-key map "\C-c\C-a" #'lisp-show-arglist)
+ (define-key map "\C-c\C-d" #'lisp-describe-sym)
+ (define-key map "\C-c\C-f" #'lisp-show-function-documentation)
+ (define-key map "\C-c\C-v" #'lisp-show-variable-documentation)
map))
(easy-menu-define
inferior-lisp-menu
inferior-lisp-mode-map
- "Inferior Lisp Menu"
+ "Inferior Lisp Menu."
'("Inf-Lisp"
["Eval Last Sexp" lisp-eval-last-sexp t]
"--"
@@ -107,20 +106,20 @@ mode. Default is whitespace followed by 0 or 1
single-letter colon-keyword
;;; These commands augment Lisp mode, so you can process Lisp code in
;;; the source files.
-(define-key lisp-mode-map "\M-\C-x" 'lisp-eval-defun) ; GNU convention
-(define-key lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) ; GNU convention
-(define-key lisp-mode-map "\C-c\C-e" 'lisp-eval-defun)
-(define-key lisp-mode-map "\C-c\C-r" 'lisp-eval-region)
-(define-key lisp-mode-map "\C-c\C-n" 'lisp-eval-form-and-next)
-(define-key lisp-mode-map "\C-c\C-p" 'lisp-eval-paragraph)
-(define-key lisp-mode-map "\C-c\C-c" 'lisp-compile-defun)
-(define-key lisp-mode-map "\C-c\C-z" 'switch-to-lisp)
-(define-key lisp-mode-map "\C-c\C-l" 'lisp-load-file)
-(define-key lisp-mode-map "\C-c\C-k" 'lisp-compile-file) ; "kompile" file
-(define-key lisp-mode-map "\C-c\C-a" 'lisp-show-arglist)
-(define-key lisp-mode-map "\C-c\C-d" 'lisp-describe-sym)
-(define-key lisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation)
-(define-key lisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation)
+(define-key lisp-mode-map "\M-\C-x" #'lisp-eval-defun) ; GNU convention
+(define-key lisp-mode-map "\C-x\C-e" #'lisp-eval-last-sexp) ; GNU convention
+(define-key lisp-mode-map "\C-c\C-e" #'lisp-eval-defun)
+(define-key lisp-mode-map "\C-c\C-r" #'lisp-eval-region)
+(define-key lisp-mode-map "\C-c\C-n" #'lisp-eval-form-and-next)
+(define-key lisp-mode-map "\C-c\C-p" #'lisp-eval-paragraph)
+(define-key lisp-mode-map "\C-c\C-c" #'lisp-compile-defun)
+(define-key lisp-mode-map "\C-c\C-z" #'switch-to-lisp)
+(define-key lisp-mode-map "\C-c\C-l" #'lisp-load-file)
+(define-key lisp-mode-map "\C-c\C-k" #'lisp-compile-file) ; "kompile" file
+(define-key lisp-mode-map "\C-c\C-a" #'lisp-show-arglist)
+(define-key lisp-mode-map "\C-c\C-d" #'lisp-describe-sym)
+(define-key lisp-mode-map "\C-c\C-f" #'lisp-show-function-documentation)
+(define-key lisp-mode-map "\C-c\C-v" #'lisp-show-variable-documentation)
;; This function exists for backwards compatibility.
@@ -133,24 +132,23 @@ mode. Default is whitespace followed by 0 or 1
single-letter colon-keyword
;;; (with-eval-after-load 'inf-lisp 'inferior-lisp-install-letter-bindings)
;;;You can modify this function to install just the bindings you want."
(defun inferior-lisp-install-letter-bindings ()
- (define-key lisp-mode-map "\C-ce" 'lisp-eval-defun-and-go)
- (define-key lisp-mode-map "\C-cr" 'lisp-eval-region-and-go)
- (define-key lisp-mode-map "\C-cc" 'lisp-compile-defun-and-go)
- (define-key lisp-mode-map "\C-cz" 'switch-to-lisp)
- (define-key lisp-mode-map "\C-cl" 'lisp-load-file)
- (define-key lisp-mode-map "\C-ck" 'lisp-compile-file)
- (define-key lisp-mode-map "\C-ca" 'lisp-show-arglist)
- (define-key lisp-mode-map "\C-cd" 'lisp-describe-sym)
- (define-key lisp-mode-map "\C-cf" 'lisp-show-function-documentation)
- (define-key lisp-mode-map "\C-cv" 'lisp-show-variable-documentation)
-
- (define-key inferior-lisp-mode-map "\C-cl" 'lisp-load-file)
- (define-key inferior-lisp-mode-map "\C-ck" 'lisp-compile-file)
- (define-key inferior-lisp-mode-map "\C-ca" 'lisp-show-arglist)
- (define-key inferior-lisp-mode-map "\C-cd" 'lisp-describe-sym)
- (define-key inferior-lisp-mode-map "\C-cf" 'lisp-show-function-documentation)
- (define-key inferior-lisp-mode-map "\C-cv"
- 'lisp-show-variable-documentation))
+ (define-key lisp-mode-map "\C-ce" #'lisp-eval-defun-and-go)
+ (define-key lisp-mode-map "\C-cr" #'lisp-eval-region-and-go)
+ (define-key lisp-mode-map "\C-cc" #'lisp-compile-defun-and-go)
+ (define-key lisp-mode-map "\C-cz" #'switch-to-lisp)
+ (define-key lisp-mode-map "\C-cl" #'lisp-load-file)
+ (define-key lisp-mode-map "\C-ck" #'lisp-compile-file)
+ (define-key lisp-mode-map "\C-ca" #'lisp-show-arglist)
+ (define-key lisp-mode-map "\C-cd" #'lisp-describe-sym)
+ (define-key lisp-mode-map "\C-cf" #'lisp-show-function-documentation)
+ (define-key lisp-mode-map "\C-cv" #'lisp-show-variable-documentation)
+
+ (define-key inferior-lisp-mode-map "\C-cl" #'lisp-load-file)
+ (define-key inferior-lisp-mode-map "\C-ck" #'lisp-compile-file)
+ (define-key inferior-lisp-mode-map "\C-ca" #'lisp-show-arglist)
+ (define-key inferior-lisp-mode-map "\C-cd" #'lisp-describe-sym)
+ (define-key inferior-lisp-mode-map "\C-cf"
#'lisp-show-function-documentation)
+ (define-key inferior-lisp-mode-map "\C-cv"
#'lisp-show-variable-documentation))
(defcustom inferior-lisp-program "lisp"
"Program name for invoking an inferior Lisp in Inferior Lisp mode."
@@ -181,7 +179,7 @@ franz: \"^\\\\(->\\\\|<[0-9]*>:\\\\) *\"
kcl: \"^>+ *\""
:type 'regexp)
-(defvar inferior-lisp-buffer nil "*The current inferior-lisp process buffer.
+(defvar inferior-lisp-buffer nil "*The current `inferior-lisp' process buffer.
MULTIPLE PROCESS SUPPORT
===========================================================================
@@ -326,18 +324,18 @@ Prefix argument means switch to the Lisp buffer
afterwards."
(if and-go (switch-to-lisp t)))
(defun lisp-compile-string (string)
- "Send the string to the inferior Lisp process to be compiled and executed."
+ "Send STRING to the inferior Lisp process to be compiled and executed."
(comint-send-string
(inferior-lisp-proc)
(format "(funcall (compile nil (lambda () %s)))\n" string)))
(defun lisp-eval-string (string)
- "Send the string to the inferior Lisp process to be executed."
+ "Send STRING to the inferior Lisp process to be executed."
(comint-send-string (inferior-lisp-proc) (concat string "\n")))
(defun lisp-do-defun (do-string do-region)
"Send the current defun to the inferior Lisp process.
-The actually processing is done by `do-string' and `do-region'
+The actually processing is done by DO-STRING and DO-REGION
which determine whether the code is compiled before evaluation.
DEFVAR forms reset the variables to the init values."
(save-excursion
@@ -444,7 +442,7 @@ With argument, positions cursor at end of buffer."
;;; (let ((name-start (point)))
;;; (forward-sexp 1)
;;; (process-send-string "inferior-lisp"
-;;; (format "(compile '%s #'(lambda "
+;;; (format "(compile '%s (lambda "
;;; (buffer-substring name-start
;;; (point)))))
;;; (let ((body-start (point)))
@@ -460,7 +458,7 @@ With argument, positions cursor at end of buffer."
;;; (interactive "r")
;;; (save-excursion
;;; (goto-char start) (end-of-defun) (beginning-of-defun) ; error check
-;;; (if (< (point) start) (error "region begins in middle of defun"))
+;;; (if (< (point) start) (error "Region begins in middle of defun"))
;;; (goto-char start)
;;; (let ((s start))
;;; (end-of-defun)
@@ -591,7 +589,7 @@ See variable `lisp-function-doc-command'."
(format lisp-function-doc-command fn)))
(defun lisp-show-variable-documentation (var)
- "Send a command to the inferior Lisp to give documentation for function FN.
+ "Send a command to the inferior Lisp to give documentation for variable VAR.
See variable `lisp-var-doc-command'."
(interactive (lisp-symprompt "Variable doc" (lisp-var-at-pt)))
(comint-proc-query (inferior-lisp-proc) (format lisp-var-doc-command var)))
@@ -620,8 +618,8 @@ See variable `lisp-describe-sym-command'."
(error "No Lisp subprocess; see variable `inferior-lisp-buffer'"))))
-;;; Do the user's customization...
-;;;===============================
+;; Obsolete.
+
(defvar inferior-lisp-load-hook nil
"This hook is run when the library `inf-lisp' is loaded.")
(make-obsolete-variable 'inferior-lisp-load-hook
diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el
index eb690a7..a942235 100644
--- a/lisp/progmodes/js.el
+++ b/lisp/progmodes/js.el
@@ -494,10 +494,11 @@ for preventing Firefox from stealing the keyboard focus."
:type 'boolean)
(defcustom js-js-tmpdir
- "~/.emacs.d/js/js"
+ (locate-user-emacs-file "js/js")
"Temporary directory used by `js-mode' to communicate with Mozilla.
This directory must be readable and writable by both Mozilla and Emacs."
- :type 'directory)
+ :type 'directory
+ :version "28.1")
(defcustom js-js-timeout 5
"Reply timeout for executing commands in Mozilla via `js-mode'.
@@ -4654,4 +4655,4 @@ one of the aforementioned options instead of using this
mode."
(provide 'js)
-;; js.el ends here
+;;; js.el ends here
diff --git a/lisp/progmodes/meta-mode.el b/lisp/progmodes/meta-mode.el
index a590148..5026844 100644
--- a/lisp/progmodes/meta-mode.el
+++ b/lisp/progmodes/meta-mode.el
@@ -942,9 +942,6 @@ The environment marked is the one that contains point or
follows point."
(list (list "\\<\\(\\sw+\\)" 1 'meta-symbol-list)
(list "" 'ispell-complete-word))))
-
-;;; Just in case ...
-
(provide 'meta-mode)
(run-hooks 'meta-mode-load-hook)
diff --git a/lisp/progmodes/octave.el b/lisp/progmodes/octave.el
index 196f2de..a1a5192 100644
--- a/lisp/progmodes/octave.el
+++ b/lisp/progmodes/octave.el
@@ -1769,8 +1769,8 @@ sentence."
(insert "\nRetry with ")
(insert-text-button "'-all'"
'follow-link t
- 'action #'(lambda (_b)
- (octave-lookfor str '-all)))
+ 'action (lambda (_b)
+ (octave-lookfor str '-all)))
(insert ".\n"))
(octave-help-mode)))))
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index 8ae30f5..8e025bd 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -1,7 +1,7 @@
;;; project.el --- Operations on the current project -*- lexical-binding: t;
-*-
;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
-;; Version: 0.5.4
+;; Version: 0.6.0
;; Package-Requires: ((emacs "26.1") (xref "1.0.2"))
;; This is a GNU ELPA :core package. Avoid using functionality that
@@ -318,7 +318,7 @@ The default implementation uses `find-program'."
;; Make sure ~/ etc. in local directory name is
;; expanded and not left for the shell command
;; to interpret.
- (localdir (file-local-name (expand-file-name dir)))
+ (localdir (file-name-unquote (file-local-name (expand-file-name
dir))))
(command (format "%s %s %s -type f %s -print0"
find-program
;; In case DIR is a symlink.
@@ -333,16 +333,25 @@ The default implementation uses `find-program'."
(concat " -o " find-name-arg " "))
" "
(shell-quote-argument ")"))
- ""))))
+ "")))
+ (output (with-output-to-string
+ (with-current-buffer standard-output
+ (let ((status
+ (process-file-shell-command command nil t)))
+ (unless (zerop status)
+ (error "File listing failed: %s"
(buffer-string))))))))
(project--remote-file-names
- (sort (split-string (shell-command-to-string command) "\0" t)
+ (sort (split-string output "\0" t)
#'string<))))
(defun project--remote-file-names (local-files)
- "Return LOCAL-FILES as if they were on the system of `default-directory'."
+ "Return LOCAL-FILES as if they were on the system of `default-directory'.
+Also quote LOCAL-FILES if `default-directory' is quoted."
(let ((remote-id (file-remote-p default-directory)))
(if (not remote-id)
- local-files
+ (if (file-name-quoted-p default-directory)
+ (mapcar #'file-name-quote local-files)
+ local-files)
(mapcar (lambda (file)
(concat remote-id file))
local-files))))
@@ -761,13 +770,14 @@ requires quoting, e.g. `\\[quoted-insert]<space>'."
(interactive (list (project--read-regexp)))
(require 'xref)
(require 'grep)
- (let* ((pr (project-current t))
+ (let* ((caller-dir default-directory)
+ (pr (project-current t))
(default-directory (project-root pr))
(files
(if (not current-prefix-arg)
(project-files pr)
(let ((dir (read-directory-name "Base directory: "
- nil default-directory t)))
+ caller-dir nil t)))
(project--files-in-directory dir
nil
(grep-read-files regexp))))))
@@ -937,11 +947,7 @@ With \\[universal-argument] prefix arg, create a new
inferior shell buffer even
if one already exists."
(interactive)
(let* ((default-directory (project-root (project-current t)))
- (default-project-shell-name
- (concat "*" (file-name-nondirectory
- (directory-file-name
- (file-name-directory default-directory)))
- "-shell*"))
+ (default-project-shell-name (project-prefixed-buffer-name "shell"))
(shell-buffer (get-buffer default-project-shell-name)))
(if (and shell-buffer (not current-prefix-arg))
(pop-to-buffer-same-window shell-buffer)
@@ -957,11 +963,7 @@ if one already exists."
(interactive)
(defvar eshell-buffer-name)
(let* ((default-directory (project-root (project-current t)))
- (eshell-buffer-name
- (concat "*" (file-name-nondirectory
- (directory-file-name
- (file-name-directory default-directory)))
- "-eshell*"))
+ (eshell-buffer-name (project-prefixed-buffer-name "eshell"))
(eshell-buffer (get-buffer eshell-buffer-name)))
(if (and eshell-buffer (not current-prefix-arg))
(pop-to-buffer-same-window eshell-buffer)
@@ -1013,12 +1015,34 @@ loop using the command \\[fileloop-continue]."
(defvar compilation-read-command)
(declare-function compilation-read-command "compile")
+(defun project-prefixed-buffer-name (mode)
+ (concat "*"
+ (file-name-nondirectory
+ (directory-file-name default-directory))
+ "-"
+ (downcase mode)
+ "*"))
+
+(defcustom project-compilation-buffer-name-function nil
+ "Function to compute the name of a project compilation buffer.
+If non-nil, it overrides `compilation-buffer-name-function' for
+`project-compile'."
+ :version "28.1"
+ :group 'project
+ :type '(choice (const :tag "Default" nil)
+ (const :tag "Prefixed with root directory name"
+ project-prefixed-buffer-name)
+ (function :tag "Custom function")))
+
;;;###autoload
(defun project-compile ()
"Run `compile' in the project root."
(declare (interactive-only compile))
(interactive)
- (let ((default-directory (project-root (project-current t))))
+ (let ((default-directory (project-root (project-current t)))
+ (compilation-buffer-name-function
+ (or project-compilation-buffer-name-function
+ compilation-buffer-name-function)))
(call-interactively #'compile)))
(defun project--read-project-buffer ()
@@ -1321,6 +1345,7 @@ to distinguish the menu entries in the dispatch menu. If
KEY is
absent, COMMAND must be bound in `project-prefix-map', and the
key is looked up in that map."
:version "28.1"
+ :group 'project
:package-version '(project . "0.6.0")
:type '(repeat
(list
@@ -1337,6 +1362,7 @@ listed in `project-switch-commands' and signal an error
when
others are invoked. Otherwise, all keys in `project-prefix-map'
are legal even if they aren't listed in the dispatch menu."
:type 'boolean
+ :group 'project
:version "28.1")
(defun project--keymap-prompt ()
@@ -1350,7 +1376,7 @@ are legal even if they aren't listed in the dispatch
menu."
key tmp)))
(let ((key (if key
(vector key)
- (where-is-internal cmd project-prefix-map t))))
+ (where-is-internal cmd (list project-prefix-map) t))))
(format "[%s] %s"
(propertize (key-description key) 'face 'bold)
label)))
@@ -1366,28 +1392,36 @@ made from `project-switch-commands'.
When called in a program, it will use the project corresponding
to directory DIR."
(interactive (list (project-prompt-project-dir)))
- (let ((commands-menu
- (mapcar
- (lambda (row)
- (if (characterp (car row))
- ;; Deprecated format.
- ;; XXX: Add a warning about it?
- (reverse row)
- row))
- project-switch-commands))
- command)
+ (let* ((commands-menu
+ (mapcar
+ (lambda (row)
+ (if (characterp (car row))
+ ;; Deprecated format.
+ ;; XXX: Add a warning about it?
+ (reverse row)
+ row))
+ project-switch-commands))
+ (commands-map
+ (let ((temp-map (make-sparse-keymap)))
+ (set-keymap-parent temp-map project-prefix-map)
+ (dolist (row commands-menu temp-map)
+ (when-let ((cmd (nth 0 row))
+ (keychar (nth 2 row)))
+ (define-key temp-map (vector keychar) cmd)))))
+ command)
(while (not command)
- (let ((choice (read-event (project--keymap-prompt))))
- (when (setq command
- (or (car
- (seq-find (lambda (row) (equal choice (nth 2 row)))
- commands-menu))
- (lookup-key project-prefix-map (vector choice))))
+ (let ((overriding-local-map commands-map)
+ (choice (read-key-sequence (project--keymap-prompt))))
+ (when (setq command (lookup-key commands-map choice))
(unless (or project-switch-use-entire-map
(assq command commands-menu))
;; TODO: Add some hint to the prompt, like "key not
;; recognized" or something.
- (setq command nil)))))
+ (setq command nil)))
+ (let ((global-command (lookup-key (current-global-map) choice)))
+ (when (memq global-command
+ '(keyboard-quit keyboard-escape-quit))
+ (call-interactively global-command)))))
(let ((default-directory dir)
(project-current-inhibit-prompt t))
(call-interactively command))))
diff --git a/lisp/progmodes/ps-mode.el b/lisp/progmodes/ps-mode.el
index 598f748..67c034d 100644
--- a/lisp/progmodes/ps-mode.el
+++ b/lisp/progmodes/ps-mode.el
@@ -1,4 +1,4 @@
-;;; ps-mode.el --- PostScript mode for GNU Emacs
+;;; ps-mode.el --- PostScript mode for GNU Emacs -*- lexical-binding: t; -*-
;; Copyright (C) 1999, 2001-2021 Free Software Foundation, Inc.
@@ -281,20 +281,20 @@ If nil, use `temporary-file-directory'."
(defvar ps-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-c\C-v" 'ps-run-boundingbox)
- (define-key map "\C-c\C-u" 'ps-mode-uncomment-region)
- (define-key map "\C-c\C-t" 'ps-mode-epsf-rich)
- (define-key map "\C-c\C-s" 'ps-run-start)
- (define-key map "\C-c\C-r" 'ps-run-region)
- (define-key map "\C-c\C-q" 'ps-run-quit)
- (define-key map "\C-c\C-p" 'ps-mode-print-buffer)
- (define-key map "\C-c\C-o" 'ps-mode-comment-out-region)
- (define-key map "\C-c\C-k" 'ps-run-kill)
- (define-key map "\C-c\C-j" 'ps-mode-other-newline)
- (define-key map "\C-c\C-l" 'ps-run-clear)
- (define-key map "\C-c\C-b" 'ps-run-buffer)
+ (define-key map "\C-c\C-v" #'ps-run-boundingbox)
+ (define-key map "\C-c\C-u" #'ps-mode-uncomment-region)
+ (define-key map "\C-c\C-t" #'ps-mode-epsf-rich)
+ (define-key map "\C-c\C-s" #'ps-run-start)
+ (define-key map "\C-c\C-r" #'ps-run-region)
+ (define-key map "\C-c\C-q" #'ps-run-quit)
+ (define-key map "\C-c\C-p" #'ps-mode-print-buffer)
+ (define-key map "\C-c\C-o" #'ps-mode-comment-out-region)
+ (define-key map "\C-c\C-k" #'ps-run-kill)
+ (define-key map "\C-c\C-j" #'ps-mode-other-newline)
+ (define-key map "\C-c\C-l" #'ps-run-clear)
+ (define-key map "\C-c\C-b" #'ps-run-buffer)
;; FIXME: Add `indent' to backward-delete-char-untabify-method instead?
- (define-key map "\177" 'ps-mode-backward-delete-char)
+ (define-key map "\177" #'ps-mode-backward-delete-char)
map)
"Local keymap to use in PostScript mode.")
@@ -336,10 +336,10 @@ If nil, use `temporary-file-directory'."
(defvar ps-run-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map comint-mode-map)
- (define-key map "\C-c\C-q" 'ps-run-quit)
- (define-key map "\C-c\C-k" 'ps-run-kill)
- (define-key map "\C-c\C-e" 'ps-run-goto-error)
- (define-key map [mouse-2] 'ps-run-mouse-goto-error)
+ (define-key map "\C-c\C-q" #'ps-run-quit)
+ (define-key map "\C-c\C-k" #'ps-run-kill)
+ (define-key map "\C-c\C-e" #'ps-run-goto-error)
+ (define-key map [mouse-2] #'ps-run-mouse-goto-error)
map)
"Local keymap to use in PostScript run mode.")
@@ -1092,7 +1092,7 @@ Use line numbers if `ps-run-error-line-numbers' is not
nil."
;;
-(add-hook 'kill-emacs-hook 'ps-run-cleanup)
+(add-hook 'kill-emacs-hook #'ps-run-cleanup)
(provide 'ps-mode)
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index afb9697..20ec339 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -241,14 +241,12 @@
;; 2) Add the following hook in your .emacs:
;; (add-hook 'python-mode-hook
-;; #'(lambda ()
-;; (define-key python-mode-map "\C-m" 'newline-and-indent)))
+;; (lambda ()
+;; (define-key python-mode-map "\C-m" 'newline-and-indent)))
;; I'd recommend the first one since you'll get the same behavior for
;; all modes out-of-the-box.
-;;; TODO:
-
;;; Code:
(require 'ansi-color)
@@ -3385,7 +3383,8 @@ user-friendly message if there's no process running;
defaults to
t when called interactively."
(interactive "p")
(pop-to-buffer
- (process-buffer (python-shell-get-process-or-error msg)) nil t))
+ (process-buffer (python-shell-get-process-or-error msg))
+ nil 'mark-for-redisplay))
(defun python-shell-send-setup-code ()
"Send all setup code for shell.
@@ -3976,8 +3975,8 @@ Returns the tracked buffer."
"Finish tracking."
(python-pdbtrack-unset-tracked-buffer)
(when python-pdbtrack-kill-buffers
- (mapc #'(lambda (buffer)
- (ignore-errors (kill-buffer buffer)))
+ (mapc (lambda (buffer)
+ (ignore-errors (kill-buffer buffer)))
python-pdbtrack-buffers-to-kill))
(setq python-pdbtrack-buffers-to-kill nil))
diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el
index 84ac8fd..3577282 100644
--- a/lisp/progmodes/ruby-mode.el
+++ b/lisp/progmodes/ruby-mode.el
@@ -291,6 +291,7 @@ Only has effect when `ruby-use-smie' is nil."
(defcustom ruby-encoding-map
'((us-ascii . nil) ;; Do not put coding: us-ascii
+ (utf-8 . nil) ;; Default since Ruby 2.0
(shift-jis . cp932) ;; Emacs charset name of Shift_JIS
(shift_jis . cp932) ;; MIME charset name of Shift_JIS
(japanese-cp932 . cp932)) ;; Emacs charset name of CP932
@@ -760,7 +761,7 @@ The style of the comment is controlled by
`ruby-encoding-magic-comment-style'."
(defun ruby--detect-encoding ()
(if (eq ruby-insert-encoding-magic-comment 'always-utf8)
- "utf-8"
+ 'utf-8
(let ((coding-system
(or save-buffer-coding-system
buffer-file-coding-system)))
@@ -769,12 +770,11 @@ The style of the comment is controlled by
`ruby-encoding-magic-comment-style'."
(or (coding-system-get coding-system 'mime-charset)
(coding-system-change-eol-conversion coding-system nil))))
(if coding-system
- (symbol-name
- (if ruby-use-encoding-map
- (let ((elt (assq coding-system ruby-encoding-map)))
- (if elt (cdr elt) coding-system))
- coding-system))
- "ascii-8bit"))))
+ (if ruby-use-encoding-map
+ (let ((elt (assq coding-system ruby-encoding-map)))
+ (if elt (cdr elt) coding-system))
+ coding-system)
+ 'ascii-8bit))))
(defun ruby--encoding-comment-required-p ()
(or (eq ruby-insert-encoding-magic-comment 'always-utf8)
@@ -796,7 +796,7 @@ The style of the comment is controlled by
`ruby-encoding-magic-comment-style'."
(unless (string= (match-string 2) coding-system)
(goto-char (match-beginning 2))
(delete-region (point) (match-end 2))
- (insert coding-system)))
+ (insert (symbol-name coding-system))))
((looking-at "\\s *#.*coding\\s *[:=]"))
(t (when ruby-insert-encoding-magic-comment
(ruby--insert-coding-comment coding-system))))
diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el
index ba59f9c..c6bd32a 100644
--- a/lisp/progmodes/sh-script.el
+++ b/lisp/progmodes/sh-script.el
@@ -2967,7 +2967,7 @@ The document is bounded by `sh-here-document-word'."
(define-minor-mode sh-electric-here-document-mode
"Make << insert a here document skeleton."
- nil nil nil
+ :lighter nil
(if sh-electric-here-document-mode
(add-hook 'post-self-insert-hook #'sh--maybe-here-document nil t)
(remove-hook 'post-self-insert-hook #'sh--maybe-here-document t)))
diff --git a/lisp/progmodes/simula.el b/lisp/progmodes/simula.el
index f92f446..7c0de9f 100644
--- a/lisp/progmodes/simula.el
+++ b/lisp/progmodes/simula.el
@@ -1,4 +1,4 @@
-;;; simula.el --- SIMULA 87 code editing commands for Emacs
+;;; simula.el --- SIMULA 87 code editing commands for Emacs -*-
lexical-binding: t; -*-
;; Copyright (C) 1992, 1994, 1996, 2001-2021 Free Software Foundation,
;; Inc.
@@ -52,6 +52,7 @@ the run of whitespace at the beginning of the line.")
Otherwise TAB indents only when point is within
the run of whitespace at the beginning of the line."
:type 'boolean)
+(make-obsolete-variable 'simula-tab-always-indent 'tab-always-indent "28.1")
(defconst simula-indent-level-default 3
"Indentation of SIMULA statements with respect to containing block.")
@@ -148,7 +149,24 @@ Please note that the standard definitions are required
for SIMULA mode to function correctly."
:type '(choice file (const nil)))
-(defvar simula-mode-syntax-table nil
+(defvar simula-mode-syntax-table
+ (let ((st (copy-syntax-table (standard-syntax-table))))
+ (modify-syntax-entry ?! "<" st)
+ (modify-syntax-entry ?$ "." st)
+ (modify-syntax-entry ?% "< b" st)
+ (modify-syntax-entry ?\n "> b" st)
+ (modify-syntax-entry ?' "\"" st)
+ (modify-syntax-entry ?\( "()" st)
+ (modify-syntax-entry ?\) ")(" st)
+ (modify-syntax-entry ?\; ">" st)
+ (modify-syntax-entry ?\[ "." st)
+ (modify-syntax-entry ?\\ "." st)
+ (modify-syntax-entry ?\] "." st)
+ (modify-syntax-entry ?_ "_" st)
+ (modify-syntax-entry ?\| "." st)
+ (modify-syntax-entry ?\{ "." st)
+ (modify-syntax-entry ?\} "." st)
+ st)
"Syntax table in SIMULA mode buffers.")
(defconst simula-syntax-propertize-function
@@ -237,39 +255,20 @@ for SIMULA mode to function correctly."
["Forward Statement" simula-next-statement t]
["Backward Up Level" simula-backward-up-level t]
["Forward Down Statement" simula-forward-down-level t])
- "Lucid Emacs menu for SIMULA mode.")
-
-(if simula-mode-syntax-table
- ()
- (setq simula-mode-syntax-table (copy-syntax-table (standard-syntax-table)))
- (modify-syntax-entry ?! "<" simula-mode-syntax-table)
- (modify-syntax-entry ?$ "." simula-mode-syntax-table)
- (modify-syntax-entry ?% "< b" simula-mode-syntax-table)
- (modify-syntax-entry ?\n "> b" simula-mode-syntax-table)
- (modify-syntax-entry ?' "\"" simula-mode-syntax-table)
- (modify-syntax-entry ?\( "()" simula-mode-syntax-table)
- (modify-syntax-entry ?\) ")(" simula-mode-syntax-table)
- (modify-syntax-entry ?\; ">" simula-mode-syntax-table)
- (modify-syntax-entry ?\[ "." simula-mode-syntax-table)
- (modify-syntax-entry ?\\ "." simula-mode-syntax-table)
- (modify-syntax-entry ?\] "." simula-mode-syntax-table)
- (modify-syntax-entry ?_ "_" simula-mode-syntax-table)
- (modify-syntax-entry ?\| "." simula-mode-syntax-table)
- (modify-syntax-entry ?\{ "." simula-mode-syntax-table)
- (modify-syntax-entry ?\} "." simula-mode-syntax-table))
+ "Emacs menu for SIMULA mode.")
(defvar simula-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-c\C-u" 'simula-backward-up-level)
- (define-key map "\C-c\C-p" 'simula-previous-statement)
- (define-key map "\C-c\C-d" 'simula-forward-down-level)
- (define-key map "\C-c\C-n" 'simula-next-statement)
- ;; (define-key map "\C-c\C-g" 'simula-goto-definition)
- ;; (define-key map "\C-c\C-h" 'simula-standard-help)
- (define-key map "\177" 'backward-delete-char-untabify)
- (define-key map ":" 'simula-electric-label)
- (define-key map "\e\C-q" 'simula-indent-exp)
- (define-key map "\t" 'simula-indent-command)
+ (define-key map "\C-c\C-u" #'simula-backward-up-level)
+ (define-key map "\C-c\C-p" #'simula-previous-statement)
+ (define-key map "\C-c\C-d" #'simula-forward-down-level)
+ (define-key map "\C-c\C-n" #'simula-next-statement)
+ ;; (define-key map "\C-c\C-g" #'simula-goto-definition)
+ ;; (define-key map "\C-c\C-h" #'simula-standard-help)
+ (define-key map "\177" #'backward-delete-char-untabify)
+ (define-key map ":" #'simula-electric-label)
+ (define-key map "\e\C-q" #'simula-indent-exp)
+ ;; (define-key map "\t" #'simula-indent-command)
map)
"Keymap used in `simula-mode'.")
@@ -285,8 +284,8 @@ for SIMULA mode to function correctly."
["Previous Statement" simula-previous-statement
:enable (not (bobp))]
"---"
- ["Indent Line" simula-indent-command
- :enable (not buffer-read-only)]
+ ;; ["Indent Line" simula-indent-command
+ ;; :enable (not buffer-read-only)]
["Indent Expression" simula-indent-exp
:enable (not buffer-read-only)]))
@@ -295,9 +294,6 @@ for SIMULA mode to function correctly."
"Major mode for editing SIMULA code.
\\{simula-mode-map}
Variables controlling indentation style:
- `simula-tab-always-indent'
- Non-nil means TAB in SIMULA mode should always reindent the current line,
- regardless of where in the line point is when the TAB command is used.
`simula-indent-level'
Indentation of SIMULA statements with respect to containing block.
`simula-substatement-offset'
@@ -335,7 +331,7 @@ with no arguments, if that value is non-nil."
;; (setq-local end-comment-column 75)
(setq-local paragraph-start "[ \t]*$\\|\f")
(setq-local paragraph-separate paragraph-start)
- (setq-local indent-line-function 'simula-indent-line)
+ (setq-local indent-line-function #'simula-indent-line)
(setq-local comment-start "! ")
(setq-local comment-end " ;")
(setq-local comment-start-skip "!+ *")
@@ -415,6 +411,7 @@ A numeric argument, regardless of its value, means indent
rigidly
all the lines of the SIMULA statement after point so that this line
becomes properly indented.
The relative indentation among the lines of the statement are preserved."
+ (declare (obsolete indent-for-tab-command "28.1"))
(interactive "P")
(let ((case-fold-search t))
(if (or whole-exp simula-tab-always-indent
@@ -1564,30 +1561,6 @@ If not nil and not t, move to limit of search and return
nil."
(simula-install-standard-abbrevs))
;; Hilit mode support.
-(when (fboundp 'hilit-set-mode-patterns)
- (when (and (boundp 'hilit-patterns-alist)
- (not (assoc 'simula-mode hilit-patterns-alist)))
- (hilit-set-mode-patterns
- 'simula-mode
- '(
- ("^%\\([ \t\f].*\\)?$" nil comment)
- ("^%include\\>" nil include)
- ("\"[^\"\n]*\"\\|'.'\\|'![0-9]+!'" nil string)
- ((regexp-opt '("ACTIVATE" "AFTER" "AND" "ARRAY" "AT" "BEFORE"
- "BEGIN" "BOOLEAN" "CHARACTER" "CLASS" "DELAY"
- "DO" "ELSE" "END" "EQ" "EQV" "EXTERNAL" "FALSE"
- "FOR" "GE" "GO" "GOTO" "GT" "HIDDEN" "IF" "IMP"
- "IN" "INNER" "INSPECT" "INTEGER" "IS" "LABEL"
- "LE" "LONG" "LT" "NAME" "NE" "NEW" "NONE" "NOT"
- "NOTEXT" "OR" "OTHERWISE" "PRIOR" "PROCEDURE"
- "PROTECTED" "QUA" "REACTIVATE" "REAL" "REF"
- "SHORT" "STEP" "SWITCH" "TEXT" "THEN" "THIS"
- "TO" "TRUE" "UNTIL" "VALUE" "VIRTUAL" "WHEN"
- "WHILE")
- 'words)
- nil keyword)
- ("!\\|\\<COMMENT\\>" ";" comment))
- nil 'case-insensitive)))
;; obsolete
@@ -1598,7 +1571,7 @@ If not nil and not t, move to limit of search and return
nil."
"24.4")
(define-obsolete-function-alias 'simula-submit-bug-report
- 'report-emacs-bug "24.4")
+ #'report-emacs-bug "24.4")
(defun simula-popup-menu (_e)
"Pops up the SIMULA menu."
diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el
index 6224b3b..65a4094 100644
--- a/lisp/progmodes/sql.el
+++ b/lisp/progmodes/sql.el
@@ -1545,9 +1545,7 @@ statement. The format of variable should be a valid
;; `sql-font-lock-keywords-builder' function and follow the
;; implementation pattern used for the other products in this file.
-(eval-when-compile
- (defvar sql-mode-ansi-font-lock-keywords)
- (setq sql-mode-ansi-font-lock-keywords nil))
+(defvar sql-mode-ansi-font-lock-keywords)
(eval-and-compile
(defun sql-font-lock-keywords-builder (face boundaries &rest keywords)
@@ -5608,7 +5606,7 @@ The default value disables the internal pager."
(provide 'sql)
-;;; sql.el ends here
-
; LocalWords: sql SQL SQLite sqlite Sybase Informix MySQL
; LocalWords: Postgres SQLServer SQLi
+
+;;; sql.el ends here
diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el
index 8ba3483..2b88120 100644
--- a/lisp/progmodes/verilog-mode.el
+++ b/lisp/progmodes/verilog-mode.el
@@ -9,7 +9,7 @@
;; Keywords: languages
;; The "Version" is the date followed by the decimal rendition of the Git
;; commit hex.
-;; Version: 2021.03.29.215531170
+;; Version: 2021.04.12.188864585
;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this
;; file on 19/3/2008, and the maintainer agreed that when a bug is
@@ -124,7 +124,7 @@
;;
;; This variable will always hold the version number of the mode
-(defconst verilog-mode-version "2021-03-29-cd8bea2-vpo-GNU"
+(defconst verilog-mode-version "2021-04-12-b41d849-vpo-GNU"
"Version of this Verilog mode.")
(defconst verilog-mode-release-emacs t
"If non-nil, this version of Verilog mode was released with Emacs itself.")
@@ -3607,7 +3607,7 @@ inserted using a single call to `verilog-insert'."
;; More searching
(defun verilog-declaration-end ()
- (search-forward ";"))
+ (search-forward ";" nil t))
(defun verilog-single-declaration-end (limit)
"Returns pos where current (single) declaration statement ends.
@@ -6650,14 +6650,9 @@ Return >0 for nested struct."
(defun verilog-at-close-struct-p ()
"If at the } that closes a struct, return true."
- (if (and
- (equal (char-after) ?\})
- (verilog-in-struct-p))
- ;; true
- (save-excursion
- (if (looking-at "}\\(?:\\s-*\\w+\\s-*\\(\\s-*\\,\\s-*\\w+\\)*\\)?;")
1))
- ;; false
- nil))
+ (and (equal (char-after) ?\})
+ (verilog-in-struct-p)
+ (looking-at "}\\(?:\\s-*\\w+\\s-*\\(?:,\\s-*\\w+\\s-*\\)*\\)?;")))
(defun verilog-parenthesis-depth ()
"Return non zero if in parenthetical-expression."
@@ -7560,25 +7555,25 @@ will be completed at runtime and should not be added to
this list.")
TYPE is `module', `tf' for task or function, or t if unknown."
(if (string= verilog-str "")
(setq verilog-str "[a-zA-Z_]"))
- (let ((verilog-str (concat (cond
- ((eq type 'module)
"\\<\\(module\\|connectmodule\\)\\s +")
- ((eq type 'tf) "\\<\\(task\\|function\\)\\s +")
- (t
"\\<\\(task\\|function\\|module\\|connectmodule\\)\\s +"))
- "\\<\\(" verilog-str "[a-zA-Z0-9_.]*\\)\\>"))
+ (let ((verilog-str
+ (concat (cond
+ ((eq type 'module) "\\<\\(module\\|connectmodule\\)\\s +")
+ ((eq type 'tf) "\\<\\(task\\|function\\)\\s +")
+ (t "\\<\\(task\\|function\\|module\\|connectmodule\\)\\s +"))
+ "\\<\\(" verilog-str "[a-zA-Z0-9_.]*\\)\\>"))
match)
- (if (not (looking-at verilog-defun-re))
- (verilog-re-search-backward verilog-defun-re nil t))
- (forward-char 1)
+ (save-excursion
+ (if (not (looking-at verilog-defun-re))
+ (verilog-re-search-backward verilog-defun-re nil t))
+ (forward-char 1)
- ;; Search through all reachable functions
- (goto-char (point-min))
- (while (verilog-re-search-forward verilog-str (point-max) t)
- (progn (setq match (buffer-substring (match-beginning 2)
- (match-end 2)))
- (setq verilog-all (cons match verilog-all))))
- (if (match-beginning 0)
- (goto-char (match-beginning 0)))))
+ ;; Search through all reachable functions
+ (goto-char (point-min))
+ (while (verilog-re-search-forward verilog-str (point-max) t)
+ (setq match (buffer-substring (match-beginning 2)
+ (match-end 2)))
+ (setq verilog-all (cons match verilog-all))))))
(defun verilog-get-completion-decl (end)
"Macro for searching through current declaration (var, type or const)
@@ -11566,6 +11561,7 @@ See the example in `verilog-auto-inout-modport'."
(defvar vl-cell-type nil "See `verilog-auto-inst'.") ; Prevent compile warning
(defvar vl-cell-name nil "See `verilog-auto-inst'.") ; Prevent compile warning
+(defvar vl-memory nil "See `verilog-auto-inst'.") ; Prevent compile warning
(defvar vl-modport nil "See `verilog-auto-inst'.") ; Prevent compile warning
(defvar vl-name nil "See `verilog-auto-inst'.") ; Prevent compile warning
(defvar vl-width nil "See `verilog-auto-inst'.") ; Prevent compile warning
@@ -12068,6 +12064,7 @@ Lisp Templates:
vl-width Width of the input/output port (`3' for [2:0]).
May be a (...) expression if bits isn't a constant.
vl-dir Direction of the pin input/output/inout/interface.
+ vl-memory The unpacked array part of the I/O port (`[5:0]').
vl-modport The modport, if an interface with a modport.
vl-cell-type Module name/type of the cell (`InstModule').
vl-cell-name Instance name of the cell (`instName').
diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el
index 856432c..5eeac8a 100644
--- a/lisp/progmodes/vhdl-mode.el
+++ b/lisp/progmodes/vhdl-mode.el
@@ -1,4 +1,4 @@
-;;; vhdl-mode.el --- major mode for editing VHDL code
+;;; vhdl-mode.el --- major mode for editing VHDL code -*- lexical-binding: t;
-*-
;; Copyright (C) 1992-2021 Free Software Foundation, Inc.
@@ -12,6 +12,9 @@
;; file on 18/3/2008, and the maintainer agreed that when a bug is
;; filed in the Emacs bug reporting system against this file, a copy
;; of the bug report be sent to the maintainer's email address.
+;;
+;; Reto also said in Apr 2021 that he preferred to keep the XEmacs
+;; compatibility code.
(defconst vhdl-version "3.38.1"
"VHDL Mode version number.")
@@ -77,7 +80,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Installation
-;; Prerequisites: GNU Emacs 20/21/22/23/24, XEmacs 20/21.
+;; Prerequisites: GNU Emacs >= 21, XEmacs 20/21.
;; Put `vhdl-mode.el' into the `site-lisp' directory of your Emacs installation
;; or into an arbitrary directory that is added to the load path by the
@@ -92,7 +95,7 @@
;; Add the following lines to the `site-start.el' file in the `site-lisp'
;; directory of your Emacs installation or to your Emacs start-up file `.emacs'
-;; (not required in Emacs 20 and higher):
+;; (not required in Emacs):
;; (autoload 'vhdl-mode "vhdl-mode" "VHDL Mode" t)
;; (push '("\\.vhdl?\\'" . vhdl-mode) auto-mode-alist)
@@ -136,12 +139,9 @@
(when (< emacs-major-version 25)
(condition-case nil (require 'cl-lib) (file-missing (require 'cl))))
-;; Emacs 21+ handling
-(defconst vhdl-emacs-21 (and (<= 21 emacs-major-version) (not (featurep
'xemacs)))
- "Non-nil if GNU Emacs 21, 22, ... is used.")
;; Emacs 22+ handling
(defconst vhdl-emacs-22 (and (<= 22 emacs-major-version) (not (featurep
'xemacs)))
- "Non-nil if GNU Emacs 22, ... is used.")
+ "Non-nil if GNU Emacs >= 22, ... is used.")
(defvar compilation-file-regexp-alist)
(defvar conf-alist)
@@ -490,7 +490,7 @@ NOTE: Activate new error and file message regexps and
reflect the new setting
(const :tag "Upcase" upcase)
(const :tag "Downcase" downcase))))))
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-update-mode-menu))
+ (vhdl-custom-set variable value #'vhdl-update-mode-menu))
:version "24.4"
:group 'vhdl-compile)
@@ -668,8 +668,8 @@ NOTE: Reflect the new setting in the choice list of option
`vhdl-project'
:format "%t\n%v\n")))
:set (lambda (variable value)
(vhdl-custom-set variable value
- 'vhdl-update-mode-menu
- 'vhdl-speedbar-refresh))
+ #'vhdl-update-mode-menu
+ #'vhdl-speedbar-refresh))
:group 'vhdl-project)
(defcustom vhdl-project nil
@@ -713,7 +713,7 @@ All project setup files that match the file names specified
in option
\(alphabetically) last loaded setup of the first `vhdl-project-file-name'
entry is activated.
A project setup file can be obtained by exporting a project (see menu).
- At startup: project setup file is loaded at Emacs startup"
+ At startup: project setup file is loaded at Emacs startup."
:type '(set (const :tag "At startup" startup))
:group 'vhdl-project)
@@ -751,12 +751,12 @@ NOTE: Activate the new setting in a VHDL buffer by using
the menu entry
(const :tag "Math packages" math)))
:set (lambda (variable value)
(vhdl-custom-set variable value
- 'vhdl-template-map-init
- 'vhdl-mode-abbrev-table-init
- 'vhdl-template-construct-alist-init
- 'vhdl-template-package-alist-init
- 'vhdl-update-mode-menu
- 'vhdl-words-init 'vhdl-font-lock-init))
+ #'vhdl-template-map-init
+ #'vhdl-mode-abbrev-table-init
+ #'vhdl-template-construct-alist-init
+ #'vhdl-template-package-alist-init
+ #'vhdl-update-mode-menu
+ #'vhdl-words-init 'vhdl-font-lock-init))
:group 'vhdl-style)
(defcustom vhdl-basic-offset 2
@@ -770,7 +770,7 @@ This value is used by + and - symbols in
`vhdl-offsets-alist'."
This is done when typed or expanded or by the fix case functions."
:type 'boolean
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-abbrev-list-init))
+ (vhdl-custom-set variable value #'vhdl-abbrev-list-init))
:group 'vhdl-style)
(defcustom vhdl-upper-case-types nil
@@ -778,7 +778,7 @@ This is done when typed or expanded or by the fix case
functions."
This is done when expanded or by the fix case functions."
:type 'boolean
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-abbrev-list-init))
+ (vhdl-custom-set variable value #'vhdl-abbrev-list-init))
:group 'vhdl-style)
(defcustom vhdl-upper-case-attributes nil
@@ -786,7 +786,7 @@ This is done when expanded or by the fix case functions."
This is done when expanded or by the fix case functions."
:type 'boolean
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-abbrev-list-init))
+ (vhdl-custom-set variable value #'vhdl-abbrev-list-init))
:group 'vhdl-style)
(defcustom vhdl-upper-case-enum-values nil
@@ -794,7 +794,7 @@ This is done when expanded or by the fix case functions."
This is done when expanded or by the fix case functions."
:type 'boolean
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-abbrev-list-init))
+ (vhdl-custom-set variable value #'vhdl-abbrev-list-init))
:group 'vhdl-style)
(defcustom vhdl-upper-case-constants t
@@ -802,7 +802,7 @@ This is done when expanded or by the fix case functions."
This is done when expanded."
:type 'boolean
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-abbrev-list-init))
+ (vhdl-custom-set variable value #'vhdl-abbrev-list-init))
:group 'vhdl-style)
(defcustom vhdl-use-direct-instantiation 'standard
@@ -909,7 +909,7 @@ follows:
:type '(set (const :tag "VHDL keywords" vhdl)
(const :tag "User model keywords" user))
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-mode-abbrev-table-init))
+ (vhdl-custom-set variable value #'vhdl-mode-abbrev-table-init))
:group 'vhdl-template)
(defcustom vhdl-optional-labels 'process
@@ -1192,10 +1192,10 @@ NOTE: Activate the new setting in a VHDL buffer by
using the menu entry
(string :tag "Keyword " :format "%t: %v\n")))
:set (lambda (variable value)
(vhdl-custom-set variable value
- 'vhdl-model-map-init
- 'vhdl-model-defun
- 'vhdl-mode-abbrev-table-init
- 'vhdl-update-mode-menu))
+ #'vhdl-model-map-init
+ #'vhdl-model-defun
+ #'vhdl-mode-abbrev-table-init
+ #'vhdl-update-mode-menu))
:group 'vhdl-model)
@@ -1598,7 +1598,7 @@ NOTE: Activate the new setting in a VHDL buffer by
re-fontifying it (menu
entry \"Fontify Buffer\")."
:type 'boolean
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-font-lock-init))
+ (vhdl-custom-set variable value #'vhdl-font-lock-init))
:group 'vhdl-highlight)
(defcustom vhdl-highlight-names t
@@ -1615,7 +1615,7 @@ NOTE: Activate the new setting in a VHDL buffer by
re-fontifying it (menu
entry \"Fontify Buffer\")."
:type 'boolean
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-font-lock-init))
+ (vhdl-custom-set variable value #'vhdl-font-lock-init))
:group 'vhdl-highlight)
(defcustom vhdl-highlight-special-words nil
@@ -1628,7 +1628,7 @@ NOTE: Activate the new setting in a VHDL buffer by
re-fontifying it (menu
entry \"Fontify Buffer\")."
:type 'boolean
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-font-lock-init))
+ (vhdl-custom-set variable value #'vhdl-font-lock-init))
:group 'vhdl-highlight)
(defcustom vhdl-highlight-forbidden-words nil
@@ -1643,7 +1643,7 @@ NOTE: Activate the new setting in a VHDL buffer by
re-fontifying it (menu
:type 'boolean
:set (lambda (variable value)
(vhdl-custom-set variable value
- 'vhdl-words-init 'vhdl-font-lock-init))
+ #'vhdl-words-init #'vhdl-font-lock-init))
:group 'vhdl-highlight)
(defcustom vhdl-highlight-verilog-keywords nil
@@ -1656,7 +1656,7 @@ NOTE: Activate the new setting in a VHDL buffer by
re-fontifying it (menu
:type 'boolean
:set (lambda (variable value)
(vhdl-custom-set variable value
- 'vhdl-words-init 'vhdl-font-lock-init))
+ #'vhdl-words-init #'vhdl-font-lock-init))
:group 'vhdl-highlight)
(defcustom vhdl-highlight-translate-off nil
@@ -1670,7 +1670,7 @@ NOTE: Activate the new setting in a VHDL buffer by
re-fontifying it (menu
entry \"Fontify Buffer\")."
:type 'boolean
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-font-lock-init))
+ (vhdl-custom-set variable value #'vhdl-font-lock-init))
:group 'vhdl-highlight)
(defcustom vhdl-highlight-case-sensitive nil
@@ -1724,7 +1724,7 @@ NOTE: Activate a changed regexp in a VHDL buffer by
re-fontifying it (menu
(string :tag "Color (dark) ")
(boolean :tag "In comments ")))
:set (lambda (variable value)
- (vhdl-custom-set variable value 'vhdl-font-lock-init))
+ (vhdl-custom-set variable value #'vhdl-font-lock-init))
:group 'vhdl-highlight)
(defcustom vhdl-forbidden-words '()
@@ -1737,7 +1737,7 @@ NOTE: Activate the new setting in a VHDL buffer by
re-fontifying it (menu
:type '(repeat (string :format "%v"))
:set (lambda (variable value)
(vhdl-custom-set variable value
- 'vhdl-words-init 'vhdl-font-lock-init))
+ #'vhdl-words-init #'vhdl-font-lock-init))
:group 'vhdl-highlight)
(defcustom vhdl-forbidden-syntax ""
@@ -1752,7 +1752,7 @@ NOTE: Activate the new setting in a VHDL buffer by
re-fontifying it (menu
:type 'regexp
:set (lambda (variable value)
(vhdl-custom-set variable value
- 'vhdl-words-init 'vhdl-font-lock-init))
+ #'vhdl-words-init #'vhdl-font-lock-init))
:group 'vhdl-highlight)
(defcustom vhdl-directive-keywords '("psl" "pragma" "synopsys")
@@ -1763,7 +1763,7 @@ NOTE: Activate the new setting in a VHDL buffer by
re-fontifying it (menu
:type '(repeat (string :format "%v"))
:set (lambda (variable value)
(vhdl-custom-set variable value
- 'vhdl-words-init 'vhdl-font-lock-init))
+ #'vhdl-words-init #'vhdl-font-lock-init))
:group 'vhdl-highlight)
@@ -2238,11 +2238,11 @@ Ignore byte-compiler warnings you might see."
; (vhdl-warning-when-idle "Please install `xemacs-devel' package.")
(defun regexp-opt (strings &optional paren)
(let ((open (if paren "\\(" "")) (close (if paren "\\)" "")))
- (concat open (mapconcat 'regexp-quote strings "\\|") close))))
+ (concat open (mapconcat #'regexp-quote strings "\\|") close))))
;; `match-string-no-properties' undefined (XEmacs, what else?)
(unless (fboundp 'match-string-no-properties)
- (defalias 'match-string-no-properties 'match-string))
+ (defalias 'match-string-no-properties #'match-string))
;; `subst-char-in-string' undefined (XEmacs)
(unless (fboundp 'subst-char-in-string)
@@ -2269,7 +2269,7 @@ Ignore byte-compiler warnings you might see."
(let* ((nondir (file-name-nondirectory pattern))
(dirpart (file-name-directory pattern))
(dirs (if (and dirpart (string-match "[[*?]" dirpart))
- (mapcar 'file-name-as-directory
+ (mapcar #'file-name-as-directory
(file-expand-wildcards (directory-file-name
dirpart)))
(list dirpart)))
contents)
@@ -2296,7 +2296,7 @@ Ignore byte-compiler warnings you might see."
;; `member-ignore-case' undefined (XEmacs)
(unless (fboundp 'member-ignore-case)
- (defalias 'member-ignore-case 'member))
+ (defalias 'member-ignore-case #'member))
;; `last-input-char' obsolete in Emacs 24, `last-input-event' different
;; behavior in XEmacs
@@ -2495,6 +2495,7 @@ current buffer if no project is defined."
"Enable case insensitive search and switch to syntax table that includes `_',
then execute BODY, and finally restore the old environment. Used for
consistent searching."
+ (declare (debug t))
`(let ((case-fold-search t)) ; case insensitive search
;; use extended syntax table
(with-syntax-table vhdl-mode-ext-syntax-table
@@ -2504,55 +2505,59 @@ consistent searching."
"Enable case insensitive search, switch to syntax table that includes `_',
arrange to ignore `intangible' overlays, then execute BODY, and finally restore
the old environment. Used for consistent searching."
+ (declare (debug t))
`(let ((case-fold-search t) ; case insensitive search
- (current-syntax-table (syntax-table))
(inhibit-point-motion-hooks t))
;; use extended syntax table
- (set-syntax-table vhdl-mode-ext-syntax-table)
- ;; execute BODY safely
- (unwind-protect
- (progn ,@body)
- ;; restore syntax table
- (set-syntax-table current-syntax-table))))
+ (with-syntax-table vhdl-mode-ext-syntax-table
+ ;; execute BODY safely
+ (progn ,@body))))
(defmacro vhdl-visit-file (file-name issue-error &rest body)
"Visit file FILE-NAME and execute BODY."
- `(if (null ,file-name)
- (progn ,@body)
- (unless (file-directory-p ,file-name)
- (let ((source-buffer (current-buffer))
- (visiting-buffer (find-buffer-visiting ,file-name))
- file-opened)
- (when (or (and visiting-buffer (set-buffer visiting-buffer))
- (condition-case ()
- (progn (set-buffer (create-file-buffer ,file-name))
- (setq file-opened t)
- (vhdl-insert-file-contents ,file-name)
- ;; FIXME: This modifies a global syntax-table!
- (modify-syntax-entry ?\- ". 12" (syntax-table))
- (modify-syntax-entry ?\n ">" (syntax-table))
- (modify-syntax-entry ?\^M ">" (syntax-table))
- (modify-syntax-entry ?_ "w" (syntax-table))
- t)
- (error
- (if ,issue-error
- (progn
- (when file-opened (kill-buffer (current-buffer)))
- (set-buffer source-buffer)
- (error "ERROR: File cannot be opened: \"%s\""
,file-name))
- (vhdl-warning (format "File cannot be opened: \"%s\""
,file-name) t)
- nil))))
- (condition-case info
- (progn ,@body)
- (error
- (if ,issue-error
- (progn
- (when file-opened (kill-buffer (current-buffer)))
- (set-buffer source-buffer)
- (error (cadr info)))
- (vhdl-warning (cadr info))))))
- (when file-opened (kill-buffer (current-buffer)))
- (set-buffer source-buffer)))))
+ (declare (debug t) (indent 2))
+ `(vhdl--visit-file ,file-name ,issue-error (lambda () . ,body)))
+
+(defun vhdl--visit-file (file-name issue-error body-fun)
+ (if (null file-name)
+ (funcall body-fun)
+ (unless (file-directory-p file-name)
+ (let ((source-buffer (current-buffer))
+ (visiting-buffer (find-buffer-visiting file-name))
+ file-opened)
+ (when (or (and visiting-buffer (set-buffer visiting-buffer))
+ (condition-case ()
+ (progn (set-buffer (create-file-buffer file-name))
+ (setq file-opened t)
+ (vhdl-insert-file-contents file-name)
+ (let ((st (copy-syntax-table (syntax-table))))
+ (modify-syntax-entry ?\- ". 12" st)
+ (modify-syntax-entry ?\n ">" st)
+ (modify-syntax-entry ?\^M ">" st)
+ (modify-syntax-entry ?_ "w" st)
+ ;; FIXME: We should arguably reset the
+ ;; syntax-table after running `body-fun'.
+ (set-syntax-table st))
+ t)
+ (error
+ (if issue-error
+ (progn
+ (when file-opened (kill-buffer (current-buffer)))
+ (set-buffer source-buffer)
+ (error "ERROR: File cannot be opened: \"%s\""
file-name))
+ (vhdl-warning (format "File cannot be opened: \"%s\""
file-name) t)
+ nil))))
+ (condition-case info
+ (funcall body-fun)
+ (error
+ (if issue-error
+ (progn
+ (when file-opened (kill-buffer (current-buffer)))
+ (set-buffer source-buffer)
+ (error (cadr info)))
+ (vhdl-warning (cadr info))))))
+ (when file-opened (kill-buffer (current-buffer)))
+ (set-buffer source-buffer)))))
(defun vhdl-insert-file-contents (filename)
"Nicked from `insert-file-contents-literally', but allow coding system
@@ -2600,7 +2605,7 @@ conversion."
"Refresh directory or project with name KEY."
(when (and (boundp 'speedbar-frame)
(frame-live-p speedbar-frame))
- (let ((pos (point))
+ (let (;; (pos (point))
(last-frame (selected-frame)))
(if (null key)
(speedbar-refresh)
@@ -2677,96 +2682,96 @@ elements > `vhdl-menu-max-size'."
"Initialize `vhdl-template-map'."
(setq vhdl-template-map (make-sparse-keymap))
;; key bindings for VHDL templates
- (define-key vhdl-template-map "al" 'vhdl-template-alias)
- (define-key vhdl-template-map "ar" 'vhdl-template-architecture)
- (define-key vhdl-template-map "at" 'vhdl-template-assert)
- (define-key vhdl-template-map "ad" 'vhdl-template-attribute-decl)
- (define-key vhdl-template-map "as" 'vhdl-template-attribute-spec)
- (define-key vhdl-template-map "bl" 'vhdl-template-block)
- (define-key vhdl-template-map "ca" 'vhdl-template-case-is)
- (define-key vhdl-template-map "cd" 'vhdl-template-component-decl)
- (define-key vhdl-template-map "ci" 'vhdl-template-component-inst)
- (define-key vhdl-template-map "cs" 'vhdl-template-conditional-signal-asst)
- (define-key vhdl-template-map "Cb" 'vhdl-template-block-configuration)
- (define-key vhdl-template-map "Cc" 'vhdl-template-component-conf)
- (define-key vhdl-template-map "Cd" 'vhdl-template-configuration-decl)
- (define-key vhdl-template-map "Cs" 'vhdl-template-configuration-spec)
- (define-key vhdl-template-map "co" 'vhdl-template-constant)
- (define-key vhdl-template-map "ct" 'vhdl-template-context)
- (define-key vhdl-template-map "di" 'vhdl-template-disconnect)
- (define-key vhdl-template-map "el" 'vhdl-template-else)
- (define-key vhdl-template-map "ei" 'vhdl-template-elsif)
- (define-key vhdl-template-map "en" 'vhdl-template-entity)
- (define-key vhdl-template-map "ex" 'vhdl-template-exit)
- (define-key vhdl-template-map "fi" 'vhdl-template-file)
- (define-key vhdl-template-map "fg" 'vhdl-template-for-generate)
- (define-key vhdl-template-map "fl" 'vhdl-template-for-loop)
- (define-key vhdl-template-map "\C-f" 'vhdl-template-footer)
- (define-key vhdl-template-map "fb" 'vhdl-template-function-body)
- (define-key vhdl-template-map "fd" 'vhdl-template-function-decl)
- (define-key vhdl-template-map "ge" 'vhdl-template-generic)
- (define-key vhdl-template-map "gd" 'vhdl-template-group-decl)
- (define-key vhdl-template-map "gt" 'vhdl-template-group-template)
- (define-key vhdl-template-map "\C-h" 'vhdl-template-header)
- (define-key vhdl-template-map "ig" 'vhdl-template-if-generate)
- (define-key vhdl-template-map "it" 'vhdl-template-if-then)
- (define-key vhdl-template-map "li" 'vhdl-template-library)
- (define-key vhdl-template-map "lo" 'vhdl-template-bare-loop)
- (define-key vhdl-template-map "\C-m" 'vhdl-template-modify)
- (define-key vhdl-template-map "\C-t" 'vhdl-template-insert-date)
- (define-key vhdl-template-map "ma" 'vhdl-template-map)
- (define-key vhdl-template-map "ne" 'vhdl-template-next)
- (define-key vhdl-template-map "ot" 'vhdl-template-others)
- (define-key vhdl-template-map "Pd" 'vhdl-template-package-decl)
- (define-key vhdl-template-map "Pb" 'vhdl-template-package-body)
- (define-key vhdl-template-map "(" 'vhdl-template-paired-parens)
- (define-key vhdl-template-map "po" 'vhdl-template-port)
- (define-key vhdl-template-map "pb" 'vhdl-template-procedure-body)
- (define-key vhdl-template-map "pd" 'vhdl-template-procedure-decl)
- (define-key vhdl-template-map "pc" 'vhdl-template-process-comb)
- (define-key vhdl-template-map "ps" 'vhdl-template-process-seq)
- (define-key vhdl-template-map "rp" 'vhdl-template-report)
- (define-key vhdl-template-map "rt" 'vhdl-template-return)
- (define-key vhdl-template-map "ss" 'vhdl-template-selected-signal-asst)
- (define-key vhdl-template-map "si" 'vhdl-template-signal)
- (define-key vhdl-template-map "su" 'vhdl-template-subtype)
- (define-key vhdl-template-map "ty" 'vhdl-template-type)
- (define-key vhdl-template-map "us" 'vhdl-template-use)
- (define-key vhdl-template-map "va" 'vhdl-template-variable)
- (define-key vhdl-template-map "wa" 'vhdl-template-wait)
- (define-key vhdl-template-map "wl" 'vhdl-template-while-loop)
- (define-key vhdl-template-map "wi" 'vhdl-template-with)
- (define-key vhdl-template-map "wc" 'vhdl-template-clocked-wait)
- (define-key vhdl-template-map "\C-pb" 'vhdl-template-package-numeric-bit)
- (define-key vhdl-template-map "\C-pn" 'vhdl-template-package-numeric-std)
- (define-key vhdl-template-map "\C-ps" 'vhdl-template-package-std-logic-1164)
- (define-key vhdl-template-map "\C-pA" 'vhdl-template-package-std-logic-arith)
- (define-key vhdl-template-map "\C-pM" 'vhdl-template-package-std-logic-misc)
- (define-key vhdl-template-map "\C-pS"
'vhdl-template-package-std-logic-signed)
- (define-key vhdl-template-map "\C-pT"
'vhdl-template-package-std-logic-textio)
- (define-key vhdl-template-map "\C-pU"
'vhdl-template-package-std-logic-unsigned)
- (define-key vhdl-template-map "\C-pt" 'vhdl-template-package-textio)
- (define-key vhdl-template-map "\C-dn" 'vhdl-template-directive-translate-on)
- (define-key vhdl-template-map "\C-df" 'vhdl-template-directive-translate-off)
- (define-key vhdl-template-map "\C-dN" 'vhdl-template-directive-synthesis-on)
- (define-key vhdl-template-map "\C-dF" 'vhdl-template-directive-synthesis-off)
- (define-key vhdl-template-map "\C-q" 'vhdl-template-search-prompt)
+ (define-key vhdl-template-map "al" #'vhdl-template-alias)
+ (define-key vhdl-template-map "ar" #'vhdl-template-architecture)
+ (define-key vhdl-template-map "at" #'vhdl-template-assert)
+ (define-key vhdl-template-map "ad" #'vhdl-template-attribute-decl)
+ (define-key vhdl-template-map "as" #'vhdl-template-attribute-spec)
+ (define-key vhdl-template-map "bl" #'vhdl-template-block)
+ (define-key vhdl-template-map "ca" #'vhdl-template-case-is)
+ (define-key vhdl-template-map "cd" #'vhdl-template-component-decl)
+ (define-key vhdl-template-map "ci" #'vhdl-template-component-inst)
+ (define-key vhdl-template-map "cs" #'vhdl-template-conditional-signal-asst)
+ (define-key vhdl-template-map "Cb" #'vhdl-template-block-configuration)
+ (define-key vhdl-template-map "Cc" #'vhdl-template-component-conf)
+ (define-key vhdl-template-map "Cd" #'vhdl-template-configuration-decl)
+ (define-key vhdl-template-map "Cs" #'vhdl-template-configuration-spec)
+ (define-key vhdl-template-map "co" #'vhdl-template-constant)
+ (define-key vhdl-template-map "ct" #'vhdl-template-context)
+ (define-key vhdl-template-map "di" #'vhdl-template-disconnect)
+ (define-key vhdl-template-map "el" #'vhdl-template-else)
+ (define-key vhdl-template-map "ei" #'vhdl-template-elsif)
+ (define-key vhdl-template-map "en" #'vhdl-template-entity)
+ (define-key vhdl-template-map "ex" #'vhdl-template-exit)
+ (define-key vhdl-template-map "fi" #'vhdl-template-file)
+ (define-key vhdl-template-map "fg" #'vhdl-template-for-generate)
+ (define-key vhdl-template-map "fl" #'vhdl-template-for-loop)
+ (define-key vhdl-template-map "\C-f" #'vhdl-template-footer)
+ (define-key vhdl-template-map "fb" #'vhdl-template-function-body)
+ (define-key vhdl-template-map "fd" #'vhdl-template-function-decl)
+ (define-key vhdl-template-map "ge" #'vhdl-template-generic)
+ (define-key vhdl-template-map "gd" #'vhdl-template-group-decl)
+ (define-key vhdl-template-map "gt" #'vhdl-template-group-template)
+ (define-key vhdl-template-map "\C-h" #'vhdl-template-header)
+ (define-key vhdl-template-map "ig" #'vhdl-template-if-generate)
+ (define-key vhdl-template-map "it" #'vhdl-template-if-then)
+ (define-key vhdl-template-map "li" #'vhdl-template-library)
+ (define-key vhdl-template-map "lo" #'vhdl-template-bare-loop)
+ (define-key vhdl-template-map "\C-m" #'vhdl-template-modify)
+ (define-key vhdl-template-map "\C-t" #'vhdl-template-insert-date)
+ (define-key vhdl-template-map "ma" #'vhdl-template-map)
+ (define-key vhdl-template-map "ne" #'vhdl-template-next)
+ (define-key vhdl-template-map "ot" #'vhdl-template-others)
+ (define-key vhdl-template-map "Pd" #'vhdl-template-package-decl)
+ (define-key vhdl-template-map "Pb" #'vhdl-template-package-body)
+ (define-key vhdl-template-map "(" #'vhdl-template-paired-parens)
+ (define-key vhdl-template-map "po" #'vhdl-template-port)
+ (define-key vhdl-template-map "pb" #'vhdl-template-procedure-body)
+ (define-key vhdl-template-map "pd" #'vhdl-template-procedure-decl)
+ (define-key vhdl-template-map "pc" #'vhdl-template-process-comb)
+ (define-key vhdl-template-map "ps" #'vhdl-template-process-seq)
+ (define-key vhdl-template-map "rp" #'vhdl-template-report)
+ (define-key vhdl-template-map "rt" #'vhdl-template-return)
+ (define-key vhdl-template-map "ss" #'vhdl-template-selected-signal-asst)
+ (define-key vhdl-template-map "si" #'vhdl-template-signal)
+ (define-key vhdl-template-map "su" #'vhdl-template-subtype)
+ (define-key vhdl-template-map "ty" #'vhdl-template-type)
+ (define-key vhdl-template-map "us" #'vhdl-template-use)
+ (define-key vhdl-template-map "va" #'vhdl-template-variable)
+ (define-key vhdl-template-map "wa" #'vhdl-template-wait)
+ (define-key vhdl-template-map "wl" #'vhdl-template-while-loop)
+ (define-key vhdl-template-map "wi" #'vhdl-template-with)
+ (define-key vhdl-template-map "wc" #'vhdl-template-clocked-wait)
+ (define-key vhdl-template-map "\C-pb" #'vhdl-template-package-numeric-bit)
+ (define-key vhdl-template-map "\C-pn" #'vhdl-template-package-numeric-std)
+ (define-key vhdl-template-map "\C-ps" #'vhdl-template-package-std-logic-1164)
+ (define-key vhdl-template-map "\C-pA"
#'vhdl-template-package-std-logic-arith)
+ (define-key vhdl-template-map "\C-pM" #'vhdl-template-package-std-logic-misc)
+ (define-key vhdl-template-map "\C-pS"
#'vhdl-template-package-std-logic-signed)
+ (define-key vhdl-template-map "\C-pT"
#'vhdl-template-package-std-logic-textio)
+ (define-key vhdl-template-map "\C-pU"
#'vhdl-template-package-std-logic-unsigned)
+ (define-key vhdl-template-map "\C-pt" #'vhdl-template-package-textio)
+ (define-key vhdl-template-map "\C-dn" #'vhdl-template-directive-translate-on)
+ (define-key vhdl-template-map "\C-df"
#'vhdl-template-directive-translate-off)
+ (define-key vhdl-template-map "\C-dN" #'vhdl-template-directive-synthesis-on)
+ (define-key vhdl-template-map "\C-dF"
#'vhdl-template-directive-synthesis-off)
+ (define-key vhdl-template-map "\C-q" #'vhdl-template-search-prompt)
(when (vhdl-standard-p 'ams)
- (define-key vhdl-template-map "br" 'vhdl-template-break)
- (define-key vhdl-template-map "cu" 'vhdl-template-case-use)
- (define-key vhdl-template-map "iu" 'vhdl-template-if-use)
- (define-key vhdl-template-map "lm" 'vhdl-template-limit)
- (define-key vhdl-template-map "na" 'vhdl-template-nature)
- (define-key vhdl-template-map "pa" 'vhdl-template-procedural)
- (define-key vhdl-template-map "qf" 'vhdl-template-quantity-free)
- (define-key vhdl-template-map "qb" 'vhdl-template-quantity-branch)
- (define-key vhdl-template-map "qs" 'vhdl-template-quantity-source)
- (define-key vhdl-template-map "sn" 'vhdl-template-subnature)
- (define-key vhdl-template-map "te" 'vhdl-template-terminal)
+ (define-key vhdl-template-map "br" #'vhdl-template-break)
+ (define-key vhdl-template-map "cu" #'vhdl-template-case-use)
+ (define-key vhdl-template-map "iu" #'vhdl-template-if-use)
+ (define-key vhdl-template-map "lm" #'vhdl-template-limit)
+ (define-key vhdl-template-map "na" #'vhdl-template-nature)
+ (define-key vhdl-template-map "pa" #'vhdl-template-procedural)
+ (define-key vhdl-template-map "qf" #'vhdl-template-quantity-free)
+ (define-key vhdl-template-map "qb" #'vhdl-template-quantity-branch)
+ (define-key vhdl-template-map "qs" #'vhdl-template-quantity-source)
+ (define-key vhdl-template-map "sn" #'vhdl-template-subnature)
+ (define-key vhdl-template-map "te" #'vhdl-template-terminal)
)
(when (vhdl-standard-p 'math)
- (define-key vhdl-template-map "\C-pc" 'vhdl-template-package-math-complex)
- (define-key vhdl-template-map "\C-pr" 'vhdl-template-package-math-real)
+ (define-key vhdl-template-map "\C-pc" #'vhdl-template-package-math-complex)
+ (define-key vhdl-template-map "\C-pr" #'vhdl-template-package-math-real)
))
;; initialize template map for VHDL Mode
@@ -2812,119 +2817,120 @@ STRING are replaced by `-' and substrings are
converted to lower case."
;; model key bindings
(define-key vhdl-mode-map "\C-c\C-m" vhdl-model-map)
;; standard key bindings
- (define-key vhdl-mode-map "\M-a" 'vhdl-beginning-of-statement)
- (define-key vhdl-mode-map "\M-e" 'vhdl-end-of-statement)
- (define-key vhdl-mode-map "\M-\C-f" 'vhdl-forward-sexp)
- (define-key vhdl-mode-map "\M-\C-b" 'vhdl-backward-sexp)
- (define-key vhdl-mode-map "\M-\C-u" 'vhdl-backward-up-list)
- (define-key vhdl-mode-map "\M-\C-a" 'vhdl-backward-same-indent)
- (define-key vhdl-mode-map "\M-\C-e" 'vhdl-forward-same-indent)
+ (define-key vhdl-mode-map "\M-a" #'vhdl-beginning-of-statement)
+ (define-key vhdl-mode-map "\M-e" #'vhdl-end-of-statement)
+ (define-key vhdl-mode-map "\M-\C-f" #'vhdl-forward-sexp)
+ (define-key vhdl-mode-map "\M-\C-b" #'vhdl-backward-sexp)
+ (define-key vhdl-mode-map "\M-\C-u" #'vhdl-backward-up-list)
+ (define-key vhdl-mode-map "\M-\C-a" #'vhdl-backward-same-indent)
+ (define-key vhdl-mode-map "\M-\C-e" #'vhdl-forward-same-indent)
(unless (featurep 'xemacs) ; would override `M-backspace' in XEmacs
- (define-key vhdl-mode-map "\M-\C-h" 'vhdl-mark-defun))
- (define-key vhdl-mode-map "\M-\C-q" 'vhdl-indent-sexp)
- (define-key vhdl-mode-map "\M-^" 'vhdl-delete-indentation)
+ (define-key vhdl-mode-map "\M-\C-h" #'vhdl-mark-defun))
+ (define-key vhdl-mode-map "\M-\C-q" #'vhdl-indent-sexp)
+ (define-key vhdl-mode-map "\M-^" #'vhdl-delete-indentation)
;; mode specific key bindings
- (define-key vhdl-mode-map "\C-c\C-m\C-e" 'vhdl-electric-mode)
- (define-key vhdl-mode-map "\C-c\C-m\C-s" 'vhdl-stutter-mode)
- (define-key vhdl-mode-map "\C-c\C-s\C-p" 'vhdl-set-project)
- (define-key vhdl-mode-map "\C-c\C-p\C-d" 'vhdl-duplicate-project)
- (define-key vhdl-mode-map "\C-c\C-p\C-m" 'vhdl-import-project)
- (define-key vhdl-mode-map "\C-c\C-p\C-x" 'vhdl-export-project)
- (define-key vhdl-mode-map "\C-c\C-s\C-k" 'vhdl-set-compiler)
- (define-key vhdl-mode-map "\C-c\C-k" 'vhdl-compile)
- (define-key vhdl-mode-map "\C-c\M-\C-k" 'vhdl-make)
- (define-key vhdl-mode-map "\C-c\M-k" 'vhdl-generate-makefile)
- (define-key vhdl-mode-map "\C-c\C-p\C-w" 'vhdl-port-copy)
- (define-key vhdl-mode-map "\C-c\C-p\M-w" 'vhdl-port-copy)
- (define-key vhdl-mode-map "\C-c\C-p\C-e" 'vhdl-port-paste-entity)
- (define-key vhdl-mode-map "\C-c\C-p\C-c" 'vhdl-port-paste-component)
- (define-key vhdl-mode-map "\C-c\C-p\C-i" 'vhdl-port-paste-instance)
- (define-key vhdl-mode-map "\C-c\C-p\C-s" 'vhdl-port-paste-signals)
- (define-key vhdl-mode-map "\C-c\C-p\M-c" 'vhdl-port-paste-constants)
- (if (featurep 'xemacs) ; `... C-g' not allowed in XEmacs
- (define-key vhdl-mode-map "\C-c\C-p\M-g" 'vhdl-port-paste-generic-map)
- (define-key vhdl-mode-map "\C-c\C-p\C-g" 'vhdl-port-paste-generic-map))
- (define-key vhdl-mode-map "\C-c\C-p\C-z" 'vhdl-port-paste-initializations)
- (define-key vhdl-mode-map "\C-c\C-p\C-t" 'vhdl-port-paste-testbench)
- (define-key vhdl-mode-map "\C-c\C-p\C-f" 'vhdl-port-flatten)
- (define-key vhdl-mode-map "\C-c\C-p\C-r" 'vhdl-port-reverse-direction)
- (define-key vhdl-mode-map "\C-c\C-s\C-w" 'vhdl-subprog-copy)
- (define-key vhdl-mode-map "\C-c\C-s\M-w" 'vhdl-subprog-copy)
- (define-key vhdl-mode-map "\C-c\C-s\C-d" 'vhdl-subprog-paste-declaration)
- (define-key vhdl-mode-map "\C-c\C-s\C-b" 'vhdl-subprog-paste-body)
- (define-key vhdl-mode-map "\C-c\C-s\C-c" 'vhdl-subprog-paste-call)
- (define-key vhdl-mode-map "\C-c\C-s\C-f" 'vhdl-subprog-flatten)
- (define-key vhdl-mode-map "\C-c\C-m\C-n" 'vhdl-compose-new-component)
- (define-key vhdl-mode-map "\C-c\C-m\C-p" 'vhdl-compose-place-component)
- (define-key vhdl-mode-map "\C-c\C-m\C-w" 'vhdl-compose-wire-components)
- (define-key vhdl-mode-map "\C-c\C-m\C-f" 'vhdl-compose-configuration)
- (define-key vhdl-mode-map "\C-c\C-m\C-k" 'vhdl-compose-components-package)
- (define-key vhdl-mode-map "\C-c\C-c" 'vhdl-comment-uncomment-region)
- (define-key vhdl-mode-map "\C-c-" 'vhdl-comment-append-inline)
- (define-key vhdl-mode-map "\C-c\M--" 'vhdl-comment-display-line)
- (define-key vhdl-mode-map "\C-c\C-i\C-l" 'indent-according-to-mode)
- (define-key vhdl-mode-map "\C-c\C-i\C-g" 'vhdl-indent-group)
- (define-key vhdl-mode-map "\M-\C-\\" 'vhdl-indent-region)
- (define-key vhdl-mode-map "\C-c\C-i\C-b" 'vhdl-indent-buffer)
- (define-key vhdl-mode-map "\C-c\C-a\C-g" 'vhdl-align-group)
- (define-key vhdl-mode-map "\C-c\C-a\C-a" 'vhdl-align-group)
- (define-key vhdl-mode-map "\C-c\C-a\C-i" 'vhdl-align-same-indent)
- (define-key vhdl-mode-map "\C-c\C-a\C-l" 'vhdl-align-list)
- (define-key vhdl-mode-map "\C-c\C-a\C-d" 'vhdl-align-declarations)
- (define-key vhdl-mode-map "\C-c\C-a\M-a" 'vhdl-align-region)
- (define-key vhdl-mode-map "\C-c\C-a\C-b" 'vhdl-align-buffer)
- (define-key vhdl-mode-map "\C-c\C-a\C-c" 'vhdl-align-inline-comment-group)
- (define-key vhdl-mode-map "\C-c\C-a\M-c" 'vhdl-align-inline-comment-region)
- (define-key vhdl-mode-map "\C-c\C-f\C-l" 'vhdl-fill-list)
- (define-key vhdl-mode-map "\C-c\C-f\C-f" 'vhdl-fill-list)
- (define-key vhdl-mode-map "\C-c\C-f\C-g" 'vhdl-fill-group)
- (define-key vhdl-mode-map "\C-c\C-f\C-i" 'vhdl-fill-same-indent)
- (define-key vhdl-mode-map "\C-c\C-f\M-f" 'vhdl-fill-region)
- (define-key vhdl-mode-map "\C-c\C-l\C-w" 'vhdl-line-kill)
- (define-key vhdl-mode-map "\C-c\C-l\M-w" 'vhdl-line-copy)
- (define-key vhdl-mode-map "\C-c\C-l\C-y" 'vhdl-line-yank)
- (define-key vhdl-mode-map "\C-c\C-l\t" 'vhdl-line-expand)
- (define-key vhdl-mode-map "\C-c\C-l\C-n" 'vhdl-line-transpose-next)
- (define-key vhdl-mode-map "\C-c\C-l\C-p" 'vhdl-line-transpose-previous)
- (define-key vhdl-mode-map "\C-c\C-l\C-o" 'vhdl-line-open)
- (define-key vhdl-mode-map "\C-c\C-l\C-g" 'goto-line)
- (define-key vhdl-mode-map "\C-c\C-l\C-c" 'vhdl-comment-uncomment-line)
- (define-key vhdl-mode-map "\C-c\C-x\C-s" 'vhdl-fix-statement-region)
- (define-key vhdl-mode-map "\C-c\C-x\M-s" 'vhdl-fix-statement-buffer)
- (define-key vhdl-mode-map "\C-c\C-x\C-p" 'vhdl-fix-clause)
- (define-key vhdl-mode-map "\C-c\C-x\M-c" 'vhdl-fix-case-region)
- (define-key vhdl-mode-map "\C-c\C-x\C-c" 'vhdl-fix-case-buffer)
- (define-key vhdl-mode-map "\C-c\C-x\M-w" 'vhdl-fixup-whitespace-region)
- (define-key vhdl-mode-map "\C-c\C-x\C-w" 'vhdl-fixup-whitespace-buffer)
- (define-key vhdl-mode-map "\C-c\M-b" 'vhdl-beautify-region)
- (define-key vhdl-mode-map "\C-c\C-b" 'vhdl-beautify-buffer)
- (define-key vhdl-mode-map "\C-c\C-u\C-s"
'vhdl-update-sensitivity-list-process)
- (define-key vhdl-mode-map "\C-c\C-u\M-s"
'vhdl-update-sensitivity-list-buffer)
- (define-key vhdl-mode-map "\C-c\C-i\C-f" 'vhdl-fontify-buffer)
- (define-key vhdl-mode-map "\C-c\C-i\C-s" 'vhdl-statistics-buffer)
- (define-key vhdl-mode-map "\C-c\M-m" 'vhdl-show-messages)
- (define-key vhdl-mode-map "\C-c\C-h" 'vhdl-doc-mode)
- (define-key vhdl-mode-map "\C-c\C-v" 'vhdl-version)
- (define-key vhdl-mode-map "\M-\t" 'insert-tab)
+ (define-key vhdl-mode-map "\C-c\C-m\C-e" #'vhdl-electric-mode)
+ (define-key vhdl-mode-map "\C-c\C-m\C-s" #'vhdl-stutter-mode)
+ (define-key vhdl-mode-map "\C-c\C-s\C-p" #'vhdl-set-project)
+ (define-key vhdl-mode-map "\C-c\C-p\C-d" #'vhdl-duplicate-project)
+ (define-key vhdl-mode-map "\C-c\C-p\C-m" #'vhdl-import-project)
+ (define-key vhdl-mode-map "\C-c\C-p\C-x" #'vhdl-export-project)
+ (define-key vhdl-mode-map "\C-c\C-s\C-k" #'vhdl-set-compiler)
+ (define-key vhdl-mode-map "\C-c\C-k" #'vhdl-compile)
+ (define-key vhdl-mode-map "\C-c\M-\C-k" #'vhdl-make)
+ (define-key vhdl-mode-map "\C-c\M-k" #'vhdl-generate-makefile)
+ (define-key vhdl-mode-map "\C-c\C-p\C-w" #'vhdl-port-copy)
+ (define-key vhdl-mode-map "\C-c\C-p\M-w" #'vhdl-port-copy)
+ (define-key vhdl-mode-map "\C-c\C-p\C-e" #'vhdl-port-paste-entity)
+ (define-key vhdl-mode-map "\C-c\C-p\C-c" #'vhdl-port-paste-component)
+ (define-key vhdl-mode-map "\C-c\C-p\C-i" #'vhdl-port-paste-instance)
+ (define-key vhdl-mode-map "\C-c\C-p\C-s" #'vhdl-port-paste-signals)
+ (define-key vhdl-mode-map "\C-c\C-p\M-c" #'vhdl-port-paste-constants)
+ (define-key vhdl-mode-map
+ ;; `... C-g' not allowed in XEmacs.
+ (if (featurep 'xemacs) "\C-c\C-p\M-g" "\C-c\C-p\C-g")
+ #'vhdl-port-paste-generic-map)
+ (define-key vhdl-mode-map "\C-c\C-p\C-z" #'vhdl-port-paste-initializations)
+ (define-key vhdl-mode-map "\C-c\C-p\C-t" #'vhdl-port-paste-testbench)
+ (define-key vhdl-mode-map "\C-c\C-p\C-f" #'vhdl-port-flatten)
+ (define-key vhdl-mode-map "\C-c\C-p\C-r" #'vhdl-port-reverse-direction)
+ (define-key vhdl-mode-map "\C-c\C-s\C-w" #'vhdl-subprog-copy)
+ (define-key vhdl-mode-map "\C-c\C-s\M-w" #'vhdl-subprog-copy)
+ (define-key vhdl-mode-map "\C-c\C-s\C-d" #'vhdl-subprog-paste-declaration)
+ (define-key vhdl-mode-map "\C-c\C-s\C-b" #'vhdl-subprog-paste-body)
+ (define-key vhdl-mode-map "\C-c\C-s\C-c" #'vhdl-subprog-paste-call)
+ (define-key vhdl-mode-map "\C-c\C-s\C-f" #'vhdl-subprog-flatten)
+ (define-key vhdl-mode-map "\C-c\C-m\C-n" #'vhdl-compose-new-component)
+ (define-key vhdl-mode-map "\C-c\C-m\C-p" #'vhdl-compose-place-component)
+ (define-key vhdl-mode-map "\C-c\C-m\C-w" #'vhdl-compose-wire-components)
+ (define-key vhdl-mode-map "\C-c\C-m\C-f" #'vhdl-compose-configuration)
+ (define-key vhdl-mode-map "\C-c\C-m\C-k" #'vhdl-compose-components-package)
+ (define-key vhdl-mode-map "\C-c\C-c" #'vhdl-comment-uncomment-region)
+ (define-key vhdl-mode-map "\C-c-" #'vhdl-comment-append-inline)
+ (define-key vhdl-mode-map "\C-c\M--" #'vhdl-comment-display-line)
+ (define-key vhdl-mode-map "\C-c\C-i\C-l" #'indent-according-to-mode)
+ (define-key vhdl-mode-map "\C-c\C-i\C-g" #'vhdl-indent-group)
+ (define-key vhdl-mode-map "\M-\C-\\" #'indent-region)
+ (define-key vhdl-mode-map "\C-c\C-i\C-b" #'vhdl-indent-buffer)
+ (define-key vhdl-mode-map "\C-c\C-a\C-g" #'vhdl-align-group)
+ (define-key vhdl-mode-map "\C-c\C-a\C-a" #'vhdl-align-group)
+ (define-key vhdl-mode-map "\C-c\C-a\C-i" #'vhdl-align-same-indent)
+ (define-key vhdl-mode-map "\C-c\C-a\C-l" #'vhdl-align-list)
+ (define-key vhdl-mode-map "\C-c\C-a\C-d" #'vhdl-align-declarations)
+ (define-key vhdl-mode-map "\C-c\C-a\M-a" #'vhdl-align-region)
+ (define-key vhdl-mode-map "\C-c\C-a\C-b" #'vhdl-align-buffer)
+ (define-key vhdl-mode-map "\C-c\C-a\C-c" #'vhdl-align-inline-comment-group)
+ (define-key vhdl-mode-map "\C-c\C-a\M-c" #'vhdl-align-inline-comment-region)
+ (define-key vhdl-mode-map "\C-c\C-f\C-l" #'vhdl-fill-list)
+ (define-key vhdl-mode-map "\C-c\C-f\C-f" #'vhdl-fill-list)
+ (define-key vhdl-mode-map "\C-c\C-f\C-g" #'vhdl-fill-group)
+ (define-key vhdl-mode-map "\C-c\C-f\C-i" #'vhdl-fill-same-indent)
+ (define-key vhdl-mode-map "\C-c\C-f\M-f" #'vhdl-fill-region)
+ (define-key vhdl-mode-map "\C-c\C-l\C-w" #'vhdl-line-kill)
+ (define-key vhdl-mode-map "\C-c\C-l\M-w" #'vhdl-line-copy)
+ (define-key vhdl-mode-map "\C-c\C-l\C-y" #'vhdl-line-yank)
+ (define-key vhdl-mode-map "\C-c\C-l\t" #'vhdl-line-expand)
+ (define-key vhdl-mode-map "\C-c\C-l\C-n" #'vhdl-line-transpose-next)
+ (define-key vhdl-mode-map "\C-c\C-l\C-p" #'vhdl-line-transpose-previous)
+ (define-key vhdl-mode-map "\C-c\C-l\C-o" #'vhdl-line-open)
+ (define-key vhdl-mode-map "\C-c\C-l\C-g" #'goto-line)
+ (define-key vhdl-mode-map "\C-c\C-l\C-c" #'vhdl-comment-uncomment-line)
+ (define-key vhdl-mode-map "\C-c\C-x\C-s" #'vhdl-fix-statement-region)
+ (define-key vhdl-mode-map "\C-c\C-x\M-s" #'vhdl-fix-statement-buffer)
+ (define-key vhdl-mode-map "\C-c\C-x\C-p" #'vhdl-fix-clause)
+ (define-key vhdl-mode-map "\C-c\C-x\M-c" #'vhdl-fix-case-region)
+ (define-key vhdl-mode-map "\C-c\C-x\C-c" #'vhdl-fix-case-buffer)
+ (define-key vhdl-mode-map "\C-c\C-x\M-w" #'vhdl-fixup-whitespace-region)
+ (define-key vhdl-mode-map "\C-c\C-x\C-w" #'vhdl-fixup-whitespace-buffer)
+ (define-key vhdl-mode-map "\C-c\M-b" #'vhdl-beautify-region)
+ (define-key vhdl-mode-map "\C-c\C-b" #'vhdl-beautify-buffer)
+ (define-key vhdl-mode-map "\C-c\C-u\C-s"
#'vhdl-update-sensitivity-list-process)
+ (define-key vhdl-mode-map "\C-c\C-u\M-s"
#'vhdl-update-sensitivity-list-buffer)
+ (define-key vhdl-mode-map "\C-c\C-i\C-f" #'vhdl-fontify-buffer)
+ (define-key vhdl-mode-map "\C-c\C-i\C-s" #'vhdl-statistics-buffer)
+ (define-key vhdl-mode-map "\C-c\M-m" #'vhdl-show-messages)
+ (define-key vhdl-mode-map "\C-c\C-h" #'vhdl-doc-mode)
+ (define-key vhdl-mode-map "\C-c\C-v" #'vhdl-version)
+ (define-key vhdl-mode-map "\M-\t" #'insert-tab)
;; insert commands bindings
- (define-key vhdl-mode-map "\C-c\C-i\C-t" 'vhdl-template-insert-construct)
- (define-key vhdl-mode-map "\C-c\C-i\C-p" 'vhdl-template-insert-package)
- (define-key vhdl-mode-map "\C-c\C-i\C-d" 'vhdl-template-insert-directive)
- (define-key vhdl-mode-map "\C-c\C-i\C-m" 'vhdl-model-insert)
+ (define-key vhdl-mode-map "\C-c\C-i\C-t" #'vhdl-template-insert-construct)
+ (define-key vhdl-mode-map "\C-c\C-i\C-p" #'vhdl-template-insert-package)
+ (define-key vhdl-mode-map "\C-c\C-i\C-d" #'vhdl-template-insert-directive)
+ (define-key vhdl-mode-map "\C-c\C-i\C-m" #'vhdl-model-insert)
;; electric key bindings
- (define-key vhdl-mode-map " " 'vhdl-electric-space)
+ (define-key vhdl-mode-map " " #'vhdl-electric-space)
(when vhdl-intelligent-tab
- (define-key vhdl-mode-map "\t" 'vhdl-electric-tab))
- (define-key vhdl-mode-map "\r" 'vhdl-electric-return)
- (define-key vhdl-mode-map "-" 'vhdl-electric-dash)
- (define-key vhdl-mode-map "[" 'vhdl-electric-open-bracket)
- (define-key vhdl-mode-map "]" 'vhdl-electric-close-bracket)
- (define-key vhdl-mode-map "'" 'vhdl-electric-quote)
- (define-key vhdl-mode-map ";" 'vhdl-electric-semicolon)
- (define-key vhdl-mode-map "," 'vhdl-electric-comma)
- (define-key vhdl-mode-map "." 'vhdl-electric-period)
+ (define-key vhdl-mode-map "\t" #'vhdl-electric-tab))
+ (define-key vhdl-mode-map "\r" #'vhdl-electric-return)
+ (define-key vhdl-mode-map "-" #'vhdl-electric-dash)
+ (define-key vhdl-mode-map "[" #'vhdl-electric-open-bracket)
+ (define-key vhdl-mode-map "]"
#'vhdl-electric-close-bracket)
+ (define-key vhdl-mode-map "'" #'vhdl-electric-quote)
+ (define-key vhdl-mode-map ";" #'vhdl-electric-semicolon)
+ (define-key vhdl-mode-map "," #'vhdl-electric-comma)
+ (define-key vhdl-mode-map "." #'vhdl-electric-period)
(when (vhdl-standard-p 'ams)
- (define-key vhdl-mode-map "=" 'vhdl-electric-equal)))
+ (define-key vhdl-mode-map "=" #'vhdl-electric-equal)))
;; initialize mode map for VHDL Mode
(vhdl-mode-map-init)
@@ -2935,7 +2941,7 @@ STRING are replaced by `-' and substrings are converted
to lower case."
(let ((map (make-sparse-keymap)))
(set-keymap-parent map minibuffer-local-map)
(when vhdl-word-completion-in-minibuffer
- (define-key map "\t" 'vhdl-minibuffer-tab))
+ (define-key map "\t" #'vhdl-minibuffer-tab))
map)
"Keymap for minibuffer used in VHDL Mode.")
@@ -3168,7 +3174,8 @@ STRING are replaced by `-' and substrings are converted
to lower case."
(unless (equal keyword "")
(push (list keyword ""
(vhdl-function-name
- "vhdl-model" (nth 0 elem) "hook") 0 'system)
+ "vhdl-model" (nth 0 elem) "hook")
+ 0 'system)
abbrev-list)))
abbrev-list)))))
@@ -3575,7 +3582,7 @@ STRING are replaced by `-' and substrings are converted
to lower case."
("Indent"
["Line" indent-according-to-mode :keys "C-c C-i C-l"]
["Group" vhdl-indent-group :keys "C-c C-i C-g"]
- ["Region" vhdl-indent-region (mark)]
+ ["Region" indent-region (mark)]
["Buffer" vhdl-indent-buffer :keys "C-c C-i C-b"])
("Align"
["Group" vhdl-align-group t]
@@ -4885,7 +4892,7 @@ Key bindings:
(set (make-local-variable 'paragraph-separate) paragraph-start)
(set (make-local-variable 'paragraph-ignore-fill-prefix) t)
(set (make-local-variable 'parse-sexp-ignore-comments) t)
- (set (make-local-variable 'indent-line-function) 'vhdl-indent-line)
+ (set (make-local-variable 'indent-line-function) #'vhdl-indent-line)
(set (make-local-variable 'comment-start) "--")
(set (make-local-variable 'comment-end) "")
(set (make-local-variable 'comment-column) vhdl-inline-comment-column)
@@ -4898,13 +4905,13 @@ Key bindings:
;; setup the comment indent variable in an Emacs version portable way
;; ignore any byte compiler warnings you might get here
(when (boundp 'comment-indent-function)
- (set (make-local-variable 'comment-indent-function) 'vhdl-comment-indent))
+ (set (make-local-variable 'comment-indent-function) #'vhdl-comment-indent))
;; initialize font locking
(set (make-local-variable 'font-lock-defaults)
(list
'(nil vhdl-font-lock-keywords) nil
- (not vhdl-highlight-case-sensitive) '((?\_ . "w")) 'beginning-of-line))
+ (not vhdl-highlight-case-sensitive) '((?\_ . "w")) #'beginning-of-line))
(if (eval-when-compile (fboundp 'syntax-propertize-rules))
(set (make-local-variable 'syntax-propertize-function)
(syntax-propertize-rules
@@ -4913,7 +4920,7 @@ Key bindings:
("\\('\\).\\('\\)" (1 "\"'") (2 "\"'"))))
(set (make-local-variable 'font-lock-syntactic-keywords)
vhdl-font-lock-syntactic-keywords))
- (unless vhdl-emacs-21
+ (when (featurep 'xemacs)
(set (make-local-variable 'font-lock-support-mode) 'lazy-lock-mode)
(set (make-local-variable 'lazy-lock-defer-contextually) nil)
(set (make-local-variable 'lazy-lock-defer-on-the-fly) t)
@@ -4959,10 +4966,10 @@ Key bindings:
(defun vhdl-write-file-hooks-init ()
"Add/remove hooks when buffer is saved."
(if vhdl-modify-date-on-saving
- (add-hook 'write-file-functions 'vhdl-template-modify-noerror nil t)
- (remove-hook 'write-file-functions '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))
+ (add-hook 'after-save-hook #'vhdl-add-modified-file nil t))
(defun vhdl-process-command-line-option (option)
"Process command line options for VHDL Mode."
@@ -5745,7 +5752,7 @@ negative, skip forward otherwise."
;; XEmacs hack: work around buggy `forward-comment' in XEmacs 21.4+
(unless (and (featurep 'xemacs) (string< "21.2" emacs-version))
- (defalias 'vhdl-forward-comment 'forward-comment))
+ (defalias 'vhdl-forward-comment #'forward-comment))
(defun vhdl-back-to-indentation ()
"Move point to the first non-whitespace character on this line."
@@ -5809,7 +5816,7 @@ negative, skip forward otherwise."
state)))
(and (string-match "Win-Emacs" emacs-version)
- (fset 'vhdl-in-literal 'vhdl-win-il))
+ (fset 'vhdl-in-literal #'vhdl-win-il))
;; Skipping of "syntactic whitespace". Syntactic whitespace is
;; defined as lexical whitespace or comments. Search no farther back
@@ -5847,9 +5854,9 @@ negative, skip forward otherwise."
(t (setq stop t))))))
(and (string-match "Win-Emacs" emacs-version)
- (fset 'vhdl-forward-syntactic-ws 'vhdl-win-fsws))
+ (fset 'vhdl-forward-syntactic-ws #'vhdl-win-fsws))
-(defun vhdl-beginning-of-macro (&optional lim)
+(defun vhdl-beginning-of-macro (&optional _lim)
"Go to the beginning of a cpp macro definition (nicked from `cc-engine')."
(let ((here (point)))
(beginning-of-line)
@@ -5862,7 +5869,7 @@ negative, skip forward otherwise."
(goto-char here)
nil)))
-(defun vhdl-beginning-of-directive (&optional lim)
+(defun vhdl-beginning-of-directive (&optional _lim)
"Go to the beginning of a directive (nicked from `cc-engine')."
(let ((here (point)))
(beginning-of-line)
@@ -5906,7 +5913,7 @@ negative, skip forward otherwise."
(t (setq stop t))))))
(and (string-match "Win-Emacs" emacs-version)
- (fset 'vhdl-backward-syntactic-ws 'vhdl-win-bsws))
+ (fset 'vhdl-backward-syntactic-ws #'vhdl-win-bsws))
;; Functions to help finding the correct indentation column:
@@ -6054,7 +6061,7 @@ keyword."
t)
))
-(defun vhdl-corresponding-mid (&optional lim)
+(defun vhdl-corresponding-mid (&optional _lim)
(cond
((looking-at "is\\|block\\|generate\\|process\\|procedural")
"begin")
@@ -6270,7 +6277,7 @@ of an identifier that just happens to contain an \"end\"
keyword."
"A regular expression for searching backward that matches all known
\"statement\" keywords.")
-(defun vhdl-statement-p (&optional lim)
+(defun vhdl-statement-p (&optional _lim)
"Return t if we are looking at a real \"statement\" keyword.
Assumes that the caller will make sure that we are looking at
vhdl-statement-fwd-re, and are not inside a literal, and that we are not
@@ -6462,7 +6469,7 @@ searches."
;; internal-p controls where the statement keyword can
;; be found.
(internal-p (aref begin-vec 3))
- (last-backward (point)) last-forward
+ (last-backward (point)) ;; last-forward
foundp literal keyword)
;; Look for the statement keyword.
(while (and (not foundp)
@@ -6497,7 +6504,7 @@ searches."
(setq begin-re
(concat "\\b\\(" begin-re "\\)\\b[^_]"))
(save-excursion
- (setq last-forward (point))
+ ;; (setq last-forward (point))
;; Look for the supplementary keyword
;; (bounded by the backward search start
;; point).
@@ -6549,7 +6556,7 @@ With argument, do this that many times."
(setq target (point)))
(goto-char target)))
-(defun vhdl-end-of-defun (&optional count)
+(defun vhdl-end-of-defun (&optional _count)
"Move forward to the end of a VHDL defun."
(interactive)
(let ((case-fold-search t))
@@ -7321,7 +7328,7 @@ after the containing paren which starts the arglist."
(current-column))))
(- ce-curcol cs-curcol -1))))
-(defun vhdl-lineup-comment (langelem)
+(defun vhdl-lineup-comment (_langelem)
"Support old behavior for comment indentation. We look at
vhdl-comment-only-line-offset to decide how to indent comment
only-lines."
@@ -7383,27 +7390,13 @@ only-lines."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Progress reporting
-(defvar vhdl-progress-info nil
- "Array variable for progress information: 0 begin, 1 end, 2 time.")
-
-(defun vhdl-update-progress-info (string pos)
- "Update progress information."
- (when (and vhdl-progress-info (not noninteractive)
- (time-less-p vhdl-progress-interval
- (time-since (aref vhdl-progress-info 2))))
- (let ((delta (- (aref vhdl-progress-info 1)
- (aref vhdl-progress-info 0))))
- (message "%s... (%2d%%)" string
- (if (= 0 delta)
- 100
- (floor (* 100.0 (- pos (aref vhdl-progress-info 0)))
- delta))))
- (aset vhdl-progress-info 2 (time-convert nil 'integer))))
+(defvar vhdl--progress-reporter nil
+ "Holds the progress reporter data during long running operations.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Indentation commands
-(defun vhdl-electric-tab (&optional prefix-arg)
+(defun vhdl-electric-tab (&optional arg)
"If preceding character is part of a word or a paren then hippie-expand,
else if right of non whitespace on line then insert tab,
else if last command was a tab or return then dedent one step or if a comment
@@ -7414,7 +7407,7 @@ else indent `correctly'."
(cond
;; indent region if region is active
((and (not (featurep 'xemacs)) (use-region-p))
- (vhdl-indent-region (region-beginning) (region-end) nil))
+ (indent-region (region-beginning) (region-end) nil))
;; expand word
((= (char-syntax (preceding-char)) ?w)
(let ((case-fold-search (not vhdl-word-completion-case-sensitive))
@@ -7423,12 +7416,12 @@ else indent `correctly'."
(or (and (boundp 'hippie-expand-only-buffers)
hippie-expand-only-buffers)
'(vhdl-mode))))
- (vhdl-expand-abbrev prefix-arg)))
+ (vhdl-expand-abbrev arg)))
;; expand parenthesis
((or (= (preceding-char) ?\() (= (preceding-char) ?\)))
(let ((case-fold-search (not vhdl-word-completion-case-sensitive))
(case-replace nil))
- (vhdl-expand-paren prefix-arg)))
+ (vhdl-expand-paren arg)))
;; insert tab
((> (current-column) (current-indentation))
(insert-tab))
@@ -7487,7 +7480,7 @@ indentation change."
(setq syntax (vhdl-get-syntactic-context)))))
(when is-comment
(push (cons 'comment nil) syntax))
- (apply '+ (mapcar 'vhdl-get-offset syntax)))
+ (apply #'+ (mapcar #'vhdl-get-offset syntax)))
;; indent like previous nonblank line
(save-excursion (beginning-of-line)
(re-search-backward "^[^\n]" nil t)
@@ -7509,25 +7502,17 @@ indentation change."
(when (> (- (point-max) pos) (point))
(goto-char (- (point-max) pos))))
(run-hooks 'vhdl-special-indent-hook)
- (vhdl-update-progress-info "Indenting" (vhdl-current-line))
+ (when vhdl--progress-reporter
+ (progress-reporter-update vhdl--progress-reporter (point)))
shift-amt))
-(defun vhdl-indent-region (beg end &optional column)
- "Indent region as VHDL code.
-Adds progress reporting to `indent-region'."
- (interactive "r\nP")
- (when vhdl-progress-interval
- (setq vhdl-progress-info (vector (count-lines (point-min) beg)
- (count-lines (point-min) end) 0)))
- (indent-region beg end column)
- (when vhdl-progress-interval (message "Indenting...done"))
- (setq vhdl-progress-info nil))
+(define-obsolete-function-alias 'vhdl-indent-region #'indent-region "28.1")
(defun vhdl-indent-buffer ()
"Indent whole buffer as VHDL code.
Calls `indent-region' for whole buffer and adds progress reporting."
(interactive)
- (vhdl-indent-region (point-min) (point-max)))
+ (indent-region (point-min) (point-max)))
(defun vhdl-indent-group ()
"Indent group of lines between empty lines."
@@ -7540,7 +7525,7 @@ Calls `indent-region' for whole buffer and adds progress
reporting."
(if (re-search-forward vhdl-align-group-separate nil t)
(point-marker)
(point-max-marker)))))
- (vhdl-indent-region beg end)))
+ (indent-region beg end)))
(defun vhdl-indent-sexp (&optional endpos)
"Indent each line of the list starting just after point.
@@ -7699,7 +7684,7 @@ parentheses."
;; run FUNCTION
(funcall function beg end spacing)))
-(defun vhdl-align-region-1 (begin end &optional spacing alignment-list indent)
+(defun vhdl-align-region-1 (begin end &optional spacing alignment-list _indent)
"Attempt to align a range of lines based on the content of the
lines. The definition of `alignment-list' determines the matching
order and the manner in which the lines are aligned. If ALIGNMENT-LIST
@@ -7709,12 +7694,15 @@ indentation is done before aligning."
(setq alignment-list (or alignment-list vhdl-align-alist))
(setq spacing (or spacing 1))
(save-excursion
- (let (bol indent)
+ (let (bol) ;; indent
(goto-char end)
(setq end (point-marker))
(goto-char begin)
(setq bol (setq begin (progn (beginning-of-line) (point))))
- (when indent
+ ;; FIXME: The `indent' arg is not used, and I think it's because
+ ;; the let binding commented out above `indent' was hiding it, so
+ ;; the test below should maybe still test `indent'?
+ (when nil ;; indent
(indent-region bol end nil))))
(let ((copy (copy-alist alignment-list)))
(vhdl-prepare-search-2
@@ -7799,18 +7787,21 @@ the token in MATCH."
"Align region, treat groups of lines separately."
(interactive "r\nP")
(save-excursion
- (let (orig pos)
- (goto-char beg)
- (beginning-of-line)
- (setq orig (point-marker))
- (setq beg (point))
- (goto-char end)
- (setq end (point-marker))
- (untabify beg end)
- (unless no-message
- (when vhdl-progress-interval
- (setq vhdl-progress-info (vector (count-lines (point-min) beg)
- (count-lines (point-min) end) 0))))
+ (goto-char beg)
+ (beginning-of-line)
+ (setq beg (point))
+ (goto-char end)
+ (setq end (point-marker))
+ (untabify beg end)
+ (let ((orig (copy-marker beg))
+ pos
+ (vhdl--progress-reporter
+ (if no-message
+ ;; Preserve a potential progress reporter from
+ ;; when called from `vhdl-align-region' call.
+ vhdl--progress-reporter
+ (when vhdl-progress-interval
+ (make-progress-reporter "Aligning..." beg (copy-marker end))))))
(when (nth 0 vhdl-beautify-options)
(vhdl-fixup-whitespace-region beg end t))
(goto-char beg)
@@ -7825,19 +7816,21 @@ the token in MATCH."
(setq pos (point-marker))
(vhdl-align-region-1 beg pos spacing)
(unless no-comments (vhdl-align-inline-comment-region-1 beg pos))
- (vhdl-update-progress-info "Aligning" (vhdl-current-line))
+ (when vhdl--progress-reporter
+ (progress-reporter-update vhdl--progress-reporter (point)))
(setq beg (1+ pos))
(goto-char beg))
;; align last group
(when (< beg end)
(vhdl-align-region-1 beg end spacing)
(unless no-comments (vhdl-align-inline-comment-region-1 beg end))
- (vhdl-update-progress-info "Aligning" (vhdl-current-line))))
+ (when vhdl--progress-reporter
+ (progress-reporter-update vhdl--progress-reporter (point)))))
(when vhdl-indent-tabs-mode
(tabify orig end))
(unless no-message
- (when vhdl-progress-interval (message "Aligning...done"))
- (setq vhdl-progress-info nil)))))
+ (when vhdl--progress-reporter
+ (progress-reporter-done vhdl--progress-reporter))))))
(defun vhdl-align-region (beg end &optional spacing)
"Align region, treat blocks with same indent and argument lists separately."
@@ -7848,10 +7841,10 @@ the token in MATCH."
;; align blocks with same indent and argument lists
(save-excursion
(let ((cur-beg beg)
- indent cur-end)
- (when vhdl-progress-interval
- (setq vhdl-progress-info (vector (count-lines (point-min) beg)
- (count-lines (point-min) end) 0)))
+ indent cur-end
+ (vhdl--progress-reporter
+ (when vhdl-progress-interval
+ (make-progress-reporter "Aligning..." beg (copy-marker end)))))
(goto-char end)
(setq end (point-marker))
(goto-char cur-beg)
@@ -7874,15 +7867,16 @@ the token in MATCH."
(= (current-indentation) indent))
(<= (save-excursion
(nth 0 (parse-partial-sexp
- (point) (vhdl-point 'eol)))) 0))
+ (point) (vhdl-point 'eol))))
+ 0))
(unless (looking-at "^\\s-*$")
(setq cur-end (vhdl-point 'bonl)))
(beginning-of-line 2)))
;; align region
(vhdl-align-region-groups cur-beg cur-end spacing t t))
(vhdl-align-inline-comment-region beg end spacing noninteractive)
- (when vhdl-progress-interval (message "Aligning...done"))
- (setq vhdl-progress-info nil)))))
+ (when vhdl--progress-reporter
+ (progress-reporter-done vhdl--progress-reporter))))))
(defun vhdl-align-group (&optional spacing)
"Align group of lines between empty lines."
@@ -8031,7 +8025,7 @@ empty lines are aligned individually, if
`vhdl-align-groups' is non-nil."
(tabify orig end))
(unless no-message (message "Aligning inline comments...done")))))
-(defun vhdl-align-inline-comment-group (&optional spacing)
+(defun vhdl-align-inline-comment-group (&optional _spacing)
"Align inline comments within a group of lines between empty lines."
(interactive)
(save-excursion
@@ -8126,7 +8120,8 @@ end of line, do nothing in comments."
"Convert all words matching WORD-REGEXP in region to lower or upper case,
depending on parameter UPPER-CASE."
(let ((case-replace nil)
- (last-update 0))
+ (pr (when (and count vhdl-progress-interval (not noninteractive))
+ (make-progress-reporter "Fixing case..." beg (copy-marker end)))))
(vhdl-prepare-search-2
(save-excursion
(goto-char end)
@@ -8137,19 +8132,13 @@ depending on parameter UPPER-CASE."
(if upper-case
(upcase-word -1)
(downcase-word -1)))
- (when (and count vhdl-progress-interval (not noninteractive)
- (time-less-p vhdl-progress-interval
- (time-since last-update)))
- (message "Fixing case... (%2d%s)"
- (+ (* count 20) (/ (* 20 (- (point) beg)) (- end beg)))
- "%")
- (setq last-update (time-convert nil 'integer))))
- (goto-char end)))))
-
-(defun vhdl-fix-case-region (beg end &optional arg)
+ (when pr (progress-reporter-update pr (point))))
+ (when pr (progress-reporter-done pr))))))
+
+(defun vhdl-fix-case-region (beg end &optional _arg)
"Convert all VHDL words in region to lower or upper case, depending on
options vhdl-upper-case-{keywords,types,attributes,enum-values}."
- (interactive "r\nP")
+ (interactive "r")
(vhdl-fix-case-region-1
beg end vhdl-upper-case-keywords vhdl-keywords-regexp 0)
(vhdl-fix-case-region-1
@@ -8195,11 +8184,11 @@ options
vhdl-upper-case-{keywords,types,attributes,enum-values}."
;; - force each statement to be on a separate line except when on same line
;; with 'end' keyword
-(defun vhdl-fix-statement-region (beg end &optional arg)
+(defun vhdl-fix-statement-region (beg end &optional _arg)
"Force statements in region on separate line except when on same line
with `end' keyword (necessary for correct indentation).
Currently supported keywords: `begin', `if'."
- (interactive "r\nP")
+ (interactive "r")
(vhdl-prepare-search-2
(let (point)
(save-excursion
@@ -8251,9 +8240,9 @@ with `end' keyword (necessary for correct indentation)."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Trailing spaces
-(defun vhdl-remove-trailing-spaces-region (beg end &optional arg)
+(defun vhdl-remove-trailing-spaces-region (beg end &optional _arg)
"Remove trailing spaces in region."
- (interactive "r\nP")
+ (interactive "r")
(save-excursion
(goto-char end)
(setq end (point-marker))
@@ -8283,7 +8272,7 @@ case fixing to a region. Calls functions
`vhdl-indent-buffer',
(replace-match "" nil t)))
(when (nth 0 vhdl-beautify-options) (vhdl-fixup-whitespace-region beg end t))
(when (nth 1 vhdl-beautify-options) (vhdl-fix-statement-region beg end))
- (when (nth 2 vhdl-beautify-options) (vhdl-indent-region beg end))
+ (when (nth 2 vhdl-beautify-options) (indent-region beg end))
(when (nth 3 vhdl-beautify-options)
(let ((vhdl-align-groups t)) (vhdl-align-region beg end)))
(when (nth 4 vhdl-beautify-options) (vhdl-fix-case-region beg end))
@@ -8516,7 +8505,7 @@ buffer."
(delete-region sens-beg sens-end)
(when read-list
(insert " ()") (backward-char)))
- (setq read-list (sort read-list 'string<))
+ (setq read-list (sort read-list #'string<))
(when read-list
(setq margin (current-column))
(insert (car read-list))
@@ -8548,7 +8537,7 @@ buffer."
(concat (vhdl-replace-string vhdl-entity-file-name entity-name t)
"." (file-name-extension (buffer-file-name)))))
(vhdl-visit-file
- file-name t
+ file-name t
(vhdl-prepare-search-2
(goto-char (point-min))
(if (not (re-search-forward (concat "^entity\\s-+" entity-name "\\>")
nil t))
@@ -8556,7 +8545,8 @@ buffer."
(when (setq beg (vhdl-re-search-forward
"\\<port[ \t\n\r\f]*("
(save-excursion
- (re-search-forward "^end\\>" nil t)) t))
+ (re-search-forward "^end\\>" nil t))
+ t))
(setq end (save-excursion
(backward-char) (forward-sexp) (point)))
(vhdl-forward-syntactic-ws)
@@ -8688,9 +8678,9 @@ buffer."
Used for undoing after template abortion.")
;; correct different behavior of function `unread-command-events' in XEmacs
-(defun vhdl-character-to-event (arg))
+(defun vhdl-character-to-event (_arg) nil)
(defalias 'vhdl-character-to-event
- (if (fboundp 'character-to-event) 'character-to-event 'identity))
+ (if (fboundp 'character-to-event) #'character-to-event #'identity))
(defun vhdl-work-library ()
"Return the working library name of the current project or \"work\" if no
@@ -9147,7 +9137,8 @@ a configuration declaration if not within a design unit."
(re-search-backward "^\\(configuration\\|end\\)\\>" nil t))
(equal "CONFIGURATION" (upcase (match-string 1))))
(if (eq (vhdl-decision-query
- "configuration" "(b)lock or (c)omponent configuration?" t) ?c)
+ "configuration" "(b)lock or (c)omponent configuration?" t)
+ ?c)
(vhdl-template-component-conf)
(vhdl-template-block-configuration)))
(t (vhdl-template-configuration-decl))))) ; otherwise
@@ -9256,7 +9247,7 @@ a configuration declaration if not within a design unit."
(interactive)
(let ((margin (current-indentation))
(start (point))
- entity-exists string name position)
+ name position) ;; entity-exists string
(vhdl-insert-keyword "CONTEXT ")
(when (setq name (vhdl-template-field "name" nil t start (point)))
(vhdl-insert-keyword " IS\n")
@@ -9412,7 +9403,8 @@ otherwise."
(re-search-backward "^\\(configuration\\|end\\)\\>" nil t))
(equal "CONFIGURATION" (upcase (match-string 1))))
(if (eq (vhdl-decision-query
- "for" "(b)lock or (c)omponent configuration?" t) ?c)
+ "for" "(b)lock or (c)omponent configuration?" t)
+ ?c)
(vhdl-template-component-conf)
(vhdl-template-block-configuration)))
((and (save-excursion
@@ -9527,11 +9519,12 @@ otherwise."
(defun vhdl-template-group ()
"Insert group or group template declaration."
(interactive)
- (let ((start (point)))
- (if (eq (vhdl-decision-query
- "group" "(d)eclaration or (t)emplate declaration?" t) ?t)
- (vhdl-template-group-template)
- (vhdl-template-group-decl))))
+ ;; (let ((start (point)))
+ (if (eq (vhdl-decision-query
+ "group" "(d)eclaration or (t)emplate declaration?" t)
+ ?t)
+ (vhdl-template-group-template)
+ (vhdl-template-group-decl))) ;; )
(defun vhdl-template-group-decl ()
"Insert group declaration."
@@ -10472,7 +10465,8 @@ specification, if not already there."
(and (not (bobp))
(re-search-backward
(concat
"^\\s-*\\(\\(library\\)\\s-+\\(\\w+\\s-*,\\s-*\\)*"
- library "\\|end\\)\\>") nil t)
+ library "\\|end\\)\\>")
+ nil t)
(match-string 2))))
(equal (downcase library) "work"))
(vhdl-insert-keyword "LIBRARY ")
@@ -10832,9 +10826,9 @@ If starting after end-comment-column, start a new line."
(vhdl-line-kill-entire)))))
(goto-char final-pos))))
-(defun vhdl-comment-uncomment-region (beg end &optional arg)
+(defun vhdl-comment-uncomment-region (beg end &optional _arg)
"Comment out region if not commented out, uncomment otherwise."
- (interactive "r\nP")
+ (interactive "r")
(save-excursion
(goto-char (1- end))
(end-of-line)
@@ -10911,7 +10905,7 @@ Point is left between them."
"Read from user a procedure or function argument list."
(insert " (")
(let ((margin (current-column))
- (start (point))
+ ;; (start (point))
(end-pos (point))
not-empty interface semicolon-pos)
(unless vhdl-argument-list-indent
@@ -10920,7 +10914,8 @@ Point is left between them."
(indent-to margin))
(setq interface (vhdl-template-field
(concat "[CONSTANT | SIGNAL"
- (unless is-function " | VARIABLE") "]") " " t))
+ (unless is-function " | VARIABLE") "]")
+ " " t))
(while (vhdl-template-field "[names]" nil t)
(setq not-empty t)
(insert " : ")
@@ -10937,7 +10932,8 @@ Point is left between them."
(indent-to margin)
(setq interface (vhdl-template-field
(concat "[CONSTANT | SIGNAL"
- (unless is-function " | VARIABLE") "]") " " t)))
+ (unless is-function " | VARIABLE") "]")
+ " " t)))
(delete-region end-pos (point))
(when semicolon-pos (goto-char semicolon-pos))
(if not-empty
@@ -11157,7 +11153,7 @@ with double-quotes is to be inserted. DEFAULT
specifies a default string."
"Adjust case of following NUM words."
(if vhdl-upper-case-keywords (upcase-word num) (downcase-word num)))
-(defun vhdl-minibuffer-tab (&optional prefix-arg)
+(defun vhdl-minibuffer-tab (&optional arg)
"If preceding character is part of a word or a paren then hippie-expand,
else insert tab (used for word completion in VHDL minibuffer)."
(interactive "P")
@@ -11170,12 +11166,12 @@ else insert tab (used for word completion in VHDL
minibuffer)."
(or (and (boundp 'hippie-expand-only-buffers)
hippie-expand-only-buffers)
'(vhdl-mode))))
- (vhdl-expand-abbrev prefix-arg)))
+ (vhdl-expand-abbrev arg)))
;; expand parenthesis
((or (= (preceding-char) ?\() (= (preceding-char) ?\)))
(let ((case-fold-search (not vhdl-word-completion-case-sensitive))
(case-replace nil))
- (vhdl-expand-paren prefix-arg)))
+ (vhdl-expand-paren arg)))
;; insert tab
(t (insert-tab))))
@@ -11562,7 +11558,8 @@ but not if inside a comment or quote."
(unless (equal model-keyword "")
(eval `(defun
,(vhdl-function-name
- "vhdl-model" model-name "hook") ()
+ "vhdl-model" model-name "hook")
+ ()
(vhdl-hooked-abbrev
',(vhdl-function-name "vhdl-model" model-name)))))
(setq model-alist (cdr model-alist)))))
@@ -11858,7 +11855,7 @@ reflected in a subsequent paste operation."
(defun vhdl-port-paste-context-clause (&optional exclude-pack-name)
"Paste a context clause."
- (let ((margin (current-indentation))
+ (let (;; (margin (current-indentation))
(clause-list (nth 3 vhdl-port-list))
clause)
(while clause-list
@@ -11868,7 +11865,8 @@ reflected in a subsequent paste operation."
(save-excursion
(re-search-backward
(concat "^\\s-*use\\s-+" (car clause)
- "." (cdr clause) "\\>") nil t)))
+ "." (cdr clause) "\\>")
+ nil t)))
(vhdl-template-standard-package (car clause) (cdr clause))
(insert "\n"))
(setq clause-list (cdr clause-list)))))
@@ -12260,7 +12258,8 @@ reflected in a subsequent paste operation."
(cond ((and vhdl-include-direction-comments (nth 2 port))
(format "%-6s" (concat "[" (nth 2 port) "] ")))
(vhdl-include-direction-comments " "))
- (when vhdl-include-port-comments (nth 4 port))) t))
+ (when vhdl-include-port-comments (nth 4 port)))
+ t))
(setq port-list (cdr port-list))
(when port-list (insert "\n") (indent-to margin)))
;; align signal list
@@ -12314,7 +12313,7 @@ reflected in a subsequent paste operation."
(let ((case-fold-search t)
(ent-name (vhdl-replace-string vhdl-testbench-entity-name
(nth 0 vhdl-port-list)))
- (source-buffer (current-buffer))
+ ;; (source-buffer (current-buffer))
arch-name config-name ent-file-name arch-file-name
ent-buffer arch-buffer position)
;; open entity file
@@ -12411,7 +12410,7 @@ reflected in a subsequent paste operation."
(insert "\n")
(setq position (point))
(vhdl-insert-string-or-file vhdl-testbench-declarations)
- (vhdl-indent-region position (point)))
+ (indent-region position (point)))
(setq position (point))
(insert "\n\n")
(vhdl-comment-display-line) (insert "\n")
@@ -12442,7 +12441,7 @@ reflected in a subsequent paste operation."
(insert "\n")
(setq position (point))
(vhdl-insert-string-or-file vhdl-testbench-statements)
- (vhdl-indent-region position (point)))
+ (indent-region position (point)))
(insert "\n")
(indent-to vhdl-basic-offset)
(unless (eq vhdl-testbench-create-files 'none)
@@ -12815,7 +12814,7 @@ expressions (e.g. for index ranges of types and
signals)."
;; override `he-list-beg' from `hippie-exp'
(unless (and (boundp 'viper-mode) viper-mode)
- (defalias 'he-list-beg 'vhdl-he-list-beg))
+ (defalias 'he-list-beg #'vhdl-he-list-beg))
;; function for expanding abbrevs and dabbrevs
(defalias 'vhdl-expand-abbrev (make-hippie-expand-function
@@ -12862,14 +12861,14 @@ expressions (e.g. for index ranges of types and
signals)."
(beginning-of-line)
(yank))
-(defun vhdl-line-expand (&optional prefix-arg)
+(defun vhdl-line-expand (&optional arg)
"Hippie-expand current line."
(interactive "P")
(require 'hippie-exp)
(let ((case-fold-search t) (case-replace nil)
(hippie-expand-try-functions-list
'(try-expand-line try-expand-line-all-buffers)))
- (hippie-expand prefix-arg)))
+ (hippie-expand arg)))
(defun vhdl-line-transpose-next (&optional arg)
"Interchange this line with next line."
@@ -12991,7 +12990,7 @@ File statistics: \"%s\"\n\
# total lines : %5d\n"
(buffer-file-name) no-stats no-code-lines no-empty-lines
no-comm-lines no-comments no-lines)
- (unless vhdl-emacs-21 (vhdl-show-messages))))
+ (when (featurep 'xemacs) (vhdl-show-messages))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Help functions
@@ -13040,7 +13039,7 @@ File statistics: \"%s\"\n\
(customize-set-variable 'vhdl-project vhdl-project)
(customize-save-customized))
-(defun vhdl-toggle-project (name token indent)
+(defun vhdl-toggle-project (name _token _indent)
"Set current project to NAME or unset if NAME is current project."
(vhdl-set-project (if (equal name vhdl-project) "" name)))
@@ -13244,6 +13243,7 @@ File statistics: \"%s\"\n\
"Toggle hideshow minor mode and update menu bar."
(interactive "P")
(require 'hideshow)
+ (declare-function hs-hide-all "hideshow" ())
;; check for hideshow version 5.x
(if (not (boundp 'hs-block-start-mdata-select))
(vhdl-warning-when-idle "Install included `hideshow.el' patch first (see
INSTALL file)")
@@ -13255,8 +13255,8 @@ File statistics: \"%s\"\n\
hs-special-modes-alist)))
(if (featurep 'xemacs) (make-local-hook 'hs-minor-mode-hook))
(if vhdl-hide-all-init
- (add-hook 'hs-minor-mode-hook 'hs-hide-all nil t)
- (remove-hook 'hs-minor-mode-hook 'hs-hide-all t))
+ (add-hook 'hs-minor-mode-hook #'hs-hide-all nil t)
+ (remove-hook 'hs-minor-mode-hook #'hs-hide-all t))
(hs-minor-mode arg)
(force-mode-line-update))) ; hack to update menu bar
@@ -13523,6 +13523,8 @@ This does background highlighting of translate-off
regions.")
(while syntax-alist
(setq name (vhdl-function-name
"vhdl-font-lock" (nth 0 (car syntax-alist)) "face"))
+ ;; FIXME: This `defvar' shouldn't be needed: just quote the face
+ ;; name when you use it.
(eval `(defvar ,name ',name
,(concat "Face name to use for "
(nth 0 (car syntax-alist)) ".")))
@@ -13735,7 +13737,7 @@ This does background highlighting of translate-off
regions.")
(when (boundp 'ps-print-color-p)
(vhdl-ps-print-settings))
(if (featurep 'xemacs) (make-local-hook 'ps-print-hook))
- (add-hook 'ps-print-hook 'vhdl-ps-print-settings nil t)))
+ (add-hook 'ps-print-hook #'vhdl-ps-print-settings nil t)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -13907,7 +13909,7 @@ hierarchy otherwise.")
pack-list pack-body-list inst-list inst-ent-list)
;; scan file
(vhdl-visit-file
- file-name nil
+ file-name nil
(vhdl-prepare-search-2
(save-excursion
;; scan for design units
@@ -14082,7 +14084,8 @@ hierarchy otherwise.")
"component[ \t\n\r\f]+\\(\\w+\\)\\|"
"\\(\\(entity\\)\\|configuration\\)[
\t\n\r\f]+\\(\\(\\w+\\)\\.\\)?\\(\\w+\\)\\([ \t\n\r\f]*(\\(\\w+\\))\\)?\\|"
"\\(\\(for\\|if\\)\\>[^;:]+\\<generate\\>\\|block\\>\\)\\)\\|"
- "\\(^[ \t]*end[
\t\n\r\f]+\\(generate\\|block\\)\\>\\)") end-of-unit t)
+ "\\(^[ \t]*end[
\t\n\r\f]+\\(generate\\|block\\)\\>\\)")
+ end-of-unit t)
(or (not limit-hier-inst-no)
(<= (if (or (match-string 14)
(match-string 16))
@@ -14444,12 +14447,15 @@ of PROJECT."
;; (inst-key inst-file-marker comp-ent-key comp-ent-file-marker
;; comp-arch-key comp-arch-file-marker comp-conf-key comp-conf-file-marker
;; comp-lib-name level)
-(defun vhdl-get-hierarchy (ent-alist conf-alist ent-key arch-key conf-key
- conf-inst-alist level indent
- &optional include-top ent-hier)
+(defun vhdl-get-hierarchy ( ent-alist-arg conf-alist-arg ent-key arch-key
+ conf-key-arg conf-inst-alist level indent
+ &optional include-top ent-hier)
"Get instantiation hierarchy beginning in architecture ARCH-KEY of
entity ENT-KEY."
- (let* ((ent-entry (vhdl-aget ent-alist ent-key))
+ (let* ((ent-alist ent-alist-arg)
+ (conf-alist conf-alist-arg)
+ (conf-key conf-key-arg)
+ (ent-entry (vhdl-aget ent-alist ent-key))
(arch-entry (if arch-key (vhdl-aget (nth 3 ent-entry) arch-key)
(cdar (last (nth 3 ent-entry)))))
(inst-alist (nth 3 arch-entry))
@@ -14581,6 +14587,8 @@ entity ENT-KEY."
(error (progn (vhdl-warning "ERROR: An error occurred while saving the
hierarchy caches")
(sit-for 2)))))
+(defvar vhdl-cache-version)
+
(defun vhdl-save-cache (key)
"Save current hierarchy cache to file."
(let* ((orig-buffer (current-buffer))
@@ -14667,7 +14675,7 @@ entity ENT-KEY."
(file-dir-name (expand-file-name file-name directory))
vhdl-cache-version)
(unless (memq 'vhdl-save-caches kill-emacs-hook)
- (add-hook 'kill-emacs-hook 'vhdl-save-caches))
+ (add-hook 'kill-emacs-hook #'vhdl-save-caches))
(when (file-exists-p file-dir-name)
(condition-case ()
(progn (load-file file-dir-name)
@@ -14707,6 +14715,8 @@ if required."
(declare-function speedbar-change-initial-expansion-list "speedbar"
(new-default))
(declare-function speedbar-add-expansion-list "speedbar" (new-list))
+(declare-function speedbar-expand-line "speedbar" (&optional arg))
+(declare-function speedbar-edit-line "speedbar" ())
(defun vhdl-speedbar-initialize ()
"Initialize speedbar."
@@ -14731,19 +14741,19 @@ if required."
;; keymap
(unless vhdl-speedbar-mode-map
(setq vhdl-speedbar-mode-map (speedbar-make-specialized-keymap))
- (define-key vhdl-speedbar-mode-map "e" 'speedbar-edit-line)
- (define-key vhdl-speedbar-mode-map "\C-m" 'speedbar-edit-line)
- (define-key vhdl-speedbar-mode-map "+" 'speedbar-expand-line)
- (define-key vhdl-speedbar-mode-map "=" 'speedbar-expand-line)
- (define-key vhdl-speedbar-mode-map "-" 'vhdl-speedbar-contract-level)
- (define-key vhdl-speedbar-mode-map "_" 'vhdl-speedbar-contract-all)
- (define-key vhdl-speedbar-mode-map "C" 'vhdl-speedbar-port-copy)
- (define-key vhdl-speedbar-mode-map "P" 'vhdl-speedbar-place-component)
- (define-key vhdl-speedbar-mode-map "F" 'vhdl-speedbar-configuration)
- (define-key vhdl-speedbar-mode-map "A" 'vhdl-speedbar-select-mra)
- (define-key vhdl-speedbar-mode-map "K" 'vhdl-speedbar-make-design)
- (define-key vhdl-speedbar-mode-map "R" 'vhdl-speedbar-rescan-hierarchy)
- (define-key vhdl-speedbar-mode-map "S" 'vhdl-save-caches)
+ (define-key vhdl-speedbar-mode-map "e" #'speedbar-edit-line)
+ (define-key vhdl-speedbar-mode-map "\C-m" #'speedbar-edit-line)
+ (define-key vhdl-speedbar-mode-map "+" #'speedbar-expand-line)
+ (define-key vhdl-speedbar-mode-map "=" #'speedbar-expand-line)
+ (define-key vhdl-speedbar-mode-map "-" #'vhdl-speedbar-contract-level)
+ (define-key vhdl-speedbar-mode-map "_" #'vhdl-speedbar-contract-all)
+ (define-key vhdl-speedbar-mode-map "C" #'vhdl-speedbar-port-copy)
+ (define-key vhdl-speedbar-mode-map "P" #'vhdl-speedbar-place-component)
+ (define-key vhdl-speedbar-mode-map "F" #'vhdl-speedbar-configuration)
+ (define-key vhdl-speedbar-mode-map "A" #'vhdl-speedbar-select-mra)
+ (define-key vhdl-speedbar-mode-map "K" #'vhdl-speedbar-make-design)
+ (define-key vhdl-speedbar-mode-map "R" #'vhdl-speedbar-rescan-hierarchy)
+ (define-key vhdl-speedbar-mode-map "S" #'vhdl-save-caches)
(let ((key 0))
(while (<= key 9)
(define-key vhdl-speedbar-mode-map (int-to-string key)
@@ -14814,7 +14824,7 @@ if required."
(setq speedbar-initial-expansion-list-name "vhdl directory"))
(when (eq vhdl-speedbar-display-mode 'project)
(setq speedbar-initial-expansion-list-name "vhdl project"))
- (add-hook 'speedbar-timer-hook 'vhdl-update-hierarchy)))
+ (add-hook 'speedbar-timer-hook #'vhdl-update-hierarchy)))
(defun vhdl-speedbar (&optional arg)
"Open/close speedbar."
@@ -14832,17 +14842,17 @@ if required."
"Name of last selected project.")
;; macros must be defined in the file they are used (copied from `speedbar.el')
-;;; (defmacro speedbar-with-writable (&rest forms)
-;;; "Allow the buffer to be writable and evaluate FORMS."
-;;; (list 'let '((inhibit-read-only t))
-;;; (cons 'progn forms)))
-;;; (put 'speedbar-with-writable 'lisp-indent-function 0)
+;; (defmacro speedbar-with-writable (&rest forms)
+;; "Allow the buffer to be writable and evaluate FORMS."
+;; (declare (indent 0) (debug t))
+;; (list 'let '((inhibit-read-only t))
+;; (cons 'progn forms)))
(declare-function speedbar-extension-list-to-regex "speedbar" (extlist))
(declare-function speedbar-directory-buttons "speedbar" (directory _index))
(declare-function speedbar-file-lists "speedbar" (directory))
-(defun vhdl-speedbar-display-directory (directory depth &optional rescan)
+(defun vhdl-speedbar-display-directory (directory depth &optional _rescan)
"Display directory and hierarchy information in speedbar."
(setq vhdl-speedbar-show-projects nil)
(setq speedbar-ignored-directory-regexp
@@ -14863,7 +14873,7 @@ if required."
(when (= depth 0) (vhdl-speedbar-expand-dirs directory)))
(error (vhdl-warning-when-idle "ERROR: Invalid hierarchy information,
unable to display correctly")))))
-(defun vhdl-speedbar-display-projects (project depth &optional rescan)
+(defun vhdl-speedbar-display-projects (_project _depth &optional _rescan)
"Display projects and hierarchy information in speedbar."
(setq vhdl-speedbar-show-projects t)
(setq speedbar-ignored-directory-regexp ".")
@@ -14879,6 +14889,8 @@ if required."
(declare-function speedbar-make-tag-line "speedbar"
(type char func data tag tfunc tdata tface depth))
+(defvar vhdl-speedbar-update-current-unit)
+
(defun vhdl-speedbar-insert-projects ()
"Insert all projects in speedbar."
(vhdl-speedbar-make-title-line "Projects:")
@@ -14889,9 +14901,9 @@ if required."
;; insert projects
(while project-alist
(speedbar-make-tag-line
- 'angle ?+ 'vhdl-speedbar-expand-project
+ 'angle ?+ #'vhdl-speedbar-expand-project
(caar project-alist) (caar project-alist)
- 'vhdl-toggle-project (caar project-alist) 'speedbar-directory-face 0)
+ #'vhdl-toggle-project (caar project-alist) 'speedbar-directory-face 0)
(setq project-alist (cdr project-alist)))
(setq project-alist vhdl-project-alist)
;; expand projects
@@ -14938,12 +14950,14 @@ otherwise use cached data."
(vhdl-speedbar-expand-units directory)
(vhdl-aput 'vhdl-directory-alist directory (list (list directory))))
-(defun vhdl-speedbar-insert-hierarchy (ent-alist conf-alist pack-alist
- ent-inst-list depth)
+(defun vhdl-speedbar-insert-hierarchy ( ent-alist-arg conf-alist-arg pack-alist
+ ent-inst-list depth)
"Insert hierarchy of ENT-ALIST, CONF-ALIST, and PACK-ALIST."
(if (not (or ent-alist conf-alist pack-alist))
(vhdl-speedbar-make-title-line "No VHDL design units!" depth)
- (let (ent-entry conf-entry pack-entry)
+ (let ((ent-alist ent-alist-arg)
+ (conf-alist conf-alist-arg)
+ ent-entry conf-entry pack-entry)
;; insert entities
(when ent-alist (vhdl-speedbar-make-title-line "Entities:" depth))
(while ent-alist
@@ -15004,7 +15018,7 @@ otherwise use cached data."
(declare-function speedbar-goto-this-file "speedbar" (file))
-(defun vhdl-speedbar-expand-dirs (directory)
+(defun vhdl-speedbar-expand-dirs (_directory)
"Expand subdirectories in DIRECTORY according to
`speedbar-shown-directories'."
;; (nicked from `speedbar-default-directory-list')
@@ -15043,7 +15057,8 @@ otherwise use cached data."
(goto-char position)
(when (re-search-forward
(concat "^[0-9]+:\\s-*\\(\\[\\|{.}\\s-+"
- (car arch-alist) "\\>\\)") nil t)
+ (car arch-alist) "\\>\\)")
+ nil t)
(beginning-of-line)
(when (looking-at "^[0-9]+:\\s-*{")
(goto-char (match-end 0))
@@ -15412,6 +15427,7 @@ otherwise use cached data."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Display help functions
+;; FIXME: This `defvar' should be moved before its first use.
(defvar vhdl-speedbar-update-current-unit t
"Non-nil means to run `vhdl-speedbar-update-current-unit'.")
@@ -15847,7 +15863,7 @@ NO-POSITION non-nil means do not re-position cursor."
(abbreviate-file-name
(file-name-as-directory (speedbar-line-directory indent)))))
-(defun vhdl-speedbar-line-project (&optional indent)
+(defun vhdl-speedbar-line-project (&optional _indent)
"Get currently displayed project name."
(and vhdl-speedbar-show-projects
(save-excursion
@@ -15917,7 +15933,7 @@ NO-POSITION non-nil means do not re-position cursor."
;; speedbar loads dframe at runtime.
(declare-function dframe-maybee-jump-to-attached-frame "dframe" ())
-(defun vhdl-speedbar-find-file (text token indent)
+(defun vhdl-speedbar-find-file (_text token _indent)
"When user clicks on TEXT, load file with name and position in TOKEN.
Jump to the design unit if `vhdl-speedbar-jump-to-unit' is t or if the file
is already shown in a buffer."
@@ -15945,12 +15961,12 @@ is already shown in a buffer."
(let ((token (get-text-property
(match-beginning 3) 'speedbar-token)))
(vhdl-visit-file (car token) t
- (progn (goto-char (point-min))
- (forward-line (1- (cdr token)))
- (end-of-line)
- (if is-entity
- (vhdl-port-copy)
- (vhdl-subprog-copy)))))
+ (goto-char (point-min))
+ (forward-line (1- (cdr token)))
+ (end-of-line)
+ (if is-entity
+ (vhdl-port-copy)
+ (vhdl-subprog-copy))))
(error (error "ERROR: %s not scanned successfully\n (%s)"
(if is-entity "Port" "Interface") (cadr info))))
(error "ERROR: No entity/component or subprogram on current line")))))
@@ -16140,7 +16156,7 @@ expansion function)."
;; initialize speedbar
(if (not (boundp 'speedbar-frame))
- (with-no-warnings (add-hook 'speedbar-load-hook 'vhdl-speedbar-initialize))
+ (with-no-warnings (add-hook 'speedbar-load-hook
#'vhdl-speedbar-initialize))
(vhdl-speedbar-initialize)
(when speedbar-frame (vhdl-speedbar-refresh)))
@@ -16168,7 +16184,7 @@ expansion function)."
(read-from-minibuffer "architecture name: "
nil vhdl-minibuffer-local-map)
(vhdl-replace-string vhdl-compose-architecture-name ent-name)))
- ent-file-name arch-file-name ent-buffer arch-buffer project end-pos)
+ ent-file-name arch-file-name ent-buffer arch-buffer end-pos) ;; project
(message "Creating component \"%s(%s)\"..." ent-name arch-name)
;; open entity file
(unless (eq vhdl-compose-create-files 'none)
@@ -16368,7 +16384,7 @@ component instantiation."
(if comp-name
;; ... from component declaration
(vhdl-visit-file
- (when vhdl-use-components-package pack-file-name) t
+ (when vhdl-use-components-package pack-file-name) t
(save-excursion
(goto-char (point-min))
(unless (re-search-forward (concat "^\\s-*component[
\t\n\r\f]+" comp-name "\\>") nil t)
@@ -16379,7 +16395,7 @@ component instantiation."
(concat (vhdl-replace-string vhdl-entity-file-name
comp-ent-name t)
"." (file-name-extension (buffer-file-name))))
(vhdl-visit-file
- comp-ent-file-name t
+ comp-ent-file-name t
(save-excursion
(goto-char (point-min))
(unless (re-search-forward (concat "^\\s-*entity[ \t\n\r\f]+"
comp-ent-name "\\>") nil t)
@@ -16652,6 +16668,8 @@ component instantiation."
(vhdl-comment-insert-inline (nth 4 entry) t))
(insert "\n"))
+(defvar lazy-lock-minimum-size)
+
(defun vhdl-compose-components-package ()
"Generate a package containing component declarations for all entities in the
current project/directory."
@@ -16704,10 +16722,10 @@ current project/directory."
;; insert component declarations
(while ent-alist
(vhdl-visit-file (nth 2 (car ent-alist)) nil
- (progn (goto-char (point-min))
- (forward-line (1- (nth 3 (car ent-alist))))
- (end-of-line)
- (vhdl-port-copy)))
+ (goto-char (point-min))
+ (forward-line (1- (nth 3 (car ent-alist))))
+ (end-of-line)
+ (vhdl-port-copy))
(goto-char component-pos)
(vhdl-port-paste-component t)
(when (cdr ent-alist) (insert "\n\n") (indent-to vhdl-basic-offset))
@@ -16721,13 +16739,16 @@ current project/directory."
(message "Generating components package \"%s\"...done\n File created:
\"%s\""
pack-name pack-file-name)))
-(defun vhdl-compose-configuration-architecture (ent-name arch-name ent-alist
- conf-alist inst-alist
- &optional insert-conf)
+(defun vhdl-compose-configuration-architecture ( _ent-name arch-name
+ ent-alist-arg conf-alist-arg
+ inst-alist
+ &optional insert-conf)
"Generate block configuration for architecture."
- (let ((margin (current-indentation))
+ (let ((ent-alist ent-alist-arg)
+ (conf-alist conf-alist-arg)
+ (margin (current-indentation))
(beg (point-at-bol))
- ent-entry inst-entry inst-path inst-prev-path cons-key tmp-alist)
+ ent-entry inst-entry inst-path inst-prev-path tmp-alist) ;; cons-key
;; insert block configuration (for architecture)
(vhdl-insert-keyword "FOR ") (insert arch-name "\n")
(setq margin (+ margin vhdl-basic-offset))
@@ -17078,7 +17099,7 @@ do not print any file names."
(file-relative-name (buffer-file-name))))
(when (and (= 0 (nth 1 (nth 10 compiler)))
(= 0 (nth 1 (nth 11 compiler))))
- (setq compilation-process-setup-function 'vhdl-compile-print-file-name))
+ (setq compilation-process-setup-function #'vhdl-compile-print-file-name))
;; run compilation
(if options
(when command
@@ -17152,7 +17173,7 @@ specified by a target."
vhdl-error-regexp-emacs-alist)))
(when vhdl-emacs-22
- (add-hook 'compilation-mode-hook 'vhdl-error-regexp-add-emacs))
+ (add-hook 'compilation-mode-hook #'vhdl-error-regexp-add-emacs))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Makefile generation
@@ -17431,7 +17452,7 @@ specified by a target."
(setq tmp-list rule-alist)
(while tmp-list ; pre-sort rule targets
(setq cell (cdar tmp-list))
- (setcar cell (sort (car cell) 'string<))
+ (setcar cell (sort (car cell) #'string<))
(setq tmp-list (cdr tmp-list)))
(setq rule-alist ; sort by first rule target
(sort rule-alist
@@ -17521,9 +17542,9 @@ specified by a target."
;; insert rule for each library unit
(insert "\n\n# Rules for compiling single library units and their
subhierarchy\n")
(while prim-list
- (setq second-list (sort (nth 1 (car prim-list)) 'string<))
+ (setq second-list (sort (nth 1 (car prim-list)) #'string<))
(setq subcomp-list
- (sort (vhdl-uniquify (nth 2 (car prim-list))) 'string<))
+ (sort (vhdl-uniquify (nth 2 (car prim-list))) #'string<))
(setq unit-key (caar prim-list)
unit-name (or (nth 0 (vhdl-aget ent-alist unit-key))
(nth 0 (vhdl-aget conf-alist unit-key))
@@ -17553,7 +17574,7 @@ specified by a target."
(vhdl-get-compile-options project compiler (nth 0 rule) t))
;; insert rule if file is supposed to be compiled
(setq target-list (nth 1 rule)
- depend-list (sort (vhdl-uniquify (nth 2 rule)) 'string<))
+ depend-list (sort (vhdl-uniquify (nth 2 rule)) #'string<))
;; insert targets
(setq tmp-list target-list)
(while target-list
@@ -17576,7 +17597,8 @@ specified by a target."
(if (eq options 'default) "$(OPTIONS)" options) " "
(nth 0 rule)
(if (equal vhdl-compile-post-command "") ""
- " $(POST-COMPILE)") "\n")
+ " $(POST-COMPILE)")
+ "\n")
(insert "\n"))
(unless (and options mapping-exist)
(setq tmp-list target-list)
@@ -17616,6 +17638,7 @@ specified by a target."
"Submit via mail a bug report on VHDL Mode."
(interactive)
;; load in reporter
+ (defvar reporter-prompt-for-summary-p)
(and
(y-or-n-p "Do you want to submit a report on VHDL Mode? ")
(let ((reporter-prompt-for-summary-p t))
diff --git a/lisp/progmodes/which-func.el b/lisp/progmodes/which-func.el
index 3303257..02a8d72 100644
--- a/lisp/progmodes/which-func.el
+++ b/lisp/progmodes/which-func.el
@@ -1,7 +1,6 @@
;;; which-func.el --- print current function in mode line -*-
lexical-binding:t -*-
-;; Copyright (C) 1994, 1997-1998, 2001-2021 Free Software Foundation,
-;; Inc.
+;; Copyright (C) 1994-2021 Free Software Foundation, Inc.
;; Author: Alex Rezinsky <alexr@msil.sps.mot.com>
;; (doesn't seem to be responsive any more)
@@ -25,17 +24,17 @@
;;; Commentary:
;; This package prints name of function where your current point is
-;; located in mode line. It assumes that you work with imenu package
-;; and imenu--index-alist is up to date.
+;; located in mode line. It assumes that you work with the imenu
+;; package and `imenu--index-alist' is up to date.
;; KNOWN BUGS
;; ----------
;; Really this package shows not "function where the current point is
;; located now", but "nearest function which defined above the current
-;; point". So if your current point is located after end of function
-;; FOO but before begin of function BAR, FOO will be displayed in mode
-;; line.
-;; - if two windows display the same buffer, both windows
+;; point". So if your current point is located after the end of
+;; function FOO but before the beginning of function BAR, FOO will be
+;; displayed in the mode line.
+;; - If two windows display the same buffer, both windows
;; show the same `which-func' information.
;; TODO LIST
@@ -44,7 +43,7 @@
;; function determination mechanism should be used to determine the end
;; of a function as well as the beginning of a function.
;; 2. This package should be realized with the help of overlay
-;; properties instead of imenu--index-alist variable.
+;; properties instead of the `imenu--index-alist' variable.
;;; History:
@@ -214,7 +213,7 @@ It creates the Imenu index for the buffer, if necessary."
(setq which-func-mode nil))))
(defun which-func-update ()
- ;; "Update the Which-Function mode display for all windows."
+ "Update the Which-Function mode display for all windows."
;; (walk-windows 'which-func-update-1 nil 'visible))
(let ((non-essential t))
(which-func-update-1 (selected-window))))
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index ea52bef..7fc7181 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -1,7 +1,7 @@
;;; xref.el --- Cross-referencing commands -*-lexical-binding:t-*-
;; Copyright (C) 2014-2021 Free Software Foundation, Inc.
-;; Version: 1.0.4
+;; Version: 1.1.0
;; Package-Requires: ((emacs "26.1"))
;; This is a GNU ELPA :core package. Avoid functionality that is not
@@ -24,11 +24,6 @@
;;; Commentary:
-;; NOTE: The xref API is still experimental and can change in major,
-;; backward-incompatible ways. Everyone is encouraged to try it, and
-;; report to us any problems or use cases we hadn't anticipated, by
-;; sending an email to emacs-devel, or `M-x report-emacs-bug'.
-;;
;; This file provides a somewhat generic infrastructure for cross
;; referencing commands, in particular "find-definition".
;;
@@ -103,7 +98,7 @@ This is typically the filename.")
;;;; Commonly needed location classes are defined here:
-(defcustom xref-file-name-display 'abs
+(defcustom xref-file-name-display 'project-relative
"Style of file name display in *xref* buffers.
If the value is the symbol `abs', the default, show the file names
@@ -521,7 +516,7 @@ If SELECT is non-nil, select the target window."
"Face for displaying line numbers in the xref buffer."
:version "27.1")
-(defface xref-match '((t :inherit highlight))
+(defface xref-match '((t :inherit match))
"Face used to highlight matches in the xref buffer."
:version "27.1")
@@ -657,8 +652,8 @@ SELECT is `quit', also quit the *xref* window."
(defun xref-goto-xref (&optional quit)
"Jump to the xref on the current line and select its window.
-Non-interactively, non-nil QUIT, or interactively, with prefix argument
-means to first quit the *xref* buffer."
+If QUIT is non-nil (interactively, with prefix argument), also
+quit the *xref* buffer."
(interactive "P")
(let* ((buffer (current-buffer))
(xref (or (xref--item-at-point)
@@ -1416,7 +1411,8 @@ IGNORES is a list of glob patterns for files to ignore."
(command (xref--rgrep-command (xref--regexp-to-extended regexp)
files
(file-name-as-directory
- (file-local-name (expand-file-name dir)))
+ (file-name-unquote
+ (file-local-name (expand-file-name
dir))))
ignores))
(def default-directory)
(buf (get-buffer-create " *xref-grep*"))
@@ -1533,6 +1529,8 @@ FILES must be a list of absolute file names."
#'tramp-file-local-name
#'file-local-name)
files)))
+ (when (file-name-quoted-p (car files))
+ (setq files (mapcar #'file-name-unquote files)))
(with-current-buffer output
(erase-buffer)
(with-temp-buffer
diff --git a/lisp/ps-bdf.el b/lisp/ps-bdf.el
index 7bf2f71..72cbcf8 100644
--- a/lisp/ps-bdf.el
+++ b/lisp/ps-bdf.el
@@ -1,4 +1,4 @@
-;;; ps-bdf.el --- BDF font file handler for ps-print
+;;; ps-bdf.el --- BDF font file handler for ps-print -*- lexical-binding: t;
-*-
;; Copyright (C) 1998-1999, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
@@ -138,7 +138,7 @@ See the documentation of the function `bdf-read-font-info'
for more detail."
(defun bdf-initialize ()
"Initialize `bdf' library."
(and (bdf-read-cache)
- (add-hook 'kill-emacs-hook 'bdf-write-cache)))
+ (add-hook 'kill-emacs-hook #'bdf-write-cache)))
(defun bdf-compact-code (code code-range)
(if (or (< code (aref code-range 4))
diff --git a/lisp/ps-mule.el b/lisp/ps-mule.el
index db86f94..a8b5210 100644
--- a/lisp/ps-mule.el
+++ b/lisp/ps-mule.el
@@ -1,4 +1,4 @@
-;;; ps-mule.el --- provide multi-byte character facility to ps-print
+;;; ps-mule.el --- provide multi-byte character facility to ps-print -*-
lexical-binding: t; -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
@@ -612,7 +612,7 @@ f2, f3, h0, h1, and H0 respectively."
(push (/ code 256) code-list)
(push (% code 256) code-list))))
(forward-char 1)))
- (apply 'unibyte-string (nreverse code-list))))
+ (apply #'unibyte-string (nreverse code-list))))
(defun ps-mule-plot-composition (composition font-spec-table)
"Generate PostScript code for plotting COMPOSITION with FONT-SPEC-TABLE."
@@ -1041,10 +1041,11 @@ Any other value is treated as \"/H0\"."
(list (ps-mule-encode-region (point-min) (point-max)
(aref ps-mule-font-spec-tables
(aref ps-mule-font-number-to-type
- (cond ((string= fonttag "/h0") 4)
- ((string= fonttag "/h1") 5)
- ((string= fonttag "/L0") 6)
- (t 0))))))))
+ (pcase fonttag
+ ("/h0" 4)
+ ("/h1" 5)
+ ("/L0" 6)
+ (_ 0))))))))
;;;###autoload
(defun ps-mule-begin-job (from to)
@@ -1055,20 +1056,17 @@ It checks if all multi-byte characters in the region
are printable or not."
(goto-char from)
(= (skip-chars-forward "\x00-\x7F" to) to)))
;; All characters can be printed by normal PostScript fonts.
- (setq ps-basic-plot-string-function 'ps-basic-plot-string
+ (setq ps-basic-plot-string-function #'ps-basic-plot-string
;; FIXME: Doesn't ps-encode-header-string-function take 2 args?
- ps-encode-header-string-function 'identity)
- (setq ps-basic-plot-string-function 'ps-mule-plot-string
- ps-encode-header-string-function 'ps-mule-encode-header-string
+ ps-encode-header-string-function #'identity)
+ (setq ps-basic-plot-string-function #'ps-mule-plot-string
+ ps-encode-header-string-function #'ps-mule-encode-header-string
ps-mule-font-info-database
- (cond ((eq ps-multibyte-buffer 'non-latin-printer)
- ps-mule-font-info-database-ps)
- ((eq ps-multibyte-buffer 'bdf-font)
- ps-mule-font-info-database-bdf)
- ((eq ps-multibyte-buffer 'bdf-font-except-latin)
- ps-mule-font-info-database-ps-bdf)
- (t
- ps-mule-font-info-database-default)))
+ (pcase ps-multibyte-buffer
+ ('non-latin-printer ps-mule-font-info-database-ps)
+ ('bdf-font ps-mule-font-info-database-bdf)
+ ('bdf-font-except-latin ps-mule-font-info-database-ps-bdf)
+ (_ ps-mule-font-info-database-default)))
;; Be sure to have font information for Latin-1.
(or (assq 'iso-8859-1 ps-mule-font-info-database)
@@ -1112,10 +1110,12 @@ It checks if all multi-byte characters in the region
are printable or not."
id-max (1+ id-max))
(if (ps-mule-check-font font-spec)
(aset font-spec-vec
- (cond ((eq (car e) 'normal) 0)
- ((eq (car e) 'bold) 1)
- ((eq (car e) 'italic) 2)
- (t 3)) font-spec)))
+ (pcase (car e)
+ ('normal 0)
+ ('bold 1)
+ ('italic 2)
+ (_ 3))
+ font-spec)))
(when (aref font-spec-vec 0)
(or (aref font-spec-vec 3)
(aset font-spec-vec 3 (or (aref font-spec-vec 1)
@@ -1182,7 +1182,7 @@ V%s 0 /%s-latin1 /%s Latin1Encoding put\n"
(let ((output-head (list t))
(ps-mule-output-list (list t)))
(dotimes (i 4)
- (map-char-table 'ps-mule-prepare-glyph
+ (map-char-table #'ps-mule-prepare-glyph
(aref ps-mule-font-spec-tables i)))
(ps-mule-restruct-output-list (cdr ps-mule-output-list) output-head)
(ps-output-prologue (cdr output-head)))
diff --git a/lisp/recentf.el b/lisp/recentf.el
index 48b8e2b..9ae059a 100644
--- a/lisp/recentf.el
+++ b/lisp/recentf.el
@@ -1,4 +1,4 @@
-;;; recentf.el --- setup a menu of recently opened files
+;;; recentf.el --- setup a menu of recently opened files -*- lexical-binding:
t -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
@@ -24,19 +24,21 @@
;;; Commentary:
;; This package maintains a menu for visiting files that were operated
-;; on recently. When enabled a new "Open Recent" sub menu is
+;; on recently. When enabled a new "Open Recent" submenu is
;; displayed in the "File" menu. The recent files list is
-;; automatically saved across Emacs sessions. You can customize the
-;; number of recent files displayed, the location of the menu and
-;; others options (see the source code for details).
+;; automatically saved across Emacs sessions.
-;; To enable this package, add the following to your .emacs:
-;; (recentf-mode 1)
+;; You can customize the number of recent files displayed, the
+;; location of the menu and others options. Type:
+;;
+;; M-x customize-group RET recentf RET
-;;; History:
+;; To enable this package, add this line to your Init file:
;;
+;; (recentf-mode 1)
;;; Code:
+
(require 'tree-widget)
(require 'timer)
@@ -76,7 +78,7 @@ See the command `recentf-save-list'."
:type 'file
:initialize 'custom-initialize-default
:set (lambda (symbol value)
- (let ((oldvalue (eval symbol)))
+ (let ((oldvalue (symbol-value symbol)))
(custom-set-default symbol value)
(and (not (equal value oldvalue))
recentf-mode
@@ -295,7 +297,7 @@ They are successively passed a file name to transform it."
(function :tag "Other function")))))
(defcustom recentf-show-file-shortcuts-flag t
- "Whether to show \"[N]\" for the Nth item up to 10.
+ "Non-nil means to show \"[N]\" for the Nth item up to 10.
If non-nil, `recentf-open-files' will show labels for keys that can be
used as shortcuts to open the Nth file."
:group 'recentf
@@ -330,15 +332,6 @@ Ignore case if `recentf-case-fold-search' is non-nil."
(setq list (cdr list)))
list)
-(defsubst recentf-trunc-list (l n)
- "Return from L the list of its first N elements."
- (let (nl)
- (while (and l (> n 0))
- (setq nl (cons (car l) nl)
- n (1- n)
- l (cdr l)))
- (nreverse nl)))
-
(defun recentf-dump-variable (variable &optional limit)
"Insert a \"(setq VARIABLE value)\" in the current buffer.
When the value of VARIABLE is a list, optional argument LIMIT
@@ -348,7 +341,7 @@ the full list."
(if (atom value)
(insert (format "\n(setq %S '%S)\n" variable value))
(when (and (integerp limit) (> limit 0))
- (setq value (recentf-trunc-list value limit)))
+ (setq value (seq-take value limit)))
(insert (format "\n(setq %S\n '(" variable))
(dolist (e value)
(insert (format "\n %S" e)))
@@ -519,7 +512,7 @@ filter function this variable is reset to nil.")
(defsubst recentf-elements (n)
"Return a list of the first N elements of the recent list."
- (recentf-trunc-list recentf-list n))
+ (seq-take recentf-list n))
(defsubst recentf-make-menu-element (menu-item menu-value)
"Create a new menu-element.
@@ -559,7 +552,7 @@ This a menu element (FILE . FILE)."
(defsubst recentf-menu-elements (n)
"Return a list of the first N default menu elements from the recent list.
See also `recentf-make-default-menu-element'."
- (mapcar 'recentf-make-default-menu-element
+ (mapcar #'recentf-make-default-menu-element
(recentf-elements n)))
(defun recentf-apply-menu-filter (filter l)
@@ -600,7 +593,7 @@ This is a menu filter function which ignores the MENU
argument."
(let* ((recentf-menu-shortcuts 0)
(file-items
(condition-case err
- (mapcar 'recentf-make-menu-item
+ (mapcar #'recentf-make-menu-item
(recentf-apply-menu-filter
recentf-menu-filter
(recentf-menu-elements recentf-max-menu-items)))
@@ -642,7 +635,7 @@ Return nil if file NAME is not one of the ten more recent."
(let ((item (recentf-menu-element-item elt))
(value (recentf-menu-element-value elt)))
(if (recentf-sub-menu-element-p elt)
- (cons item (mapcar 'recentf-make-menu-item value))
+ (cons item (mapcar #'recentf-make-menu-item value))
(let ((k (and (< recentf-menu-shortcuts 10)
(recentf-menu-value-shortcut value))))
(vector item
@@ -767,12 +760,12 @@ This filter combines the
`recentf-sort-basenames-descending' and
(defun recentf-relative-filter (l)
"Filter the list of menu-elements L to show relative filenames.
Filenames are relative to the `default-directory'."
- (mapcar #'(lambda (menu-element)
- (let* ((ful (recentf-menu-element-value menu-element))
- (rel (file-relative-name ful default-directory)))
- (if (string-match "^\\.\\." rel)
- menu-element
- (recentf-make-menu-element rel ful))))
+ (mapcar (lambda (menu-element)
+ (let* ((ful (recentf-menu-element-value menu-element))
+ (rel (file-relative-name ful default-directory)))
+ (if (string-match "^\\.\\." rel)
+ menu-element
+ (recentf-make-menu-element rel ful))))
l))
;;; Rule based menu filters
@@ -944,10 +937,10 @@ Rules obey `recentf-arrange-rules' format."
This simplified version of `recentf-show-basenames' does not handle
duplicates. It is used by `recentf-arrange-by-dir' as its
`recentf-arrange-by-rule-subfilter'."
- (mapcar #'(lambda (e)
- (recentf-make-menu-element
- (file-name-nondirectory (recentf-menu-element-value e))
- (recentf-menu-element-value e)))
+ (mapcar (lambda (e)
+ (recentf-make-menu-element
+ (file-name-nondirectory (recentf-menu-element-value e))
+ (recentf-menu-element-value e)))
l))
(defun recentf-dir-rule (file)
@@ -1000,15 +993,15 @@ Filtering of L is delegated to the selected filter in
the menu."
(list
`("Show files"
,@(mapcar
- #'(lambda (f)
- `[,(cdr f)
- (setq recentf-filter-changer-current ',(car f))
- ;;:active t
- :style radio ;;radio Don't work with GTK :-(
- :selected (eq recentf-filter-changer-current
- ',(car f))
- ;;:help ,(cdr f)
- ])
+ (lambda (f)
+ `[,(cdr f)
+ (setq recentf-filter-changer-current ',(car f))
+ ;;:active t
+ :style radio ;;radio Don't work with GTK :-(
+ :selected (eq recentf-filter-changer-current
+ ',(car f))
+ ;;:help ,(cdr f)
+ ])
recentf-filter-changer-alist))))
(recentf-apply-menu-filter recentf-filter-changer-current l)))
@@ -1065,9 +1058,9 @@ Go to the beginning of buffer if not found."
(defvar recentf-dialog-mode-map
(let ((km (copy-keymap recentf--shortcuts-keymap)))
(set-keymap-parent km widget-keymap)
- (define-key km "q" 'recentf-cancel-dialog)
- (define-key km "n" 'next-line)
- (define-key km "p" 'previous-line)
+ (define-key km "q" #'recentf-cancel-dialog)
+ (define-key km "n" #'next-line)
+ (define-key km "p" #'previous-line)
km)
"Keymap used in recentf dialogs.")
@@ -1086,8 +1079,8 @@ Go to the beginning of buffer if not found."
;; Cleanup buffer
(let ((inhibit-read-only t)
(ol (overlay-lists)))
- (mapc 'delete-overlay (car ol))
- (mapc 'delete-overlay (cdr ol))
+ (mapc #'delete-overlay (car ol))
+ (mapc #'delete-overlay (cdr ol))
(erase-buffer))
(recentf-dialog-mode)
,@forms
@@ -1181,7 +1174,7 @@ IGNORE other arguments."
:node (item :tag ,(car menu-element)
:sample-face bold
:format "%{%t%}:\n")
- ,@(mapcar 'recentf-open-files-item
+ ,@(mapcar #'recentf-open-files-item
(cdr menu-element)))
;; Represent a single file with a link widget
`(link :tag ,(car menu-element)
@@ -1196,8 +1189,8 @@ IGNORE other arguments."
(defun recentf-open-files-items (files)
"Return a list of widgets to display FILES in a dialog buffer."
(setq-local recentf--files-with-key
- (recentf-trunc-list files 10))
- (mapcar 'recentf-open-files-item
+ (seq-take files 10))
+ (mapcar #'recentf-open-files-item
(append
;; When requested group the files with shortcuts together
;; at the top of the list.
@@ -1205,12 +1198,12 @@ IGNORE other arguments."
(setq files (nthcdr 10 files))
(recentf-apply-menu-filter
'recentf-show-digit-shortcut-filter
- (mapcar 'recentf-make-default-menu-element
+ (mapcar #'recentf-make-default-menu-element
recentf--files-with-key)))
;; Then the other files.
(recentf-apply-menu-filter
recentf-menu-filter
- (mapcar 'recentf-make-default-menu-element
+ (mapcar #'recentf-make-default-menu-element
files)))))
(defun recentf-open-files (&optional files buffer-name)
@@ -1231,7 +1224,7 @@ use for the dialog. It defaults to
\"*`recentf-menu-title'*\"."
(format-message "Click on Cancel or type `q' to cancel.\n"))
;; Use a L&F that looks like the recentf menu.
(tree-widget-set-theme "folder")
- (apply 'widget-create
+ (apply #'widget-create
`(group
:indent 2
:format "\n%v\n"
@@ -1313,7 +1306,7 @@ empty `file-name-history' with the recent list."
(load-file file)
(and recentf-initialize-file-name-history
(not file-name-history)
- (setq file-name-history (mapcar 'abbreviate-file-name
+ (setq file-name-history (mapcar #'abbreviate-file-name
recentf-list))))))
(defun recentf-cleanup ()
@@ -1380,6 +1373,10 @@ buffers you switch to a lot, you can say something like
the following:
;; continue standard unloading
nil)
+;; Obsolete.
+
+(define-obsolete-function-alias 'recentf-trunc-list #'seq-take "28.1")
+
(provide 'recentf)
(run-hooks 'recentf-load-hook)
diff --git a/lisp/rect.el b/lisp/rect.el
index cb941b4..504be41 100644
--- a/lisp/rect.el
+++ b/lisp/rect.el
@@ -652,7 +652,7 @@ with a prefix argument, prompt for START-AT and FORMAT."
"Toggle the region as rectangular.
Activates the region if needed. Only lasts until the region is deactivated."
- nil nil nil
+ :lighter nil
(rectangle--reset-crutches)
(when rectangle-mark-mode
(add-hook 'deactivate-mark-hook
diff --git a/lisp/repeat.el b/lisp/repeat.el
index a2b04b8..b7118cc 100644
--- a/lisp/repeat.el
+++ b/lisp/repeat.el
@@ -342,6 +342,34 @@ For example, you can set it to <return> like
`isearch-exit'."
:group 'convenience
:version "28.1")
+(defcustom repeat-keep-prefix t
+ "Keep the prefix arg of the previous command."
+ :type 'boolean
+ :group 'convenience
+ :version "28.1")
+
+(defcustom repeat-echo-function #'repeat-echo-message
+ "Function to display a hint about available keys.
+Function is called after every repeatable command with one argument:
+a repeating map, or nil after deactivating the repeat mode."
+ :type '(choice (const :tag "Show hints in the echo area"
+ repeat-echo-message)
+ (const :tag "Show indicator in the mode line"
+ repeat-echo-mode-line)
+ (const :tag "No visual feedback" ignore)
+ (function :tag "Function"))
+ :group 'convenience
+ :version "28.1")
+
+(defvar repeat-in-progress nil
+ "Non-nil when the repeating map is active.")
+
+;;;###autoload
+(defvar repeat-map nil
+ "The value of the repeating map for the next command.
+A command called from the map can set it again to the same map when
+the map can't be set on the command symbol property `repeat-map'.")
+
;;;###autoload
(define-minor-mode repeat-mode
"Toggle Repeat mode.
@@ -363,42 +391,73 @@ When Repeat mode is enabled, and the command symbol has
the property named
(defun repeat-post-hook ()
"Function run after commands to set transient keymap for repeatable keys."
- (when repeat-mode
- (let ((repeat-map (and (symbolp this-command)
- (get this-command 'repeat-map))))
- (when repeat-map
- (when (boundp repeat-map)
- (setq repeat-map (symbol-value repeat-map)))
- (let ((map (copy-keymap repeat-map))
- keys mess)
- (map-keymap (lambda (key _) (push key keys)) map)
-
- ;; Exit when the last char is not among repeatable keys,
- ;; so e.g. `C-x u u' repeats undo, whereas `C-/ u' doesn't.
- (when (or (memq last-command-event keys)
- (memq this-original-command '(universal-argument
- universal-argument-more
- digit-argument
- negative-argument)))
- ;; Messaging
- (setq mess (format-message
- "Repeat with %s%s"
- (mapconcat (lambda (key)
- (key-description (vector key)))
- keys ", ")
- (if repeat-exit-key
- (format ", or exit with %s"
- (key-description repeat-exit-key))
- "")))
- (if (current-message)
- (message "%s [%s]" (current-message) mess)
- (message mess))
-
- ;; Adding an exit key
- (when repeat-exit-key
- (define-key map repeat-exit-key 'ignore))
-
- (set-transient-map map)))))))
+ (let ((was-in-progress repeat-in-progress))
+ (setq repeat-in-progress nil)
+ (when repeat-mode
+ (let ((rep-map (or repeat-map
+ (and (symbolp real-this-command)
+ (get real-this-command 'repeat-map)))))
+ (when rep-map
+ (when (boundp rep-map)
+ (setq rep-map (symbol-value rep-map)))
+ (let ((map (copy-keymap rep-map)))
+
+ ;; Exit when the last char is not among repeatable keys,
+ ;; so e.g. `C-x u u' repeats undo, whereas `C-/ u' doesn't.
+ (when (and (zerop (minibuffer-depth)) ; avoid remapping in prompts
+ (or (lookup-key map (this-command-keys-vector))
+ prefix-arg))
+
+ ;; Messaging
+ (unless prefix-arg
+ (funcall repeat-echo-function map))
+
+ ;; Adding an exit key
+ (when repeat-exit-key
+ (define-key map repeat-exit-key 'ignore))
+
+ (when (and repeat-keep-prefix (not prefix-arg))
+ (setq prefix-arg current-prefix-arg))
+
+ (setq repeat-in-progress t)
+ (set-transient-map map))))))
+
+ (setq repeat-map nil)
+ (when (and was-in-progress (not repeat-in-progress))
+ (funcall repeat-echo-function nil))))
+
+(defun repeat-echo-message-string (map)
+ "Return a string with a list of repeating keys."
+ (let (keys)
+ (map-keymap (lambda (key _) (push key keys)) map)
+ (format-message "Repeat with %s%s"
+ (mapconcat (lambda (key)
+ (key-description (vector key)))
+ keys ", ")
+ (if repeat-exit-key
+ (format ", or exit with %s"
+ (key-description repeat-exit-key))
+ ""))))
+
+(defun repeat-echo-message (map)
+ "Display available repeating keys in the echo area."
+ (when map
+ (let ((mess (repeat-echo-message-string map)))
+ (if (current-message)
+ (message "%s [%s]" (current-message) mess)
+ (message mess)))))
+
+(defvar repeat-echo-mode-line-string
+ (propertize "[Repeating...] " 'face 'mode-line-emphasis)
+ "String displayed in the mode line in repeating mode.")
+
+(defun repeat-echo-mode-line (map)
+ "Display the repeat indicator in the mode line."
+ (if map
+ (unless (assq 'repeat-in-progress mode-line-modes)
+ (add-to-list 'mode-line-modes (list 'repeat-in-progress
+ repeat-echo-mode-line-string)))
+ (force-mode-line-update t)))
(provide 'repeat)
diff --git a/lisp/replace.el b/lisp/replace.el
index f131d26..b5dea61 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -1433,7 +1433,7 @@ This is a compatibility function for \\[next-error]
invocations."
(defface match
'((((class color) (min-colors 88) (background light))
- :background "yellow1")
+ :background "khaki1")
(((class color) (min-colors 88) (background dark))
:background "RoyalBlue3")
(((class color) (min-colors 8) (background light))
@@ -1477,15 +1477,22 @@ If the value is nil, don't highlight the buffer names
specially."
(defcustom list-matching-lines-jump-to-current-line nil
"If non-nil, \\[list-matching-lines] shows the current line highlighted.
-Set the point right after such line when there are matches after it."
+The current line for this purpose is the line of the original buffer
+which was current when \\[list-matching-lines] was invoked.
+Point in the `*Occur*' buffer will be set right after such line when
+there are matches after it."
:type 'boolean
:group 'matching
:version "26.1")
(defcustom list-matching-lines-prefix-face 'shadow
"Face used by \\[list-matching-lines] to show the prefix column.
-If the face doesn't differ from the default face,
-don't highlight the prefix with line numbers specially."
+The prefix column is the part of display that precedes the actual
+contents of the line; it normally shows the line number. \(For
+multiline matches, the prefix column shows the line number for the
+first line and whitespace for the rest of the lines.\)
+If this face will display the same as the default face, the prefix
+column will not be highlighted speciall."
:type 'face
:group 'matching
:version "24.4")
@@ -1565,11 +1572,24 @@ REGION must be a list of (START . END) positions as
returned by
`region-bounds'.
The lines are shown in a buffer named `*Occur*'.
-It serves as a menu to find any of the occurrences in this buffer.
+That buffer can serve as a menu for finding any of the matches for REGEXP
+in the current buffer.
\\<occur-mode-map>\\[describe-mode] in that buffer will explain how.
-If `list-matching-lines-jump-to-current-line' is non-nil, then show
-the current line highlighted with `list-matching-lines-current-line-face'
-and set point at the first match after such line.
+
+Matches for REGEXP are shown in the face determined by the
+variable `list-matching-lines-face'.
+Names of buffers with matched lines are shown in the face determined
+by the variable `list-matching-lines-buffer-name-face'.
+The line numbers of the matching lines are shown in the face
+determined by the variable `list-matching-lines-prefix-face'.
+
+If `list-matching-lines-jump-to-current-line' is non-nil, then the
+line in the current buffer which was current when the command was
+invoked will be shown in the `*Occur*' buffer highlighted with
+the `list-matching-lines-current-line-face', with point at the end
+of that line. (If the current line doesn't match REGEXP, it will
+nonetheless be inserted into the `*Occur*' buffer between the 2
+closest lines that do match REGEXP.)
If REGEXP contains upper case characters (excluding those preceded by `\\')
and `search-upper-case' is non-nil, the matching is case-sensitive.
diff --git a/lisp/rot13.el b/lisp/rot13.el
index dfcf4ad..4e4e60f 100644
--- a/lisp/rot13.el
+++ b/lisp/rot13.el
@@ -3,6 +3,7 @@
;; Copyright (C) 1988, 2001-2021 Free Software Foundation, Inc.
;; Author: Howard Gayle
+;; Simon Josefsson
;; Maintainer: emacs-devel@gnu.org
;; This file is part of GNU Emacs.
@@ -22,18 +23,26 @@
;;; Commentary:
-;; The entry point, `rot13-other-window', performs a Caesar cipher
-;; encrypt/decrypt on the current buffer and displays the result in another
-;; window. ROT13 encryption is sometimes used on USENET as a read-at-your-
-;; own-risk wrapper for material some might consider offensive, such as
-;; ethnic humor.
+;; "ROT13 ('rotate by 13 places') is a simple letter substitution
+;; cipher that replaces a letter with the 13th letter after it in
+;; the alphabet. ROT13 is a special case of the Caesar cipher
+;; which was developed in ancient Rome.
;;
-;; Written by Howard Gayle.
-;; This hack is mainly to show off the char table stuff.
+;; Because there are 26 letters (2×13) in the basic Latin
+;; alphabet, ROT13 is its own inverse; that is, to undo ROT13, the
+;; same algorithm is applied, so the same action can be used for
+;; encoding and decoding. The algorithm provides virtually no
+;; cryptographic security, and is often cited as a canonical
+;; example of weak encryption.
;;
-;; New entry points, `rot13', `rot13-string', and `rot13-region' that
-;; performs Caesar cipher encrypt/decrypt on buffers and strings, was
-;; added by Simon Josefsson.
+;; ROT13 is used in online forums as a means of hiding spoilers,
+;; punchlines, puzzle solutions, and offensive materials from the
+;; casual glance." - Wikipedia article on ROT13
+;;
+;; The entry points, `rot13', `rot13-string', and `rot13-region' performs ROT13
+;; encoding/decoding on buffers and strings. The entry point
+;; `rot13-other-window' performs a ROT13 encoding/decoding on the current
+;; buffer and displays the result in another window.
;;; Code:
diff --git a/lisp/ruler-mode.el b/lisp/ruler-mode.el
index fc9196c..a0d4f6e 100644
--- a/lisp/ruler-mode.el
+++ b/lisp/ruler-mode.el
@@ -100,10 +100,7 @@
;; To automatically display the ruler in specific major modes use:
;;
;; (add-hook '<major-mode>-hook 'ruler-mode)
-;;
-;;; History:
-;;
;;; Code:
(eval-when-compile
@@ -571,8 +568,6 @@ format first."
;;;###autoload
(define-minor-mode ruler-mode
"Toggle display of ruler in header line (Ruler mode)."
- nil nil
- ruler-mode-map
:group 'ruler-mode
:variable (ruler-mode
. (lambda (enable)
diff --git a/lisp/scroll-all.el b/lisp/scroll-all.el
index 25b245e..415244f 100644
--- a/lisp/scroll-all.el
+++ b/lisp/scroll-all.el
@@ -1,4 +1,4 @@
-;;; scroll-all.el --- scroll all buffers together minor mode
+;;; scroll-all.el --- scroll all buffers together minor mode -*-
lexical-binding: t -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
@@ -47,38 +47,41 @@
(condition-case nil
(funcall func arg)
;; Ignore beginning- or end-of-buffer error in other windows.
- (error nil)
- )
+ (error nil))
(other-window 1)
(setq count (1+ count))))))
(defun scroll-all-scroll-down-all (arg)
- "Scroll down in all visible windows."
+ "Scroll down ARG lines in all visible windows."
(interactive "p")
(scroll-all-function-all 'next-line arg))
(defun scroll-all-scroll-up-all (arg)
- "Scroll up in all visible windows."
+ "Scroll up ARG lines in all visible windows."
(interactive "p")
(scroll-all-function-all 'previous-line arg))
(defun scroll-all-page-down-all (arg)
- "Page down in all visible windows."
+ "Page down in all visible windows.
+ARG is like in `scroll-up'."
(interactive "P")
(scroll-all-function-all 'scroll-up arg))
(defun scroll-all-page-up-all (arg)
- "Page up in all visible windows."
+ "Page up in all visible windows.
+ARG is like in `scroll-down'."
(interactive "P")
(scroll-all-function-all 'scroll-down arg))
(defun scroll-all-beginning-of-buffer-all (arg)
- "Go to the beginning of the buffer in all visible windows."
+ "Go to the beginning of the buffer in all visible windows.
+ARG is like in `beginning-of-buffer'."
(interactive "P")
(scroll-all-function-all 'beginning-of-buffer arg))
(defun scroll-all-end-of-buffer-all (arg)
- "Go to the end of the buffer in all visible windows."
+ "Go to the end of the buffer in all visible windows.
+ARG is like in `end-of-buffer'."
(interactive "P")
(scroll-all-function-all 'end-of-buffer arg))
@@ -105,7 +108,7 @@
When Scroll-All mode is enabled, scrolling commands invoked in
one window apply to all visible windows in the same frame."
- nil " *SL*" nil
+ :lighter " *SL*"
:global t
:group 'windows
(if scroll-all-mode
diff --git a/lisp/ses.el b/lisp/ses.el
index 6058d48..bc3c2de 100644
--- a/lisp/ses.el
+++ b/lisp/ses.el
@@ -1,4 +1,4 @@
-;;; ses.el -- Simple Emacs Spreadsheet -*- lexical-binding:t -*-
+;;; ses.el --- Simple Emacs Spreadsheet -*- lexical-binding:t -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -172,14 +172,14 @@ Each function is called with ARG=1."
(defvar ses--completion-table nil
"Set globally to what completion table to use depending on type
- of completion (local printers, cells, etc.). We need to go
- through a local variable to pass the SES buffer local variable
- to completing function while the current buffer is the
- minibuffer.")
+of completion (local printers, cells, etc.). We need to go
+through a local variable to pass the SES buffer local variable
+to completing function while the current buffer is the
+minibuffer.")
(defvar ses--list-orig-buffer nil
- "Calling buffer for SES listing help. Used for listing local
- printers or renamed cells.")
+ "Calling buffer for SES listing help.
+Used for listing local printers or renamed cells.")
(defconst ses-mode-edit-map
@@ -395,8 +395,9 @@ left-justification of the result. Set to error-signal if
`ses-call-printer'
encountered an error during printing. Otherwise nil.")
(defvar ses-start-time nil
- "Time when current operation started. Used by `ses--time-check' to decide
-when to emit a progress message.")
+ "Time when current operation started.
+Used by `ses--time-check' to decide when to emit a progress
+message.")
;;----------------------------------------------------------------------------
@@ -560,9 +561,10 @@ the corresponding cell with name PROPERTY-NAME."
(eq (ses-cell-symbol (car rowcol) (cdr rowcol)) sym))))))
(defun ses--cell (sym value formula printer references)
- "Load a cell SYM from the spreadsheet file. Does not recompute VALUE from
-FORMULA, does not reprint using PRINTER, does not check REFERENCES.
-Safety-checking for FORMULA and PRINTER are deferred until first use."
+ "Load a cell SYM from the spreadsheet file.
+Does not recompute VALUE from FORMULA, does not reprint using
+PRINTER, does not check REFERENCES. Safety-checking for FORMULA
+and PRINTER are deferred until first use."
(let ((rowcol (ses-sym-rowcol sym)))
(ses-formula-record formula)
(ses-printer-record printer)
@@ -580,8 +582,7 @@ Safety-checking for FORMULA and PRINTER are deferred until
first use."
(set sym value))
(defun ses-local-printer-compile (printer)
- "Convert local printer function into faster printer
-definition."
+ "Convert local printer function into faster printer definition."
(cond
((functionp printer) printer)
((stringp printer)
@@ -610,8 +611,8 @@ Return the printer info."
ses--local-printer-hashmap))
(defmacro ses-column-widths (widths)
- "Load the vector of column widths from the spreadsheet file. This is a
-macro to prevent propagate-on-load viruses."
+ "Load the vector of column widths from the spreadsheet file.
+This is a macro to prevent propagate-on-load viruses."
(or (and (vectorp widths) (= (length widths) ses--numcols))
(error "Bad column-width vector"))
;;To save time later, we also calculate the total width of each line in the
@@ -748,8 +749,8 @@ for this spreadsheet."
(intern (concat (ses-column-letter col) (number-to-string (1+ row)))))
(defun ses-decode-cell-symbol (str)
- "Decode a symbol \"A1\" => (0,0). Return nil if STR is not a
-canonical cell name."
+ "Decode a symbol \"A1\" => (0,0).
+Return nil if STR is not a canonical cell name."
(let (case-fold-search)
(and (string-match "\\`\\([A-Z]+\\)\\([0-9]+\\)\\'" str)
(let* ((col-str (match-string-no-properties 1 str))
@@ -1061,15 +1062,15 @@ the old and FORCE is nil."
(ses-cell-set-formula row col nil))
(defcustom ses-self-reference-early-detection nil
- "True if cycle detection is early for cells that refer to themselves."
+ "Non-nil if cycle detection is early for cells that refer to themselves."
:version "24.1"
:type 'boolean
:group 'ses)
(defun ses-update-cells (list &optional force)
- "Recalculate cells in LIST, checking for dependency loops. Prints
-progress messages every second. Dependent cells are not recalculated
-if the cell's value is unchanged and FORCE is nil."
+ "Recalculate cells in LIST, checking for dependency loops.
+Print progress messages every second. Dependent cells are not
+recalculated if the cell's value is unchanged and FORCE is nil."
(let ((ses--deferred-recalc list)
(nextlist list)
(pos (point))
@@ -2025,7 +2026,7 @@ Delete overlays, remove special text properties."
When you invoke SES in a new buffer, it is divided into cells
that you can enter data into. You can navigate the cells with
the arrow keys and add more cells with the tab key. The contents
-of these cells can be numbers, text, or Lisp expressions. (To
+of these cells can be numbers, text, or Lisp expressions. (To
enter text, enclose it in double quotes.)
In an expression, you can use cell coordinates to refer to the
@@ -2131,9 +2132,9 @@ formula:
(defun ses-command-hook ()
"Invoked from `post-command-hook'. If point has moved to a different cell,
-moves the underlining overlay. Performs any recalculations or cell-data
+move the underlining overlay. Perform any recalculations or cell-data
writes that have been deferred. If buffer-narrowing has been deferred,
-narrows the buffer now."
+narrow the buffer now."
(condition-case err
(when (eq major-mode 'ses-mode) ; Otherwise, not our buffer anymore.
(when ses--deferred-recalc
@@ -2267,8 +2268,8 @@ Based on the current set of columns and `window-hscroll'
position."
(ses-jump cell)))
(defun ses-reprint-all (&optional nonarrow)
- "Recreate the display area. Calls all printer functions. Narrows to
-print area if NONARROW is nil."
+ "Recreate the display area. Call all printer functions.
+Narrow to print area if optional argument NONARROW is nil."
(interactive "*P")
(widen)
(unless nonarrow
@@ -2495,8 +2496,8 @@ to are recalculated first."
(and collection (list start end collection))))))
(defun ses-edit-cell (row col newval)
- "Display current cell contents in minibuffer, for editing. Returns nil if
-cell formula was unsafe and user declined confirmation."
+ "Display current cell contents in minibuffer, for editing.
+Return nil if cell formula was unsafe and user declined confirmation."
(interactive
(progn
(barf-if-buffer-read-only)
@@ -2559,8 +2560,9 @@ cell formula was unsafe and user declined confirmation."
(funcall x 1))))
(defun ses-read-symbol (row col symb)
- "Self-insert for a symbol as a cell formula. The set of all symbols that
-have been used as formulas in this spreadsheet is available for completions."
+ "Self-insert for a symbol as a cell formula.
+The set of all symbols that have been used as formulas in this
+spreadsheet is available for completions."
(interactive
(let ((rowcol (progn (ses-check-curcell) (ses-sym-rowcol ses--curcell)))
newval)
@@ -2593,7 +2595,7 @@ With prefix, deletes several cells."
(forward-char 1))))
(defun ses-clear-cell-backward (count)
- "Move to previous cell and then delete it. With prefix, deletes several
+ "Move to previous cell and then delete it. With prefix, delete several
cells."
(interactive "*p")
(if (< count 0)
@@ -3371,9 +3373,9 @@ is non-nil. Newlines and tabs in the export text are
escaped."
;;----------------------------------------------------------------------------
(defun ses-list-local-printers (&optional local-printer-hashmap)
- "List local printers in a help buffer. Can be called either
-during editing a printer or a formula, or while in the SES
-buffer."
+ "List local printers in a help buffer.
+Can be called either during editing a printer or a formula, or
+while in the SES buffer."
(interactive
(list (cond
((derived-mode-p 'ses-mode) ses--local-printer-hashmap)
@@ -3405,9 +3407,9 @@ buffer."
(buffer-string)))))))
(defun ses-list-named-cells (&optional named-cell-hashmap)
- "List named cells in a help buffer. Can be called either
-during editing a printer or a formula, or while in the SES
-buffer."
+ "List named cells in a help buffer.
+Can be called either during editing a printer or a formula, or
+while in the SES buffer."
(interactive
(list (cond
((derived-mode-p 'ses-mode) ses--named-cell-hashmap)
diff --git a/lisp/shadowfile.el b/lisp/shadowfile.el
index a4f0eba..f39f173 100644
--- a/lisp/shadowfile.el
+++ b/lisp/shadowfile.el
@@ -1,4 +1,4 @@
-;;; shadowfile.el --- automatic file copying
+;;; shadowfile.el --- automatic file copying -*- lexical-binding: t; -*-
;; Copyright (C) 1993-1994, 2001-2021 Free Software Foundation, Inc.
@@ -90,27 +90,23 @@
"If t, always copy shadow files without asking.
If nil (the default), always ask. If not nil and not t, ask only if there
is no buffer currently visiting the file."
- :type '(choice (const t) (const nil) (other :tag "Ask if no buffer" maybe))
- :group 'shadow)
+ :type '(choice (const t) (const nil) (other :tag "Ask if no buffer" maybe)))
(defcustom shadow-inhibit-message nil
"If non-nil, do not display a message when a file needs copying."
- :type 'boolean
- :group 'shadow)
+ :type 'boolean)
(defcustom shadow-inhibit-overload nil
"If non-nil, shadowfile won't redefine \\[save-buffers-kill-emacs].
Normally it overloads the function `save-buffers-kill-emacs' to check for
files that have been changed and need to be copied to other systems."
- :type 'boolean
- :group 'shadow)
+ :type 'boolean)
(defcustom shadow-info-file (locate-user-emacs-file "shadows" ".shadows")
"File to keep shadow information in.
The `shadow-info-file' should be shadowed to all your accounts to
ensure consistency. Default: ~/.emacs.d/shadows"
:type 'file
- :group 'shadow
:version "26.2")
(defcustom shadow-todo-file
@@ -122,13 +118,12 @@ remember and ask you again in your next Emacs session.
This file must NOT be shadowed to any other system, it is host-specific.
Default: ~/.emacs.d/shadow_todo"
:type 'file
- :group 'shadow
:version "26.2")
-;;; The following two variables should in most cases initialize themselves
-;;; correctly. They are provided as variables in case the defaults are wrong
-;;; on your machine (and for efficiency).
+;; The following two variables should in most cases initialize themselves
+;; correctly. They are provided as variables in case the defaults are wrong
+;; on your machine (and for efficiency).
(defvar shadow-system-name (concat "/" (system-name) ":")
"The identification for local files on this machine.")
@@ -160,7 +155,7 @@ created by `shadow-define-regexp-group'.")
(defvar shadow-files-to-copy nil) ; List of files that need to
; be copied to remote hosts.
-(defvar shadow-hashtable nil) ; for speed
+(defvar shadow-hashtable (make-hash-table :test #'equal)) ; for speed
(defvar shadow-info-buffer nil) ; buf visiting shadow-info-file
(defvar shadow-todo-buffer nil) ; buf visiting shadow-todo-file
@@ -172,20 +167,6 @@ created by `shadow-define-regexp-group'.")
;;; Syntactic sugar; General list and string manipulation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun shadow-union (a b)
- "Add members of list A to list B if not equal to items already in B."
- (if (null a)
- b
- (if (member (car a) b)
- (shadow-union (cdr a) b)
- (shadow-union (cdr a) (cons (car a) b)))))
-
-(defun shadow-find (func list)
- "If FUNC applied to some element of LIST is non-nil, return first such
element."
- (while (and list (not (funcall func (car list))))
- (setq list (cdr list)))
- (car list))
-
(defun shadow-regexp-superquote (string)
"Like `regexp-quote', but includes the \\` and \\'.
This makes sure regexp matches nothing but STRING."
@@ -205,11 +186,11 @@ PREFIX."
;;; Clusters and sites
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; I use the term `site' to refer to a string which may be the
-;;; cluster identification "/name:", a remote identification
-;;; "/method:user@host:", or "/system-name:" (the value of
-;;; `shadow-system-name') for the location of local files. All
-;;; user-level commands should accept either.
+;; I use the term `site' to refer to a string which may be the
+;; cluster identification "/name:", a remote identification
+;; "/method:user@host:", or "/system-name:" (the value of
+;; `shadow-system-name') for the location of local files. All
+;; user-level commands should accept either.
(cl-defstruct (shadow-cluster (:type list) :named) name primary regexp)
@@ -226,7 +207,7 @@ information defining the cluster. For interactive use, call
(defun shadow-get-cluster (name)
"Return cluster named NAME, or nil."
- (shadow-find
+ (seq-find
(lambda (x) (string-equal (shadow-cluster-name x) name))
shadow-clusters))
@@ -252,7 +233,7 @@ information defining the cluster. For interactive use, call
(defun shadow-site-cluster (site)
"Given a SITE, return cluster it is in, or nil."
(or (shadow-get-cluster (shadow-site-name site))
- (shadow-find
+ (seq-find
(lambda (x)
(string-match (shadow-cluster-regexp x) (shadow-name-site site)))
shadow-clusters)))
@@ -594,7 +575,7 @@ be shadowed), and list of SITES."
Filename should have clusters expanded, but otherwise can have any format.
Return value is a list of dotted pairs like (from . to), where from
and to are absolute file names."
- (or (symbol-value (intern-soft file shadow-hashtable))
+ (or (gethash file shadow-hashtable)
(let* ((absolute-file (shadow-expand-file-name
(or (shadow-local-file file) file)
shadow-homedir))
@@ -612,7 +593,7 @@ and to are absolute file names."
"shadow-shadows-of: %s %s %s %s %s"
file (shadow-local-file file) shadow-homedir
absolute-file canonical-file))
- (set (intern file shadow-hashtable) shadows))))
+ (puthash file shadows shadow-hashtable))))
(defun shadow-shadows-of-1 (file groups regexp)
"Return list of FILE's shadows in GROUPS.
@@ -653,7 +634,7 @@ Consider them as regular expressions if third arg REGEXP is
true."
shadows shadow-files-to-copy (with-output-to-string (backtrace))))
(when shadows
(setq shadow-files-to-copy
- (shadow-union shadows shadow-files-to-copy))
+ (nreverse (cl-union shadows shadow-files-to-copy :test #'equal)))
(when (not shadow-inhibit-message)
(message "%s" (substitute-command-keys
"Use \\[shadow-copy-files] to update shadows."))
@@ -749,7 +730,7 @@ With non-nil argument also saves the buffer."
(sit-for 1))))))
(defun shadow-invalidate-hashtable ()
- (setq shadow-hashtable (make-vector 37 0)))
+ (clrhash shadow-hashtable))
(defun shadow-insert-var (variable)
"Build a `setq' to restore VARIABLE.
@@ -758,17 +739,17 @@ will restore VARIABLE to its current setting.
VARIABLE must be the name of a variable whose value is a list."
(let ((standard-output (current-buffer)))
(insert (format "(setq %s" variable))
- (cond ((consp (eval variable))
+ (cond ((consp (symbol-value variable))
(insert "\n '(")
- (prin1 (car (eval variable)))
- (let ((rest (cdr (eval variable))))
+ (prin1 (car (symbol-value variable)))
+ (let ((rest (cdr (symbol-value variable))))
(while rest
(insert "\n ")
(prin1 (car rest))
(setq rest (cdr rest)))
(insert "))\n\n")))
(t (insert " ")
- (prin1 (eval variable))
+ (prin1 (symbol-value variable))
(insert ")\n\n")))))
(defun shadow-save-buffers-kill-emacs (&optional arg)
@@ -777,6 +758,11 @@ With prefix arg, silently save all file-visiting buffers,
then kill.
Extended by shadowfile to automatically save `shadow-todo-file' and
look for files that have been changed and need to be copied to other systems."
+ (interactive "P")
+ (shadow--save-buffers-kill-emacs arg)
+ (save-buffers-kill-emacs arg))
+
+(defun shadow--save-buffers-kill-emacs (&optional arg &rest _)
;; This function is necessary because we need to get control and save
;; the todo file /after/ saving other files, but /before/ the warning
;; message about unsaved buffers (because it can get modified by the
@@ -784,27 +770,10 @@ look for files that have been changed and need to be
copied to other systems."
;; because it is not called at the correct time, and also because it is
;; called when the terminal is disconnected and we cannot ask whether
;; to copy files.
- (interactive "P")
(shadow-save-todo-file)
(save-some-buffers arg t)
(shadow-copy-files)
- (shadow-save-todo-file)
- (and (or (not (memq t (mapcar (lambda (buf) (and (buffer-file-name buf)
- (buffer-modified-p buf)))
- (buffer-list))))
- (yes-or-no-p "Modified buffers exist; exit anyway? "))
- (or (not (fboundp 'process-list))
- ;; `process-list' is not defined on MSDOS.
- (let ((processes (process-list))
- active)
- (while processes
- (and (memq (process-status (car processes)) '(run stop open
listen))
- (process-query-on-exit-flag (car processes))
- (setq active t))
- (setq processes (cdr processes)))
- (or (not active)
- (yes-or-no-p "Active processes exist; kill them and exit
anyway? "))))
- (kill-emacs)))
+ (shadow-save-todo-file))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Hook us up
@@ -823,22 +792,29 @@ look for files that have been changed and need to be
copied to other systems."
(message "Shadowfile information files not found - aborting")
(beep)
(sit-for 3))
- (when (and (not shadow-inhibit-overload)
- (not (fboundp 'shadow-orig-save-buffers-kill-emacs)))
- (defalias 'shadow-orig-save-buffers-kill-emacs
- (symbol-function 'save-buffers-kill-emacs))
- (defalias 'save-buffers-kill-emacs 'shadow-save-buffers-kill-emacs))
- (add-hook 'write-file-functions 'shadow-add-to-todo)
- (define-key ctl-x-4-map "s" 'shadow-copy-files)))
+ (unless shadow-inhibit-overload
+ (advice-add 'save-buffers-kill-emacs :before
+ #'shadow--save-buffers-kill-emacs))
+ (add-hook 'write-file-functions #'shadow-add-to-todo)
+ (define-key ctl-x-4-map "s" #'shadow-copy-files)))
(defun shadowfile-unload-function ()
- (substitute-key-definition 'shadow-copy-files nil ctl-x-4-map)
- (when (fboundp 'shadow-orig-save-buffers-kill-emacs)
- (fset 'save-buffers-kill-emacs
- (symbol-function 'shadow-orig-save-buffers-kill-emacs)))
+ (substitute-key-definition #'shadow-copy-files nil ctl-x-4-map)
+ (advice-remove 'save-buffers-kill-emacs #'shadow--save-buffers-kill-emacs)
;; continue standard unloading
nil)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Obsolete
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun shadow-union (a b)
+ "Add members of list A to list B if not equal to items already in B."
+ (declare (obsolete cl-union "28.1"))
+ (nreverse (cl-union a b :test #'equal)))
+
+(define-obsolete-function-alias 'shadow-find #'seq-find "28.1")
+
(provide 'shadowfile)
;;; shadowfile.el ends here
diff --git a/lisp/shell.el b/lisp/shell.el
index cd99b00..3098d3a 100644
--- a/lisp/shell.el
+++ b/lisp/shell.el
@@ -980,7 +980,7 @@ Environment variables are expanded, see function
`substitute-in-file-name'."
The `dirtrack' package provides an alternative implementation of
this feature; see the function `dirtrack-mode'."
- nil nil nil
+ :lighter nil
(setq list-buffers-directory (if shell-dirtrack-mode default-directory))
(if shell-dirtrack-mode
(add-hook 'comint-input-filter-functions #'shell-directory-tracker nil t)
diff --git a/lisp/simple.el b/lisp/simple.el
index c48e644..26eb8ca 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -2080,8 +2080,11 @@ or (if one of MODES is a minor mode), if it is switched
on in BUFFER."
(obsolete
(format " (%s)" (car obsolete)))
((and binding (not (stringp binding)))
- (format " (%s)" (key-description binding))))))
- (if suffix (list command-name suffix) command-name)))
+ (format " (%s)" (key-description binding)))
+ (t ""))))
+ (put-text-property 0 (length suffix)
+ 'face 'completions-annotations suffix)
+ (list command-name "" suffix)))
command-names)))
(defcustom suggest-key-bindings t
@@ -2798,7 +2801,6 @@ or to the last history element for a backward search."
(if isearch-forward
(goto-history-element (length (minibuffer-history-value)))
(goto-history-element 0))
- (setq isearch-success t)
(goto-char (if isearch-forward (minibuffer-prompt-end) (point-max))))
(defun minibuffer-history-isearch-push-state ()
diff --git a/lisp/so-long.el b/lisp/so-long.el
index f44d41d..f916b61 100644
--- a/lisp/so-long.el
+++ b/lisp/so-long.el
@@ -1185,7 +1185,7 @@ current buffer, and buffer-local values are assigned to
variables in accordance
with `so-long-variable-overrides'.
This minor mode is a standard `so-long-action' option."
- nil nil nil
+ :lighter nil
(if so-long-minor-mode ;; We are enabling the mode.
(progn
;; Housekeeping. `so-long-minor-mode' might be invoked directly rather
diff --git a/lisp/speedbar.el b/lisp/speedbar.el
index 12e57b1..4666026 100644
--- a/lisp/speedbar.el
+++ b/lisp/speedbar.el
@@ -1,4 +1,4 @@
-;;; speedbar --- quick access to files and tags in a frame -*-
lexical-binding: t; -*-
+;;; speedbar.el --- quick access to files and tags in a frame -*-
lexical-binding: t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
@@ -4055,7 +4055,6 @@ this version is not backward compatible to 0.14 or
earlier.")
(provide 'speedbar)
-;; run load-time hooks
(run-hooks 'speedbar-load-hook)
-;;; speedbar ends here
+;;; speedbar.el ends here
diff --git a/lisp/startup.el b/lisp/startup.el
index b173d61..3513ab7 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -519,6 +519,7 @@ DIRS are relative."
xdg-dir)
(t emacs-d-dir))))
+(defvar comp-eln-load-path)
(defun normal-top-level ()
"Emacs calls this function when it first starts up.
It sets `command-line-processed', processes the command-line,
@@ -536,6 +537,22 @@ It is the default value of the variable `top-level'."
(setq user-emacs-directory
(startup--xdg-or-homedot startup--xdg-config-home-emacs nil))
+ (when (featurep 'nativecomp)
+ ;; Form `comp-eln-load-path'.
+ (let ((path-env (getenv "EMACSNATIVELOADPATH")))
+ (when path-env
+ (dolist (path (split-string path-env path-separator))
+ (unless (string= "" path)
+ (push path comp-eln-load-path)))))
+ (push (expand-file-name "eln-cache/" user-emacs-directory)
+ comp-eln-load-path)
+ ;; When $HOME is set to '/nonexistent' means we are running the
+ ;; testsuite, add a temporary folder in front to produce there
+ ;; new compilations.
+ (when (equal (getenv "HOME") "/nonexistent")
+ (let ((tmp-dir (make-temp-file "emacs-testsuite-" t)))
+ (add-hook 'kill-emacs-hook (lambda () (delete-directory tmp-dir t)))
+ (push tmp-dir comp-eln-load-path))))
;; Look in each dir in load-path for a subdirs.el file. If we
;; find one, load it, which will add the appropriate subdirs of
;; that dir into load-path. This needs to be done before setting
@@ -622,6 +639,16 @@ It is the default value of the variable `top-level'."
(set pathsym (mapcar (lambda (dir)
(decode-coding-string dir coding t))
path)))))
+ (when (featurep 'nativecomp)
+ (let ((npath (symbol-value 'comp-eln-load-path)))
+ (set 'comp-eln-load-path
+ (mapcar (lambda (dir)
+ ;; Call expand-file-name to remove all the
+ ;; pesky ".." from the directyory names in
+ ;; comp-eln-load-path.
+ (expand-file-name
+ (decode-coding-string dir coding t)))
+ npath))))
(dolist (filesym '(data-directory doc-directory exec-directory
installation-directory
invocation-directory invocation-name
@@ -1097,7 +1124,7 @@ please check its value")
("--no-x-resources") ("--debug-init")
("--user") ("--iconic") ("--icon-type") ("--quick")
("--no-blinking-cursor") ("--basic-display")
- ("--dump-file") ("--temacs")))
+ ("--dump-file") ("--temacs") ("--seccomp")))
(argi (pop args))
(orig-argi argi)
argval)
@@ -1149,7 +1176,8 @@ please check its value")
(push '(visibility . icon) initial-frame-alist))
((member argi '("-nbc" "-no-blinking-cursor"))
(setq no-blinking-cursor t))
- ((member argi '("-dump-file" "-temacs")) ; Handled in C
+ ((member argi '("-dump-file" "-temacs" "-seccomp"))
+ ;; Handled in C
(or argval (pop args))
(setq argval nil))
;; Push the popped arg back on the list of arguments.
@@ -1174,7 +1202,7 @@ please check its value")
;; are dependencies between them.
(nreverse custom-delayed-init-variables))
(mapc #'custom-reevaluate-setting custom-delayed-init-variables)
- (setq custom-delayed-init-variables nil)
+ (setq custom-delayed-init-variables t)
;; Warn for invalid user name.
(when init-file-user
diff --git a/lisp/strokes.el b/lisp/strokes.el
index 55f2ae8..18595cb 100644
--- a/lisp/strokes.el
+++ b/lisp/strokes.el
@@ -1,4 +1,4 @@
-;;; strokes.el --- control Emacs through mouse strokes
+;;; strokes.el --- control Emacs through mouse strokes -*- lexical-binding:
t; -*-
;; Copyright (C) 1997, 2000-2021 Free Software Foundation, Inc.
@@ -138,15 +138,14 @@
;; the user to enter strokes which "remove the pencil from the paper"
;; so to speak, so one character can have multiple strokes.
-;; NOTE (Oct 7, 2006): The URLs below seem to be invalid!!!
-
;; You can read more about strokes at:
-;; http://www.mit.edu/people/cadet/strokes-help.html
+;;
https://web.archive.org/web/20041209171947/http://www.mit.edu/people/cadet/strokes-help.html
;; If you're interested in using strokes for writing English into Emacs
;; using strokes, then you'll want to read about it on the web page above
-;; or just download from http://www.mit.edu/people/cadet/strokes-abc.el,
+;; or just download from:
+;;
https://web.archive.org/web/20041204163338/http://www.mit.edu/people/cadet/strokes-abc.el
;; which is nothing but a file with some helper commands for inserting
;; alphanumerics and punctuation.
@@ -216,14 +215,12 @@ static char * stroke_xpm[] = {
(defcustom strokes-lighter " Strokes"
"Mode line identifier for Strokes mode."
- :type 'string
- :group 'strokes)
+ :type 'string)
(defcustom strokes-character ?@
"Character used when drawing strokes in the strokes buffer.
\(The default is `@', which works well.)"
- :type 'character
- :group 'strokes)
+ :type 'character)
(defcustom strokes-minimum-match-score 1000
"Minimum score for a stroke to be considered a possible match.
@@ -239,8 +236,7 @@ then you can set `strokes-minimum-match-score' to something
that works
for you. The only purpose of this variable is to insure that if you
do a bogus stroke that really doesn't match any of the predefined
ones, then strokes should NOT pick the one that came closest."
- :type 'integer
- :group 'strokes)
+ :type 'integer)
(defcustom strokes-grid-resolution 9
"Integer defining dimensions of the stroke grid.
@@ -256,14 +252,12 @@ WARNING: Changing the value of this variable will gravely
affect the
figure out what it should be based on your needs and on how
quick the particular platform(s) you're operating on, and
only then start programming in your custom strokes."
- :type 'integer
- :group 'strokes)
+ :type 'integer)
(defcustom strokes-file (locate-user-emacs-file "strokes" ".strokes")
"File containing saved strokes for Strokes mode."
:version "24.4" ; added locate-user-emacs-file
- :type 'file
- :group 'strokes)
+ :type 'file)
(defvar strokes-buffer-name " *strokes*"
"The name of the buffer that the strokes take place in.")
@@ -273,8 +267,7 @@ WARNING: Changing the value of this variable will gravely
affect the
If nil, strokes will be read the same, however the user will not be
able to see the strokes. This be helpful for people who don't like
the delay in switching to the strokes buffer."
- :type 'boolean
- :group 'strokes)
+ :type 'boolean)
;;; internal variables...
@@ -313,12 +306,6 @@ the corresponding interactive function.")
;;; Macros...
-;; unused
-;; (defmacro strokes-while-inhibiting-garbage-collector (&rest forms)
-;; "Execute FORMS without interference from the garbage collector."
-;; `(let ((gc-cons-threshold 134217727))
-;; ,@forms))
-
(defsubst strokes-click-p (stroke)
"Non-nil if STROKE is really click."
(< (length stroke) 2))
@@ -1044,7 +1031,7 @@ o Strokes are a bit computer-dependent in that they
depend somewhat on
(help-mode)
(help-print-return-message)))
-(define-obsolete-function-alias 'strokes-report-bug 'report-emacs-bug "24.1")
+(define-obsolete-function-alias 'strokes-report-bug #'report-emacs-bug "24.1")
(defun strokes-window-configuration-changed-p ()
"Non-nil if the `strokes-window-configuration' frame properties changed.
@@ -1379,8 +1366,8 @@ If STROKES-MAP is not given, `strokes-global-map' will be
used instead."
(defvar strokes-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map [(shift down-mouse-2)] 'strokes-do-stroke)
- (define-key map [(meta down-mouse-2)] 'strokes-do-complex-stroke)
+ (define-key map [(shift down-mouse-2)] #'strokes-do-stroke)
+ (define-key map [(meta down-mouse-2)] #'strokes-do-complex-stroke)
map))
;;;###autoload
@@ -1399,8 +1386,7 @@ Encode/decode your strokes with \\[strokes-encode-buffer],
\\[strokes-decode-buffer].
\\{strokes-mode-map}"
- nil strokes-lighter strokes-mode-map
- :group 'strokes :global t
+ :lighter strokes-lighter :global t
(cond ((not (display-mouse-p))
(error "Can't use Strokes without a mouse"))
(strokes-mode ; turn on strokes
@@ -1408,15 +1394,15 @@ Encode/decode your strokes with
\\[strokes-encode-buffer],
(null strokes-global-map)
(strokes-load-user-strokes))
(add-hook 'kill-emacs-query-functions
- 'strokes-prompt-user-save-strokes)
+ #'strokes-prompt-user-save-strokes)
(add-hook 'select-frame-hook
- 'strokes-update-window-configuration)
+ #'strokes-update-window-configuration)
(strokes-update-window-configuration))
(t ; turn off strokes
(if (get-buffer strokes-buffer-name)
(kill-buffer (get-buffer strokes-buffer-name)))
(remove-hook 'select-frame-hook
- 'strokes-update-window-configuration))))
+ #'strokes-update-window-configuration))))
;;;; strokes-xpm stuff (later may be separate)...
@@ -1426,74 +1412,75 @@ Encode/decode your strokes with
\\[strokes-encode-buffer],
(defface strokes-char '((t (:background "lightgray")))
"Face for strokes characters."
- :version "21.1"
- :group 'strokes)
+ :version "21.1")
(put 'strokes 'char-table-extra-slots 0)
-(defconst strokes-char-table (make-char-table 'strokes) ;
+(defconst strokes-char-table
+ (let ((ct (make-char-table 'strokes))) ;
+ (aset ct ?0 0)
+ (aset ct ?1 1)
+ (aset ct ?2 2)
+ (aset ct ?3 3)
+ (aset ct ?4 4)
+ (aset ct ?5 5)
+ (aset ct ?6 6)
+ (aset ct ?7 7)
+ (aset ct ?8 8)
+ (aset ct ?9 9)
+ (aset ct ?a 10)
+ (aset ct ?b 11)
+ (aset ct ?c 12)
+ (aset ct ?d 13)
+ (aset ct ?e 14)
+ (aset ct ?f 15)
+ (aset ct ?g 16)
+ (aset ct ?h 17)
+ (aset ct ?i 18)
+ (aset ct ?j 19)
+ (aset ct ?k 20)
+ (aset ct ?l 21)
+ (aset ct ?m 22)
+ (aset ct ?n 23)
+ (aset ct ?o 24)
+ (aset ct ?p 25)
+ (aset ct ?q 26)
+ (aset ct ?r 27)
+ (aset ct ?s 28)
+ (aset ct ?t 29)
+ (aset ct ?u 30)
+ (aset ct ?v 31)
+ (aset ct ?w 32)
+ (aset ct ?x 33)
+ (aset ct ?y 34)
+ (aset ct ?z 35)
+ (aset ct ?A 36)
+ (aset ct ?B 37)
+ (aset ct ?C 38)
+ (aset ct ?D 39)
+ (aset ct ?E 40)
+ (aset ct ?F 41)
+ (aset ct ?G 42)
+ (aset ct ?H 43)
+ (aset ct ?I 44)
+ (aset ct ?J 45)
+ (aset ct ?K 46)
+ (aset ct ?L 47)
+ (aset ct ?M 48)
+ (aset ct ?N 49)
+ (aset ct ?O 50)
+ (aset ct ?P 51)
+ (aset ct ?Q 52)
+ (aset ct ?R 53)
+ (aset ct ?S 54)
+ (aset ct ?T 55)
+ (aset ct ?U 56)
+ (aset ct ?V 57)
+ (aset ct ?W 58)
+ (aset ct ?X 59)
+ (aset ct ?Y 60)
+ (aset ct ?Z 61)
+ ct)
"The table which stores values for the character keys.")
-(aset strokes-char-table ?0 0)
-(aset strokes-char-table ?1 1)
-(aset strokes-char-table ?2 2)
-(aset strokes-char-table ?3 3)
-(aset strokes-char-table ?4 4)
-(aset strokes-char-table ?5 5)
-(aset strokes-char-table ?6 6)
-(aset strokes-char-table ?7 7)
-(aset strokes-char-table ?8 8)
-(aset strokes-char-table ?9 9)
-(aset strokes-char-table ?a 10)
-(aset strokes-char-table ?b 11)
-(aset strokes-char-table ?c 12)
-(aset strokes-char-table ?d 13)
-(aset strokes-char-table ?e 14)
-(aset strokes-char-table ?f 15)
-(aset strokes-char-table ?g 16)
-(aset strokes-char-table ?h 17)
-(aset strokes-char-table ?i 18)
-(aset strokes-char-table ?j 19)
-(aset strokes-char-table ?k 20)
-(aset strokes-char-table ?l 21)
-(aset strokes-char-table ?m 22)
-(aset strokes-char-table ?n 23)
-(aset strokes-char-table ?o 24)
-(aset strokes-char-table ?p 25)
-(aset strokes-char-table ?q 26)
-(aset strokes-char-table ?r 27)
-(aset strokes-char-table ?s 28)
-(aset strokes-char-table ?t 29)
-(aset strokes-char-table ?u 30)
-(aset strokes-char-table ?v 31)
-(aset strokes-char-table ?w 32)
-(aset strokes-char-table ?x 33)
-(aset strokes-char-table ?y 34)
-(aset strokes-char-table ?z 35)
-(aset strokes-char-table ?A 36)
-(aset strokes-char-table ?B 37)
-(aset strokes-char-table ?C 38)
-(aset strokes-char-table ?D 39)
-(aset strokes-char-table ?E 40)
-(aset strokes-char-table ?F 41)
-(aset strokes-char-table ?G 42)
-(aset strokes-char-table ?H 43)
-(aset strokes-char-table ?I 44)
-(aset strokes-char-table ?J 45)
-(aset strokes-char-table ?K 46)
-(aset strokes-char-table ?L 47)
-(aset strokes-char-table ?M 48)
-(aset strokes-char-table ?N 49)
-(aset strokes-char-table ?O 50)
-(aset strokes-char-table ?P 51)
-(aset strokes-char-table ?Q 52)
-(aset strokes-char-table ?R 53)
-(aset strokes-char-table ?S 54)
-(aset strokes-char-table ?T 55)
-(aset strokes-char-table ?U 56)
-(aset strokes-char-table ?V 57)
-(aset strokes-char-table ?W 58)
-(aset strokes-char-table ?X 59)
-(aset strokes-char-table ?Y 60)
-(aset strokes-char-table ?Z 61)
(defconst strokes-base64-chars
;; I wanted to make this a vector of individual like (vector ?0
diff --git a/lisp/subr.el b/lisp/subr.el
index c2be26a..964eb8f 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -246,6 +246,11 @@ value of last one, or nil if there are none.
(declare (indent 1) (debug t))
(cons 'if (cons cond (cons nil body))))
+(defsubst subr-primitive-p (object)
+ "Return t if OBJECT is a built-in primitive function."
+ (and (subrp object)
+ (not (subr-native-elisp-p object))))
+
(defsubst xor (cond1 cond2)
"Return the boolean exclusive-or of COND1 and COND2.
If only one of the arguments is non-nil, return it; otherwise
@@ -1830,12 +1835,13 @@ function, it is changed to a list of functions."
(unless (member function hook-value)
(when (stringp function) ;FIXME: Why?
(setq function (purecopy function)))
+ ;; All those `equal' tests performed between functions can end up being
+ ;; costly since those functions may be large recursive and even cyclic
+ ;; structures, so we index `hook--depth-alist' with `eq'. (bug#46326)
(when (or (get hook 'hook--depth-alist) (not (zerop depth)))
;; Note: The main purpose of the above `when' test is to avoid running
;; this `setf' before `gv' is loaded during bootstrap.
- (setf (alist-get function (get hook 'hook--depth-alist)
- 0 'remove #'equal)
- depth))
+ (push (cons function depth) (get hook 'hook--depth-alist)))
(setq hook-value
(if (< 0 depth)
(append hook-value (list function))
@@ -1845,8 +1851,8 @@ function, it is changed to a list of functions."
(setq hook-value
(sort (if (< 0 depth) hook-value (copy-sequence hook-value))
(lambda (f1 f2)
- (< (alist-get f1 depth-alist 0 nil #'equal)
- (alist-get f2 depth-alist 0 nil #'equal))))))))
+ (< (alist-get f1 depth-alist 0 nil #'eq)
+ (alist-get f2 depth-alist 0 nil #'eq))))))))
;; Set the actual variable
(if local
(progn
@@ -1907,11 +1913,21 @@ one will be removed."
(not (and (consp (symbol-value hook))
(memq t (symbol-value hook)))))
(setq local t))
- (let ((hook-value (if local (symbol-value hook) (default-value hook))))
+ (let ((hook-value (if local (symbol-value hook) (default-value hook)))
+ (old-fun nil))
;; Remove the function, for both the list and the non-list cases.
(if (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
- (if (equal hook-value function) (setq hook-value nil))
- (setq hook-value (delete function (copy-sequence hook-value))))
+ (when (equal hook-value function)
+ (setq old-fun hook-value)
+ (setq hook-value nil))
+ (when (setq old-fun (car (member function hook-value)))
+ (setq hook-value (remq old-fun hook-value))))
+ (when old-fun
+ ;; Remove auxiliary depth info to avoid leaks (bug#46414)
+ ;; and to avoid the list growing too long.
+ (let* ((depths (get hook 'hook--depth-alist))
+ (di (assq old-fun depths)))
+ (when di (put hook 'hook--depth-alist (delq di depths)))))
;; If the function is on the global hook, we need to shadow it locally
;;(when (and local (member function (default-value hook))
;; (not (member (cons 'not function) hook-value)))
@@ -5007,7 +5023,8 @@ See also `with-eval-after-load'."
(funcall func)
(let ((lfn load-file-name)
;; Don't use letrec, because equal (in
- ;; add/remove-hook) would get trapped in a cycle.
+ ;; add/remove-hook) could get trapped in a cycle
+ ;; (bug#46326).
(fun (make-symbol "eval-after-load-helper")))
(fset fun (lambda (file)
(when (equal file lfn)
@@ -5517,7 +5534,7 @@ command is called from a keyboard macro?"
;; Now `frame' should be "the function from which we were called".
(pcase (cons frame nextframe)
;; No subr calls `interactive-p', so we can rule that out.
- (`((,_ ,(pred (lambda (f) (subrp (indirect-function f)))) . ,_) . ,_)
nil)
+ (`((,_ ,(pred (lambda (f) (subr-primitive-p (indirect-function f)))) .
,_) . ,_) nil)
;; In case #<subr funcall-interactively> without going through the
;; `funcall-interactively' symbol (bug#3984).
(`(,_ . (t ,(pred (lambda (f)
@@ -5595,8 +5612,8 @@ to deactivate this transient map, regardless of
KEEP-PRED."
(internal-pop-keymap map 'overriding-terminal-local-map)
(remove-hook 'pre-command-hook clearfun)
(when on-exit (funcall on-exit)))))
- ;; Don't use letrec, because equal (in add/remove-hook) would get trapped
- ;; in a cycle.
+ ;; Don't use letrec, because equal (in add/remove-hook) could get trapped
+ ;; in a cycle. (bug#46326)
(fset clearfun
(lambda ()
(with-demoted-errors "set-transient-map PCH: %S"
diff --git a/lisp/svg.el b/lisp/svg.el
index 717c847..05accf4 100644
--- a/lisp/svg.el
+++ b/lisp/svg.el
@@ -41,7 +41,7 @@
;; into the buffer:
;;
;; (setq svg (svg-create 800 800 :stroke "orange" :stroke-width 5))
-;; (svg-gradient svg "gradient" 'linear '(0 . "red") '(100 . "blue"))
+;; (svg-gradient svg "gradient" 'linear '((0 . "red") (100 . "blue")))
;; (save-excursion (goto-char (point-max)) (svg-insert-image svg))
;; Then add various elements to the structure:
@@ -81,7 +81,7 @@ STOPS is a list of percentage/color pairs."
(svg--def
svg
(apply
- 'dom-node
+ #'dom-node
(if (eq type 'linear)
'linearGradient
'radialGradient)
@@ -358,8 +358,7 @@ This is in contrast to merely setting it to 0."
(plist-get command-args :default-relative))))
(intern (if relative (downcase char) (upcase char)))))
-(defun svg--elliptical-arc-coordinates
- (rx ry x y &rest args)
+(defun svg--elliptical-arc-coordinates (rx ry x y &rest args)
(list
rx ry
(or (plist-get args :x-axis-rotation) 0)
@@ -370,21 +369,19 @@ This is in contrast to merely setting it to 0."
(defun svg--elliptical-arc-command (coordinates-list &rest args)
(cons
(svg--path-command-symbol 'a args)
- (apply 'append
- (mapcar
- (lambda (coordinates)
- (apply 'svg--elliptical-arc-coordinates
- coordinates))
- coordinates-list))))
+ (mapcan
+ (lambda (coordinates)
+ (apply #'svg--elliptical-arc-coordinates
+ coordinates))
+ coordinates-list)))
(defun svg--moveto-command (coordinates-list &rest args)
(cons
(svg--path-command-symbol 'm args)
- (apply 'append
- (mapcar
- (lambda (coordinates)
- (list (car coordinates) (cdr coordinates)))
- coordinates-list))))
+ (mapcan
+ (lambda (coordinates)
+ (list (car coordinates) (cdr coordinates)))
+ coordinates-list)))
(defun svg--closepath-command (&rest args)
(list (svg--path-command-symbol 'z args)))
@@ -392,11 +389,10 @@ This is in contrast to merely setting it to 0."
(defun svg--lineto-command (coordinates-list &rest args)
(cons
(svg--path-command-symbol 'l args)
- (apply 'append
- (mapcar
- (lambda (coordinates)
- (list (car coordinates) (cdr coordinates)))
- coordinates-list))))
+ (mapcan
+ (lambda (coordinates)
+ (list (car coordinates) (cdr coordinates)))
+ coordinates-list)))
(defun svg--horizontal-lineto-command (coordinate-list &rest args)
(cons
@@ -411,24 +407,24 @@ This is in contrast to merely setting it to 0."
(defun svg--curveto-command (coordinates-list &rest args)
(cons
(svg--path-command-symbol 'c args)
- (apply 'append coordinates-list)))
+ (apply #'append coordinates-list)))
(defun svg--smooth-curveto-command (coordinates-list &rest args)
(cons
(svg--path-command-symbol 's args)
- (apply 'append coordinates-list)))
+ (apply #'append coordinates-list)))
(defun svg--quadratic-bezier-curveto-command (coordinates-list
&rest args)
(cons
(svg--path-command-symbol 'q args)
- (apply 'append coordinates-list)))
+ (apply #'append coordinates-list)))
(defun svg--smooth-quadratic-bezier-curveto-command (coordinates-list
&rest args)
(cons
(svg--path-command-symbol 't args)
- (apply 'append coordinates-list)))
+ (apply #'append coordinates-list)))
(defun svg--eval-path-command (command default-relative)
(cl-letf
@@ -450,7 +446,7 @@ This is in contrast to merely setting it to 0."
#'svg--elliptical-arc-command)
(extended-command (append command (list :default-relative
default-relative))))
- (mapconcat 'prin1-to-string (apply extended-command) " ")))
+ (mapconcat #'prin1-to-string (apply extended-command) " ")))
(defun svg-path (svg commands &rest args)
"Add the outline of a shape to SVG according to COMMANDS.
@@ -459,7 +455,7 @@ modifiers. If :relative is t, then coordinates are
relative to
the last position, or -- initially -- to the origin."
(let* ((default-relative (plist-get args :relative))
(stripped-args (svg--plist-delete args :relative))
- (d (mapconcat 'identity
+ (d (mapconcat #'identity
(mapcar
(lambda (command)
(svg--eval-path-command command
diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el
index 2e27b29..f3c2fb7 100644
--- a/lisp/tab-bar.el
+++ b/lisp/tab-bar.el
@@ -2075,6 +2075,28 @@ When `switch-to-buffer-obey-display-actions' is non-nil,
(define-key tab-prefix-map "\C-r" 'find-file-read-only-other-tab)
(define-key tab-prefix-map "t" 'other-tab-prefix)
+(defvar tab-bar-switch-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "o" 'tab-next)
+ (define-key map "O" 'tab-previous)
+ map)
+ "Keymap to repeat tab switch key sequences `C-x t o o O'.
+Used in `repeat-mode'.")
+(put 'tab-next 'repeat-map 'tab-bar-switch-repeat-map)
+(put 'tab-previous 'repeat-map 'tab-bar-switch-repeat-map)
+
+(defvar tab-bar-move-repeat-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "m" 'tab-move)
+ (define-key map "M" (lambda ()
+ (interactive)
+ (setq repeat-map 'tab-bar-move-repeat-map)
+ (tab-move -1)))
+ map)
+ "Keymap to repeat tab move key sequences `C-x t m m M'.
+Used in `repeat-mode'.")
+(put 'tab-move 'repeat-map 'tab-bar-move-repeat-map)
+
(provide 'tab-bar)
diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el
index fa9b475..3f0cca0 100644
--- a/lisp/tar-mode.el
+++ b/lisp/tar-mode.el
@@ -474,6 +474,7 @@ checksum before doing the check."
"Construct a `rw-r--r--' string indicating MODE.
MODE should be an integer which is a file mode value.
For instance, if mode is #o700, then it produces `rwx------'."
+ (declare (obsolete file-modes-number-to-symbolic "28.1"))
(substring (file-modes-number-to-symbolic mode) 1))
(defun tar-header-block-summarize (tar-hblock &optional mod-p)
@@ -489,25 +490,26 @@ For instance, if mode is #o700, then it produces
`rwx------'."
;; (ck (tar-header-checksum tar-hblock))
(type (tar-header-link-type tar-hblock))
(link-name (tar-header-link-name tar-hblock)))
- (format "%c%c%s %7s/%-7s %7s%s %s%s"
+ (format "%c%s %7s/%-7s %7s%s %s%s"
(if mod-p ?* ? )
- (cond ((or (eq type nil) (eq type 0)) ?-)
- ((eq type 1) ?h) ; link
- ((eq type 2) ?l) ; symlink
- ((eq type 3) ?c) ; char special
- ((eq type 4) ?b) ; block special
- ((eq type 5) ?d) ; directory
- ((eq type 6) ?p) ; FIFO/pipe
- ((eq type 20) ?*) ; directory listing
- ((eq type 28) ?L) ; next has longname
- ((eq type 29) ?M) ; multivolume continuation
- ((eq type 35) ?S) ; sparse
- ((eq type 38) ?V) ; volume header
- ((eq type 55) ?H) ; pax global extended header
- ((eq type 72) ?X) ; pax extended header
- (t ?\s)
- )
- (tar-grind-file-mode mode)
+ (file-modes-number-to-symbolic
+ mode
+ (cond ((or (eq type nil) (eq type 0)) ?-)
+ ((eq type 1) ?h) ; link
+ ((eq type 2) ?l) ; symlink
+ ((eq type 3) ?c) ; char special
+ ((eq type 4) ?b) ; block special
+ ((eq type 5) ?d) ; directory
+ ((eq type 6) ?p) ; FIFO/pipe
+ ((eq type 20) ?*) ; directory listing
+ ((eq type 28) ?L) ; next has longname
+ ((eq type 29) ?M) ; multivolume continuation
+ ((eq type 35) ?S) ; sparse
+ ((eq type 38) ?V) ; volume header
+ ((eq type 55) ?H) ; pax global extended header
+ ((eq type 72) ?X) ; pax extended header
+ (t ?\s)
+ ))
(if (= 0 (length uname)) uid uname)
(if (= 0 (length gname)) gid gname)
size
@@ -751,7 +753,7 @@ 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
+ :lighter nil
(or (and (boundp 'tar-superior-buffer) tar-superior-buffer)
(error "This buffer is not an element of a tar file"))
(cond (tar-subfile-mode
diff --git a/lisp/term/konsole.el b/lisp/term/konsole.el
index e38a5d3..1f65a46 100644
--- a/lisp/term/konsole.el
+++ b/lisp/term/konsole.el
@@ -9,4 +9,4 @@
(provide 'term/konsole)
-;; konsole.el ends here
+;;; konsole.el ends here
diff --git a/lisp/term/linux.el b/lisp/term/linux.el
index 35bd3ac..c6d84ab 100644
--- a/lisp/term/linux.el
+++ b/lisp/term/linux.el
@@ -1,4 +1,6 @@
-;; The Linux console handles Latin-1 by default. -*- lexical-binding:t -*-
+;;; linux.el -*- lexical-binding:t -*-
+
+;; The Linux console handles Latin-1 by default.
(declare-function gpm-mouse-enable "t-mouse" ())
diff --git a/lisp/term/lk201.el b/lisp/term/lk201.el
index 3bcaa2e..c280247 100644
--- a/lisp/term/lk201.el
+++ b/lisp/term/lk201.el
@@ -1,4 +1,4 @@
-;; Define function key sequences for DEC terminals. -*- lexical-binding: t -*-
+;;; lk201.el --- Define function key sequences for DEC terminals. -*-
lexical-binding: t -*-
(defvar lk201-function-map
(let ((map (make-sparse-keymap)))
diff --git a/lisp/term/screen.el b/lisp/term/screen.el
index 04481e8..9655f41 100644
--- a/lisp/term/screen.el
+++ b/lisp/term/screen.el
@@ -22,4 +22,4 @@ it runs, which can change when the screen session is moved to
another tty."
(provide 'term/screen)
-;; screen.el ends here
+;;; screen.el ends here
diff --git a/lisp/term/st.el b/lisp/term/st.el
index 08432c4..9a1c064 100644
--- a/lisp/term/st.el
+++ b/lisp/term/st.el
@@ -17,4 +17,4 @@
(provide 'term/st)
-;; st.el ends here
+;;; st.el ends here
diff --git a/lisp/term/tmux.el b/lisp/term/tmux.el
index aa0c983..4ea6f41 100644
--- a/lisp/term/tmux.el
+++ b/lisp/term/tmux.el
@@ -22,4 +22,4 @@ it runs, which can change when the tmux session is moved to
another tty."
(provide 'term/tmux)
-;; tmux.el ends here
+;;; tmux.el ends here
diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el
index 687250f..6b84916 100644
--- a/lisp/term/w32-win.el
+++ b/lisp/term/w32-win.el
@@ -284,7 +284,8 @@ See the documentation of `create-fontset-from-fontset-spec'
for the format.")
'(libxml2 "libxml2-2.dll" "libxml2.dll")
'(zlib "zlib1.dll" "libz-1.dll")
'(lcms2 "liblcms2-2.dll")
- '(json "libjansson-4.dll")))
+ '(json "libjansson-4.dll")
+ '(gccjit "libgccjit-0.dll")))
;;; multi-tty support
(defvar w32-initialized nil
diff --git a/lisp/term/w32console.el b/lisp/term/w32console.el
index 4a925cd..1a5dc05 100644
--- a/lisp/term/w32console.el
+++ b/lisp/term/w32console.el
@@ -1,4 +1,4 @@
-;;; w32console.el -- Setup w32 console keys and colors. -*- lexical-binding:
t; -*-
+;;; w32console.el --- Setup w32 console keys and colors. -*- lexical-binding:
t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el
index dc45a73..d9a83c5 100644
--- a/lisp/textmodes/artist.el
+++ b/lisp/textmodes/artist.el
@@ -33,7 +33,7 @@
;; What is artist?
;; ---------------
;;
-;; Artist is an Emacs lisp package that allows you to draw lines,
+;; Artist is an Emacs Lisp package that allows you to draw lines,
;; rectangles and ellipses by using your mouse and/or keyboard. The
;; shapes are made up with the ascii characters |, -, / and \.
;;
@@ -106,13 +106,6 @@
;; If you add a new drawing mode, send it to me, and I would gladly
;; include in the next release!
-;;; Installation:
-
-;; To use artist, put this in your .emacs:
-;;
-;; (autoload 'artist-mode "artist" "Enter artist-mode" t)
-
-
;;; Requirements:
;; Artist requires the `rect' package (which comes with Emacs) to be
@@ -1760,13 +1753,6 @@ info-variant-part."
"Call function FN with ARGS, if FN is not nil."
`(if ,fn (funcall ,fn ,@args)))
-(defun artist-uniq (l)
- "Remove consecutive duplicates in list L. Comparison is done with `equal'."
- (cond ((null l) nil)
- ((null (cdr l)) l) ; only one element in list
- ((equal (car l) (car (cdr l))) (artist-uniq (cdr l))) ; first 2 equal
- (t (cons (car l) (artist-uniq (cdr l)))))) ; first 2 are different
-
(defun artist-string-split (str r)
"Split string STR at occurrences of regexp R, returning a list of strings."
(let ((res nil)
@@ -2768,7 +2754,7 @@ to append to the end of the list, when doing free-hand
drawing)."
Also, the `artist-key-poly-point-list' is reversed."
(setq artist-key-poly-point-list
- (artist-uniq artist-key-poly-point-list))
+ (seq-uniq artist-key-poly-point-list))
(if (>= (length artist-key-poly-point-list) 2)
@@ -5379,10 +5365,7 @@ The event, EV, is the mouse event."
(concat "Hello Tomas,\n\n"
"I have a nice bug report on Artist for you! Here it is:")))))
-
-;;
-;; Now provide this minor mode
-;;
+(define-obsolete-function-alias 'artist-uniq #'seq-uniq "28.1")
(provide 'artist)
diff --git a/lisp/textmodes/bibtex-style.el b/lisp/textmodes/bibtex-style.el
index 6d01871..27b2e0e 100644
--- a/lisp/textmodes/bibtex-style.el
+++ b/lisp/textmodes/bibtex-style.el
@@ -24,7 +24,6 @@
;; Done: font-lock, imenu, outline, commenting, indentation.
;; Todo: tab-completion.
-;; Bugs:
;;; Code:
diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el
index f01c66b..31186fb 100644
--- a/lisp/textmodes/bibtex.el
+++ b/lisp/textmodes/bibtex.el
@@ -5608,8 +5608,5 @@ If APPEND is non-nil, append ENTRIES to those already
displayed."
(setq buffer-read-only t)
(goto-char (point-min)))
-
-;; Make BibTeX a Feature
-
(provide 'bibtex)
;;; bibtex.el ends here
diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el
index cb5027a..3914bde 100644
--- a/lisp/textmodes/fill.el
+++ b/lisp/textmodes/fill.el
@@ -49,10 +49,12 @@ A value of nil means that any change in indentation starts
a new paragraph."
(defcustom fill-separate-heterogeneous-words-with-space nil
"Non-nil means to use a space to separate words of a different kind.
-This will be done with a word in the end of a line and a word in
-the beginning of the next line when concatenating them for
-filling those lines. Whether to use a space depends on how the
-words are categorized."
+For example, when an English word at the end of a line and a CJK word
+at the beginning of the next line are joined into a single line, they
+will be separated by a space if this variable is non-nil.
+Whether to use a space to separate such words also depends on the entry
+in `fill-nospace-between-words-table' for the characters before and
+after the newline."
:type 'boolean
:version "26.1")
@@ -412,12 +414,12 @@ and `fill-nobreak-invisible'."
;; Register `kinsoku' for scripts HAN, KANA, BOPOMOFO, and CJK-MISC.
;; Also tell that they don't use space between words.
(map-char-table
- #'(lambda (key val)
- (when (memq val '(han kana bopomofo cjk-misc))
- (set-char-table-range fill-find-break-point-function-table
- key 'kinsoku)
- (set-char-table-range fill-nospace-between-words-table
- key t)))
+ (lambda (key val)
+ (when (memq val '(han kana bopomofo cjk-misc))
+ (set-char-table-range fill-find-break-point-function-table
+ key 'kinsoku)
+ (set-char-table-range fill-nospace-between-words-table
+ key t)))
char-script-table)
;; Do the same thing also for full width characters and half
;; width kana variants.
diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el
index a48b345..8d2715f 100644
--- a/lisp/textmodes/flyspell.el
+++ b/lisp/textmodes/flyspell.el
@@ -77,7 +77,7 @@ Detection of repeated words is not implemented in
"A list of exceptions for duplicated words.
It should be a list of (LANGUAGE . EXCEPTION-LIST).
-LANGUAGE is nil, which means the exceptions apply regardless of
+LANGUAGE can be nil, which means the exceptions apply regardless of
the current dictionary, or a regular expression matching the
dictionary name (`ispell-local-dictionary' or
`ispell-dictionary') for which the exceptions should apply.
diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el
index cee578f..932308e 100644
--- a/lisp/textmodes/ispell.el
+++ b/lisp/textmodes/ispell.el
@@ -1207,9 +1207,9 @@ If LANG is omitted, get the extra word characters for the
default language."
(split-string
(ispell--call-enchant-lsmod "-list-dicts") " ([^)]+)\n" t))
(found
- (mapcar #'(lambda (lang)
- `(,lang "[[:alpha:]]" "[^[:alpha:]]"
- ,(ispell--get-extra-word-characters lang) t nil
nil utf-8))
+ (mapcar (lambda (lang)
+ `(,lang "[[:alpha:]]" "[^[:alpha:]]"
+ ,(ispell--get-extra-word-characters lang) t nil
nil utf-8))
dictionaries)))
;; Merge into FOUND any elements from the standard
ispell-dictionary-base-alist
;; which have no element in FOUND at all.
@@ -3744,7 +3744,7 @@ SPC.
For spell-checking \"on the fly\", not just after typing SPC or
RET, use `flyspell-mode'."
- nil " Spell" ispell-minor-keymap)
+ :lighter " Spell" :keymap ispell-minor-keymap)
(defun ispell-minor-check ()
"Check previous word, then continue with the normal binding of this key.
diff --git a/lisp/textmodes/makeinfo.el b/lisp/textmodes/makeinfo.el
index 8152f4b..653540a 100644
--- a/lisp/textmodes/makeinfo.el
+++ b/lisp/textmodes/makeinfo.el
@@ -284,7 +284,6 @@ line LINE of the window, or centered if LINE is nil."
(pop-to-buffer old-buffer)
)))
-;;; Place `provide' at end of file.
(provide 'makeinfo)
;;; makeinfo.el ends here
diff --git a/lisp/textmodes/page.el b/lisp/textmodes/page.el
index e1d7fb7..b86a2f1 100644
--- a/lisp/textmodes/page.el
+++ b/lisp/textmodes/page.el
@@ -170,8 +170,6 @@ point, respectively."
(interactive)
(apply #'message (cons "Page %d, line %d" (page--what-page))))
-
-;;; Place `provide' at end of file.
(provide 'page)
;;; page.el ends here
diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el
index 31e91c7..59b15e8 100644
--- a/lisp/textmodes/paragraphs.el
+++ b/lisp/textmodes/paragraphs.el
@@ -202,8 +202,6 @@ This is desirable in modes where blank lines are the
paragraph delimiters."
(put 'paragraph-ignore-fill-prefix 'safe-local-variable #'booleanp)
;; Silence the compiler.
-(defvar multiple-lines)
-
(defun forward-paragraph (&optional arg)
"Move forward to end of paragraph.
With argument ARG, do it ARG times;
@@ -262,13 +260,13 @@ Returns the count of paragraphs left to move."
;; Search back for line that starts or separates paragraphs.
(if (if fill-prefix-regexp
;; There is a fill prefix; it overrides parstart.
- (let (multiple-lines)
+ (let () ;; multiple-lines
(while (and (progn (beginning-of-line) (not (bobp)))
(progn (move-to-left-margin)
(not (looking-at parsep)))
(looking-at fill-prefix-regexp))
- (unless (= (point) start)
- (setq multiple-lines t))
+ ;; (unless (= (point) start)
+ ;; (setq multiple-lines t))
(forward-line -1))
(move-to-left-margin)
;; This deleted code caused a long hanging-indent line
diff --git a/lisp/textmodes/refer.el b/lisp/textmodes/refer.el
index 53519ac..e710180 100644
--- a/lisp/textmodes/refer.el
+++ b/lisp/textmodes/refer.el
@@ -245,10 +245,10 @@ found on the last `refer-find-entry' or
`refer-find-next-entry'."
(forward-paragraph 1)
(setq end (point))
(setq found
- (refer-every (lambda (keyword)
- (goto-char begin)
- (re-search-forward keyword end t))
- keywords-list))
+ (seq-every-p (lambda (keyword)
+ (goto-char begin)
+ (re-search-forward keyword end t))
+ keywords-list))
(if (not found)
(progn
(setq begin end)
@@ -260,12 +260,6 @@ found on the last `refer-find-entry' or
`refer-find-next-entry'."
(progn (message "Scanning %s... not found" file)
nil))))
-(defun refer-every (pred l)
- (cond ((null l) nil)
- ((funcall pred (car l))
- (or (null (cdr l))
- (refer-every pred (cdr l))))))
-
(defun refer-convert-string-to-list-of-strings (s)
(let ((current (current-buffer))
(temp-buffer (get-buffer-create "*refer-temp*")))
@@ -391,4 +385,6 @@ found on the last `refer-find-entry' or
`refer-find-next-entry'."
(setq refer-bib-files files))
files))
+(define-obsolete-function-alias 'refer-every #'seq-every-p "28.1")
+
;;; refer.el ends here
diff --git a/lisp/textmodes/reftex-auc.el b/lisp/textmodes/reftex-auc.el
index 8429fce..977da70 100644
--- a/lisp/textmodes/reftex-auc.el
+++ b/lisp/textmodes/reftex-auc.el
@@ -32,11 +32,12 @@
(optional prompt default &optional complete))
(declare-function TeX-argument-insert "ext:tex"
(name optional &optional prefix))
-(declare-function LaTeX-add-labels "ext:tex" (&rest entries) t)
-(declare-function LaTeX-add-index-entries "ext:tex" (&rest entries) t)
-(declare-function LaTeX-bibitem-list "ext:tex" () t)
-(declare-function LaTeX-index-entry-list "ext:tex" () t)
-(declare-function LaTeX-label-list "ext:tex" () t)
+(declare-function LaTeX-add-labels "ext:latex" (&rest labels) t)
+(declare-function LaTeX-add-index-entries "ext:latex" (&rest index-entries) t)
+(declare-function LaTeX-add-bibitems "ext:latex" (&rest bibitems) t)
+(declare-function LaTeX-bibitem-list "ext:latex" () t)
+(declare-function LaTeX-index-entry-list "ext:latex" () t)
+(declare-function LaTeX-label-list "ext:latex" () t)
(declare-function multi-prompt "ext:multi-prompt"
(separator unique prompt table &optional
mp-predicate require-match initial history))
@@ -69,8 +70,6 @@ What is being used depends upon `reftex-plug-into-AUCTeX'."
(LaTeX-add-labels label))
(TeX-argument-insert label optional)))
-(declare-function LaTeX-add-bibitems "latex") ;FIXME: Can't find the definition
-
;;;###autoload
(defun reftex-arg-cite (optional &optional prompt definition)
"Use `reftex-citation' or AUCTeX's code to insert a cite-key macro argument.
@@ -88,7 +87,6 @@ What is being used depends upon `reftex-plug-into-AUCTeX'."
(TeX-argument-insert (mapconcat #'identity items reftex-cite-key-separator)
optional)))
-
;;;###autoload
(defun reftex-arg-index-tag (optional &optional prompt &rest _args)
"Prompt for an index tag with completion.
diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el
index a65772d..0d6bfb5 100644
--- a/lisp/textmodes/reftex-vars.el
+++ b/lisp/textmodes/reftex-vars.el
@@ -888,50 +888,46 @@ DOWNCASE t: Downcase words before using them."
(string :tag ""))
(option (boolean :tag "Downcase words "))))
-(if (featurep 'xemacs)
- ;; XEmacs 21.5 doesn't have explicitly numbered matching groups,
- ;; so this list mustn't get any more items.
- (defconst reftex-label-regexps '("\\\\label{\\([^}]*\\)}"))
- (defcustom reftex-label-regexps
- `(;; Normal \\label{foo} labels
- "\\\\label{\\(?1:[^}]*\\)}"
- ;; keyvals [..., label = {foo}, ...] forms used by ctable,
- ;; listings, breqn, ...
- ,(concat
- ;; Make sure we search only for optional arguments of
- ;; environments/macros and don't match any other [. ctable
- ;; provides a macro called \ctable, beamer/breqn/listings have
- ;; environments. Start with a backslash and a group for names
- "\\\\\\(?:"
- ;; begin, optional spaces and opening brace
- "begin[[:space:]]*{"
- ;; Build a regexp for env names
- (regexp-opt '("lstlisting" "dmath" "dseries" "dgroup"
- "darray" "frame"))
- ;; closing brace, optional spaces
- "}[[:space:]]*"
- ;; Now for macros
- "\\|"
- ;; Build a regexp for macro names; currently only \ctable
- (regexp-opt '("ctable"))
- ;; Close the group for names
- "\\)"
- ;; Match the opening [ and the following chars
- "\\[[^][]*"
- ;; Allow nested levels of chars enclosed in braces
- "\\(?:{[^}{]*"
- "\\(?:{[^}{]*"
- "\\(?:{[^}{]*}[^}{]*\\)*"
- "}[^}{]*\\)*"
- "}[^][]*\\)*"
- ;; Match the label key
- "\\<label[[:space:]]*=[[:space:]]*"
- ;; Match the label value; braces around the value are
- ;; optional.
- "{?\\(?1:[^] ,}\r\n\t%]+\\)"
- ;; We are done. Just search until the next closing bracket
- "[^]]*\\]"))
- "List of regexps matching \\label definitions.
+(defcustom reftex-label-regexps
+ `(;; Normal \\label{foo} labels
+ "\\\\label{\\(?1:[^}]*\\)}"
+ ;; keyvals [..., label = {foo}, ...] forms used by ctable,
+ ;; listings, breqn, ...
+ ,(concat
+ ;; Make sure we search only for optional arguments of
+ ;; environments/macros and don't match any other [. ctable
+ ;; provides a macro called \ctable, beamer/breqn/listings have
+ ;; environments. Start with a backslash and a group for names
+ "\\\\\\(?:"
+ ;; begin, optional spaces and opening brace
+ "begin[[:space:]]*{"
+ ;; Build a regexp for env names
+ (regexp-opt '("lstlisting" "dmath" "dseries" "dgroup"
+ "darray" "frame"))
+ ;; closing brace, optional spaces
+ "}[[:space:]]*"
+ ;; Now for macros
+ "\\|"
+ ;; Build a regexp for macro names; currently only \ctable
+ (regexp-opt '("ctable"))
+ ;; Close the group for names
+ "\\)"
+ ;; Match the opening [ and the following chars
+ "\\[[^][]*"
+ ;; Allow nested levels of chars enclosed in braces
+ "\\(?:{[^}{]*"
+ "\\(?:{[^}{]*"
+ "\\(?:{[^}{]*}[^}{]*\\)*"
+ "}[^}{]*\\)*"
+ "}[^][]*\\)*"
+ ;; Match the label key
+ "\\<label[[:space:]]*=[[:space:]]*"
+ ;; Match the label value; braces around the value are
+ ;; optional.
+ "{?\\(?1:[^] ,}\r\n\t%]+\\)"
+ ;; We are done. Just search until the next closing bracket
+ "[^]]*\\]"))
+ "List of regexps matching \\label definitions.
The default value matches usual \\label{...} definitions and
keyval style [..., label = {...}, ...] label definitions. The
regexp for keyval style explicitly looks for environments
@@ -946,13 +942,13 @@ you have to define it using \\(?1:...\\) when adding new
regexps.
When changed from Lisp, make sure to call
`reftex-compile-variables' afterwards to make the change
effective."
- :version "28.1"
- :set (lambda (symbol value)
- (set symbol value)
- (when (fboundp 'reftex-compile-variables)
- (reftex-compile-variables)))
- :group 'reftex-defining-label-environments
- :type '(repeat (regexp :tag "Regular Expression"))))
+ :version "28.1"
+ :set (lambda (symbol value)
+ (set symbol value)
+ (when (fboundp 'reftex-compile-variables)
+ (reftex-compile-variables)))
+ :group 'reftex-defining-label-environments
+ :type '(repeat (regexp :tag "Regular Expression")))
(defcustom reftex-label-ignored-macros-and-environments nil
"List of macros and environments to be ignored when searching for labels.
diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el
index b731c12..4acdc9f 100644
--- a/lisp/textmodes/remember.el
+++ b/lisp/textmodes/remember.el
@@ -1,4 +1,4 @@
-;;; remember --- a mode for quickly jotting down things to remember -*-
lexical-binding: t; -*-
+;;; remember.el --- a mode for quickly jotting down things to remember -*-
lexical-binding: t; -*-
;; Copyright (C) 1999-2001, 2003-2021 Free Software Foundation, Inc.
@@ -176,14 +176,8 @@
;;
;; 2003.08.12 Sacha's birthday
-;;; History:
-
;;; Code:
-(defconst remember-version "2.0"
- "This version of remember.")
-(make-obsolete-variable 'remember-version nil "28.1")
-
(defgroup remember nil
"A mode to remember information."
:group 'data)
@@ -613,7 +607,7 @@ This sets `buffer-save-without-query' so that
`save-some-buffers' will
save the notes buffer without asking.
\\{remember-notes-mode-map}"
- nil nil nil
+ :lighter nil
(cond
(remember-notes-mode
(add-hook 'kill-buffer-query-functions
@@ -673,6 +667,11 @@ is non-nil, bury it and return nil; otherwise return t."
nil)
t))
+;; Obsolete
+
+(defconst remember-version "2.0" "This version of remember.")
+(make-obsolete-variable 'remember-version 'emacs-version "28.1")
+
(provide 'remember)
;;; remember.el ends here
diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el
index ce15637..1471be0 100644
--- a/lisp/textmodes/rst.el
+++ b/lisp/textmodes/rst.el
@@ -554,30 +554,30 @@ After interpretation of ARGS the results are concatenated
as for
`:seq'."
(apply #'concat
(mapcar
- #'(lambda (re)
- (cond
- ((stringp re)
- re)
- ((symbolp re)
- (cadr (assoc re rst-re-alist)))
- ((characterp re)
- (regexp-quote (char-to-string re)))
- ((listp re)
- (let ((nested
- (mapcar #'rst-re (cdr re))))
- (cond
- ((eq (car re) :seq)
- (mapconcat #'identity nested ""))
- ((eq (car re) :shy)
- (concat "\\(?:" (mapconcat #'identity nested "") "\\)"))
- ((eq (car re) :grp)
- (concat "\\(" (mapconcat #'identity nested "") "\\)"))
- ((eq (car re) :alt)
- (concat "\\(?:" (mapconcat #'identity nested "\\|") "\\)"))
- (t
- (error "Unknown list car: %s" (car re))))))
- (t
- (error "Unknown object type for building regex: %s" re))))
+ (lambda (re)
+ (cond
+ ((stringp re)
+ re)
+ ((symbolp re)
+ (cadr (assoc re rst-re-alist)))
+ ((characterp re)
+ (regexp-quote (char-to-string re)))
+ ((listp re)
+ (let ((nested
+ (mapcar #'rst-re (cdr re))))
+ (cond
+ ((eq (car re) :seq)
+ (mapconcat #'identity nested ""))
+ ((eq (car re) :shy)
+ (concat "\\(?:" (mapconcat #'identity nested "") "\\)"))
+ ((eq (car re) :grp)
+ (concat "\\(" (mapconcat #'identity nested "") "\\)"))
+ ((eq (car re) :alt)
+ (concat "\\(?:" (mapconcat #'identity nested "\\|") "\\)"))
+ (t
+ (error "Unknown list car: %s" (car re))))))
+ (t
+ (error "Unknown object type for building regex: %s" re))))
args)))
;; FIXME: Remove circular dependency between `rst-re' and `rst-re-alist'.
@@ -709,8 +709,8 @@ Return CHAR if so or signal an error otherwise."
;; testcover: ok.
"Return position of SELF in ADOS or nil."
(cl-check-type self rst-Ado)
- (cl-position-if #'(lambda (e)
- (rst-Ado-equal self e))
+ (cl-position-if (lambda (e)
+ (rst-Ado-equal self e))
ados))
@@ -814,8 +814,8 @@ Return ADO if so or signal an error otherwise."
"Return sublist of HDRS whose car's adornment equals that of SELF or nil."
(cl-check-type self rst-Hdr)
(let ((ado (rst-Hdr-ado self)))
- (cl-member-if #'(lambda (hdr)
- (rst-Ado-equal ado (rst-Hdr-ado hdr)))
+ (cl-member-if (lambda (hdr)
+ (rst-Ado-equal ado (rst-Hdr-ado hdr)))
hdrs)))
(defun rst-Hdr-ado-map (selves)
@@ -1277,8 +1277,8 @@ This inherits from Text mode.")
;; Abbrevs.
(define-abbrev-table 'rst-mode-abbrev-table
- (mapcar #'(lambda (x)
- (append x '(nil 0 system)))
+ (mapcar (lambda (x)
+ (append x '(nil 0 system)))
'(("contents" ".. contents::\n..\n ")
("con" ".. contents::\n..\n ")
("cont" "[...]")
@@ -1408,13 +1408,11 @@ highlighting.
When ReST minor mode is enabled, the ReST mode keybindings
are installed on top of the major mode bindings. Use this
for modes derived from Text mode, like Mail mode."
- ;; The initial value.
- nil
- ;; The indicator for the mode line.
- " ReST"
- ;; The minor mode bindings.
- rst-mode-map
- :group 'rst)
+ ;; The indicator for the mode line.
+ :lighter " ReST"
+ ;; The minor mode bindings.
+ :keymap rst-mode-map
+ :group 'rst)
;; FIXME: can I somehow install these too?
;; :abbrev-table rst-mode-abbrev-table
@@ -1501,9 +1499,9 @@ file."
:type `(repeat
(group :tag "Adornment specification"
(choice :tag "Adornment character"
- ,@(mapcar #'(lambda (char)
- (list 'const
- :tag (char-to-string char) char))
+ ,@(mapcar (lambda (char)
+ (list 'const
+ :tag (char-to-string char) char))
rst-adornment-chars))
(radio :tag "Adornment type"
(const :tag "Overline and underline" over-and-under)
@@ -1540,8 +1538,8 @@ search starts after this entry. Return nil if no new
preferred
;; Start searching after the level of the previous adornment.
(cdr (rst-Hdr-member-ado prev (rst-Hdr-preferred-adornments))))
(rst-Hdr-preferred-adornments))))
- (cl-find-if #'(lambda (cand)
- (not (rst-Hdr-member-ado cand seen)))
+ (cl-find-if (lambda (cand)
+ (not (rst-Hdr-member-ado cand seen)))
candidates)))
(defun rst-update-section (hdr)
@@ -1620,55 +1618,55 @@ returned."
(ttl-blw ; Title found below starting here.
(rst-forward-line-looking-at
+1 'ttl-beg-1
- #'(lambda (mtcd)
- (when mtcd
- (setq txt-blw (match-string-no-properties 1))
- (point)))))
+ (lambda (mtcd)
+ (when mtcd
+ (setq txt-blw (match-string-no-properties 1))
+ (point)))))
txt-abv
(ttl-abv ; Title found above starting here.
(rst-forward-line-looking-at
-1 'ttl-beg-1
- #'(lambda (mtcd)
- (when mtcd
- (setq txt-abv (match-string-no-properties 1))
- (point)))))
+ (lambda (mtcd)
+ (when mtcd
+ (setq txt-abv (match-string-no-properties 1))
+ (point)))))
(und-fnd ; Matching underline found starting here.
(and ttl-blw
(rst-forward-line-looking-at
+2 (list ado-re 'lin-end)
- #'(lambda (mtcd)
- (when mtcd
- (point))))))
+ (lambda (mtcd)
+ (when mtcd
+ (point))))))
(ovr-fnd ; Matching overline found starting here.
(and ttl-abv
(rst-forward-line-looking-at
-2 (list ado-re 'lin-end)
- #'(lambda (mtcd)
- (when mtcd
- (point))))))
+ (lambda (mtcd)
+ (when mtcd
+ (point))))))
(und-wng ; Wrong underline found starting here.
(and ttl-blw
(not und-fnd)
(rst-forward-line-looking-at
+2 'ado-beg-2-1
- #'(lambda (mtcd)
- (when mtcd
- (point))))))
+ (lambda (mtcd)
+ (when mtcd
+ (point))))))
(ovr-wng ; Wrong overline found starting here.
(and ttl-abv (not ovr-fnd)
(rst-forward-line-looking-at
-2 'ado-beg-2-1
- #'(lambda (mtcd)
- (when (and
- mtcd
- ;; An adornment above may be a legal
- ;; adornment for the line above - consider it
- ;; a wrong overline only when it is equally
- ;; long.
- (equal
- (length (match-string-no-properties 1))
- (length adornment)))
- (point)))))))
+ (lambda (mtcd)
+ (when (and
+ mtcd
+ ;; An adornment above may be a legal
+ ;; adornment for the line above - consider it
+ ;; a wrong overline only when it is equally
+ ;; long.
+ (equal
+ (length (match-string-no-properties 1))
+ (length adornment)))
+ (point)))))))
(cond
((and nxt-emp prv-emp)
;; A transition.
@@ -1708,11 +1706,11 @@ a section header or nil if no title line is found."
(rst-forward-line-strict 0))
(let* (cnd-beg ; Beginning of a title candidate.
cnd-txt ; Text of a title candidate.
- (cnd-fun #'(lambda (mtcd) ; Function setting title candidate data.
- (when mtcd
- (setq cnd-beg (match-beginning 0))
- (setq cnd-txt (match-string-no-properties 1))
- t)))
+ (cnd-fun (lambda (mtcd) ; Function setting title candidate data.
+ (when mtcd
+ (setq cnd-beg (match-beginning 0))
+ (setq cnd-txt (match-string-no-properties 1))
+ t)))
ttl)
(cond
((looking-at (rst-re 'ado-beg-2-1))
@@ -1728,10 +1726,10 @@ a section header or nil if no title line is found."
;; Title line found - check for a following underline.
(setq ttl (rst-forward-line-looking-at
1 'ado-beg-2-1
- #'(lambda (mtcd)
- (when mtcd
- (rst-classify-adornment
- (match-string-no-properties 0) (match-end 0))))))
+ (lambda (mtcd)
+ (when mtcd
+ (rst-classify-adornment
+ (match-string-no-properties 0) (match-end 0))))))
;; Title candidate found if no valid adornment found.
(funcall cnd-fun (not ttl))))
(cond
@@ -1827,15 +1825,15 @@ given."
(ignore-ttl
(if ignore-position
(cl-find-if
- #'(lambda (ttl)
- (equal (rst-Ttl-contains ttl ignore-position) 0))
+ (lambda (ttl)
+ (equal (rst-Ttl-contains ttl ignore-position) 0))
all-ttls)))
(really-ignore
(if ignore-ttl
(<= (cl-count-if
- #'(lambda (ttl)
- (rst-Ado-equal (rst-Ttl-ado ignore-ttl)
- (rst-Ttl-ado ttl)))
+ (lambda (ttl)
+ (rst-Ado-equal (rst-Ttl-ado ignore-ttl)
+ (rst-Ttl-ado ttl)))
all-ttls)
1)))
(real-ttls (delq (if really-ignore ignore-ttl) all-ttls)))
@@ -1859,14 +1857,14 @@ given."
Return a list of (`rst-Ttl' . LEVEL) with ascending line number."
(let ((hier (rst-Hdr-ado-map (rst-hdr-hierarchy))))
(mapcar
- #'(lambda (ttl)
- (cons ttl (rst-Ado-position (rst-Ttl-ado ttl) hier)))
+ (lambda (ttl)
+ (cons ttl (rst-Ado-position (rst-Ttl-ado ttl) hier)))
(rst-all-ttls))))
(defun rst-get-previous-hdr ()
"Return the `rst-Hdr' before point or nil if none."
- (let ((prev (cl-find-if #'(lambda (ttl)
- (< (rst-Ttl-contains ttl (point)) 0))
+ (let ((prev (cl-find-if (lambda (ttl)
+ (< (rst-Ttl-contains ttl (point)) 0))
(rst-all-ttls)
:from-end t)))
(and prev (rst-Ttl-hdr prev))))
@@ -2169,19 +2167,19 @@ hierarchy is similar to that used by
`rst-adjust-section'."
(let* ((beg (region-beginning))
(end (region-end))
(ttls-reg (cl-remove-if-not
- #'(lambda (ttl)
- (and
- (>= (rst-Ttl-contains ttl beg) 0)
- (< (rst-Ttl-contains ttl end) 0)))
+ (lambda (ttl)
+ (and
+ (>= (rst-Ttl-contains ttl beg) 0)
+ (< (rst-Ttl-contains ttl end) 0)))
(rst-all-ttls))))
(save-excursion
;; Apply modifications.
(rst-destructuring-dolist
((marker &rest hdr
&aux (hier (rst-hdr-hierarchy)))
- (mapcar #'(lambda (ttl)
- (cons (copy-marker (rst-Ttl-get-title-beginning ttl))
- (rst-Ttl-hdr ttl)))
+ (mapcar (lambda (ttl)
+ (cons (copy-marker (rst-Ttl-get-title-beginning ttl))
+ (rst-Ttl-hdr ttl)))
ttls-reg))
(set-marker
(goto-char marker) nil)
@@ -2391,9 +2389,9 @@ also arranged by `rst-insert-list-new-tag'."
"List of favorite bullets."
:group 'rst
:type `(repeat
- (choice ,@(mapcar #'(lambda (char)
- (list 'const
- :tag (char-to-string char) char))
+ (choice ,@(mapcar (lambda (char)
+ (list 'const
+ :tag (char-to-string char) char))
rst-bullets)))
:package-version '(rst . "1.1.0"))
@@ -2517,13 +2515,13 @@ ordered by POINT."
(looking-at (rst-re rst-re-beg)) ; Start found
(not (rst-forward-line-looking-at
-1 'lin-end
- #'(lambda (mtcd) ; Previous line exists and is...
- (and
- (not mtcd) ; non-empty,
- (<= (current-indentation) clm) ; less indented
- (not (and (= (current-indentation) clm)
+ (lambda (mtcd) ; Previous line exists and is...
+ (and
+ (not mtcd) ; non-empty,
+ (<= (current-indentation) clm) ; less indented
+ (not (and (= (current-indentation) clm)
; not a beg at same level.
- (looking-at (rst-re rst-re-beg)))))))))
+ (looking-at (rst-re rst-re-beg)))))))))
(back-to-indentation)
(push (cons (point) clm) r)))
(1value ; At least one line is moved in this loop.
@@ -2553,8 +2551,8 @@ modified."
((bullet _clm &rest pnts)
;; Zip preferred bullets and sorted columns associating a bullet
;; with a column and all the points this column is found.
- (cl-mapcar #'(lambda (bullet clm2pnt)
- (cons bullet clm2pnt))
+ (cl-mapcar (lambda (bullet clm2pnt)
+ (cons bullet clm2pnt))
rst-preferred-bullets
(sort clm2pnts #'car-less-than-car)))
;; Replace the bullets by the preferred ones.
@@ -2614,8 +2612,8 @@ section headers at all."
(when (>= point (rst-Stn-get-title-beginning stn))
;; Point may be in this section or a child.
(let ((in-child (cl-find-if
- #'(lambda (child)
- (>= point (rst-Stn-get-title-beginning child)))
+ (lambda (child)
+ (>= point (rst-Stn-get-title-beginning child)))
(rst-Stn-children stn)
:from-end t)))
(if in-child
@@ -2829,18 +2827,18 @@ file-write hook to always make it up-to-date
automatically."
(and beg
(rst-forward-line-looking-at
1 'lin-end
- #'(lambda (mtcd)
- (unless mtcd
- (rst-apply-indented-blocks
- (point) (point-max) (current-indentation)
- #'(lambda (count _in-first _in-sub in-super in-empty
- _relind)
- (cond
- ((or (> count 1) in-super))
- ((not in-empty)
- (setq fnd (line-end-position))
- nil)))))
- t)))
+ (lambda (mtcd)
+ (unless mtcd
+ (rst-apply-indented-blocks
+ (point) (point-max) (current-indentation)
+ (lambda (count _in-first _in-sub in-super in-empty
+ _relind)
+ (cond
+ ((or (> count 1) in-super))
+ ((not in-empty)
+ (setq fnd (line-end-position))
+ nil)))))
+ t)))
(when fnd
(delete-region beg fnd))
(goto-char beg)
@@ -3024,14 +3022,14 @@ direction."
(contained nil) ; Title contains point (or is after point otherwise).
(found (or (cl-position-if
;; Find a title containing or after point.
- #'(lambda (ttl)
- (let ((cmp (rst-Ttl-contains ttl pnt)))
- (cond
- ((= cmp 0) ; Title contains point.
- (setq contained t)
- t)
- ((> cmp 0) ; Title after point.
- t))))
+ (lambda (ttl)
+ (let ((cmp (rst-Ttl-contains ttl pnt)))
+ (cond
+ ((= cmp 0) ; Title contains point.
+ (setq contained t)
+ t)
+ ((> cmp 0) ; Title after point.
+ t))))
ttls)
;; Point after all titles.
count))
@@ -3290,8 +3288,8 @@ remove all indentation (CNT = 0). A tab is taken from
the text
above. If no suitable tab is found `rst-indent-width' is used."
(interactive "r\np")
(let ((tabs (sort (rst-compute-tabs beg)
- #'(lambda (x y)
- (<= x y))))
+ (lambda (x y)
+ (<= x y))))
(leftmostcol (rst-find-leftmost-column beg end)))
(when (or (> leftmostcol 0) (> cnt 0))
;; Apply the indent.
@@ -3306,8 +3304,8 @@ above. If no suitable tab is found `rst-indent-width' is
used."
(dir (cl-signum cnt)) ; Direction to take.
(abs (abs cnt)) ; Absolute number of steps to take.
;; Get the position of the first tab beyond leftmostcol.
- (fnd (cl-position-if #'(lambda (elt)
- (funcall cmp elt leftmostcol))
+ (fnd (cl-position-if (lambda (elt)
+ (funcall cmp elt leftmostcol))
tabs))
;; Virtual position of tab.
(pos (+ (or fnd len) (1- abs)))
@@ -3492,20 +3490,20 @@ do all lines instead of just paragraphs."
(indent ""))
(rst-apply-indented-blocks
beg end (rst-find-leftmost-column beg end)
- #'(lambda (count in-first in-sub in-super in-empty _relind)
- (cond
- (in-empty)
- (in-super)
- ((zerop count))
- (in-sub
- (insert indent))
- ((or in-first all)
- (let ((tag (format "%d. " (cl-incf enum))))
- (setq indent (make-string (length tag) ? ))
- (insert tag)))
- (t
- (insert indent)))
- nil))))
+ (lambda (count in-first in-sub in-super in-empty _relind)
+ (cond
+ (in-empty)
+ (in-super)
+ ((zerop count))
+ (in-sub
+ (insert indent))
+ ((or in-first all)
+ (let ((tag (format "%d. " (cl-incf enum))))
+ (setq indent (make-string (length tag) ? ))
+ (insert tag)))
+ (t
+ (insert indent)))
+ nil))))
;; FIXME: Does not deal with deeper indentation - although
;; `rst-apply-indented-blocks' could.
@@ -3520,18 +3518,18 @@ do all lines instead of just paragraphs."
(indent (make-string (length bul) ? )))
(rst-apply-indented-blocks
beg end (rst-find-leftmost-column beg end)
- #'(lambda (count in-first in-sub in-super in-empty _relind)
- (cond
- (in-empty)
- (in-super)
- ((zerop count))
- (in-sub
- (insert indent))
- ((or in-first all)
- (insert bul))
- (t
- (insert indent)))
- nil))))
+ (lambda (count in-first in-sub in-super in-empty _relind)
+ (cond
+ (in-empty)
+ (in-super)
+ ((zerop count))
+ (in-sub
+ (insert indent))
+ ((or in-first all)
+ (insert bul))
+ (t
+ (insert indent)))
+ nil))))
;; FIXME: Does not deal with a varying number of digits appropriately.
;; FIXME: Does not deal with multiple levels independently.
@@ -3561,11 +3559,11 @@ Region is from BEG to END. With WITH-EMPTY prefix
empty lines too."
(let ((ind (rst-find-leftmost-column beg end)))
(rst-apply-indented-blocks
beg end ind
- #'(lambda (_count _in-first _in-sub in-super in-empty _relind)
- (when (and (not in-super) (or with-empty (not in-empty)))
- (move-to-column ind t)
- (insert "| "))
- nil))))
+ (lambda (_count _in-first _in-sub in-super in-empty _relind)
+ (when (and (not in-super) (or with-empty (not in-empty)))
+ (move-to-column ind t)
+ (insert "| "))
+ nil))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -4085,16 +4083,16 @@ end of the buffer) return nil and do not move point."
(setq fnd (rst-apply-indented-blocks
(line-beginning-position 2) ; Skip the current line
(or limit (point-max)) (or column (current-column))
- #'(lambda (_count _in-first _in-sub in-super in-empty _relind)
- (cond
- (in-empty
- (setq candidate (or candidate (line-beginning-position)))
- nil)
- (in-super
- (or candidate (line-beginning-position)))
- (t ; Non-empty, same or more indented line.
- (setq candidate nil)
- nil)))))
+ (lambda (_count _in-first _in-sub in-super in-empty _relind)
+ (cond
+ (in-empty
+ (setq candidate (or candidate (line-beginning-position)))
+ nil)
+ (in-super
+ (or candidate (line-beginning-position)))
+ (t ; Non-empty, same or more indented line.
+ (setq candidate nil)
+ nil)))))
(when fnd
(goto-char fnd))))
diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el
index 6958ab8..d5930e8 100644
--- a/lisp/textmodes/sgml-mode.el
+++ b/lisp/textmodes/sgml-mode.el
@@ -623,7 +623,8 @@ Do \\[describe-key] on the following bindings to discover
what they do.
(setq-local syntax-propertize-function #'sgml-syntax-propertize)
(setq-local syntax-ppss-table sgml-tag-syntax-table)
(setq-local facemenu-add-face-function 'sgml-mode-facemenu-add-face-function)
- (setq-local sgml-xml-mode (sgml-xml-guess))
+ (when (sgml-xml-guess)
+ (setq-local sgml-xml-mode t))
(unless sgml-xml-mode
(setq-local skeleton-transformation-function sgml-transformation-function))
;; This will allow existing comments within declarations to be
@@ -2440,7 +2441,7 @@ The third `match-string' will be the used in the menu.")
HTML Autoview mode is a buffer-local minor mode for use with
`html-mode'. If enabled, saving the file automatically runs
`browse-url-of-buffer' to view it."
- nil nil nil
+ :lighter nil
(if html-autoview-mode
(add-hook 'after-save-hook #'browse-url-of-buffer nil t)
(remove-hook 'after-save-hook #'browse-url-of-buffer t)))
diff --git a/lisp/textmodes/table.el b/lisp/textmodes/table.el
index 13b4a6d..2dd52b8 100644
--- a/lisp/textmodes/table.el
+++ b/lisp/textmodes/table.el
@@ -383,7 +383,7 @@
;; There is no artificial-intelligence magic in this package. The
;; definition of a table and the cells inside the table is reasonably
;; limited in order to achieve acceptable performance in the
-;; interactive operation under Emacs lisp implementation. A valid
+;; interactive operation under Emacs Lisp implementation. A valid
;; table is a rectangular text area completely filled with valid
;; cells. A valid cell is a rectangle text area, which four borders
;; consist of valid border characters. Cells can not be nested one to
diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el
index fb57b9b..8d7f459 100644
--- a/lisp/textmodes/tex-mode.el
+++ b/lisp/textmodes/tex-mode.el
@@ -28,7 +28,6 @@
;;; Code:
-;; Pacify the byte-compiler
(eval-when-compile
(require 'compare-w)
(require 'cl-lib)
diff --git a/lisp/textmodes/texinfmt.el b/lisp/textmodes/texinfmt.el
index a797df9..977f3ba 100644
--- a/lisp/textmodes/texinfmt.el
+++ b/lisp/textmodes/texinfmt.el
@@ -23,9 +23,9 @@
;;; Commentary:
-;;; Code:
+;;; Emacs Lisp functions to convert Texinfo files to Info files.
-;;; Emacs lisp functions to convert Texinfo files to Info files.
+;;; Code:
(defvar texinfmt-version "2.42 of 7 Jul 2006")
(make-obsolete-variable 'texinfmt-version 'emacs-version "28.1")
@@ -4310,8 +4310,6 @@ For example, invoke
(setq error 1))))
(kill-emacs error))))
-
-;;; Place `provide' at end of file.
(provide 'texinfmt)
;;; texinfmt.el ends here
diff --git a/lisp/textmodes/texnfo-upd.el b/lisp/textmodes/texnfo-upd.el
index 27807a9..0300454 100644
--- a/lisp/textmodes/texnfo-upd.el
+++ b/lisp/textmodes/texnfo-upd.el
@@ -2112,8 +2112,6 @@ chapter."
(message "Multiple files updated."))
-
-;; Place `provide' at end of file.
(provide 'texnfo-upd)
;;; texnfo-upd.el ends here
diff --git a/lisp/textmodes/tildify.el b/lisp/textmodes/tildify.el
index 069c8e3..01e2ad7 100644
--- a/lisp/textmodes/tildify.el
+++ b/lisp/textmodes/tildify.el
@@ -486,7 +486,7 @@ that space character is replaced by a hard space specified
by
When `tildify-mode' is enabled, if `tildify-string-alist' specifies a hard
space
representation for current major mode, the `tildify-space-string' buffer-local
variable will be set to the representation."
- nil " ~" nil
+ :lighter " ~"
(when tildify-mode
(let ((space (with-suppressed-warnings ((obsolete
tildify--pick-alist-entry))
@@ -503,8 +503,6 @@ variable will be set to the representation."
(remove-hook 'post-self-insert-hook #'tildify-space t)))
-;;; *** Announce ***
-
(provide 'tildify)
;;; tildify.el ends here
diff --git a/lisp/textmodes/two-column.el b/lisp/textmodes/two-column.el
index 6c3bacc..5a3a64a 100644
--- a/lisp/textmodes/two-column.el
+++ b/lisp/textmodes/two-column.el
@@ -319,16 +319,17 @@ first and the associated buffer to its right."
;;;###autoload
-(defun 2C-associate-buffer ()
- "Associate another buffer with this one in two-column minor mode.
+(defun 2C-associate-buffer (buffer)
+ "Associate another BUFFER with this one in two-column minor mode.
Can also be used to associate a just previously visited file, by
accepting the proposed default buffer.
\(See \\[describe-mode] .)"
- (interactive)
+ (interactive
+ (list (or (2C-other)
+ (read-buffer "Associate buffer: " (other-buffer)))))
(let ((b1 (current-buffer))
- (b2 (or (2C-other)
- (read-buffer "Associate buffer: " (other-buffer)))))
+ (b2 buffer))
(setq 2C-mode nil)
(with-current-buffer b2
(and (2C-other)
diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el
index c52fcfc..8ca0f42 100644
--- a/lisp/thingatpt.el
+++ b/lisp/thingatpt.el
@@ -600,10 +600,14 @@ with angle brackets.")
(buffer-substring-no-properties
(car boundary-pair) (cdr boundary-pair))))))
-;; Buffer
+;; Buffer and region
(put 'buffer 'end-op (lambda () (goto-char (point-max))))
(put 'buffer 'beginning-op (lambda () (goto-char (point-min))))
+(put 'region 'bounds-of-thing-at-point
+ (lambda ()
+ (when (use-region-p)
+ (cons (region-beginning) (region-end)))))
;; UUID
diff --git a/lisp/thumbs.el b/lisp/thumbs.el
index 3e7c912..5710b8c 100644
--- a/lisp/thumbs.el
+++ b/lisp/thumbs.el
@@ -51,9 +51,6 @@
;; In thumbs-mode, pressing <return> on an image will bring you in image view
;; mode for that image. C-h m will give you a list of available keybinding.
-;;; History:
-;;
-
;;; Code:
(require 'dired)
diff --git a/lisp/time.el b/lisp/time.el
index 7e1d918..fd53f63 100644
--- a/lisp/time.el
+++ b/lisp/time.el
@@ -525,9 +525,16 @@ If the value is t instead of an alist, use the value of
'((t :inherit font-lock-variable-name-face))
"Face for time zone label in `world-clock' buffer.")
+(defvar world-clock-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "n" #'next-line)
+ (define-key map "p" #'previous-line)
+ map))
+
(define-derived-mode world-clock-mode special-mode "World clock"
"Major mode for buffer that displays times in various time zones.
See `world-clock'."
+ :interactive nil
(setq-local revert-buffer-function #'world-clock-update)
(setq show-trailing-whitespace nil))
@@ -591,7 +598,9 @@ To turn off the world time display, go to the window and
type `\\[quit-window]'.
"Update the `world-clock' buffer."
(if (get-buffer world-clock-buffer-name)
(with-current-buffer (get-buffer world-clock-buffer-name)
- (world-clock-display (time--display-world-list)))
+ (let ((op (point)))
+ (world-clock-display (time--display-world-list))
+ (goto-char op)))
(world-clock-cancel-timer)))
;;;###autoload
diff --git a/lisp/transient.el b/lisp/transient.el
new file mode 100644
index 0000000..6e7b5ea
--- /dev/null
+++ b/lisp/transient.el
@@ -0,0 +1,3615 @@
+;;; transient.el --- Transient commands -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018-2021 Free Software Foundation, Inc.
+
+;; Author: Jonas Bernoulli <jonas@bernoul.li>
+;; Homepage: https://github.com/magit/transient
+;; Package-Requires: ((emacs "25.1"))
+;; Package-Version: 0.3.2
+;; Keywords: bindings
+
+;; 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/>.
+
+;;; Commentary:
+
+;; Taking inspiration from prefix keys and prefix arguments, Transient
+;; implements a similar abstraction involving a prefix command, infix
+;; arguments and suffix commands. We could call this abstraction a
+;; "transient command", but because it always involves at least two
+;; commands (a prefix and a suffix) we prefer to call it just a
+;; "transient".
+
+;; When the user calls a transient prefix command, then a transient
+;; (temporary) keymap is activated, which binds the transient's infix
+;; and suffix commands, and functions that control the transient state
+;; are added to `pre-command-hook' and `post-command-hook'. The
+;; available suffix and infix commands and their state are shown in
+;; the echo area until the transient is exited by invoking a suffix
+;; command.
+
+;; Calling an infix command causes its value to be changed, possibly
+;; by reading a new value in the minibuffer.
+
+;; Calling a suffix command usually causes the transient to be exited
+;; but suffix commands can also be configured to not exit the
+;; transient state.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'eieio)
+(require 'format-spec)
+(require 'seq)
+
+(eval-when-compile
+ (require 'subr-x))
+
+(declare-function info 'info)
+(declare-function Man-find-section 'man)
+(declare-function Man-next-section 'man)
+(declare-function Man-getpage-in-background 'man)
+
+(defvar Man-notify-method)
+
+(define-obsolete-function-alias 'define-transient-command
+ 'transient-define-prefix "Transient 0.3.0")
+(define-obsolete-function-alias 'define-suffix-command
+ 'transient-define-suffix "Transient 0.3.0")
+(define-obsolete-function-alias 'define-infix-command
+ 'transient-define-infix "Transient 0.3.0")
+(define-obsolete-function-alias 'define-infix-argument
+ 'transient-define-argument "Transient 0.3.0")
+
+(define-obsolete-variable-alias 'current-transient-prefix
+ 'transient-current-prefix "Transient 0.3.0")
+(define-obsolete-variable-alias 'current-transient-command
+ 'transient-current-command "Transient 0.3.0")
+(define-obsolete-variable-alias 'current-transient-suffixes
+ 'transient-current-suffixes "Transient 0.3.0")
+(define-obsolete-variable-alias 'post-transient-hook
+ 'transient-exit-hook "Transient 0.3.0")
+
+(defmacro transient--with-emergency-exit (&rest body)
+ (declare (indent defun))
+ `(condition-case err
+ (let ((debugger #'transient--exit-and-debug))
+ ,(macroexp-progn body))
+ ((debug error)
+ (transient--emergency-exit)
+ (signal (car err) (cdr err)))))
+
+(defun transient--exit-and-debug (&rest args)
+ (transient--emergency-exit)
+ (apply #'debug args))
+
+;;; Options
+
+(defgroup transient nil
+ "Transient commands."
+ :group 'extensions)
+
+(defcustom transient-show-popup t
+ "Whether to show the current transient in a popup buffer.
+
+- If t, then show the popup as soon as a transient prefix command
+ is invoked.
+
+- If nil, then do not show the popup unless the user explicitly
+ requests it, by pressing an incomplete prefix key sequence.
+
+- If a number, then delay displaying the popup and instead show
+ a brief one-line summary. If zero or negative, then suppress
+ even showing that summary and display the pressed key only.
+
+ Show the popup when the user explicitly requests it by pressing
+ an incomplete prefix key sequence. Unless zero, then also show
+ the popup after that many seconds of inactivity (using the
+ absolute value)."
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type '(choice (const :tag "instantly" t)
+ (const :tag "on demand" nil)
+ (const :tag "on demand (no summary)" 0)
+ (number :tag "after delay" 1)))
+
+(defcustom transient-enable-popup-navigation nil
+ "Whether navigation commands are enabled in the transient popup.
+
+While a transient is active the transient popup buffer is not the
+current buffer, making it necessary to use dedicated commands to
+act on that buffer itself. If this non-nil, then the following
+features are available:
+
+- \"<up>\" moves the cursor to the previous suffix.
+ \"<down>\" moves the cursor to the next suffix.
+ \"RET\" invokes the suffix the cursor is on.
+- \"<mouse-1>\" invokes the clicked on suffix.
+- \"C-s\" and \"C-r\" start isearch in the popup buffer."
+ :package-version '(transient . "0.2.0")
+ :group 'transient
+ :type 'boolean)
+
+(defcustom transient-display-buffer-action
+ '(display-buffer-in-side-window
+ (side . bottom)
+ (inhibit-same-window . t))
+ "The action used to display the transient popup buffer.
+
+The transient popup buffer is displayed in a window using
+
+ \(display-buffer buf transient-display-buffer-action)
+
+The value of this option has the form (FUNCTION . ALIST),
+where FUNCTION is a function or a list of functions. Each such
+function should accept two arguments: a buffer to display and
+an alist of the same form as ALIST. See `display-buffer' for
+details.
+
+The default is (display-buffer-in-side-window (side . bottom)).
+This displays the window at the bottom of the selected frame.
+Another useful value is (display-buffer-below-selected). This
+is what `magit-popup' used by default. For more alternatives
+see info node `(elisp)Display Action Functions'.
+
+It may be possible to display the window in another frame, but
+whether that works in practice depends on the window-manager.
+If the window manager selects the new window (Emacs frame),
+then it doesn't work.
+
+If you change the value of this option, then you might also
+want to change the value of `transient-mode-line-format'."
+ :package-version '(transient . "0.3.0")
+ :group 'transient
+ :type '(cons (choice function (repeat :tag "Functions" function))
+ alist))
+
+(defcustom transient-mode-line-format 'line
+ "The mode-line format for the transient popup buffer.
+
+If nil, then the buffer has no mode-line. If the buffer is not
+displayed right above the echo area, then this probably is not
+a good value.
+
+If `line' (the default), then the buffer also has no mode-line,
+but a thin line is drawn instead, using the background color of
+the face `transient-separator'. Termcap frames cannot display
+thin lines and therefore fallback to treating `line' like nil.
+
+Otherwise this can be any mode-line format.
+See `mode-line-format' for details."
+ :package-version '(transient . "0.2.0")
+ :group 'transient
+ :type '(choice (const :tag "hide mode-line" nil)
+ (const :tag "substitute thin line" line)
+ (const :tag "name of prefix command"
+ ("%e" mode-line-front-space
+ mode-line-buffer-identification))
+ (sexp :tag "custom mode-line format")))
+
+(defcustom transient-show-common-commands nil
+ "Whether to show common transient suffixes in the popup buffer.
+
+These commands are always shown after typing the prefix key
+\"C-x\" when a transient command is active. To toggle the value
+of this variable use \"C-x t\" when a transient is active."
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type 'boolean)
+
+(defcustom transient-read-with-initial-input nil
+ "Whether to use the last history element as initial minibuffer input."
+ :package-version '(transient . "0.2.0")
+ :group 'transient
+ :type 'boolean)
+
+(defcustom transient-highlight-mismatched-keys nil
+ "Whether to highlight keys that do not match their argument.
+
+This only affects infix arguments that represent command-line
+arguments. When this option is non-nil, then the key binding
+for infix argument are highlighted when only a long argument
+\(e.g. \"--verbose\") is specified but no shor-thand (e.g \"-v\").
+In the rare case that a short-hand is specified but does not
+match the key binding, then it is highlighed differently.
+
+The highlighting is done using using `transient-mismatched-key'
+and `transient-nonstandard-key'."
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type 'boolean)
+
+(defcustom transient-substitute-key-function nil
+ "Function used to modify key bindings.
+
+This function is called with one argument, the prefix object,
+and must return a key binding description, either the existing
+key description it finds in the `key' slot, or a substitution.
+
+This is intended to let users replace certain prefix keys. It
+could also be used to make other substitutions, but that is
+discouraged.
+
+For example, \"=\" is hard to reach using my custom keyboard
+layout, so I substitute \"(\" for that, which is easy to reach
+using a layout optimized for lisp.
+
+ (setq transient-substitute-key-function
+ (lambda (obj)
+ (let ((key (oref obj key)))
+ (if (string-match \"\\\\`\\\\(=\\\\)[a-zA-Z]\" key)
+ (replace-match \"(\" t t key 1)
+ key)))))"
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type '(choice (const :tag "Transform no keys (nil)" nil) function))
+
+(defcustom transient-semantic-coloring nil
+ "Whether to color prefixes and suffixes in Hydra-like fashion.
+This feature is experimental.
+
+If non-nil, then the key binding of each suffix is colorized to
+indicate whether it exits the transient state or not. The color
+of the prefix is indicated using the line that is drawn when the
+value of `transient-mode-line-format' is `line'.
+
+For more information about how Hydra uses colors see
+https://github.com/abo-abo/hydra#color and
+https://oremacs.com/2015/02/19/hydra-colors-reloaded.";
+ :package-version '(transient . "0.3.0")
+ :group 'transient
+ :type 'boolean)
+
+(defcustom transient-detect-key-conflicts nil
+ "Whether to detect key binding conflicts.
+
+Conflicts are detected when a transient prefix command is invoked
+and results in an error, which prevents the transient from being
+used."
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type 'boolean)
+
+(defcustom transient-force-fixed-pitch nil
+ "Whether to force use of monospaced font in the popup buffer.
+
+Even if you use a proportional font for the `default' face,
+you might still want to use a monospaced font in transient's
+popup buffer. Setting this option to t causes `default' to
+be remapped to `fixed-pitch' in that buffer."
+ :package-version '(transient . "0.2.0")
+ :group 'transient
+ :type 'boolean)
+
+(defcustom transient-default-level 4
+ "Control what suffix levels are made available by default.
+
+Each suffix command is placed on a level and each prefix command
+has a level, which controls which suffix commands are available.
+Integers between 1 and 7 (inclusive) are valid levels.
+
+The levels of individual transients and/or their individual
+suffixes can be changed individually, by invoking the prefix and
+then pressing \"C-x l\".
+
+The default level for both transients and their suffixes is 4.
+This option only controls the default for transients. The default
+suffix level is always 4. The author of a transient should place
+certain suffixes on a higher level if they expect that it won't be
+of use to most users, and they should place very important suffixes
+on a lower level so that they remain available even if the user
+lowers the transient level.
+
+\(Magit currently places nearly all suffixes on level 4 and lower
+levels are not used at all yet. So for the time being you should
+not set a lower level here and using a higher level might not
+give you as many additional suffixes as you hoped.)"
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type '(choice (const :tag "1 - fewest suffixes" 1)
+ (const 2)
+ (const 3)
+ (const :tag "4 - default" 4)
+ (const 5)
+ (const 6)
+ (const :tag "7 - most suffixes" 7)))
+
+(defcustom transient-levels-file
+ (locate-user-emacs-file (convert-standard-filename "transient/levels.el"))
+ "File used to save levels of transients and their suffixes."
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type 'file)
+
+(defcustom transient-values-file
+ (locate-user-emacs-file (convert-standard-filename "transient/values.el"))
+ "File used to save values of transients."
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type 'file)
+
+(defcustom transient-history-file
+ (locate-user-emacs-file (convert-standard-filename "transient/history.el"))
+ "File used to save history of transients and their infixes."
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type 'file)
+
+(defcustom transient-history-limit 10
+ "Number of history elements to keep when saving to file."
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type 'integer)
+
+(defcustom transient-save-history t
+ "Whether to save history of transient commands when exiting Emacs."
+ :package-version '(transient . "0.1.0")
+ :group 'transient
+ :type 'boolean)
+
+;;; Faces
+
+(defgroup transient-faces nil
+ "Faces used by Transient."
+ :group 'transient)
+
+(defface transient-heading '((t :inherit font-lock-keyword-face))
+ "Face used for headings."
+ :group 'transient-faces)
+
+(defface transient-key '((t :inherit font-lock-builtin-face))
+ "Face used for keys."
+ :group 'transient-faces)
+
+(defface transient-argument '((t :inherit font-lock-warning-face))
+ "Face used for enabled arguments."
+ :group 'transient-faces)
+
+(defface transient-value '((t :inherit font-lock-string-face))
+ "Face used for values."
+ :group 'transient-faces)
+
+(defface transient-inactive-argument '((t :inherit shadow))
+ "Face used for inactive arguments."
+ :group 'transient-faces)
+
+(defface transient-inactive-value '((t :inherit shadow))
+ "Face used for inactive values."
+ :group 'transient-faces)
+
+(defface transient-unreachable '((t :inherit shadow))
+ "Face used for suffixes unreachable from the current prefix sequence."
+ :group 'transient-faces)
+
+(defface transient-active-infix '((t :inherit secondary-selection))
+ "Face used for the infix for which the value is being read."
+ :group 'transient-faces)
+
+(defface transient-unreachable-key '((t :inherit shadow))
+ "Face used for keys unreachable from the current prefix sequence."
+ :group 'transient-faces)
+
+(defface transient-nonstandard-key '((t :underline t))
+ "Face optionally used to highlight keys conflicting with short-argument.
+Also see option `transient-highlight-mismatched-keys'."
+ :group 'transient-faces)
+
+(defface transient-mismatched-key '((t :underline t))
+ "Face optionally used to highlight keys without a short-argument.
+Also see option `transient-highlight-mismatched-keys'."
+ :group 'transient-faces)
+
+(defface transient-inapt-suffix '((t :inherit shadow :italic t))
+ "Face used for suffixes that are inapt at this time."
+ :group 'transient-faces)
+
+(defface transient-enabled-suffix
+ '((t :background "green" :foreground "black" :weight bold))
+ "Face used for enabled levels while editing suffix levels.
+See info node `(transient)Enabling and Disabling Suffixes'."
+ :group 'transient-faces)
+
+(defface transient-disabled-suffix
+ '((t :background "red" :foreground "black" :weight bold))
+ "Face used for disabled levels while editing suffix levels.
+See info node `(transient)Enabling and Disabling Suffixes'."
+ :group 'transient-faces)
+
+(defface transient-separator
+ `((((class color) (background light))
+ ,@(and (>= emacs-major-version 27) '(:extend t))
+ :background "grey80")
+ (((class color) (background dark))
+ ,@(and (>= emacs-major-version 27) '(:extend t))
+ :background "grey30"))
+ "Face used to draw line below transient popup window.
+This is only used if `transient-mode-line-format' is `line'.
+Only the background color is significant."
+ :group 'transient-faces)
+
+(defgroup transient-color-faces
+ '((transient-semantic-coloring custom-variable))
+ "Faces used by Transient for Hydra-like command coloring.
+These faces are only used if `transient-semantic-coloring'
+\(which see) is non-nil."
+ :group 'transient-faces)
+
+(defface transient-red
+ '((t :inherit transient-key :foreground "red"))
+ "Face used for red prefixes and suffixes."
+ :group 'transient-color-faces)
+
+(defface transient-blue
+ '((t :inherit transient-key :foreground "blue"))
+ "Face used for blue prefixes and suffixes."
+ :group 'transient-color-faces)
+
+(defface transient-amaranth
+ '((t :inherit transient-key :foreground "#E52B50"))
+ "Face used for amaranth prefixes."
+ :group 'transient-color-faces)
+
+(defface transient-pink
+ '((t :inherit transient-key :foreground "#FF6EB4"))
+ "Face used for pink prefixes."
+ :group 'transient-color-faces)
+
+(defface transient-teal
+ '((t :inherit transient-key :foreground "#367588"))
+ "Face used for teal prefixes."
+ :group 'transient-color-faces)
+
+;;; Persistence
+
+(defun transient--read-file-contents (file)
+ (with-demoted-errors "Transient error: %S"
+ (and (file-exists-p file)
+ (with-temp-buffer
+ (insert-file-contents file)
+ (read (current-buffer))))))
+
+(defun transient--pp-to-file (list file)
+ (make-directory (file-name-directory file) t)
+ (setq list (cl-sort (copy-sequence list) #'string< :key #'car))
+ (with-temp-file file
+ (let ((print-level nil)
+ (print-length nil))
+ (pp list (current-buffer)))))
+
+(defvar transient-values
+ (transient--read-file-contents transient-values-file)
+ "Values of transient commands.
+The value of this variable persists between Emacs sessions
+and you usually should not change it manually.")
+
+(defun transient-save-values ()
+ (transient--pp-to-file transient-values transient-values-file))
+
+(defvar transient-levels
+ (transient--read-file-contents transient-levels-file)
+ "Levels of transient commands.
+The value of this variable persists between Emacs sessions
+and you usually should not change it manually.")
+
+(defun transient-save-levels ()
+ (transient--pp-to-file transient-levels transient-levels-file))
+
+(defvar transient-history
+ (transient--read-file-contents transient-history-file)
+ "History of transient commands and infix arguments.
+The value of this variable persists between Emacs sessions
+\(unless `transient-save-history' is nil) and you usually
+should not change it manually.")
+
+(defun transient-save-history ()
+ (setq transient-history
+ (cl-sort (mapcar (pcase-lambda (`(,key . ,val))
+ (cons key (seq-take (delete-dups val)
+ transient-history-limit)))
+ transient-history)
+ #'string< :key #'car))
+ (transient--pp-to-file transient-history transient-history-file))
+
+(defun transient-maybe-save-history ()
+ "Save the value of `transient-history'.
+If `transient-save-history' is nil, then do nothing."
+ (when transient-save-history
+ (transient-save-history)))
+
+(unless noninteractive
+ (add-hook 'kill-emacs-hook 'transient-maybe-save-history))
+
+;;; Classes
+;;;; Prefix
+
+(defclass transient-prefix ()
+ ((prototype :initarg :prototype)
+ (command :initarg :command)
+ (level :initarg :level)
+ (variable :initarg :variable :initform nil)
+ (init-value :initarg :init-value)
+ (value) (default-value :initarg :value)
+ (scope :initarg :scope :initform nil)
+ (history :initarg :history :initform nil)
+ (history-pos :initarg :history-pos :initform 0)
+ (history-key :initarg :history-key :initform nil)
+ (man-page :initarg :man-page :initform nil)
+ (info-manual :initarg :info-manual :initform nil)
+ (transient-suffix :initarg :transient-suffix :initform nil)
+ (transient-non-suffix :initarg :transient-non-suffix :initform nil)
+ (incompatible :initarg :incompatible :initform nil)
+ (suffix-description :initarg :suffix-description))
+ "Transient prefix command.
+
+Each transient prefix command consists of a command, which is
+stored in a symbol's function slot and an object, which is
+stored in the `transient--prefix' property of the same symbol.
+
+When a transient prefix command is invoked, then a clone of that
+object is stored in the global variable `transient--prefix' and
+the prototype is stored in the clone's `prototype' slot.")
+
+;;;; Suffix
+
+(defclass transient-child ()
+ ((level
+ :initarg :level
+ :initform 1
+ :documentation "Enable if level of prefix is equal or greater.")
+ (if
+ :initarg :if
+ :initform nil
+ :documentation "Enable if predicate returns non-nil.")
+ (if-not
+ :initarg :if-not
+ :initform nil
+ :documentation "Enable if predicate returns nil.")
+ (if-non-nil
+ :initarg :if-non-nil
+ :initform nil
+ :documentation "Enable if variable's value is non-nil.")
+ (if-nil
+ :initarg :if-nil
+ :initform nil
+ :documentation "Enable if variable's value is nil.")
+ (if-mode
+ :initarg :if-mode
+ :initform nil
+ :documentation "Enable if major-mode matches value.")
+ (if-not-mode
+ :initarg :if-not-mode
+ :initform nil
+ :documentation "Enable if major-mode does not match value.")
+ (if-derived
+ :initarg :if-derived
+ :initform nil
+ :documentation "Enable if major-mode derives from value.")
+ (if-not-derived
+ :initarg :if-not-derived
+ :initform nil
+ :documentation "Enable if major-mode does not derive from value."))
+ "Abstract superclass for group and and suffix classes.
+
+It is undefined what happens if more than one `if*' predicate
+slot is non-nil."
+ :abstract t)
+
+(defclass transient-suffix (transient-child)
+ ((key :initarg :key)
+ (command :initarg :command)
+ (transient :initarg :transient)
+ (format :initarg :format :initform " %k %d")
+ (description :initarg :description :initform nil)
+ (inapt :initform nil)
+ (inapt-if
+ :initarg :inapt-if
+ :initform nil
+ :documentation "Inapt if predicate returns non-nil.")
+ (inapt-if-not
+ :initarg :inapt-if-not
+ :initform nil
+ :documentation "Inapt if predicate returns nil.")
+ (inapt-if-non-nil
+ :initarg :inapt-if-non-nil
+ :initform nil
+ :documentation "Inapt if variable's value is non-nil.")
+ (inapt-if-nil
+ :initarg :inapt-if-nil
+ :initform nil
+ :documentation "Inapt if variable's value is nil.")
+ (inapt-if-mode
+ :initarg :inapt-if-mode
+ :initform nil
+ :documentation "Inapt if major-mode matches value.")
+ (inapt-if-not-mode
+ :initarg :inapt-if-not-mode
+ :initform nil
+ :documentation "Inapt if major-mode does not match value.")
+ (inapt-if-derived
+ :initarg :inapt-if-derived
+ :initform nil
+ :documentation "Inapt if major-mode derives from value.")
+ (inapt-if-not-derived
+ :initarg :inapt-if-not-derived
+ :initform nil
+ :documentation "Inapt if major-mode does not derive from value."))
+ "Superclass for suffix command.")
+
+(defclass transient-infix (transient-suffix)
+ ((transient :initform t)
+ (argument :initarg :argument)
+ (shortarg :initarg :shortarg)
+ (value :initform nil)
+ (init-value :initarg :init-value)
+ (unsavable :initarg :unsavable :initform nil)
+ (multi-value :initarg :multi-value :initform nil)
+ (always-read :initarg :always-read :initform nil)
+ (allow-empty :initarg :allow-empty :initform nil)
+ (history-key :initarg :history-key :initform nil)
+ (reader :initarg :reader :initform nil)
+ (prompt :initarg :prompt :initform nil)
+ (choices :initarg :choices :initform nil)
+ (format :initform " %k %d (%v)"))
+ "Transient infix command."
+ :abstract t)
+
+(defclass transient-argument (transient-infix) ()
+ "Abstract superclass for infix arguments."
+ :abstract t)
+
+(defclass transient-switch (transient-argument) ()
+ "Class used for command-line argument that can be turned on and off.")
+
+(defclass transient-option (transient-argument) ()
+ "Class used for command-line argument that can take a value.")
+
+(defclass transient-variable (transient-infix)
+ ((variable :initarg :variable)
+ (format :initform " %k %d %v"))
+ "Abstract superclass for infix commands that set a variable."
+ :abstract t)
+
+(defclass transient-switches (transient-argument)
+ ((argument-format :initarg :argument-format)
+ (argument-regexp :initarg :argument-regexp))
+ "Class used for sets of mutually exclusive command-line switches.")
+
+(defclass transient-files (transient-infix) ()
+ "Class used for the \"--\" argument.
+All remaining arguments are treated as files.
+They become the value of this this argument.")
+
+;;;; Group
+
+(defclass transient-group (transient-child)
+ ((suffixes :initarg :suffixes :initform nil)
+ (hide :initarg :hide :initform nil)
+ (description :initarg :description :initform nil)
+ (setup-children :initarg :setup-children)
+ (pad-keys :initarg :pad-keys))
+ "Abstract superclass of all group classes."
+ :abstract t)
+
+(defclass transient-column (transient-group) ()
+ "Group class that displays each element on a separate line.")
+
+(defclass transient-row (transient-group) ()
+ "Group class that displays all elements on a single line.")
+
+(defclass transient-columns (transient-group) ()
+ "Group class that displays elements organized in columns.
+Direct elements have to be groups whose elements have to be
+commands or string. Each subgroup represents a column. This
+class takes care of inserting the subgroups' elements.")
+
+(defclass transient-subgroups (transient-group) ()
+ "Group class that wraps other groups.
+
+Direct elements have to be groups whose elements have to be
+commands or strings. This group inserts an empty line between
+subgroups. The subgroups are responsible for displaying their
+elements themselves.")
+
+;;; Define
+
+(defmacro transient-define-prefix (name arglist &rest args)
+ "Define NAME as a transient prefix command.
+
+ARGLIST are the arguments that command takes.
+DOCSTRING is the documentation string and is optional.
+
+These arguments can optionally be followed by key-value pairs.
+Each key has to be a keyword symbol, either `:class' or a keyword
+argument supported by the constructor of that class. The
+`transient-prefix' class is used if the class is not specified
+explicitly.
+
+GROUPs add key bindings for infix and suffix commands and specify
+how these bindings are presented in the popup buffer. At least
+one GROUP has to be specified. See info node `(transient)Binding
+Suffix and Infix Commands'.
+
+The BODY is optional. If it is omitted, then ARGLIST is also
+ignored and the function definition becomes:
+
+ (lambda ()
+ (interactive)
+ (transient-setup \\='NAME))
+
+If BODY is specified, then it must begin with an `interactive'
+form that matches ARGLIST, and it must call `transient-setup'.
+It may however call that function only when some condition is
+satisfied; that is one of the reason why you might want to use
+an explicit BODY.
+
+All transients have a (possibly nil) value, which is exported
+when suffix commands are called, so that they can consume that
+value. For some transients it might be necessary to have a sort
+of secondary value, called a scope. Such a scope would usually
+be set in the commands `interactive' form and has to be passed
+to the setup function:
+
+ (transient-setup \\='NAME nil nil :scope SCOPE)
+
+\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... GROUP... [BODY...])"
+ (declare (debug (&define name lambda-list
+ [&optional lambda-doc]
+ [&rest keywordp sexp]
+ [&rest vectorp]
+ [&optional ("interactive" interactive) def-body]))
+ (indent defun)
+ (doc-string 3))
+ (pcase-let ((`(,class ,slots ,suffixes ,docstr ,body)
+ (transient--expand-define-args args)))
+ `(progn
+ (defalias ',name
+ ,(if body
+ `(lambda ,arglist ,@body)
+ `(lambda ()
+ (interactive)
+ (transient-setup ',name))))
+ (put ',name 'interactive-only t)
+ (put ',name 'function-documentation ,docstr)
+ (put ',name 'transient--prefix
+ (,(or class 'transient-prefix) :command ',name ,@slots))
+ (put ',name 'transient--layout
+ ',(cl-mapcan (lambda (s) (transient--parse-child name s))
+ suffixes)))))
+
+(defmacro transient-define-suffix (name arglist &rest args)
+ "Define NAME as a transient suffix command.
+
+ARGLIST are the arguments that the command takes.
+DOCSTRING is the documentation string and is optional.
+
+These arguments can optionally be followed by key-value pairs.
+Each key has to be a keyword symbol, either `:class' or a
+keyword argument supported by the constructor of that class.
+The `transient-suffix' class is used if the class is not
+specified explicitly.
+
+The BODY must begin with an `interactive' form that matches
+ARGLIST. The infix arguments are usually accessed by using
+`transient-args' inside `interactive'.
+
+\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... BODY...)"
+ (declare (debug (&define name lambda-list
+ [&optional lambda-doc]
+ [&rest keywordp sexp]
+ ("interactive" interactive)
+ def-body))
+ (indent defun)
+ (doc-string 3))
+ (pcase-let ((`(,class ,slots ,_ ,docstr ,body)
+ (transient--expand-define-args args)))
+ `(progn
+ (defalias ',name (lambda ,arglist ,@body))
+ (put ',name 'interactive-only t)
+ (put ',name 'function-documentation ,docstr)
+ (put ',name 'transient--suffix
+ (,(or class 'transient-suffix) :command ',name ,@slots)))))
+
+(defmacro transient-define-infix (name _arglist &rest args)
+ "Define NAME as a transient infix command.
+
+ARGLIST is always ignored and reserved for future use.
+DOCSTRING is the documentation string and is optional.
+
+The key-value pairs are mandatory. All transient infix commands
+are equal to each other (but not eq), so it is meaningless to
+define an infix command without also setting at least `:class'
+and one other keyword (which it is depends on the used class,
+usually `:argument' or `:variable').
+
+Each key has to be a keyword symbol, either `:class' or a keyword
+argument supported by the constructor of that class. The
+`transient-switch' class is used if the class is not specified
+explicitly.
+
+The function definitions is always:
+
+ (lambda ()
+ (interactive)
+ (let ((obj (transient-suffix-object)))
+ (transient-infix-set obj (transient-infix-read obj)))
+ (transient--show))
+
+`transient-infix-read' and `transient-infix-set' are generic
+functions. Different infix commands behave differently because
+the concrete methods are different for different infix command
+classes. In rare case the above command function might not be
+suitable, even if you define your own infix command class. In
+that case you have to use `transient-suffix-command' to define
+the infix command and use t as the value of the `:transient'
+keyword.
+
+\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]...)"
+ (declare (debug (&define name lambda-list
+ [&optional lambda-doc]
+ [&rest keywordp sexp]))
+ (indent defun)
+ (doc-string 3))
+ (pcase-let ((`(,class ,slots ,_ ,docstr ,_)
+ (transient--expand-define-args args)))
+ `(progn
+ (defalias ',name ,(transient--default-infix-command))
+ (put ',name 'interactive-only t)
+ (put ',name 'function-documentation ,docstr)
+ (put ',name 'transient--suffix
+ (,(or class 'transient-switch) :command ',name ,@slots)))))
+
+(defalias 'transient-define-argument 'define-infix-command
+ "Define NAME as a transient infix command.
+
+Only use this alias to define an infix command that actually
+sets an infix argument. To define a infix command that, for
+example, sets a variable use `transient-define-infix' instead.
+
+\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]...)")
+
+(defun transient--expand-define-args (args)
+ (let (class keys suffixes docstr)
+ (when (stringp (car args))
+ (setq docstr (pop args)))
+ (while (keywordp (car args))
+ (let ((k (pop args))
+ (v (pop args)))
+ (if (eq k :class)
+ (setq class v)
+ (push k keys)
+ (push v keys))))
+ (while (let ((arg (car args)))
+ (or (vectorp arg)
+ (and arg (symbolp arg))))
+ (push (pop args) suffixes))
+ (list (if (eq (car-safe class) 'quote)
+ (cadr class)
+ class)
+ (nreverse keys)
+ (nreverse suffixes)
+ docstr
+ args)))
+
+(defun transient--parse-child (prefix spec)
+ (cl-etypecase spec
+ (symbol (let ((value (symbol-value spec)))
+ (if (and (listp value)
+ (or (listp (car value))
+ (vectorp (car value))))
+ (cl-mapcan (lambda (s) (transient--parse-child prefix s))
value)
+ (transient--parse-child prefix value))))
+ (vector (when-let ((c (transient--parse-group prefix spec))) (list c)))
+ (list (when-let ((c (transient--parse-suffix prefix spec))) (list c)))
+ (string (list spec))))
+
+(defun transient--parse-group (prefix spec)
+ (setq spec (append spec nil))
+ (cl-symbol-macrolet
+ ((car (car spec))
+ (pop (pop spec)))
+ (let (level class args)
+ (when (integerp car)
+ (setq level pop))
+ (when (stringp car)
+ (setq args (plist-put args :description pop)))
+ (while (keywordp car)
+ (let ((k pop))
+ (if (eq k :class)
+ (setq class pop)
+ (setq args (plist-put args k pop)))))
+ (vector (or level (oref-default 'transient-child level))
+ (or class
+ (if (vectorp car)
+ 'transient-columns
+ 'transient-column))
+ args
+ (cl-mapcan (lambda (s) (transient--parse-child prefix s))
spec)))))
+
+(defun transient--parse-suffix (prefix spec)
+ (let (level class args)
+ (cl-symbol-macrolet
+ ((car (car spec))
+ (pop (pop spec)))
+ (when (integerp car)
+ (setq level pop))
+ (when (or (stringp car)
+ (vectorp car))
+ (setq args (plist-put args :key pop)))
+ (when (or (stringp car)
+ (eq (car-safe car) 'lambda)
+ (and (symbolp car)
+ (not (commandp car))
+ (commandp (cadr spec))))
+ (setq args (plist-put args :description pop)))
+ (cond
+ ((keywordp car)
+ (error "Need command, got %S" car))
+ ((symbolp car)
+ (setq args (plist-put args :command pop)))
+ ((and (commandp car)
+ (not (stringp car)))
+ (let ((cmd pop)
+ (sym (intern (format "transient:%s:%s"
+ prefix
+ (or (plist-get args :description)
+ (plist-get args :key))))))
+ (defalias sym cmd)
+ (setq args (plist-put args :command sym))))
+ ((or (stringp car)
+ (and car (listp car)))
+ (let ((arg pop))
+ (cl-typecase arg
+ (list
+ (setq args (plist-put args :shortarg (car arg)))
+ (setq args (plist-put args :argument (cadr arg)))
+ (setq arg (cadr arg)))
+ (string
+ (when-let ((shortarg (transient--derive-shortarg arg)))
+ (setq args (plist-put args :shortarg shortarg)))
+ (setq args (plist-put args :argument arg))))
+ (setq args (plist-put args :command
+ (intern (format "transient:%s:%s"
+ prefix arg))))
+ (cond ((and car (not (keywordp car)))
+ (setq class 'transient-option)
+ (setq args (plist-put args :reader pop)))
+ ((not (string-suffix-p "=" arg))
+ (setq class 'transient-switch))
+ (t
+ (setq class 'transient-option)))))
+ (t
+ (error "Needed command or argument, got %S" car)))
+ (while (keywordp car)
+ (let ((k pop))
+ (cl-case k
+ (:class (setq class pop))
+ (:level (setq level pop))
+ (t (setq args (plist-put args k pop)))))))
+ (unless (plist-get args :key)
+ (when-let ((shortarg (plist-get args :shortarg)))
+ (setq args (plist-put args :key shortarg))))
+ (list (or level (oref-default 'transient-child level))
+ (or class 'transient-suffix)
+ args)))
+
+(defun transient--default-infix-command ()
+ (cons 'lambda
+ '(()
+ (interactive)
+ (let ((obj (transient-suffix-object)))
+ (transient-infix-set obj (transient-infix-read obj)))
+ (transient--show))))
+
+(defun transient--ensure-infix-command (obj)
+ (let ((cmd (oref obj command)))
+ (unless (or (commandp cmd)
+ (get cmd 'transient--infix-command))
+ (if (or (cl-typep obj 'transient-switch)
+ (cl-typep obj 'transient-option))
+ (put cmd 'transient--infix-command
+ (transient--default-infix-command))
+ ;; This is not an anonymous infix argument.
+ (error "Suffix %s is not defined or autoloaded as a command" cmd)))))
+
+(defun transient--derive-shortarg (arg)
+ (save-match-data
+ (and (string-match "\\`\\(-[a-zA-Z]\\)\\(\\'\\|=\\)" arg)
+ (match-string 1 arg))))
+
+;;; Edit
+
+(defun transient--insert-suffix (prefix loc suffix action)
+ (let* ((suf (cl-etypecase suffix
+ (vector (transient--parse-group prefix suffix))
+ (list (transient--parse-suffix prefix suffix))
+ (string suffix)))
+ (mem (transient--layout-member loc prefix))
+ (elt (car mem)))
+ (cond
+ ((not mem)
+ (message "Cannot insert %S into %s; %s not found"
+ suffix prefix loc))
+ ((or (and (vectorp suffix) (not (vectorp elt)))
+ (and (listp suffix) (vectorp elt))
+ (and (stringp suffix) (vectorp elt)))
+ (message "Cannot place %S into %s at %s; %s"
+ suffix prefix loc
+ "suffixes and groups cannot be siblings"))
+ (t
+ (when (and (listp suffix)
+ (listp elt))
+ ;; Both suffixes are key bindings; not heading strings.
+ (let ((key (transient--spec-key suf)))
+ (if (equal (transient--kbd key)
+ (transient--kbd (transient--spec-key elt)))
+ ;; We must keep `mem' until after we have inserted
+ ;; behind it, which `transient-remove-suffix' does
+ ;; not allow us to do.
+ (let ((spred (transient--suffix-predicate suf))
+ (epred (transient--suffix-predicate elt)))
+ ;; If both suffixes have a predicate and they
+ ;; are not identical, then there is a high
+ ;; probability that we want to keep both.
+ (when (or (not spred)
+ (not epred)
+ (equal spred epred))
+ (setq action 'replace)))
+ (transient-remove-suffix prefix key))))
+ (cl-ecase action
+ (insert (setcdr mem (cons elt (cdr mem)))
+ (setcar mem suf))
+ (append (setcdr mem (cons suf (cdr mem))))
+ (replace (setcar mem suf)))))))
+
+;;;###autoload
+(defun transient-insert-suffix (prefix loc suffix)
+ "Insert a SUFFIX into PREFIX before LOC.
+PREFIX is a prefix command, a symbol.
+SUFFIX is a suffix command or a group specification (of
+ the same forms as expected by `transient-define-prefix').
+LOC is a command, a key vector, a key description (a string
+ as returned by `key-description'), or a coordination list
+ (whose last element may also be a command or key).
+See info node `(transient)Modifying Existing Transients'."
+ (declare (indent defun))
+ (transient--insert-suffix prefix loc suffix 'insert))
+
+;;;###autoload
+(defun transient-append-suffix (prefix loc suffix)
+ "Insert a SUFFIX into PREFIX after LOC.
+PREFIX is a prefix command, a symbol.
+SUFFIX is a suffix command or a group specification (of
+ the same forms as expected by `transient-define-prefix').
+LOC is a command, a key vector, a key description (a string
+ as returned by `key-description'), or a coordination list
+ (whose last element may also be a command or key).
+See info node `(transient)Modifying Existing Transients'."
+ (declare (indent defun))
+ (transient--insert-suffix prefix loc suffix 'append))
+
+;;;###autoload
+(defun transient-replace-suffix (prefix loc suffix)
+ "Replace the suffix at LOC in PREFIX with SUFFIX.
+PREFIX is a prefix command, a symbol.
+SUFFIX is a suffix command or a group specification (of
+ the same forms as expected by `transient-define-prefix').
+LOC is a command, a key vector, a key description (a string
+ as returned by `key-description'), or a coordination list
+ (whose last element may also be a command or key).
+See info node `(transient)Modifying Existing Transients'."
+ (declare (indent defun))
+ (transient--insert-suffix prefix loc suffix 'replace))
+
+;;;###autoload
+(defun transient-remove-suffix (prefix loc)
+ "Remove the suffix or group at LOC in PREFIX.
+PREFIX is a prefix command, a symbol.
+LOC is a command, a key vector, a key description (a string
+ as returned by `key-description'), or a coordination list
+ (whose last element may also be a command or key).
+See info node `(transient)Modifying Existing Transients'."
+ (declare (indent defun))
+ (transient--layout-member loc prefix 'remove))
+
+(defun transient-get-suffix (prefix loc)
+ "Return the suffix or group at LOC in PREFIX.
+PREFIX is a prefix command, a symbol.
+LOC is a command, a key vector, a key description (a string
+ as returned by `key-description'), or a coordination list
+ (whose last element may also be a command or key).
+See info node `(transient)Modifying Existing Transients'."
+ (if-let ((mem (transient--layout-member loc prefix)))
+ (car mem)
+ (error "%s not found in %s" loc prefix)))
+
+(defun transient-suffix-put (prefix loc prop value)
+ "Edit the suffix at LOC in PREFIX, setting PROP to VALUE.
+PREFIX is a prefix command, a symbol.
+SUFFIX is a suffix command or a group specification (of
+ the same forms as expected by `transient-define-prefix').
+LOC is a command, a key vector, a key description (a string
+ as returned by `key-description'), or a coordination list
+ (whose last element may also be a command or key).
+See info node `(transient)Modifying Existing Transients'."
+ (let ((suf (transient-get-suffix prefix loc)))
+ (setf (elt suf 2)
+ (plist-put (elt suf 2) prop value))))
+
+(defun transient--layout-member (loc prefix &optional remove)
+ (let ((val (or (get prefix 'transient--layout)
+ (error "%s is not a transient command" prefix))))
+ (when (listp loc)
+ (while (integerp (car loc))
+ (let* ((children (if (vectorp val) (aref val 3) val))
+ (mem (transient--nthcdr (pop loc) children)))
+ (if (and remove (not loc))
+ (let ((rest (delq (car mem) children)))
+ (if (vectorp val)
+ (aset val 3 rest)
+ (put prefix 'transient--layout rest))
+ (setq val nil))
+ (setq val (if loc (car mem) mem)))))
+ (setq loc (car loc)))
+ (if loc
+ (transient--layout-member-1 (transient--kbd loc) val remove)
+ val)))
+
+(defun transient--layout-member-1 (loc layout remove)
+ (cond ((listp layout)
+ (seq-some (lambda (elt) (transient--layout-member-1 loc elt remove))
+ layout))
+ ((vectorp (car (aref layout 3)))
+ (seq-some (lambda (elt) (transient--layout-member-1 loc elt remove))
+ (aref layout 3)))
+ (remove
+ (aset layout 3
+ (delq (car (transient--group-member loc layout))
+ (aref layout 3)))
+ nil)
+ (t (transient--group-member loc layout))))
+
+(defun transient--group-member (loc group)
+ (cl-member-if (lambda (suffix)
+ (and (listp suffix)
+ (let* ((def (nth 2 suffix))
+ (cmd (plist-get def :command)))
+ (if (symbolp loc)
+ (eq cmd loc)
+ (equal (transient--kbd
+ (or (plist-get def :key)
+ (transient--command-key cmd)))
+ loc)))))
+ (aref group 3)))
+
+(defun transient--kbd (keys)
+ (when (vectorp keys)
+ (setq keys (key-description keys)))
+ (when (stringp keys)
+ (setq keys (kbd keys)))
+ keys)
+
+(defun transient--spec-key (spec)
+ (let ((plist (nth 2 spec)))
+ (or (plist-get plist :key)
+ (transient--command-key
+ (plist-get plist :command)))))
+
+(defun transient--command-key (cmd)
+ (when-let ((obj (get cmd 'transient--suffix)))
+ (cond ((slot-boundp obj 'key)
+ (oref obj key))
+ ((slot-exists-p obj 'shortarg)
+ (if (slot-boundp obj 'shortarg)
+ (oref obj shortarg)
+ (transient--derive-shortarg (oref obj argument)))))))
+
+(defun transient--nthcdr (n list)
+ (nthcdr (if (< n 0) (- (length list) (abs n)) n) list))
+
+;;; Variables
+
+(defvar transient-current-prefix nil
+ "The transient from which this suffix command was invoked.
+This is an object representing that transient, use
+`transient-current-command' to get the respective command.")
+
+(defvar transient-current-command nil
+ "The transient from which this suffix command was invoked.
+This is a symbol representing that transient, use
+`current-transient-object' to get the respective object.")
+
+(defvar transient-current-suffixes nil
+ "The suffixes of the transient from which this suffix command was invoked.
+This is a list of objects. Usually it is sufficient to instead
+use the function `transient-args', which returns a list of
+values. In complex cases it might be necessary to use this
+variable instead.")
+
+(defvar transient-exit-hook nil
+ "Hook run after exiting a transient.")
+
+(defvar transient--prefix nil)
+(defvar transient--layout nil)
+(defvar transient--suffixes nil)
+
+(defconst transient--stay t "Do not exit the transient.")
+(defconst transient--exit nil "Do exit the transient.")
+
+(defvar transient--exitp nil "Whether to exit the transient.")
+(defvar transient--showp nil "Whether the transient is show in a popup
buffer.")
+(defvar transient--helpp nil "Whether help-mode is active.")
+(defvar transient--editp nil "Whether edit-mode is active.")
+
+(defvar transient--active-infix nil "The active infix awaiting user input.")
+
+(defvar transient--timer nil)
+
+(defvar transient--stack nil)
+
+(defvar transient--buffer-name " *transient*"
+ "Name of the transient buffer.")
+
+(defvar transient--window nil
+ "The window used to display the transient popup.")
+
+(defvar transient--original-window nil
+ "The window that was selected before the transient was invoked.
+Usually it remains selected while the transient is active.")
+
+(define-obsolete-variable-alias 'transient--source-buffer
+ 'transient--original-buffer "Transient 0.2.0")
+
+(defvar transient--original-buffer nil
+ "The buffer that was current before the transient was invoked.
+Usually it remains current while the transient is active.")
+
+(defvar transient--debug nil "Whether put debug information into *Messages*.")
+
+(defvar transient--history nil)
+
+(defvar transient--scroll-commands
+ '(transient-scroll-up
+ transient-scroll-down
+ mwheel-scroll
+ scroll-bar-toolkit-scroll))
+
+;;; Identities
+
+(defun transient-suffix-object (&optional command)
+ "Return the object associated with the current suffix command.
+
+Each suffix commands is associated with an object, which holds
+additional information about the suffix, such as its value (in
+the case of an infix command, which is a kind of suffix command).
+
+This function is intended to be called by infix commands, whose
+command definition usually (at least when defined using
+`transient-define-infix') is this:
+
+ (lambda ()
+ (interactive)
+ (let ((obj (transient-suffix-object)))
+ (transient-infix-set obj (transient-infix-read obj)))
+ (transient--show))
+
+\(User input is read outside of `interactive' to prevent the
+command from being added to `command-history'. See #23.)
+
+Such commands need to be able to access their associated object
+to guide how `transient-infix-read' reads the new value and to
+store the read value. Other suffix commands (including non-infix
+commands) may also need the object to guide their behavior.
+
+This function attempts to return the object associated with the
+current suffix command even if the suffix command was not invoked
+from a transient. (For some suffix command that is a valid thing
+to do, for others it is not.) In that case nil may be returned
+if the command was not defined using one of the macros intended
+to define such commands.
+
+The optional argument COMMAND is intended for internal use. If
+you are contemplating using it in your own code, then you should
+probably use this instead:
+
+ (get COMMAND 'transient--suffix)"
+ (when command
+ (cl-check-type command command))
+ (if (or transient--prefix
+ transient-current-prefix)
+ (cl-find-if (lambda (obj)
+ (eq (transient--suffix-command obj)
+ (or command this-original-command)))
+ (or transient--suffixes
+ transient-current-suffixes))
+ (when-let ((obj (get (or command this-command) 'transient--suffix))
+ (obj (clone obj)))
+ (transient-init-scope obj)
+ (transient-init-value obj)
+ obj)))
+
+(defun transient--suffix-command (object)
+ "Return the command represented by OBJECT.
+
+If the value of OBJECT's `command' slot is a command, then return
+that. Otherwise it is a symbol whose `transient--infix-command'
+property holds an anonymous command, which is returned instead."
+ (cl-check-type object transient-suffix)
+ (let ((sym (oref object command)))
+ (if (commandp sym)
+ sym
+ (get sym 'transient--infix-command))))
+
+(defun transient--suffix-symbol (arg)
+ "Return a symbol representing ARG.
+
+ARG must be a command and/or a symbol. If it is a symbol,
+then just return it. Otherwise return the symbol whose
+`transient--infix-command' property's value is ARG."
+ (or (cl-typep arg 'command)
+ (cl-typep arg 'symbol)
+ (signal 'wrong-type-argument `((command symbol) ,arg)))
+ (if (symbolp arg)
+ arg
+ (let* ((obj (transient-suffix-object))
+ (sym (oref obj command)))
+ (if (eq (get sym 'transient--infix-command) arg)
+ sym
+ (catch 'found
+ (mapatoms (lambda (sym)
+ (when (eq (get sym 'transient--infix-command) arg)
+ (throw 'found sym)))))))))
+
+;;; Keymaps
+
+(defvar transient-base-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "ESC ESC ESC") 'transient-quit-all)
+ (define-key map (kbd "C-g") 'transient-quit-one)
+ (define-key map (kbd "C-q") 'transient-quit-all)
+ (define-key map (kbd "C-z") 'transient-suspend)
+ (define-key map (kbd "C-v") 'transient-scroll-up)
+ (define-key map (kbd "C-M-v") 'transient-scroll-down)
+ (define-key map [next] 'transient-scroll-up)
+ (define-key map [prior] 'transient-scroll-down)
+ map)
+ "Parent of other keymaps used by Transient.
+
+This is the parent keymap of all the keymaps that are used in
+all transients: `transient-map' (which in turn is the parent
+of the transient-specific keymaps), `transient-edit-map' and
+`transient-sticky-map'.
+
+If you change a binding here, then you might also have to edit
+`transient-sticky-map' and `transient-common-commands'. While
+the latter isn't a proper transient prefix command, it can be
+edited using the same functions as used for transients.
+
+If you add a new command here, then you must also add a binding
+to `transient-predicate-map'.")
+
+(defvar transient-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map transient-base-map)
+ (define-key map (kbd "C-p") 'universal-argument)
+ (define-key map (kbd "C--") 'negative-argument)
+ (define-key map (kbd "C-t") 'transient-show)
+ (define-key map (kbd "?") 'transient-help)
+ (define-key map (kbd "C-h") 'transient-help)
+ ;; Also bound to "C-x p" and "C-x n" in transient-common-commands.
+ (define-key map (kbd "C-M-p") 'transient-history-prev)
+ (define-key map (kbd "C-M-n") 'transient-history-next)
+ map)
+ "Top-level keymap used by all transients.
+
+If you add a new command here, then you must also add a binding
+to `transient-predicate-map'. Also see `transient-base-map'.")
+
+(defvar transient-edit-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map transient-base-map)
+ (define-key map (kbd "?") 'transient-help)
+ (define-key map (kbd "C-h") 'transient-help)
+ (define-key map (kbd "C-x l") 'transient-set-level)
+ map)
+ "Keymap that is active while a transient in is in \"edit mode\".")
+
+(defvar transient-sticky-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map transient-base-map)
+ (define-key map (kbd "C-g") 'transient-quit-seq)
+ map)
+ "Keymap that is active while an incomplete key sequence is active.")
+
+(defvar transient--common-command-prefixes '(?\C-x))
+
+(put 'transient-common-commands
+ 'transient--layout
+ (cl-mapcan
+ (lambda (s) (transient--parse-child 'transient-common-commands s))
+ '([:hide (lambda ()
+ (and (not (memq (car transient--redisplay-key)
+ transient--common-command-prefixes))
+ (not transient-show-common-commands)))
+ ["Value commands"
+ ("C-x s " "Set" transient-set)
+ ("C-x C-s" "Save" transient-save)
+ ("C-x p " "Previous value" transient-history-prev)
+ ("C-x n " "Next value" transient-history-next)]
+ ["Sticky commands"
+ ;; Like `transient-sticky-map' except that
+ ;; "C-g" has to be bound to a different command.
+ ("C-g" "Quit prefix or transient" transient-quit-one)
+ ("C-q" "Quit transient stack" transient-quit-all)
+ ("C-z" "Suspend transient stack" transient-suspend)]
+ ["Customize"
+ ("C-x t" transient-toggle-common
+ :description (lambda ()
+ (if transient-show-common-commands
+ "Hide common commands"
+ "Show common permanently")))
+ ("C-x l" "Show/hide suffixes" transient-set-level)]])))
+
+(defvar transient-predicate-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [handle-switch-frame] 'transient--do-suspend)
+ (define-key map [transient-suspend] 'transient--do-suspend)
+ (define-key map [transient-help] 'transient--do-stay)
+ (define-key map [transient-set-level] 'transient--do-stay)
+ (define-key map [transient-history-prev] 'transient--do-stay)
+ (define-key map [transient-history-next] 'transient--do-stay)
+ (define-key map [universal-argument] 'transient--do-stay)
+ (define-key map [negative-argument] 'transient--do-stay)
+ (define-key map [digit-argument] 'transient--do-stay)
+ (define-key map [transient-quit-all] 'transient--do-quit-all)
+ (define-key map [transient-quit-one] 'transient--do-quit-one)
+ (define-key map [transient-quit-seq] 'transient--do-stay)
+ (define-key map [transient-show] 'transient--do-stay)
+ (define-key map [transient-update] 'transient--do-stay)
+ (define-key map [transient-toggle-common] 'transient--do-stay)
+ (define-key map [transient-set] 'transient--do-call)
+ (define-key map [transient-save] 'transient--do-call)
+ (define-key map [describe-key-briefly] 'transient--do-stay)
+ (define-key map [describe-key] 'transient--do-stay)
+ (define-key map [transient-scroll-up] 'transient--do-stay)
+ (define-key map [transient-scroll-down] 'transient--do-stay)
+ (define-key map [mwheel-scroll] 'transient--do-stay)
+ (define-key map [scroll-bar-toolkit-scroll] 'transient--do-stay)
+ (define-key map [transient-noop] 'transient--do-noop)
+ (define-key map [transient-mouse-push-button] 'transient--do-move)
+ (define-key map [transient-push-button] 'transient--do-move)
+ (define-key map [transient-backward-button] 'transient--do-move)
+ (define-key map [transient-forward-button] 'transient--do-move)
+ (define-key map [transient-isearch-backward] 'transient--do-move)
+ (define-key map [transient-isearch-forward] 'transient--do-move)
+ map)
+ "Base keymap used to map common commands to their transient behavior.
+
+The \"transient behavior\" of a command controls, among other
+things, whether invoking the command causes the transient to be
+exited or not and whether infix arguments are exported before
+doing so.
+
+Each \"key\" is a command that is common to all transients and
+that is bound in `transient-map', `transient-edit-map',
+`transient-sticky-map' and/or `transient-common-command'.
+
+Each binding is a \"pre-command\", a function that controls the
+transient behavior of the respective command.
+
+For transient commands that are bound in individual transients,
+the transient behavior is specified using the `:transient' slot
+of the corresponding object.")
+
+(defvar transient-popup-navigation-map)
+
+(defvar transient--transient-map nil)
+(defvar transient--predicate-map nil)
+(defvar transient--redisplay-map nil)
+(defvar transient--redisplay-key nil)
+
+(defun transient--push-keymap (map)
+ (transient--debug " push %s%s" map (if (symbol-value map) "" " VOID"))
+ (with-demoted-errors "transient--push-keymap: %S"
+ (internal-push-keymap (symbol-value map) 'overriding-terminal-local-map)))
+
+(defun transient--pop-keymap (map)
+ (transient--debug " pop %s%s" map (if (symbol-value map) "" " VOID"))
+ (with-demoted-errors "transient--pop-keymap: %S"
+ (internal-pop-keymap (symbol-value map) 'overriding-terminal-local-map)))
+
+(defun transient--make-transient-map ()
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map (if transient--editp
+ transient-edit-map
+ transient-map))
+ (dolist (obj transient--suffixes)
+ (let ((key (oref obj key)))
+ (when (vectorp key)
+ (setq key (key-description key))
+ (oset obj key key))
+ (when transient-substitute-key-function
+ (setq key (save-match-data
+ (funcall transient-substitute-key-function obj)))
+ (oset obj key key))
+ (let ((kbd (kbd key))
+ (cmd (transient--suffix-command obj)))
+ (when-let ((conflict (and transient-detect-key-conflicts
+ (transient--lookup-key map kbd))))
+ (unless (eq cmd conflict)
+ (error "Cannot bind %S to %s and also %s"
+ (string-trim key)
+ cmd conflict)))
+ (define-key map kbd cmd))))
+ (when transient-enable-popup-navigation
+ (setq map
+ (make-composed-keymap (list map transient-popup-navigation-map))))
+ map))
+
+(defun transient--make-predicate-map ()
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map transient-predicate-map)
+ (dolist (obj transient--suffixes)
+ (let* ((cmd (oref obj command))
+ (sub-prefix (and (symbolp cmd) (get cmd 'transient--prefix)))
+ (sym (transient--suffix-symbol cmd)))
+ (cond
+ ((oref obj inapt)
+ (define-key map (vector sym) 'transient--do-warn-inapt))
+ ((slot-boundp obj 'transient)
+ (define-key map (vector sym)
+ (let ((do (oref obj transient)))
+ (pcase do
+ (`t (if sub-prefix
+ 'transient--do-replace
+ 'transient--do-stay))
+ (`nil 'transient--do-exit)
+ (_ do)))))
+ ((not (lookup-key transient-predicate-map (vector sym)))
+ (define-key map (vector sym)
+ (if sub-prefix
+ 'transient--do-replace
+ (or (oref transient--prefix transient-suffix)
+ 'transient--do-exit)))))))
+ map))
+
+(defun transient--make-redisplay-map ()
+ (setq transient--redisplay-key
+ (cl-case this-command
+ (transient-update
+ (setq transient--showp t)
+ (setq unread-command-events
+ (listify-key-sequence (this-single-command-raw-keys))))
+ (transient-quit-seq
+ (setq unread-command-events
+ (butlast (listify-key-sequence
+ (this-single-command-raw-keys))
+ 2))
+ (butlast transient--redisplay-key))
+ (t nil)))
+ (let ((topmap (make-sparse-keymap))
+ (submap (make-sparse-keymap)))
+ (when transient--redisplay-key
+ (define-key topmap (vconcat transient--redisplay-key) submap)
+ (set-keymap-parent submap transient-sticky-map))
+ (map-keymap-internal
+ (lambda (key def)
+ (when (and (not (eq key ?\e))
+ (listp def)
+ (keymapp def))
+ (define-key topmap (vconcat transient--redisplay-key (list key))
+ 'transient-update)))
+ (if transient--redisplay-key
+ (lookup-key transient--transient-map (vconcat
transient--redisplay-key))
+ transient--transient-map))
+ topmap))
+
+;;; Setup
+
+(defun transient-setup (&optional name layout edit &rest params)
+ "Setup the transient specified by NAME.
+
+This function is called by transient prefix commands to setup the
+transient. In that case NAME is mandatory, LAYOUT and EDIT must
+be nil and PARAMS may be (but usually is not) used to set e.g. the
+\"scope\" of the transient (see `transient-define-prefix').
+
+This function is also called internally in which case LAYOUT and
+EDIT may be non-nil."
+ (transient--debug 'setup)
+ (when (> (minibuffer-depth) 0)
+ (user-error "Cannot invoke transient %s while minibuffer is active" name))
+ (transient--with-emergency-exit
+ (cond
+ ((not name)
+ ;; Switching between regular and edit mode.
+ (transient--pop-keymap 'transient--transient-map)
+ (transient--pop-keymap 'transient--redisplay-map)
+ (setq name (oref transient--prefix command))
+ (setq params (list :scope (oref transient--prefix scope))))
+ (transient--transient-map
+ ;; Invoked as a ":transient-non-suffix 'transient--do-{stay,call}"
+ ;; of an outer prefix. Unlike the usual `transient--do-replace',
+ ;; these predicates fail to clean up after the outer prefix.
+ (transient--pop-keymap 'transient--transient-map)
+ (transient--pop-keymap 'transient--redisplay-map))
+ ((not (or layout ; resuming parent/suspended prefix
+ transient-current-command)) ; entering child prefix
+ (transient--stack-zap)) ; replace suspended prefix, if any
+ (edit
+ ;; Returning from help to edit.
+ (setq transient--editp t)))
+ (transient--init-objects name layout params)
+ (transient--history-init transient--prefix)
+ (setq transient--predicate-map (transient--make-predicate-map))
+ (setq transient--transient-map (transient--make-transient-map))
+ (setq transient--redisplay-map (transient--make-redisplay-map))
+ (setq transient--original-window (selected-window))
+ (setq transient--original-buffer (current-buffer))
+ (transient--redisplay)
+ (transient--init-transient)
+ (transient--suspend-which-key-mode)))
+
+(cl-defgeneric transient-setup-children (group children)
+ "Setup the CHILDREN of GROUP.
+If the value of the `setup-children' slot is non-nil, then call
+that function with CHILDREN as the only argument and return the
+value. Otherwise return CHILDREN as is."
+ (if (slot-boundp group 'setup-children)
+ (funcall (oref group setup-children) children)
+ children))
+
+(defun transient--init-objects (name layout params)
+ (setq transient--prefix (transient--init-prefix name params))
+ (setq transient--layout (or layout (transient--init-suffixes name)))
+ (setq transient--suffixes (transient--flatten-suffixes transient--layout)))
+
+(defun transient--init-prefix (name &optional params)
+ (let ((obj (let ((proto (get name 'transient--prefix)))
+ (apply #'clone proto
+ :prototype proto
+ :level (or (alist-get t (alist-get name
transient-levels))
+ transient-default-level)
+ params))))
+ (transient-init-value obj)
+ obj))
+
+(defun transient--init-suffixes (name)
+ (let ((levels (alist-get name transient-levels)))
+ (cl-mapcan (lambda (c) (transient--init-child levels c))
+ (append (get name 'transient--layout)
+ (and (not transient--editp)
+ (get 'transient-common-commands
+ 'transient--layout))))))
+
+(defun transient--flatten-suffixes (layout)
+ (cl-labels ((s (def)
+ (cond
+ ((stringp def) nil)
+ ((listp def) (cl-mapcan #'s def))
+ ((transient-group--eieio-childp def)
+ (cl-mapcan #'s (oref def suffixes)))
+ ((transient-suffix--eieio-childp def)
+ (list def)))))
+ (cl-mapcan #'s layout)))
+
+(defun transient--init-child (levels spec)
+ (cl-etypecase spec
+ (vector (transient--init-group levels spec))
+ (list (transient--init-suffix levels spec))
+ (string (list spec))))
+
+(defun transient--init-group (levels spec)
+ (pcase-let ((`(,level ,class ,args ,children) (append spec nil)))
+ (when (transient--use-level-p level)
+ (let ((obj (apply class :level level args)))
+ (when (transient--use-suffix-p obj)
+ (when-let ((suffixes
+ (cl-mapcan (lambda (c) (transient--init-child levels c))
+ (transient-setup-children obj children))))
+ (oset obj suffixes suffixes)
+ (list obj)))))))
+
+(defun transient--init-suffix (levels spec)
+ (pcase-let* ((`(,level ,class ,args) spec)
+ (cmd (plist-get args :command))
+ (level (or (alist-get (transient--suffix-symbol cmd) levels)
+ level)))
+ (let ((fn (and (symbolp cmd)
+ (symbol-function cmd))))
+ (when (autoloadp fn)
+ (transient--debug " autoload %s" cmd)
+ (autoload-do-load fn)))
+ (when (transient--use-level-p level)
+ (let ((obj (if-let ((proto (and cmd
+ (symbolp cmd)
+ (get cmd 'transient--suffix))))
+ (apply #'clone proto :level level args)
+ (apply class :level level args))))
+ (transient--init-suffix-key obj)
+ (transient--ensure-infix-command obj)
+ (when (transient--use-suffix-p obj)
+ (if (transient--inapt-suffix-p obj)
+ (oset obj inapt t)
+ (transient-init-scope obj)
+ (transient-init-value obj))
+ (list obj))))))
+
+(cl-defmethod transient--init-suffix-key ((obj transient-suffix))
+ (unless (slot-boundp obj 'key)
+ (error "No key for %s" (oref obj command))))
+
+(cl-defmethod transient--init-suffix-key ((obj transient-argument))
+ (if (transient-switches--eieio-childp obj)
+ (cl-call-next-method obj)
+ (unless (slot-boundp obj 'shortarg)
+ (when-let ((shortarg (transient--derive-shortarg (oref obj argument))))
+ (oset obj shortarg shortarg)))
+ (unless (slot-boundp obj 'key)
+ (if (slot-boundp obj 'shortarg)
+ (oset obj key (oref obj shortarg))
+ (error "No key for %s" (oref obj command))))))
+
+(defun transient--use-level-p (level &optional edit)
+ (or (and transient--editp (not edit))
+ (and (>= level 1)
+ (<= level (oref transient--prefix level)))))
+
+(defun transient--use-suffix-p (obj)
+ (transient--do-suffix-p
+ (oref obj if)
+ (oref obj if-not)
+ (oref obj if-nil)
+ (oref obj if-non-nil)
+ (oref obj if-mode)
+ (oref obj if-not-mode)
+ (oref obj if-derived)
+ (oref obj if-not-derived)
+ t))
+
+(defun transient--inapt-suffix-p (obj)
+ (transient--do-suffix-p
+ (oref obj inapt-if)
+ (oref obj inapt-if-not)
+ (oref obj inapt-if-nil)
+ (oref obj inapt-if-non-nil)
+ (oref obj inapt-if-mode)
+ (oref obj inapt-if-not-mode)
+ (oref obj inapt-if-derived)
+ (oref obj inapt-if-not-derived)
+ nil))
+
+(defun transient--do-suffix-p
+ (if if-not if-nil if-non-nil if-mode if-not-mode if-derived if-not-derived
+ default)
+ (cond
+ (if (funcall if))
+ (if-not (not (funcall if-not)))
+ (if-non-nil (symbol-value if-non-nil))
+ (if-nil (not (symbol-value if-nil)))
+ (if-mode (if (atom if-mode)
+ (eq major-mode if-mode)
+ (memq major-mode if-mode)))
+ (if-not-mode (not (if (atom if-not-mode)
+ (eq major-mode if-not-mode)
+ (memq major-mode if-not-mode))))
+ (if-derived (if (atom if-derived)
+ (derived-mode-p if-derived)
+ (apply #'derived-mode-p if-derived)))
+ (if-not-derived (not (if (atom if-not-derived)
+ (derived-mode-p if-not-derived)
+ (apply #'derived-mode-p if-not-derived))))
+ (t default)))
+
+(defun transient--suffix-predicate (spec)
+ (let ((plist (nth 2 spec)))
+ (seq-some (lambda (prop)
+ (when-let ((pred (plist-get plist prop)))
+ (list prop pred)))
+ '( :if :if-not
+ :if-nil :if-non-nil
+ :if-mode :if-not-mode
+ :if-derived :if-not-derived
+ :inapt-if :inapt-if-not
+ :inapt-if-nil :inapt-if-non-nil
+ :inapt-if-mode :inapt-if-not-mode
+ :inapt-if-derived :inapt-if-not-derived))))
+
+;;; Flow-Control
+
+(defun transient--init-transient ()
+ (transient--debug 'init-transient)
+ (transient--push-keymap 'transient--transient-map)
+ (transient--push-keymap 'transient--redisplay-map)
+ (add-hook 'pre-command-hook #'transient--pre-command)
+ (add-hook 'minibuffer-setup-hook #'transient--minibuffer-setup)
+ (add-hook 'minibuffer-exit-hook #'transient--minibuffer-exit)
+ (add-hook 'post-command-hook #'transient--post-command)
+ (advice-add 'abort-recursive-edit :after #'transient--minibuffer-exit)
+ (when transient--exitp
+ ;; This prefix command was invoked as the suffix of another.
+ ;; Prevent `transient--post-command' from removing the hooks
+ ;; that we just added.
+ (setq transient--exitp 'replace)))
+
+(defun transient--pre-command ()
+ (transient--debug 'pre-command)
+ (cond
+ ((memq this-command '(transient-update transient-quit-seq))
+ (transient--pop-keymap 'transient--redisplay-map))
+ ((and transient--helpp
+ (not (memq this-command '(transient-quit-one
+ transient-quit-all))))
+ (cond
+ ((transient-help)
+ (transient--do-suspend)
+ (setq this-command 'transient-suspend)
+ (transient--pre-exit))
+ ((not (transient--edebug-command-p))
+ (setq this-command 'transient-undefined))))
+ ((and transient--editp
+ (transient-suffix-object)
+ (not (memq this-command '(transient-quit-one
+ transient-quit-all
+ transient-help))))
+ (setq this-command 'transient-set-level))
+ (t
+ (setq transient--exitp nil)
+ (when (eq (if-let ((fn (transient--get-predicate-for
+ this-original-command)))
+ (let ((action (funcall fn)))
+ (when (eq action transient--exit)
+ (setq transient--exitp (or transient--exitp t)))
+ action)
+ (if (let ((keys (this-command-keys-vector)))
+ (eq (aref keys (1- (length keys))) ?\C-g))
+ (setq this-command 'transient-noop)
+ (unless (transient--edebug-command-p)
+ (setq this-command 'transient-undefined)))
+ transient--stay)
+ transient--exit)
+ (transient--pre-exit)))))
+
+(defun transient--get-predicate-for (cmd)
+ (or (lookup-key transient--predicate-map
+ (vector (transient--suffix-symbol cmd)))
+ (oref transient--prefix transient-non-suffix)))
+
+(defun transient--pre-exit ()
+ (transient--debug 'pre-exit)
+ (transient--delete-window)
+ (transient--timer-cancel)
+ (transient--pop-keymap 'transient--transient-map)
+ (transient--pop-keymap 'transient--redisplay-map)
+ (remove-hook 'pre-command-hook #'transient--pre-command)
+ (unless transient--showp
+ (let ((message-log-max nil))
+ (message "")))
+ (setq transient--transient-map nil)
+ (setq transient--predicate-map nil)
+ (setq transient--redisplay-map nil)
+ (setq transient--redisplay-key nil)
+ (setq transient--showp nil)
+ (setq transient--helpp nil)
+ (setq transient--editp nil)
+ (setq transient--prefix nil)
+ (setq transient--layout nil)
+ (setq transient--suffixes nil)
+ (setq transient--original-window nil)
+ (setq transient--original-buffer nil)
+ (setq transient--window nil))
+
+(defun transient--delete-window ()
+ (when (window-live-p transient--window)
+ (let ((buf (window-buffer transient--window)))
+ (with-demoted-errors "Error while exiting transient: %S"
+ (delete-window transient--window))
+ (kill-buffer buf))))
+
+(defun transient--export ()
+ (setq transient-current-prefix transient--prefix)
+ (setq transient-current-command (oref transient--prefix command))
+ (setq transient-current-suffixes transient--suffixes)
+ (transient--history-push transient--prefix))
+
+(defun transient--minibuffer-setup ()
+ (transient--debug 'minibuffer-setup)
+ (unless (> (minibuffer-depth) 1)
+ (unless transient--exitp
+ (transient--pop-keymap 'transient--transient-map)
+ (transient--pop-keymap 'transient--redisplay-map)
+ (remove-hook 'pre-command-hook #'transient--pre-command))
+ (remove-hook 'post-command-hook #'transient--post-command)))
+
+(defun transient--minibuffer-exit ()
+ (transient--debug 'minibuffer-exit)
+ (unless (> (minibuffer-depth) 1)
+ (unless transient--exitp
+ (transient--push-keymap 'transient--transient-map)
+ (transient--push-keymap 'transient--redisplay-map)
+ (add-hook 'pre-command-hook #'transient--pre-command))
+ (add-hook 'post-command-hook #'transient--post-command)))
+
+(defun transient--suspend-override (&optional minibuffer-hooks)
+ (transient--debug 'suspend-override)
+ (transient--pop-keymap 'transient--transient-map)
+ (transient--pop-keymap 'transient--redisplay-map)
+ (remove-hook 'pre-command-hook #'transient--pre-command)
+ (remove-hook 'post-command-hook #'transient--post-command)
+ (when minibuffer-hooks
+ (remove-hook 'minibuffer-setup-hook #'transient--minibuffer-setup)
+ (remove-hook 'minibuffer-exit-hook #'transient--minibuffer-exit)
+ (advice-remove 'abort-recursive-edit #'transient--minibuffer-exit)))
+
+(defun transient--resume-override (&optional minibuffer-hooks)
+ (transient--debug 'resume-override)
+ (transient--push-keymap 'transient--transient-map)
+ (transient--push-keymap 'transient--redisplay-map)
+ (add-hook 'pre-command-hook #'transient--pre-command)
+ (add-hook 'post-command-hook #'transient--post-command)
+ (when minibuffer-hooks
+ (add-hook 'minibuffer-setup-hook #'transient--minibuffer-setup)
+ (add-hook 'minibuffer-exit-hook #'transient--minibuffer-exit)
+ (advice-add 'abort-recursive-edit :after #'transient--minibuffer-exit)))
+
+(defun transient--post-command ()
+ (transient--debug 'post-command)
+ (if transient--exitp
+ (progn
+ (unless (and (eq transient--exitp 'replace)
+ (or transient--prefix
+ ;; The current command could act as a prefix,
+ ;; but decided not to call `transient-setup'.
+ (prog1 nil (transient--stack-zap))))
+ (remove-hook 'minibuffer-setup-hook #'transient--minibuffer-setup)
+ (remove-hook 'minibuffer-exit-hook #'transient--minibuffer-exit)
+ (advice-remove 'abort-recursive-edit #'transient--minibuffer-exit)
+ (remove-hook 'post-command-hook #'transient--post-command))
+ (setq transient-current-prefix nil)
+ (setq transient-current-command nil)
+ (setq transient-current-suffixes nil)
+ (let ((resume (and transient--stack
+ (not (memq transient--exitp '(replace suspend))))))
+ (setq transient--exitp nil)
+ (setq transient--helpp nil)
+ (setq transient--editp nil)
+ (run-hooks 'transient-exit-hook)
+ (when resume
+ (transient--stack-pop))))
+ (transient--pop-keymap 'transient--redisplay-map)
+ (setq transient--redisplay-map (transient--make-redisplay-map))
+ (transient--push-keymap 'transient--redisplay-map)
+ (unless (eq this-command (oref transient--prefix command))
+ (transient--redisplay))))
+
+(defun transient--stack-push ()
+ (transient--debug 'stack-push)
+ (push (list (oref transient--prefix command)
+ transient--layout
+ transient--editp
+ :scope (oref transient--prefix scope))
+ transient--stack))
+
+(defun transient--stack-pop ()
+ (transient--debug 'stack-pop)
+ (and transient--stack
+ (prog1 t (apply #'transient-setup (pop transient--stack)))))
+
+(defun transient--stack-zap ()
+ (transient--debug 'stack-zap)
+ (setq transient--stack nil))
+
+(defun transient--redisplay ()
+ (if (or (eq transient-show-popup t)
+ transient--showp)
+ (unless (memq this-command transient--scroll-commands)
+ (transient--show))
+ (when (and (numberp transient-show-popup)
+ (not (zerop transient-show-popup))
+ (not transient--timer))
+ (transient--timer-start))
+ (transient--show-brief)))
+
+(defun transient--timer-start ()
+ (setq transient--timer
+ (run-at-time (abs transient-show-popup) nil
+ (lambda ()
+ (transient--timer-cancel)
+ (transient--show)
+ (let ((message-log-max nil))
+ (message ""))))))
+
+(defun transient--timer-cancel ()
+ (when transient--timer
+ (cancel-timer transient--timer)
+ (setq transient--timer nil)))
+
+(defun transient--debug (arg &rest args)
+ (when transient--debug
+ (if (symbolp arg)
+ (message "-- %-16s (cmd: %s, event: %S, exit: %s)"
+ arg
+ (transient--suffix-symbol this-command)
+ (key-description (this-command-keys-vector))
+ transient--exitp)
+ (apply #'message arg args))))
+
+(defun transient--emergency-exit ()
+ "Exit the current transient command after an error occurred.
+When no transient is active (i.e. when `transient--prefix') is
+nil, then do nothing."
+ (transient--debug 'emergency-exit)
+ (when transient--prefix
+ (setq transient--stack nil)
+ (setq transient--exitp t)
+ (transient--pre-exit)
+ (transient--post-command)))
+
+;;; Pre-Commands
+
+(defun transient--do-stay ()
+ "Call the command without exporting variables and stay transient."
+ transient--stay)
+
+(defun transient--do-noop ()
+ "Call `transient-noop' and stay transient."
+ (setq this-command 'transient-noop)
+ transient--stay)
+
+(defun transient--do-warn ()
+ "Call `transient-undefined' and stay transient."
+ (setq this-command 'transient-undefined)
+ transient--stay)
+
+(defun transient--do-warn-inapt ()
+ "Call `transient-inapt' and stay transient."
+ (setq this-command 'transient-inapt)
+ transient--stay)
+
+(defun transient--do-call ()
+ "Call the command after exporting variables and stay transient."
+ (transient--export)
+ transient--stay)
+
+(defun transient--do-exit ()
+ "Call the command after exporting variables and exit the transient."
+ (transient--export)
+ (transient--stack-zap)
+ transient--exit)
+
+(defun transient--do-replace ()
+ "Call the transient prefix command, replacing the active transient."
+ (transient--export)
+ (transient--stack-push)
+ (setq transient--exitp 'replace)
+ transient--exit)
+
+(defun transient--do-suspend ()
+ "Suspend the active transient, saving the transient stack."
+ (transient--stack-push)
+ (setq transient--exitp 'suspend)
+ transient--exit)
+
+(defun transient--do-quit-one ()
+ "If active, quit help or edit mode, else exit the active transient."
+ (cond (transient--helpp
+ (setq transient--helpp nil)
+ transient--stay)
+ (transient--editp
+ (setq transient--editp nil)
+ (transient-setup)
+ transient--stay)
+ (t transient--exit)))
+
+(defun transient--do-quit-all ()
+ "Exit all transients without saving the transient stack."
+ (transient--stack-zap)
+ transient--exit)
+
+(defun transient--do-move ()
+ "Call the command if `transient-enable-popup-navigation' is non-nil.
+In that case behave like `transient--do-stay', otherwise similar
+to `transient--do-warn'."
+ (unless transient-enable-popup-navigation
+ (setq this-command 'transient-popup-navigation-help))
+ transient--stay)
+
+(put 'transient--do-stay 'transient-color 'transient-blue)
+(put 'transient--do-noop 'transient-color 'transient-blue)
+(put 'transient--do-warn 'transient-color 'transient-blue)
+(put 'transient--do-warn-inapt 'transient-color 'transient-blue)
+(put 'transient--do-call 'transient-color 'transient-blue)
+(put 'transient--do-exit 'transient-color 'transient-red)
+(put 'transient--do-replace 'transient-color 'transient-red)
+(put 'transient--do-suspend 'transient-color 'transient-red)
+(put 'transient--do-quit-one 'transient-color 'transient-red)
+(put 'transient--do-quit-all 'transient-color 'transient-red)
+(put 'transient--do-move 'transient-color 'transient-blue)
+
+;;; Commands
+
+(defun transient-noop ()
+ "Do nothing at all."
+ (interactive))
+
+(defun transient-undefined ()
+ "Warn the user that the pressed key is not bound to any suffix."
+ (interactive)
+ (transient--invalid "Unbound suffix"))
+
+(defun transient-inapt ()
+ "Warn the user that the invoked command is inapt."
+ (interactive)
+ (transient--invalid "Inapt command"))
+
+(defun transient--invalid (msg)
+ (ding)
+ (message "%s: `%s' (Use `%s' to abort, `%s' for help) [%s]"
+ msg
+ (propertize (key-description (this-single-command-keys))
+ 'face 'font-lock-warning-face)
+ (propertize "C-g" 'face 'transient-key)
+ (propertize "?" 'face 'transient-key)
+ (propertize (symbol-name (transient--suffix-symbol
+ this-original-command))
+ 'face 'font-lock-warning-face)))
+
+(defun transient-toggle-common ()
+ "Toggle whether common commands are always shown."
+ (interactive)
+ (setq transient-show-common-commands (not transient-show-common-commands)))
+
+(defun transient-suspend ()
+ "Suspend the current transient.
+It can later be resumed using `transient-resume' while no other
+transient is active."
+ (interactive))
+
+(defun transient-quit-all ()
+ "Exit all transients without saving the transient stack."
+ (interactive))
+
+(defun transient-quit-one ()
+ "Exit the current transients, possibly returning to the previous."
+ (interactive))
+
+(defun transient-quit-seq ()
+ "Abort the current incomplete key sequence."
+ (interactive))
+
+(defun transient-update ()
+ "Redraw the transient's state in the popup buffer."
+ (interactive))
+
+(defun transient-show ()
+ "Show the transient's state in the popup buffer."
+ (interactive)
+ (setq transient--showp t))
+
+(defvar-local transient--restore-winconf nil)
+
+(defvar transient-resume-mode)
+
+(defun transient-help ()
+ "Show help for the active transient or one of its suffixes."
+ (interactive)
+ (if (called-interactively-p 'any)
+ (setq transient--helpp t)
+ (with-demoted-errors "transient-help: %S"
+ (when (lookup-key transient--transient-map
+ (this-single-command-raw-keys))
+ (setq transient--helpp nil)
+ (let ((winconf (current-window-configuration)))
+ (transient-show-help
+ (if (eq this-original-command 'transient-help)
+ transient--prefix
+ (or (transient-suffix-object)
+ this-original-command)))
+ (setq transient--restore-winconf winconf))
+ (fit-window-to-buffer nil (frame-height) (window-height))
+ (transient-resume-mode)
+ (message "Type \"q\" to resume transient command.")
+ t))))
+
+(defun transient-set-level (&optional command level)
+ "Set the level of the transient or one of its suffix commands."
+ (interactive
+ (let ((command this-original-command)
+ (prefix (oref transient--prefix command)))
+ (and (or (not (eq command 'transient-set-level))
+ (and transient--editp
+ (setq command prefix)))
+ (list command
+ (let ((keys (this-single-command-raw-keys)))
+ (and (lookup-key transient--transient-map keys)
+ (string-to-number
+ (let ((transient--active-infix
+ (transient-suffix-object command)))
+ (transient--show)
+ (transient--read-number-N
+ (format "Set level for `%s': "
+ (transient--suffix-symbol command))
+ nil nil (not (eq command prefix)))))))))))
+ (cond
+ ((not command)
+ (setq transient--editp t)
+ (transient-setup))
+ (level
+ (let* ((prefix (oref transient--prefix command))
+ (alist (alist-get prefix transient-levels))
+ (sym (transient--suffix-symbol command)))
+ (if (eq command prefix)
+ (progn (oset transient--prefix level level)
+ (setq sym t))
+ (oset (transient-suffix-object command) level level))
+ (setf (alist-get sym alist) level)
+ (setf (alist-get prefix transient-levels) alist))
+ (transient-save-levels))
+ (t
+ (transient-undefined))))
+
+(defun transient-set ()
+ "Save the value of the active transient for this Emacs session."
+ (interactive)
+ (transient-set-value (or transient--prefix transient-current-prefix)))
+
+(defun transient-save ()
+ "Save the value of the active transient persistenly across Emacs sessions."
+ (interactive)
+ (transient-save-value (or transient--prefix transient-current-prefix)))
+
+(defun transient-history-next ()
+ "Switch to the next value used for the active transient."
+ (interactive)
+ (let* ((obj transient--prefix)
+ (pos (1- (oref obj history-pos)))
+ (hst (oref obj history)))
+ (if (< pos 0)
+ (user-error "End of history")
+ (oset obj history-pos pos)
+ (oset obj value (nth pos hst))
+ (mapc #'transient-init-value transient--suffixes))))
+
+(defun transient-history-prev ()
+ "Switch to the previous value used for the active transient."
+ (interactive)
+ (let* ((obj transient--prefix)
+ (pos (1+ (oref obj history-pos)))
+ (hst (oref obj history))
+ (len (length hst)))
+ (if (> pos (1- len))
+ (user-error "End of history")
+ (oset obj history-pos pos)
+ (oset obj value (nth pos hst))
+ (mapc #'transient-init-value transient--suffixes))))
+
+(defun transient-scroll-up (&optional arg)
+ "Scroll text of transient popup window upward ARG lines.
+If ARG is nil scroll near full screen. This is a wrapper
+around `scroll-up-command' (which see)."
+ (interactive "^P")
+ (with-selected-window transient--window
+ (scroll-up-command arg)))
+
+(defun transient-scroll-down (&optional arg)
+ "Scroll text of transient popup window down ARG lines.
+If ARG is nil scroll near full screen. This is a wrapper
+around `scroll-down-command' (which see)."
+ (interactive "^P")
+ (with-selected-window transient--window
+ (scroll-down-command arg)))
+
+(defun transient-resume ()
+ "Resume a previously suspended stack of transients."
+ (interactive)
+ (cond (transient--stack
+ (let ((winconf transient--restore-winconf))
+ (kill-local-variable 'transient--restore-winconf)
+ (when transient-resume-mode
+ (transient-resume-mode -1)
+ (quit-window))
+ (when winconf
+ (set-window-configuration winconf)))
+ (transient--stack-pop))
+ (transient-resume-mode
+ (kill-local-variable 'transient--restore-winconf)
+ (transient-resume-mode -1)
+ (quit-window))
+ (t
+ (message "No suspended transient command"))))
+
+;;; Value
+;;;; Init
+
+(cl-defgeneric transient-init-scope (obj)
+ "Set the scope of the suffix object OBJ.
+
+The scope is actually a property of the transient prefix, not of
+individual suffixes. However it is possible to invoke a suffix
+command directly instead of from a transient. In that case, if
+the suffix expects a scope, then it has to determine that itself
+and store it in its `scope' slot.
+
+This function is called for all suffix commands, but unless a
+concrete method is implemented this falls through to the default
+implementation, which is a noop.")
+
+(cl-defmethod transient-init-scope ((_ transient-suffix))
+ "Noop." nil)
+
+(cl-defgeneric transient-init-value (_)
+ "Set the initial value of the object OBJ.
+
+This function is called for all prefix and suffix commands.
+
+For suffix commands (including infix argument commands) the
+default implementation is a noop. Classes derived from the
+abstract `transient-infix' class must implement this function.
+Non-infix suffix commands usually don't have a value."
+ nil)
+
+(cl-defmethod transient-init-value :around ((obj transient-prefix))
+ "If bound, then call OBJ's `init-value' function.
+Otherwise call the primary method according to objects class."
+ (if (slot-boundp obj 'init-value)
+ (funcall (oref obj init-value) obj)
+ (cl-call-next-method obj)))
+
+(cl-defmethod transient-init-value :around ((obj transient-infix))
+ "If bound, then call OBJ's `init-value' function.
+Otherwise call the primary method according to objects class."
+ (if (slot-boundp obj 'init-value)
+ (funcall (oref obj init-value) obj)
+ (cl-call-next-method obj)))
+
+(cl-defmethod transient-init-value ((obj transient-prefix))
+ (if (slot-boundp obj 'value)
+ (oref obj value)
+ (oset obj value
+ (if-let ((saved (assq (oref obj command) transient-values)))
+ (cdr saved)
+ (if-let ((default (and (slot-boundp obj 'default-value)
+ (oref obj default-value))))
+ (if (functionp default)
+ (funcall default)
+ default)
+ nil)))))
+
+(cl-defmethod transient-init-value ((obj transient-switch))
+ (oset obj value
+ (car (member (oref obj argument)
+ (oref transient--prefix value)))))
+
+(cl-defmethod transient-init-value ((obj transient-option))
+ (oset obj value
+ (transient--value-match (format "\\`%s\\(.*\\)" (oref obj argument)))))
+
+(cl-defmethod transient-init-value ((obj transient-switches))
+ (oset obj value
+ (transient--value-match (oref obj argument-regexp))))
+
+(defun transient--value-match (re)
+ (when-let ((match (cl-find-if (lambda (v)
+ (and (stringp v)
+ (string-match re v)))
+ (oref transient--prefix value))))
+ (match-string 1 match)))
+
+(cl-defmethod transient-init-value ((obj transient-files))
+ (oset obj value
+ (cdr (assoc "--" (oref transient--prefix value)))))
+
+;;;; Read
+
+(cl-defgeneric transient-infix-read (obj)
+ "Determine the new value of the infix object OBJ.
+
+This function merely determines the value; `transient-infix-set'
+is used to actually store the new value in the object.
+
+For most infix classes this is done by reading a value from the
+user using the reader specified by the `reader' slot (using the
+`transient-infix' method described below).
+
+For some infix classes the value is changed without reading
+anything in the minibuffer, i.e. the mere act of invoking the
+infix command determines what the new value should be, based
+on the previous value.")
+
+(cl-defmethod transient-infix-read :around ((obj transient-infix))
+ "Highlight the infix in the popup buffer.
+
+Also arrange for the transient to be exited in case of an error
+because otherwise Emacs would get stuck in an inconsistent state,
+which might make it necessary to kill it from the outside."
+ (let ((transient--active-infix obj))
+ (transient--show))
+ (transient--with-emergency-exit
+ (cl-call-next-method obj)))
+
+(cl-defmethod transient-infix-read ((obj transient-infix))
+ "Read a value while taking care of history.
+
+This method is suitable for a wide variety of infix commands,
+including but not limited to inline arguments and variables.
+
+If you do not use this method for your own infix class, then
+you should likely replicate a lot of the behavior of this
+method. If you fail to do so, then users might not appreciate
+the lack of history, for example.
+
+Only for very simple classes that toggle or cycle through a very
+limited number of possible values should you replace this with a
+simple method that does not handle history. (E.g. for a command
+line switch the only possible values are \"use it\" and \"don't use
+it\", in which case it is pointless to preserve history.)"
+ (with-slots (value multi-value always-read allow-empty choices) obj
+ (if (and value
+ (not multi-value)
+ (not always-read)
+ transient--prefix)
+ (oset obj value nil)
+ (let* ((overriding-terminal-local-map nil)
+ (reader (oref obj reader))
+ (prompt (transient-prompt obj))
+ (value (if multi-value (mapconcat #'identity value ",") value))
+ (history-key (or (oref obj history-key)
+ (oref obj command)))
+ (transient--history (alist-get history-key transient-history))
+ (transient--history (if (or (null value)
+ (eq value (car transient--history)))
+ transient--history
+ (cons value transient--history)))
+ (initial-input (and transient-read-with-initial-input
+ (car transient--history)))
+ (history (if initial-input
+ (cons 'transient--history 1)
+ 'transient--history))
+ (value
+ (cond
+ (reader (funcall reader prompt initial-input history))
+ (multi-value
+ (completing-read-multiple prompt choices nil nil
+ initial-input history))
+ (choices
+ (completing-read prompt choices nil t initial-input history))
+ (t (read-string prompt initial-input history)))))
+ (cond ((and (equal value "") (not allow-empty))
+ (setq value nil))
+ ((and (equal value "\"\"") allow-empty)
+ (setq value "")))
+ (when value
+ (when (and (bound-and-true-p ivy-mode)
+ (stringp (car transient--history)))
+ (set-text-properties 0 (length (car transient--history)) nil
+ (car transient--history)))
+ (setf (alist-get history-key transient-history)
+ (delete-dups transient--history)))
+ value))))
+
+(cl-defmethod transient-infix-read ((obj transient-switch))
+ "Toggle the switch on or off."
+ (if (oref obj value) nil (oref obj argument)))
+
+(cl-defmethod transient-infix-read ((obj transient-switches))
+ "Cycle through the mutually exclusive switches.
+The last value is \"don't use any of these switches\"."
+ (let ((choices (mapcar (apply-partially #'format (oref obj argument-format))
+ (oref obj choices))))
+ (if-let ((value (oref obj value)))
+ (cadr (member value choices))
+ (car choices))))
+
+(cl-defmethod transient-infix-read ((command symbol))
+ "Elsewhere use the reader of the infix command COMMAND.
+Use this if you want to share an infix's history with a regular
+stand-alone command."
+ (cl-letf (((symbol-function #'transient--show) #'ignore))
+ (transient-infix-read (get command 'transient--suffix))))
+
+;;;; Readers
+
+(defun transient-read-file (prompt _initial-input _history)
+ "Read a file."
+ (file-local-name (expand-file-name (read-file-name prompt))))
+
+(defun transient-read-existing-file (prompt _initial-input _history)
+ "Read an existing file."
+ (file-local-name (expand-file-name (read-file-name prompt nil nil t))))
+
+(defun transient-read-directory (prompt _initial-input _history)
+ "Read a directory."
+ (file-local-name (expand-file-name (read-directory-name prompt))))
+
+(defun transient-read-existing-directory (prompt _initial-input _history)
+ "Read an existing directory."
+ (file-local-name (expand-file-name (read-directory-name prompt nil nil t))))
+
+(defun transient-read-number-N0 (prompt initial-input history)
+ "Read a natural number (including zero) and return it as a string."
+ (transient--read-number-N prompt initial-input history t))
+
+(defun transient-read-number-N+ (prompt initial-input history)
+ "Read a natural number (excluding zero) and return it as a string."
+ (transient--read-number-N prompt initial-input history nil))
+
+(defun transient--read-number-N (prompt initial-input history include-zero)
+ (save-match-data
+ (cl-block nil
+ (while t
+ (let ((str (read-from-minibuffer prompt initial-input nil nil
history)))
+ (cond ((string-equal str "")
+ (cl-return nil))
+ ((string-match-p (if include-zero
+ "\\`\\(0\\|[1-9][0-9]*\\)\\'"
+ "\\`[1-9][0-9]*\\'")
+ str)
+ (cl-return str))))
+ (message "Please enter a natural number (%s zero)."
+ (if include-zero "including" "excluding"))
+ (sit-for 1)))))
+
+(defun transient-read-date (prompt default-time _history)
+ "Read a date using `org-read-date' (which see)."
+ (require 'org)
+ (when (fboundp 'org-read-date)
+ (org-read-date 'with-time nil nil prompt default-time)))
+
+;;;; Prompt
+
+(cl-defgeneric transient-prompt (obj)
+ "Return the prompt to be used to read infix object OBJ's value.")
+
+(cl-defmethod transient-prompt ((obj transient-infix))
+ "Return the prompt to be used to read infix object OBJ's value.
+
+This implementation should be suitable for almost all infix
+commands.
+
+If the value of OBJ's `prompt' slot is non-nil, then it must be
+a string or a function. If it is a string, then use that. If
+it is a function, then call that with OBJ as the only argument.
+That function must return a string, which is then used as the
+prompt.
+
+Otherwise, if the value of either the `argument' or `variable'
+slot of OBJ is a string, then base the prompt on that (preferring
+the former), appending either \"=\" (if it appears to be a
+command-line option) or \": \".
+
+Finally fall through to using \"(BUG: no prompt): \" as the
+prompt."
+ (if-let ((prompt (oref obj prompt)))
+ (let ((prompt (if (functionp prompt)
+ (funcall prompt obj)
+ prompt)))
+ (if (stringp prompt)
+ prompt
+ "(BUG: no prompt): "))
+ (or (when-let ((arg (and (slot-boundp obj 'argument) (oref obj argument))))
+ (if (and (stringp arg) (string-suffix-p "=" arg))
+ arg
+ (concat arg ": ")))
+ (when-let ((var (and (slot-boundp obj 'variable) (oref obj variable))))
+ (and (stringp var)
+ (concat var ": ")))
+ "(BUG: no prompt): ")))
+
+;;;; Set
+
+(defvar transient--unset-incompatible t)
+
+(cl-defgeneric transient-infix-set (obj value)
+ "Set the value of infix object OBJ to value.")
+
+(cl-defmethod transient-infix-set ((obj transient-infix) value)
+ "Set the value of infix object OBJ to value."
+ (oset obj value value))
+
+(cl-defmethod transient-infix-set :around ((obj transient-argument) value)
+ "Unset incompatible infix arguments."
+ (let ((arg (if (slot-boundp obj 'argument)
+ (oref obj argument)
+ (oref obj argument-regexp))))
+ (if-let ((sic (and value arg transient--unset-incompatible))
+ (spec (oref transient--prefix incompatible))
+ (incomp (remove arg (cl-find-if (lambda (elt) (member arg elt))
spec))))
+ (progn
+ (cl-call-next-method obj value)
+ (dolist (arg incomp)
+ (when-let ((obj (cl-find-if (lambda (obj)
+ (and (slot-boundp obj 'argument)
+ (equal (oref obj argument)
arg)))
+ transient--suffixes)))
+ (let ((transient--unset-incompatible nil))
+ (transient-infix-set obj nil)))))
+ (cl-call-next-method obj value))))
+
+(cl-defmethod transient-set-value ((obj transient-prefix))
+ (oset (oref obj prototype) value (transient-get-value))
+ (transient--history-push obj))
+
+;;;; Save
+
+(cl-defmethod transient-save-value ((obj transient-prefix))
+ (let ((value (transient-get-value)))
+ (oset (oref obj prototype) value value)
+ (setf (alist-get (oref obj command) transient-values) value)
+ (transient-save-values))
+ (transient--history-push obj))
+
+;;;; Get
+
+(defun transient-args (prefix)
+ "Return the value of the transient prefix command PREFIX.
+If the current command was invoked from the transient prefix
+command PREFIX, then return the active infix arguments. If
+the current command was not invoked from PREFIX, then return
+the set, saved or default value for PREFIX."
+ (delq nil (mapcar 'transient-infix-value (transient-suffixes prefix))))
+
+(defun transient-suffixes (prefix)
+ "Return the suffix objects of the transient prefix command PREFIX."
+ (if (eq transient-current-command prefix)
+ transient-current-suffixes
+ (let ((transient--prefix (transient--init-prefix prefix)))
+ (transient--flatten-suffixes
+ (transient--init-suffixes prefix)))))
+
+(defun transient-get-value ()
+ (delq nil (mapcar (lambda (obj)
+ (and (or (not (slot-exists-p obj 'unsavable))
+ (not (oref obj unsavable)))
+ (transient-infix-value obj)))
+ transient-current-suffixes)))
+
+(cl-defgeneric transient-infix-value (obj)
+ "Return the value of the suffix object OBJ.
+
+This function is called by `transient-args' (which see), meaning
+this function is how the value of a transient is determined so
+that the invoked suffix command can use it.
+
+Currently most values are strings, but that is not set in stone.
+Nil is not a value, it means \"no value\".
+
+Usually only infixes have a value, but see the method for
+`transient-suffix'.")
+
+(cl-defmethod transient-infix-value ((_ transient-suffix))
+ "Return nil, which means \"no value\".
+
+Infix arguments contribute the the transient's value while suffix
+commands consume it. This function is called for suffixes anyway
+because a command that both contributes to the transient's value
+and also consumes it is not completely unconceivable.
+
+If you define such a command, then you must define a derived
+class and implement this function because this default method
+does nothing." nil)
+
+(cl-defmethod transient-infix-value ((obj transient-infix))
+ "Return the value of OBJ's `value' slot."
+ (oref obj value))
+
+(cl-defmethod transient-infix-value ((obj transient-option))
+ "Return (concat ARGUMENT VALUE) or nil.
+
+ARGUMENT and VALUE are the values of the respective slots of OBJ.
+If VALUE is nil, then return nil. VALUE may be the empty string,
+which is not the same as nil."
+ (when-let ((value (oref obj value)))
+ (concat (oref obj argument) value)))
+
+(cl-defmethod transient-infix-value ((_ transient-variable))
+ "Return nil, which means \"no value\".
+
+Setting the value of a variable is done by, well, setting the
+value of the variable. I.e. this is a side-effect and does not
+contribute to the value of the transient."
+ nil)
+
+(cl-defmethod transient-infix-value ((obj transient-files))
+ "Return (cons ARGUMENT VALUE) or nil.
+
+ARGUMENT and VALUE are the values of the respective slots of OBJ.
+If VALUE is nil, then return nil. VALUE may be the empty string,
+which is not the same as nil."
+ (when-let ((value (oref obj value)))
+ (cons (oref obj argument) value)))
+
+;;;; Utilities
+
+(defun transient-arg-value (arg args)
+ "Return the value of ARG as it appears in ARGS.
+
+For a switch return a boolean. For an option return the value as
+a string, using the empty string for the empty value, or nil if
+the option does not appear in ARGS."
+ (if (string-match-p "=\\'" arg)
+ (save-match-data
+ (when-let ((match (let ((re (format "\\`%s\\(?:=\\(.+\\)\\)?\\'"
+ (substring arg 0 -1))))
+ (cl-find-if (lambda (a)
+ (and (stringp a)
+ (string-match re a)))
+ args))))
+ (or (match-string 1 match) "")))
+ (and (member arg args) t)))
+
+;;; History
+
+(cl-defgeneric transient--history-key (obj)
+ "Return OBJ's history key.
+If the value of the `history-key' slot is non-nil, then return
+that. Otherwise return the value of the `command' slot."
+ (or (oref obj history-key)
+ (oref obj command)))
+
+(cl-defgeneric transient--history-push (obj)
+ "Push the current value of OBJ to its entry in `transient-history'."
+ (let ((key (transient--history-key obj)))
+ (setf (alist-get key transient-history)
+ (let ((args (transient-get-value)))
+ (cons args (delete args (alist-get key transient-history)))))))
+
+(cl-defgeneric transient--history-init (obj)
+ "Initialize OBJ's `history' slot.
+This is the transient-wide history; many individual infixes also
+have a history of their own.")
+
+(cl-defmethod transient--history-init ((obj transient-prefix))
+ "Initialize OBJ's `history' slot from the variable `transient-history'."
+ (let ((val (oref obj value)))
+ (oset obj history
+ (cons val (delete val (alist-get (transient--history-key obj)
+ transient-history))))))
+
+;;; Draw
+
+(defun transient--show-brief ()
+ (let ((message-log-max nil))
+ (if (and transient-show-popup (<= transient-show-popup 0))
+ (message "%s-" (key-description (this-command-keys)))
+ (message
+ "%s- [%s] %s"
+ (key-description (this-command-keys))
+ (oref transient--prefix command)
+ (mapconcat
+ #'identity
+ (sort
+ (cl-mapcan
+ (lambda (suffix)
+ (let ((key (kbd (oref suffix key))))
+ ;; Don't list any common commands.
+ (and (not (memq (oref suffix command)
+ `(,(lookup-key transient-map key)
+ ,(lookup-key transient-sticky-map key)
+ ;; From transient-common-commands:
+ transient-set
+ transient-save
+ transient-history-prev
+ transient-history-next
+ transient-quit-one
+ transient-toggle-common
+ transient-set-level)))
+ (list (propertize (oref suffix key) 'face
'transient-key)))))
+ transient--suffixes)
+ #'string<)
+ (propertize "|" 'face 'transient-unreachable-key))))))
+
+(defun transient--show ()
+ (transient--timer-cancel)
+ (setq transient--showp t)
+ (let ((buf (get-buffer-create transient--buffer-name))
+ (focus nil))
+ (unless (window-live-p transient--window)
+ (setq transient--window
+ (display-buffer buf transient-display-buffer-action)))
+ (with-selected-window transient--window
+ (when transient-enable-popup-navigation
+ (setq focus (button-get (point) 'command)))
+ (erase-buffer)
+ (set-window-hscroll transient--window 0)
+ (set-window-dedicated-p transient--window t)
+ (set-window-parameter transient--window 'no-other-window t)
+ (setq window-size-fixed t)
+ (when (bound-and-true-p tab-line-format)
+ (setq tab-line-format nil))
+ (setq mode-line-format (if (eq transient-mode-line-format 'line)
+ nil
+ transient-mode-line-format))
+ (setq mode-line-buffer-identification
+ (symbol-name (oref transient--prefix command)))
+ (if transient-enable-popup-navigation
+ (setq-local cursor-in-non-selected-windows 'box)
+ (setq cursor-type nil))
+ (setq display-line-numbers nil)
+ (setq show-trailing-whitespace nil)
+ (transient--insert-groups)
+ (when (or transient--helpp transient--editp)
+ (transient--insert-help))
+ (when (and (eq transient-mode-line-format 'line)
+ window-system)
+ (let ((face
+ (if-let ((f (and (transient--semantic-coloring-p)
+ (transient--prefix-color transient--prefix))))
+ `(,@(and (>= emacs-major-version 27) '(:extend t))
+ :background ,(face-foreground f))
+ 'transient-separator)))
+ (insert (propertize "__" 'face face 'display '(space :height (1))))
+ (insert (propertize "\n" 'face face 'line-height t))))
+ (let ((window-resize-pixelwise t)
+ (window-size-fixed nil))
+ (fit-window-to-buffer nil nil 1))
+ (goto-char (point-min))
+ (when transient-force-fixed-pitch
+ (transient--force-fixed-pitch))
+ (when transient-enable-popup-navigation
+ (transient--goto-button focus)))))
+
+(defun transient--insert-groups ()
+ (let ((groups (cl-mapcan (lambda (group)
+ (let ((hide (oref group hide)))
+ (and (not (and (functionp hide)
+ (funcall hide)))
+ (list group))))
+ transient--layout))
+ group)
+ (while (setq group (pop groups))
+ (transient--insert-group group)
+ (when groups
+ (insert ?\n)))))
+
+(cl-defgeneric transient--insert-group (group)
+ "Format GROUP and its elements and insert the result.")
+
+(cl-defmethod transient--insert-group :before ((group transient-group))
+ "Insert GROUP's description, if any."
+ (when-let ((desc (transient-format-description group)))
+ (insert desc ?\n)))
+
+(cl-defmethod transient--insert-group ((group transient-row))
+ (transient--maybe-pad-keys group)
+ (dolist (suffix (oref group suffixes))
+ (insert (transient-format suffix))
+ (insert " "))
+ (insert ?\n))
+
+(cl-defmethod transient--insert-group ((group transient-column))
+ (transient--maybe-pad-keys group)
+ (dolist (suffix (oref group suffixes))
+ (let ((str (transient-format suffix)))
+ (insert str)
+ (unless (string-match-p ".\n\\'" str)
+ (insert ?\n)))))
+
+(cl-defmethod transient--insert-group ((group transient-columns))
+ (let* ((columns
+ (mapcar
+ (lambda (column)
+ (transient--maybe-pad-keys column group)
+ (let ((rows (mapcar 'transient-format (oref column suffixes))))
+ (when-let ((desc (transient-format-description column)))
+ (push desc rows))
+ rows))
+ (oref group suffixes)))
+ (rs (apply #'max (mapcar #'length columns)))
+ (cs (length columns))
+ (cw (mapcar (lambda (col) (apply #'max (mapcar #'length col)))
+ columns))
+ (cc (transient--seq-reductions-from (apply-partially #'+ 3) cw 0)))
+ (dotimes (r rs)
+ (dotimes (c cs)
+ (insert (make-string (- (nth c cc) (current-column)) ?\s))
+ (when-let ((cell (nth r (nth c columns))))
+ (insert cell))
+ (when (= c (1- cs))
+ (insert ?\n))))))
+
+(cl-defmethod transient--insert-group ((group transient-subgroups))
+ (let* ((subgroups (oref group suffixes))
+ (n (length subgroups)))
+ (dotimes (s n)
+ (let ((subgroup (nth s subgroups)))
+ (transient--maybe-pad-keys subgroup group)
+ (transient--insert-group subgroup)
+ (when (< s (1- n))
+ (insert ?\n))))))
+
+(cl-defgeneric transient-format (obj)
+ "Format and return OBJ for display.
+
+When this function is called, then the current buffer is some
+temporary buffer. If you need the buffer from which the prefix
+command was invoked to be current, then do so by temporarily
+making `transient--original-buffer' current.")
+
+(cl-defmethod transient-format ((arg string))
+ "Return the string ARG after applying the `transient-heading' face."
+ (propertize arg 'face 'transient-heading))
+
+(cl-defmethod transient-format ((_ null))
+ "Return a string containing just the newline character."
+ "\n")
+
+(cl-defmethod transient-format ((arg integer))
+ "Return a string containing just the ARG character."
+ (char-to-string arg))
+
+(cl-defmethod transient-format :around ((obj transient-infix))
+ "When reading user input for this infix, then highlight it."
+ (let ((str (cl-call-next-method obj)))
+ (when (eq obj transient--active-infix)
+ (setq str (concat str "\n"))
+ (add-face-text-property
+ (if (eq this-command 'transient-set-level) 3 0)
+ (length str)
+ 'transient-active-infix nil str))
+ str))
+
+(cl-defmethod transient-format :around ((obj transient-suffix))
+ "When edit-mode is enabled, then prepend the level information.
+Optional support for popup buttons is also implemented here."
+ (let ((str (concat
+ (and transient--editp
+ (let ((level (oref obj level)))
+ (propertize (format " %s " level)
+ 'face (if (transient--use-level-p level t)
+ 'transient-enabled-suffix
+ 'transient-disabled-suffix))))
+ (cl-call-next-method obj))))
+ (when (oref obj inapt)
+ (set-text-properties 0 (length str)
+ (list 'face 'transient-inapt-suffix)
+ str))
+ (if transient-enable-popup-navigation
+ (make-text-button str nil
+ 'type 'transient-button
+ 'command (transient--suffix-command obj))
+ str)))
+
+(cl-defmethod transient-format ((obj transient-infix))
+ "Return a string generated using OBJ's `format'.
+%k is formatted using `transient-format-key'.
+%d is formatted using `transient-format-description'.
+%v is formatted using `transient-format-value'."
+ (format-spec (oref obj format)
+ `((?k . ,(transient-format-key obj))
+ (?d . ,(transient-format-description obj))
+ (?v . ,(transient-format-value obj)))))
+
+(cl-defmethod transient-format ((obj transient-suffix))
+ "Return a string generated using OBJ's `format'.
+%k is formatted using `transient-format-key'.
+%d is formatted using `transient-format-description'."
+ (format-spec (oref obj format)
+ `((?k . ,(transient-format-key obj))
+ (?d . ,(transient-format-description obj)))))
+
+(cl-defgeneric transient-format-key (obj)
+ "Format OBJ's `key' for display and return the result.")
+
+(cl-defmethod transient-format-key ((obj transient-suffix))
+ "Format OBJ's `key' for display and return the result."
+ (let ((key (oref obj key))
+ (cmd (oref obj command)))
+ (if transient--redisplay-key
+ (let ((len (length transient--redisplay-key))
+ (seq (cl-coerce (edmacro-parse-keys key t) 'list)))
+ (cond
+ ((equal (seq-take seq len) transient--redisplay-key)
+ (let ((pre (key-description (vconcat (seq-take seq len))))
+ (suf (key-description (vconcat (seq-drop seq len)))))
+ (setq pre (replace-regexp-in-string "RET" "C-m" pre t))
+ (setq pre (replace-regexp-in-string "TAB" "C-i" pre t))
+ (setq suf (replace-regexp-in-string "RET" "C-m" suf t))
+ (setq suf (replace-regexp-in-string "TAB" "C-i" suf t))
+ ;; We use e.g. "-k" instead of the more correct "- k",
+ ;; because the former is prettier. If we did that in
+ ;; the definition, then we want to drop the space that
+ ;; is reinserted above. False-positives are possible
+ ;; for silly bindings like "-C-c C-c".
+ (unless (string-match-p " " key)
+ (setq pre (replace-regexp-in-string " " "" pre))
+ (setq suf (replace-regexp-in-string " " "" suf)))
+ (concat (propertize pre 'face 'default)
+ (and (string-prefix-p (concat pre " ") key) " ")
+ (transient--colorize-key suf cmd)
+ (save-excursion
+ (when (string-match " +\\'" key)
+ (match-string 0 key))))))
+ ((transient--lookup-key transient-sticky-map (kbd key))
+ (transient--colorize-key key cmd))
+ (t
+ (propertize key 'face 'transient-unreachable-key))))
+ (transient--colorize-key key cmd))))
+
+(defun transient--colorize-key (key command)
+ (propertize key 'face
+ (or (and (transient--semantic-coloring-p)
+ (transient--suffix-color command))
+ 'transient-key)))
+
+(cl-defmethod transient-format-key :around ((obj transient-argument))
+ (let ((key (cl-call-next-method obj)))
+ (cond ((not transient-highlight-mismatched-keys))
+ ((not (slot-boundp obj 'shortarg))
+ (add-face-text-property
+ 0 (length key) 'transient-nonstandard-key nil key))
+ ((not (string-equal key (oref obj shortarg)))
+ (add-face-text-property
+ 0 (length key) 'transient-mismatched-key nil key)))
+ key))
+
+(cl-defgeneric transient-format-description (obj)
+ "Format OBJ's `description' for display and return the result.")
+
+(cl-defmethod transient-format-description ((obj transient-child))
+ "The `description' slot may be a function, in which case that is
+called inside the correct buffer (see `transient-insert-group')
+and its value is returned to the caller."
+ (when-let ((desc (oref obj description)))
+ (if (functionp desc)
+ (with-current-buffer transient--original-buffer
+ (funcall desc))
+ desc)))
+
+(cl-defmethod transient-format-description ((obj transient-group))
+ "Format the description by calling the next method. If the result
+doesn't use the `face' property at all, then apply the face
+`transient-heading' to the complete string."
+ (when-let ((desc (cl-call-next-method obj)))
+ (if (text-property-not-all 0 (length desc) 'face nil desc)
+ desc
+ (propertize desc 'face 'transient-heading))))
+
+(cl-defmethod transient-format-description :around ((obj transient-suffix))
+ "Format the description by calling the next method. If the result
+is nil, then use \"(BUG: no description)\" as the description.
+If the OBJ's `key' is currently unreachable, then apply the face
+`transient-unreachable' to the complete string."
+ (let ((desc (or (cl-call-next-method obj)
+ (and (slot-boundp transient--prefix 'suffix-description)
+ (funcall (oref transient--prefix suffix-description)
+ obj))
+ (propertize "(BUG: no description)" 'face 'error))))
+ (if (transient--key-unreachable-p obj)
+ (propertize desc 'face 'transient-unreachable)
+ desc)))
+
+(cl-defgeneric transient-format-value (obj)
+ "Format OBJ's value for display and return the result.")
+
+(cl-defmethod transient-format-value ((obj transient-suffix))
+ (propertize (oref obj argument)
+ 'face (if (oref obj value)
+ 'transient-argument
+ 'transient-inactive-argument)))
+
+(cl-defmethod transient-format-value ((obj transient-option))
+ (let ((value (oref obj value)))
+ (propertize (concat (oref obj argument)
+ (if (listp value)
+ (mapconcat #'identity value ",")
+ value))
+ 'face (if value
+ 'transient-value
+ 'transient-inactive-value))))
+
+(cl-defmethod transient-format-value ((obj transient-switches))
+ (with-slots (value argument-format choices) obj
+ (format (propertize argument-format
+ 'face (if value
+ 'transient-value
+ 'transient-inactive-value))
+ (concat
+ (propertize "[" 'face 'transient-inactive-value)
+ (mapconcat
+ (lambda (choice)
+ (propertize choice 'face
+ (if (equal (format argument-format choice) value)
+ 'transient-value
+ 'transient-inactive-value)))
+ choices
+ (propertize "|" 'face 'transient-inactive-value))
+ (propertize "]" 'face 'transient-inactive-value)))))
+
+(cl-defmethod transient-format-value ((obj transient-files))
+ (let ((argument (oref obj argument)))
+ (if-let ((value (oref obj value)))
+ (propertize (concat argument " "
+ (mapconcat (lambda (f) (format "%S" f))
+ (oref obj value) " "))
+ 'face 'transient-argument)
+ (propertize argument 'face 'transient-inactive-argument))))
+
+(defun transient--key-unreachable-p (obj)
+ (and transient--redisplay-key
+ (let ((key (oref obj key)))
+ (not (or (equal (seq-take (cl-coerce (edmacro-parse-keys key t) 'list)
+ (length transient--redisplay-key))
+ transient--redisplay-key)
+ (transient--lookup-key transient-sticky-map (kbd key)))))))
+
+(defun transient--lookup-key (keymap key)
+ (let ((val (lookup-key keymap key)))
+ (and val (not (integerp val)) val)))
+
+(defun transient--maybe-pad-keys (group &optional parent)
+ (when-let ((pad (if (slot-boundp group 'pad-keys)
+ (oref group pad-keys)
+ (and parent
+ (slot-boundp parent 'pad-keys)
+ (oref parent pad-keys)))))
+ (let ((width (apply #'max
+ (cons (if (integerp pad) pad 0)
+ (mapcar (lambda (suffix)
+ (length (oref suffix key)))
+ (oref group suffixes))))))
+ (dolist (suffix (oref group suffixes))
+ (oset suffix key
+ (truncate-string-to-width (oref suffix key) width nil ?\s))))))
+
+(defun transient-command-summary-or-name (obj)
+ "Return the summary or name of the command represented by OBJ.
+
+If the command has a doc-string, then return the first line of
+that, else its name.
+
+Intended to be temporarily used as the `:suffix-description' of
+a prefix command, while porting a regular keymap to a transient."
+ (let ((command (transient--suffix-symbol (oref obj command))))
+ (if-let ((doc (documentation command)))
+ (propertize (car (split-string doc "\n")) 'face 'font-lock-doc-face)
+ (propertize (symbol-name command) 'face 'font-lock-function-name-face))))
+
+;;; Help
+
+(cl-defgeneric transient-show-help (obj)
+ "Show help for OBJ's command.")
+
+(cl-defmethod transient-show-help ((obj transient-prefix))
+ "Show the info manual, manpage or command doc-string.
+Show the first one that is specified."
+ (if-let ((manual (oref obj info-manual)))
+ (info manual)
+ (if-let ((manpage (oref obj man-page)))
+ (transient--show-manpage manpage)
+ (transient--describe-function (oref obj command)))))
+
+(cl-defmethod transient-show-help ((_ transient-suffix))
+ "Show the command doc-string."
+ (if (eq this-original-command 'transient-help)
+ (if-let ((manpage (oref transient--prefix man-page)))
+ (transient--show-manpage manpage)
+ (transient--describe-function (oref transient--prefix command)))
+ (transient--describe-function this-original-command)))
+
+(cl-defmethod transient-show-help ((obj transient-infix))
+ "Show the manpage if defined or the command doc-string.
+If the manpage is specified, then try to jump to the correct
+location."
+ (if-let ((manpage (oref transient--prefix man-page)))
+ (transient--show-manpage manpage (ignore-errors (oref obj argument)))
+ (transient--describe-function this-original-command)))
+
+;; `cl-generic-generalizers' doesn't support `command' et al.
+(cl-defmethod transient-show-help (cmd)
+ "Show the command doc-string."
+ (transient--describe-function cmd))
+
+(defun transient--show-manpage (manpage &optional argument)
+ (require 'man)
+ (let* ((Man-notify-method 'meek)
+ (buf (Man-getpage-in-background manpage))
+ (proc (get-buffer-process buf)))
+ (while (and proc (eq (process-status proc) 'run))
+ (accept-process-output proc))
+ (switch-to-buffer buf)
+ (when argument
+ (transient--goto-argument-description argument))))
+
+(defun transient--describe-function (fn)
+ (describe-function fn)
+ (select-window (get-buffer-window (help-buffer))))
+
+(defun transient--goto-argument-description (arg)
+ (goto-char (point-min))
+ (let ((case-fold-search nil)
+ ;; This matches preceding/proceeding options. Options
+ ;; such as "-a", "-S[<keyid>]", and "--grep=<pattern>"
+ ;; are matched by this regex without the shy group.
+ ;; The ". " in the shy group is for options such as
+ ;; "-m parent-number", and the "-[^[:space:]]+ " is
+ ;; for options such as "--mainline parent-number"
+ (others "-\\(?:. \\|-[^[:space:]]+ \\)?[^[:space:]]+"))
+ (when (re-search-forward
+ (if (equal arg "--")
+ ;; Special case.
+ "^[\t\s]+\\(--\\(?: \\|$\\)\\|\\[--\\]\\)"
+ ;; Should start with whitespace and may have
+ ;; any number of options before and/or after.
+ (format
+ "^[\t\s]+\\(?:%s, \\)*?\\(?1:%s\\)%s\\(?:, %s\\)*$"
+ others
+ ;; Options don't necessarily end in an "="
+ ;; (e.g., "--gpg-sign[=<keyid>]")
+ (string-remove-suffix "=" arg)
+ ;; Simple options don't end in an "=". Splitting this
+ ;; into 2 cases should make getting false positives
+ ;; less likely.
+ (if (string-suffix-p "=" arg)
+ ;; "[^[:space:]]*[^.[:space:]]" matches the option
+ ;; value, which is usually after the option name
+ ;; and either '=' or '[='. The value can't end in
+ ;; a period, as that means it's being used at the
+ ;; end of a sentence. The space is for options
+ ;; such as '--mainline parent-number'.
+ "\\(?: \\|\\[?=\\)[^[:space:]]*[^.[:space:]]"
+ ;; Either this doesn't match anything (e.g., "-a"),
+ ;; or the option is followed by a value delimited
+ ;; by a "[", "<", or ":". A space might appear
+ ;; before this value, as in "-f <file>". The
+ ;; space alternative is for options such as
+ ;; "-m parent-number".
+ "\\(?:\\(?: \\| ?[\\[<:]\\)[^[:space:]]*[^.[:space:]]\\)?")
+ others))
+ nil t)
+ (goto-char (match-beginning 1)))))
+
+(defun transient--insert-help ()
+ (unless (looking-back "\n\n" 2)
+ (insert "\n"))
+ (when transient--helpp
+ (insert
+ (format (propertize "\
+Type a %s to show help for that suffix command, or %s to show manual.
+Type %s to exit help.\n"
+ 'face 'transient-heading)
+ (propertize "<KEY>" 'face 'transient-key)
+ (propertize "?" 'face 'transient-key)
+ (propertize "C-g" 'face 'transient-key))))
+ (when transient--editp
+ (unless transient--helpp
+ (insert
+ (format (propertize "\
+Type a %s to set level for that suffix command.
+Type %s to set what levels are available for this prefix command.\n"
+ 'face 'transient-heading)
+ (propertize "<KEY>" 'face 'transient-key)
+ (propertize "C-x l" 'face 'transient-key))))
+ (with-slots (level) transient--prefix
+ (insert
+ (format (propertize "
+Suffixes on levels %s are available.
+Suffixes on levels %s and %s are unavailable.\n"
+ 'face 'transient-heading)
+ (propertize (format "1-%s" level)
+ 'face 'transient-enabled-suffix)
+ (propertize " 0 "
+ 'face 'transient-disabled-suffix)
+ (propertize (format ">=%s" (1+ level))
+ 'face 'transient-disabled-suffix))))))
+
+(defvar transient-resume-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [remap Man-quit] 'transient-resume)
+ (define-key map [remap Info-exit] 'transient-resume)
+ (define-key map [remap quit-window] 'transient-resume)
+ map)
+ "Keymap for `transient-resume-mode'.
+
+This keymap remaps every command that would usually just quit the
+documentation buffer to `transient-resume', which additionally
+resumes the suspended transient.")
+
+(define-minor-mode transient-resume-mode
+ "Auxiliary minor-mode used to resume a transient after viewing help.")
+
+;;; Compatibility
+;;;; Popup Navigation
+
+(defun transient-popup-navigation-help ()
+ "Inform the user how to enable popup navigation commands."
+ (interactive)
+ (message "This command is only available if `%s' is non-nil"
+ 'transient-enable-popup-navigation))
+
+(define-button-type 'transient-button
+ 'face nil
+ 'action (lambda (button)
+ (let ((command (button-get button 'command)))
+ ;; Yes, I know that this is wrong(tm).
+ ;; Unfortunately it is also necessary.
+ (setq this-original-command command)
+ (call-interactively command))))
+
+(defvar transient-popup-navigation-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "<down-mouse-1>") 'transient-noop)
+ (define-key map (kbd "<mouse-1>") 'transient-mouse-push-button)
+ (define-key map (kbd "RET") 'transient-push-button)
+ (define-key map (kbd "<up>") 'transient-backward-button)
+ (define-key map (kbd "C-p") 'transient-backward-button)
+ (define-key map (kbd "<down>") 'transient-forward-button)
+ (define-key map (kbd "C-n") 'transient-forward-button)
+ (define-key map (kbd "C-r") 'transient-isearch-backward)
+ (define-key map (kbd "C-s") 'transient-isearch-forward)
+ map))
+
+(defun transient-mouse-push-button (&optional pos)
+ "Invoke the suffix the user clicks on."
+ (interactive (list last-command-event))
+ (push-button pos))
+
+(defun transient-push-button ()
+ "Invoke the selected suffix command."
+ (interactive)
+ (with-selected-window transient--window
+ (push-button)))
+
+(defun transient-backward-button (n)
+ "Move to the previous button in the transient popup buffer.
+See `backward-button' for information about N."
+ (interactive "p")
+ (with-selected-window transient--window
+ (backward-button n t)))
+
+(defun transient-forward-button (n)
+ "Move to the next button in the transient popup buffer.
+See `forward-button' for information about N."
+ (interactive "p")
+ (with-selected-window transient--window
+ (forward-button n t)))
+
+(defun transient--goto-button (command)
+ (if (not command)
+ (forward-button 1)
+ (while (and (ignore-errors (forward-button 1))
+ (not (eq (button-get (button-at (point)) 'command) command))))
+ (unless (eq (button-get (button-at (point)) 'command) command)
+ (goto-char (point-min))
+ (forward-button 1))))
+
+;;;; Popup Isearch
+
+(defvar transient--isearch-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map isearch-mode-map)
+ (define-key map [remap isearch-exit] 'transient-isearch-exit)
+ (define-key map [remap isearch-cancel] 'transient-isearch-cancel)
+ (define-key map [remap isearch-abort] 'transient-isearch-abort)
+ map))
+
+(defun transient-isearch-backward (&optional regexp-p)
+ "Do incremental search backward.
+With a prefix argument, do an incremental regular expression
+search instead."
+ (interactive "P")
+ (transient--isearch-setup)
+ (let ((isearch-mode-map transient--isearch-mode-map))
+ (isearch-mode nil regexp-p)))
+
+(defun transient-isearch-forward (&optional regexp-p)
+ "Do incremental search forward.
+With a prefix argument, do an incremental regular expression
+search instead."
+ (interactive "P")
+ (transient--isearch-setup)
+ (let ((isearch-mode-map transient--isearch-mode-map))
+ (isearch-mode t regexp-p)))
+
+(defun transient-isearch-exit ()
+ "Like `isearch-exit' but adapted for `transient'."
+ (interactive)
+ (isearch-exit)
+ (transient--isearch-exit))
+
+(defun transient-isearch-cancel ()
+ "Like `isearch-cancel' but adapted for `transient'."
+ (interactive)
+ (condition-case nil (isearch-cancel) (quit))
+ (transient--isearch-exit))
+
+(defun transient-isearch-abort ()
+ "Like `isearch-abort' but adapted for `transient'."
+ (interactive)
+ (condition-case nil (isearch-abort) (quit))
+ (transient--isearch-exit))
+
+(defun transient--isearch-setup ()
+ (select-window transient--window)
+ (transient--suspend-override))
+
+(defun transient--isearch-exit ()
+ (select-window transient--original-window)
+ (transient--resume-override))
+
+;;;; Hydra Color Emulation
+
+(defun transient--semantic-coloring-p ()
+ (and transient-semantic-coloring
+ (not transient--helpp)
+ (not transient--editp)))
+
+(defun transient--suffix-color (command)
+ (or (get command 'transient-color)
+ (get (transient--get-predicate-for command) 'transient-color)))
+
+(defun transient--prefix-color (command)
+ (let* ((nonsuf (or (oref command transient-non-suffix)
+ 'transient--do-warn))
+ (nonsuf (if (memq nonsuf '(transient--do-noop transient--do-warn))
+ 'disallow
+ (get nonsuf 'transient-color)))
+ (suffix (if-let ((pred (oref command transient-suffix)))
+ (get pred 'transient-color)
+ (if (eq nonsuf 'transient-red)
+ 'transient-red
+ 'transient-blue))))
+ (pcase (list suffix nonsuf)
+ (`(transient-red disallow) 'transient-amaranth)
+ (`(transient-blue disallow) 'transient-teal)
+ (`(transient-red transient-red) 'transient-pink)
+ (`(transient-red transient-blue) 'transient-red)
+ (`(transient-blue transient-blue) 'transient-blue))))
+
+;;;; Edebug
+
+(defun transient--edebug--recursive-edit (fn arg-mode)
+ (transient--debug 'edebug--recursive-edit)
+ (if (not transient--prefix)
+ (funcall fn arg-mode)
+ (transient--suspend-override t)
+ (funcall fn arg-mode)
+ (transient--resume-override t)))
+
+(advice-add 'edebug--recursive-edit :around 'transient--edebug--recursive-edit)
+
+(defun transient--abort-edebug ()
+ (when (bound-and-true-p edebug-active)
+ (transient--emergency-exit)))
+
+(advice-add 'abort-recursive-edit :before 'transient--abort-edebug)
+(advice-add 'top-level :before 'transient--abort-edebug)
+
+(defun transient--edebug-command-p ()
+ (and (bound-and-true-p edebug-active)
+ (or (memq this-command '(top-level abort-recursive-edit))
+ (string-prefix-p "edebug" (symbol-name this-command)))))
+
+;;;; Miscellaneous
+
+(declare-function which-key-mode "which-key" (&optional arg))
+
+(defun transient--suspend-which-key-mode ()
+ (when (bound-and-true-p which-key-mode)
+ (which-key-mode -1)
+ (add-hook 'transient-exit-hook 'transient--resume-which-key-mode)))
+
+(defun transient--resume-which-key-mode ()
+ (unless transient--prefix
+ (which-key-mode 1)
+ (remove-hook 'transient-exit-hook 'transient--resume-which-key-mode)))
+
+(defun transient-bind-q-to-quit ()
+ "Modify some keymaps to bind \"q\" to the appropriate quit command.
+
+\"C-g\" is the default binding for such commands now, but Transient's
+predecessor Magit-Popup used \"q\" instead. If you would like to get
+that binding back, then call this function in your init file like so:
+
+ (with-eval-after-load \\='transient
+ (transient-bind-q-to-quit))
+
+Individual transients may already bind \"q\" to something else
+and such a binding would shadow the quit binding. If that is the
+case then \"Q\" is bound to whatever \"q\" would have been bound
+to by setting `transient-substitute-key-function' to a function
+that does that. Of course \"Q\" may already be bound to something
+else, so that function binds \"M-q\" to that command instead.
+Of course \"M-q\" may already be bound to something else, but
+we stop there."
+ (define-key transient-base-map "q" 'transient-quit-one)
+ (define-key transient-sticky-map "q" 'transient-quit-seq)
+ (setq transient-substitute-key-function
+ 'transient-rebind-quit-commands))
+
+(defun transient-rebind-quit-commands (obj)
+ "See `transient-bind-q-to-quit'."
+ (let ((key (oref obj key)))
+ (cond ((string-equal key "q") "Q")
+ ((string-equal key "Q") "M-q")
+ (t key))))
+
+(defun transient--force-fixed-pitch ()
+ (require 'face-remap)
+ (face-remap-reset-base 'default)
+ (face-remap-add-relative 'default 'fixed-pitch))
+
+;;;; Missing from Emacs
+
+(defun transient--seq-reductions-from (function sequence initial-value)
+ (let ((acc (list initial-value)))
+ (seq-doseq (elt sequence)
+ (push (funcall function (car acc) elt) acc))
+ (nreverse acc)))
+
+(defun transient-plist-to-alist (plist)
+ (let (alist)
+ (while plist
+ (push (cons (let* ((symbol (pop plist))
+ (name (symbol-name symbol)))
+ (if (eq (aref name 0) ?:)
+ (intern (substring name 1))
+ symbol))
+ (pop plist))
+ alist))
+ (nreverse alist)))
+
+;;; Font-Lock
+
+(defconst transient-font-lock-keywords
+ (eval-when-compile
+ `((,(concat "("
+ (regexp-opt (list "transient-define-prefix"
+ "transient-define-infix"
+ "transient-define-argument"
+ "transient-define-suffix")
+ t)
+ "\\_>[ \t'\(]*"
+ "\\(\\(?:\\sw\\|\\s_\\)+\\)?")
+ (1 'font-lock-keyword-face)
+ (2 'font-lock-function-name-face nil t)))))
+
+(font-lock-add-keywords 'emacs-lisp-mode transient-font-lock-keywords)
+
+;;; Auxiliary Classes
+;;;; `transient-lisp-variable'
+
+(defclass transient-lisp-variable (transient-variable)
+ ((reader :initform transient-lisp-variable--reader)
+ (always-read :initform t)
+ (set-value :initarg :set-value :initform set))
+ "[Experimental] Class used for Lisp variables.")
+
+(cl-defmethod transient-init-value ((obj transient-lisp-variable))
+ (oset obj value (symbol-value (oref obj variable))))
+
+(cl-defmethod transient-infix-set ((obj transient-lisp-variable) value)
+ (funcall (oref obj set-value)
+ (oref obj variable)
+ (oset obj value value)))
+
+(cl-defmethod transient-format-description ((obj transient-lisp-variable))
+ (or (oref obj description)
+ (symbol-name (oref obj variable))))
+
+(cl-defmethod transient-format-value ((obj transient-lisp-variable))
+ (propertize (prin1-to-string (oref obj value))
+ 'face 'transient-value))
+
+(cl-defmethod transient-prompt ((obj transient-lisp-variable))
+ (format "Set %s: " (oref obj variable)))
+
+(defun transient-lisp-variable--reader (prompt initial-input _history)
+ (read--expression prompt initial-input))
+
+;;; _
+(provide 'transient)
+;; Local Variables:
+;; indent-tabs-mode: nil
+;; End:
+;;; transient.el ends here
diff --git a/lisp/tree-widget.el b/lisp/tree-widget.el
index 44b29bf..d40a628 100644
--- a/lisp/tree-widget.el
+++ b/lisp/tree-widget.el
@@ -110,10 +110,8 @@
;; `tree-widget-themes-directory', and `tree-widget-theme' options for
;; more details.
-;;; History:
-;;
-
;;; Code:
+
(require 'wid-edit)
;;; Customization
diff --git a/lisp/uniquify.el b/lisp/uniquify.el
index 1d513d6..7cc0168 100644
--- a/lisp/uniquify.el
+++ b/lisp/uniquify.el
@@ -498,8 +498,6 @@ For use on `kill-buffer-hook'."
(file-name-directory filename) retval)))
retval))
-;;; The End
-
(defun uniquify-unload-function ()
"Unload the uniquify library."
(save-current-buffer
diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el
index 27f4f88..60388df 100644
--- a/lisp/url/url-cookie.el
+++ b/lisp/url/url-cookie.el
@@ -358,10 +358,10 @@ i.e. 1970-1-1) are loaded as expiring one year from now
instead."
Default is 1 hour. Note that if you change this variable outside of
the `customize' interface after `url-do-setup' has been run, you need
to run the `url-cookie-setup-save-timer' function manually."
- :set #'(lambda (var val)
- (set-default var val)
- (if (bound-and-true-p url-setup-done)
- (url-cookie-setup-save-timer)))
+ :set (lambda (var val)
+ (set-default var val)
+ (if (bound-and-true-p url-setup-done)
+ (url-cookie-setup-save-timer)))
:type 'integer
:group 'url-cookie)
diff --git a/lisp/url/url-dav.el b/lisp/url/url-dav.el
index edb1c1d..192b1ac 100644
--- a/lisp/url/url-dav.el
+++ b/lisp/url/url-dav.el
@@ -43,22 +43,11 @@
(defvar url-http-response-status)
(defvar url-http-end-of-headers)
-(defun url-intersection (l1 l2)
- "Return a list of the elements occurring in both of the lists L1 and L2."
- (if (null l2)
- l2
- (let (result)
- (while l1
- (if (member (car l1) l2)
- (setq result (cons (pop l1) result))
- (pop l1)))
- (nreverse result))))
-
;;;###autoload
(defun url-dav-supported-p (url)
"Return WebDAV protocol version supported by URL.
Returns nil if WebDAV is not supported."
- (url-intersection url-dav-supported-protocols
+ (seq-intersection url-dav-supported-protocols
(plist-get (url-http-options url) 'dav)))
(defun url-dav-node-text (node)
@@ -910,7 +899,9 @@ Returns nil if URL contains no name starting with FILE."
t)))
-;;; Miscellaneous stuff.
+;;; Obsolete.
+
+(define-obsolete-function-alias 'url-intersection #'seq-intersection "28.1")
(provide 'url-dav)
diff --git a/lisp/url/url-history.el b/lisp/url/url-history.el
index 10238a4..5dd1f09 100644
--- a/lisp/url/url-history.el
+++ b/lisp/url/url-history.el
@@ -38,10 +38,10 @@
If non-nil, the URL package will keep track of all the URLs visited.
If set to t, then the list is saved to disk at the end of each Emacs
session."
- :set #'(lambda (var val)
- (set-default var val)
- (and (bound-and-true-p url-setup-done)
- (url-history-setup-save-timer)))
+ :set (lambda (var val)
+ (set-default var val)
+ (and (bound-and-true-p url-setup-done)
+ (url-history-setup-save-timer)))
:type '(choice (const :tag "off" nil)
(const :tag "on" t)
(other :tag "within session" session))
@@ -59,10 +59,10 @@ is parsed at startup and used to provide URL completion."
Default is 1 hour. Note that if you change this variable outside of
the `customize' interface after `url-do-setup' has been run, you need
to run the `url-history-setup-save-timer' function manually."
- :set #'(lambda (var val)
- (set-default var val)
- (if (bound-and-true-p url-setup-done)
- (url-history-setup-save-timer)))
+ :set (lambda (var val)
+ (set-default var val)
+ (if (bound-and-true-p url-setup-done)
+ (url-history-setup-save-timer)))
:type 'integer
:group 'url-history)
diff --git a/lisp/url/url-mailto.el b/lisp/url/url-mailto.el
index 72884c0..29c2780 100644
--- a/lisp/url/url-mailto.el
+++ b/lisp/url/url-mailto.el
@@ -1,4 +1,4 @@
-;;; url-mail.el --- Mail Uniform Resource Locator retrieval code -*-
lexical-binding: t; -*-
+;;; url-mailto.el --- Mail Uniform Resource Locator retrieval code -*-
lexical-binding: t; -*-
;; Copyright (C) 1996-1999, 2004-2021 Free Software Foundation, Inc.
@@ -104,8 +104,8 @@
(or (search-forward (concat "\n" mail-header-separator "\n") nil t)
(goto-char (point-max)))
(insert (mapconcat
- #'(lambda (string)
- (replace-regexp-in-string "\r\n" "\n" string))
+ (lambda (string)
+ (replace-regexp-in-string "\r\n" "\n" string))
(cdar args) "\n")))
(url-mail-goto-field (caar args))
;; (setq func (intern-soft (concat "mail-" (caar args))))
diff --git a/lisp/url/url-proxy.el b/lisp/url/url-proxy.el
index 8436c7a..c89c1b6 100644
--- a/lisp/url/url-proxy.el
+++ b/lisp/url/url-proxy.el
@@ -49,14 +49,12 @@
;; Not sure how I should handle gracefully degrading from one proxy to
;; another, so for now just deal with the first one
;; (while proxies
- (if (listp proxies)
- (setq proxy (car proxies))
- (setq proxy proxies))
+ (setq proxy (if (listp proxies) (car proxies) proxies))
(cond
- ((string-match "^direct" proxy) nil)
- ((string-match "^proxy +" proxy)
+ ((string-match "^DIRECT" proxy) nil)
+ ((string-match "^PROXY +" proxy)
(concat "http://"; (substring proxy (match-end 0)) "/"))
- ((string-match "^socks +" proxy)
+ ((string-match "^SOCKS +" proxy)
(concat "socks://" (substring proxy (match-end 0))))
(t
(display-warning 'url (format "Unknown proxy directive: %s" proxy)
:error)
diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el
index 8c836f8..2aa2e79 100644
--- a/lisp/url/url-vars.el
+++ b/lisp/url/url-vars.el
@@ -22,10 +22,6 @@
;;; Code:
-(defconst url-version "Emacs"
- "Version number of URL package.")
-(make-obsolete-variable 'url-version nil "28.1")
-
(defgroup url nil
"Uniform Resource Locator tool."
:version "22.1"
@@ -427,6 +423,11 @@ Should be one of:
This should be set, e.g. by mail user agents rendering HTML to avoid
`bugs' which call home.")
+;; Obsolete
+
+(defconst url-version "Emacs" "Version number of URL package.")
+(make-obsolete-variable 'url-version 'emacs-version "28.1")
+
(provide 'url-vars)
;;; url-vars.el ends here
diff --git a/lisp/vc/add-log.el b/lisp/vc/add-log.el
index 6b38806..2e20284 100644
--- a/lisp/vc/add-log.el
+++ b/lisp/vc/add-log.el
@@ -1194,7 +1194,7 @@ file were isearch was started."
(forward-paragraph n)))
(defcustom add-log-current-defun-header-regexp
- "^\\([[:upper:]][[:upper:]_ ]*[[:upper:]_]\\|[-_[:alpha:]]+\\)[ \t]*[:=]"
+ "^\\([[:upper:]][[:upper:]_
]*[[:upper:]_]\\|[-_[:alnum:]]*[[:alpha:]][-_[:alnum:]]*\\)[ \t]*[:=]"
"Heuristic regexp used by `add-log-current-defun' for unknown major modes.
The regexp's first submatch is placed in the ChangeLog entry, in
parentheses."
diff --git a/lisp/vc/ediff-mult.el b/lisp/vc/ediff-mult.el
index 49b2890..8e88b60 100644
--- a/lisp/vc/ediff-mult.el
+++ b/lisp/vc/ediff-mult.el
@@ -620,7 +620,7 @@ behavior."
(setq common (ediff-intersection common lis3 #'string=)))
;; copying is needed because sort sorts via side effects
- (setq common (sort (ediff-copy-list common) 'string-lessp))
+ (setq common (sort (copy-sequence common) #'string-lessp))
;; compute difference list
(setq difflist (ediff-set-difference
@@ -631,7 +631,7 @@ behavior."
#'string=)
difflist (delete "." difflist)
;; copying is needed because sort sorts via side effects
- difflist (sort (ediff-copy-list (delete ".." difflist))
+ difflist (sort (copy-sequence (delete ".." difflist))
#'string-lessp))
(setq difflist (mapcar (lambda (elt) (cons elt 1)) difflist))
@@ -729,7 +729,7 @@ behavior."
)
;; copying is needed because sort sorts via side effects
- (setq common (sort (ediff-copy-list common) 'string-lessp))
+ (setq common (sort (copy-sequence common) #'string-lessp))
;; return result
(cons
diff --git a/lisp/vc/ediff-util.el b/lisp/vc/ediff-util.el
index fc6dcf6..1c78490 100644
--- a/lisp/vc/ediff-util.el
+++ b/lisp/vc/ediff-util.el
@@ -4188,12 +4188,7 @@ Mail anyway? (y or n) ")
(cdr result)))
(define-obsolete-function-alias 'ediff-add-to-history #'add-to-history "27.1")
-
-(defalias 'ediff-copy-list 'copy-sequence)
-
-
-;; don't report error if version control package wasn't found
-;;(ediff-load-version-control 'silent)
+(define-obsolete-function-alias 'ediff-copy-list #'copy-sequence "28.1")
(run-hooks 'ediff-load-hook)
diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el
index 56b3166..eabbaba 100644
--- a/lisp/vc/log-edit.el
+++ b/lisp/vc/log-edit.el
@@ -191,7 +191,8 @@ when this variable is set to nil.")
(defconst log-edit-files-buf "*log-edit-files*")
(defvar log-edit-initial-files nil)
(defvar log-edit-callback nil)
-(defvar log-edit-diff-function nil)
+(defvar log-edit-diff-function
+ (lambda () (error "Diff functionality has not been setup")))
(defvar log-edit-listfun nil)
(defvar log-edit-parent-buffer nil)
@@ -659,9 +660,7 @@ Also saves its contents in the comment history and hides
(defun log-edit-show-diff ()
"Show the diff for the files to be committed."
(interactive)
- (if (functionp log-edit-diff-function)
- (funcall log-edit-diff-function)
- (error "Diff functionality has not been setup")))
+ (funcall log-edit-diff-function))
(defun log-edit-show-files ()
"Show the list of files to be committed."
diff --git a/lisp/vc/pcvs.el b/lisp/vc/pcvs.el
index 6e039cc..42f531e 100644
--- a/lisp/vc/pcvs.el
+++ b/lisp/vc/pcvs.el
@@ -331,7 +331,7 @@ the primary since reading the primary can deactivate it."
"This mode is used for buffers related to a main *cvs* buffer.
All the `cvs-mode' buffer operations are simply rebound under
the \\[cvs-mode-map] prefix."
- nil " CVS"
+ :lighter " CVS"
:group 'pcl-cvs)
(put 'cvs-minor-mode 'permanent-local t)
diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el
index 2b477df..87ca542 100644
--- a/lisp/vc/vc-dispatcher.el
+++ b/lisp/vc/vc-dispatcher.el
@@ -1,4 +1,4 @@
-;;; vc-dispatcher.el -- generic command-dispatcher facility. -*-
lexical-binding: t -*-
+;;; vc-dispatcher.el --- generic command-dispatcher facility. -*-
lexical-binding: t -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
diff --git a/lisp/vc/vc-filewise.el b/lisp/vc/vc-filewise.el
index e1b042a..254e479 100644
--- a/lisp/vc/vc-filewise.el
+++ b/lisp/vc/vc-filewise.el
@@ -82,3 +82,5 @@ If the file is not registered, or the master name is not
known, return nil."
nil)))) ; Not registered
(provide 'vc-filewise)
+
+;;; vc-filewise.el ends here
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index fda8605..e37c09d 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -27,14 +27,6 @@
;; system.
;;
-;;; Installation:
-
-;; To install: put this file on the load-path and add Git to the list
-;; of supported backends in `vc-handled-backends'; the following line,
-;; placed in your init file, will accomplish this:
-;;
-;; (add-to-list 'vc-handled-backends 'Git)
-
;;; Todo:
;; - check if more functions could use vc-git-command instead
;; of start-process.
diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el
index 9faed10..c9c1e91 100644
--- a/lisp/vc/vc-hg.el
+++ b/lisp/vc/vc-hg.el
@@ -26,12 +26,6 @@
;; This is a mercurial version control backend
-;;; Thanks:
-
-;;; Bugs:
-
-;;; Installation:
-
;;; Todo:
;; 1) Implement the rest of the vc interface. See the comment at the
@@ -97,9 +91,6 @@
;; without even using `hg' (this way even if you don't have `hg' installed,
;; Emacs is able to tell you this file is under mercurial's control).
-;;; History:
-;;
-
;;; Code:
(require 'cl-lib)
diff --git a/lisp/vcursor.el b/lisp/vcursor.el
index 595a253..e219dc2 100644
--- a/lisp/vcursor.el
+++ b/lisp/vcursor.el
@@ -1,4 +1,4 @@
-;;; vcursor.el --- manipulate an alternative ("virtual") cursor
+;;; vcursor.el --- manipulate an alternative ("virtual") cursor -*-
lexical-binding: t; -*-
;; Copyright (C) 1994, 1996, 1998, 2001-2021 Free Software Foundation,
;; Inc.
@@ -27,24 +27,24 @@
;; Latest changes
;; ==============
;;
-;; - *IMPORTANT* vcursor-key-bindings is now nil by default, to avoid
+;; - *IMPORTANT* `vcursor-key-bindings' is now nil by default, to avoid
;; side-effects when the package is loaded. This means no keys are
;; bound by default. Use customize to change it to t to restore
;; the old behavior. (If you do it by hand in .emacs, it
;; must come before vcursor is loaded.)
;; - You can alter the main variables and the vcursor face via
;; M-x customize: go to the Editing group and find Vcursor.
-;; - vcursor-auto-disable can now be 'copy (actually any value not nil
+;; - `vcursor-auto-disable' can now be 'copy (actually any value not nil
;; or t), which means that copying from the vcursor will be turned
;; off after any operation not involving the vcursor, but the
;; vcursor itself will be left alone.
;; - works on dumb terminals
;; - new keymap vcursor-map for binding to a prefix key
-;; - vcursor-compare-windows substantially improved
-;; - vcursor-execute-{key,command} much better about using the
+;; - `vcursor-compare-windows' substantially improved
+;; - `vcursor-execute-{key,command}' much better about using the
;; right keymaps and arranging for the correct windows to be used
-;; - vcursor-window-funcall can call functions interactively
-;; - vcursor-interpret-input for special effects
+;; - `vcursor-window-funcall' can call functions interactively
+;; - `vcursor-interpret-input' for special effects
;;
;; Introduction
;; ============
@@ -326,21 +326,18 @@
(defface vcursor
'((((class color)) (:foreground "blue" :background "cyan" :underline t))
(t (:inverse-video t :underline t)))
- "Face for the virtual cursor."
- :group 'vcursor)
+ "Face for the virtual cursor.")
(defcustom vcursor-auto-disable nil
"If non-nil, disable the virtual cursor after use.
Any non-vcursor command will force `vcursor-disable' to be called.
If non-nil but not t, just make sure copying is toggled off, but don't
disable the vcursor."
- :type '(choice (const t) (const nil) (const copy))
- :group 'vcursor)
+ :type '(choice (const t) (const nil) (const copy)))
(defcustom vcursor-modifiers (list 'control 'shift)
"A list of modifiers that are used to define vcursor key bindings."
- :type '(repeat symbol)
- :group 'vcursor)
+ :type '(repeat symbol))
;; Needed for defcustom, must be up here
(defun vcursor-cs-binding (base &optional meta)
@@ -349,112 +346,114 @@ disable the vcursor."
(cons 'meta key)
key))))
+;; (defvar vcursor)
+
(defun vcursor-bind-keys (var value)
"Alter the value of the variable VAR to VALUE, binding keys as required.
VAR is usually `vcursor-key-bindings'. Normally this function is called
on loading vcursor and from the customize package."
(set var value)
(cond
- ((not value));; don't set any key bindings
+ ((not value)) ;; Don't set any key bindings.
((or (eq value 'oemacs)
(and (eq value t) (fboundp 'oemacs-version)))
- (global-set-key [C-f1] 'vcursor-toggle-copy)
- (global-set-key [C-f2] 'vcursor-copy)
- (global-set-key [C-f3] 'vcursor-copy-word)
- (global-set-key [C-f4] 'vcursor-copy-line)
-
- (global-set-key [S-f1] 'vcursor-disable)
- (global-set-key [S-f2] 'vcursor-other-window)
- (global-set-key [S-f3] 'vcursor-goto)
- (global-set-key [S-f4] 'vcursor-swap-point)
-
- (global-set-key [C-f5] 'vcursor-backward-char)
- (global-set-key [C-f6] 'vcursor-previous-line)
- (global-set-key [C-f7] 'vcursor-next-line)
- (global-set-key [C-f8] 'vcursor-forward-char)
-
- (global-set-key [M-f5] 'vcursor-beginning-of-line)
- (global-set-key [M-f6] 'vcursor-backward-word)
- (global-set-key [M-f6] 'vcursor-forward-word)
- (global-set-key [M-f8] 'vcursor-end-of-line)
-
- (global-set-key [S-f5] 'vcursor-beginning-of-buffer)
- (global-set-key [S-f6] 'vcursor-scroll-down)
- (global-set-key [S-f7] 'vcursor-scroll-up)
- (global-set-key [S-f8] 'vcursor-end-of-buffer)
-
- (global-set-key [C-f9] 'vcursor-isearch-forward)
-
- (global-set-key [S-f9] 'vcursor-execute-key)
- (global-set-key [S-f10] 'vcursor-execute-command)
-
-;;; Partial dictionary of Oemacs key sequences for you to roll your own,
-;;; e.g C-S-up: (global-set-key "\M-[\C-f\M-\C-m" 'vcursor-previous-line)
-;;; Sequence: Sends:
-;;; "\M-[\C-f\M-\C-m" C-S-up
-;;; "\M-[\C-f\M-\C-q" C-S-down
-;;; "\M-[\C-fs" C-S-left
-;;; "\M-[\C-ft" C-S-right
-;;;
-;;; "\M-[\C-fw" C-S-home
-;;; "\M-[\C-b\C-o" S-tab
-;;; "\M-[\C-f\M-\C-r" C-S-insert
-;;; "\M-[\C-fu" C-S-end
-;;; "\M-[\C-f\M-\C-s" C-S-delete
-;;; "\M-[\C-f\M-\C-d" C-S-prior
-;;; "\M-[\C-fv" C-S-next
-;;;
-;;; "\M-[\C-f^" C-S-f1
-;;; "\M-[\C-f_" C-S-f2
-;;; "\M-[\C-f`" C-S-f3
-;;; "\M-[\C-fa" C-S-f4
-;;; "\M-[\C-fb" C-S-f5
-;;; "\M-[\C-fc" C-S-f6
-;;; "\M-[\C-fd" C-S-f7
-;;; "\M-[\C-fe" C-S-f8
-;;; "\M-[\C-ff" C-S-f9
-;;; "\M-[\C-fg" C-S-f10
+ (global-set-key [C-f1] #'vcursor-toggle-copy)
+ (global-set-key [C-f2] #'vcursor-copy)
+ (global-set-key [C-f3] #'vcursor-copy-word)
+ (global-set-key [C-f4] #'vcursor-copy-line)
+
+ (global-set-key [S-f1] #'vcursor-disable)
+ (global-set-key [S-f2] #'vcursor-other-window)
+ (global-set-key [S-f3] #'vcursor-goto)
+ (global-set-key [S-f4] #'vcursor-swap-point)
+
+ (global-set-key [C-f5] #'vcursor-backward-char)
+ (global-set-key [C-f6] #'vcursor-previous-line)
+ (global-set-key [C-f7] #'vcursor-next-line)
+ (global-set-key [C-f8] #'vcursor-forward-char)
+
+ (global-set-key [M-f5] #'vcursor-beginning-of-line)
+ (global-set-key [M-f6] #'vcursor-backward-word)
+ (global-set-key [M-f6] #'vcursor-forward-word)
+ (global-set-key [M-f8] #'vcursor-end-of-line)
+
+ (global-set-key [S-f5] #'vcursor-beginning-of-buffer)
+ (global-set-key [S-f6] #'vcursor-scroll-down)
+ (global-set-key [S-f7] #'vcursor-scroll-up)
+ (global-set-key [S-f8] #'vcursor-end-of-buffer)
+
+ (global-set-key [C-f9] #'vcursor-isearch-forward)
+
+ (global-set-key [S-f9] #'vcursor-execute-key)
+ (global-set-key [S-f10] #'vcursor-execute-command)
+
+ ;; Partial dictionary of Oemacs key sequences for you to roll your own,
+ ;; e.g C-S-up: (global-set-key "\M-[\C-f\M-\C-m" 'vcursor-previous-line)
+ ;; Sequence: Sends:
+ ;; "\M-[\C-f\M-\C-m" C-S-up
+ ;; "\M-[\C-f\M-\C-q" C-S-down
+ ;; "\M-[\C-fs" C-S-left
+ ;; "\M-[\C-ft" C-S-right
+ ;;
+ ;; "\M-[\C-fw" C-S-home
+ ;; "\M-[\C-b\C-o" S-tab
+ ;; "\M-[\C-f\M-\C-r" C-S-insert
+ ;; "\M-[\C-fu" C-S-end
+ ;; "\M-[\C-f\M-\C-s" C-S-delete
+ ;; "\M-[\C-f\M-\C-d" C-S-prior
+ ;; "\M-[\C-fv" C-S-next
+ ;;
+ ;; "\M-[\C-f^" C-S-f1
+ ;; "\M-[\C-f_" C-S-f2
+ ;; "\M-[\C-f`" C-S-f3
+ ;; "\M-[\C-fa" C-S-f4
+ ;; "\M-[\C-fb" C-S-f5
+ ;; "\M-[\C-fc" C-S-f6
+ ;; "\M-[\C-fd" C-S-f7
+ ;; "\M-[\C-fe" C-S-f8
+ ;; "\M-[\C-ff" C-S-f9
+ ;; "\M-[\C-fg" C-S-f10
)
(t
- (global-set-key (vcursor-cs-binding "up") 'vcursor-previous-line)
- (global-set-key (vcursor-cs-binding "down") 'vcursor-next-line)
- (global-set-key (vcursor-cs-binding "left") 'vcursor-backward-char)
- (global-set-key (vcursor-cs-binding "right") 'vcursor-forward-char)
-
- (global-set-key (vcursor-cs-binding "return") 'vcursor-disable)
- (global-set-key (vcursor-cs-binding "insert") 'vcursor-copy)
- (global-set-key (vcursor-cs-binding "delete") 'vcursor-copy-word)
- (global-set-key (vcursor-cs-binding "remove") 'vcursor-copy-word)
- (global-set-key (vcursor-cs-binding "tab") 'vcursor-toggle-copy)
- (global-set-key (vcursor-cs-binding "backtab") 'vcursor-toggle-copy)
- (global-set-key (vcursor-cs-binding "home") 'vcursor-beginning-of-buffer)
- (global-set-key (vcursor-cs-binding "up" t) 'vcursor-beginning-of-buffer)
- (global-set-key (vcursor-cs-binding "end") 'vcursor-end-of-buffer)
- (global-set-key (vcursor-cs-binding "down" t) 'vcursor-end-of-buffer)
- (global-set-key (vcursor-cs-binding "prior") 'vcursor-scroll-down)
- (global-set-key (vcursor-cs-binding "next") 'vcursor-scroll-up)
-
- (global-set-key (vcursor-cs-binding "f6") 'vcursor-other-window)
- (global-set-key (vcursor-cs-binding "f7") 'vcursor-goto)
+ (global-set-key (vcursor-cs-binding "up") #'vcursor-previous-line)
+ (global-set-key (vcursor-cs-binding "down") #'vcursor-next-line)
+ (global-set-key (vcursor-cs-binding "left") #'vcursor-backward-char)
+ (global-set-key (vcursor-cs-binding "right") #'vcursor-forward-char)
+
+ (global-set-key (vcursor-cs-binding "return") #'vcursor-disable)
+ (global-set-key (vcursor-cs-binding "insert") #'vcursor-copy)
+ (global-set-key (vcursor-cs-binding "delete") #'vcursor-copy-word)
+ (global-set-key (vcursor-cs-binding "remove") #'vcursor-copy-word)
+ (global-set-key (vcursor-cs-binding "tab") #'vcursor-toggle-copy)
+ (global-set-key (vcursor-cs-binding "backtab") #'vcursor-toggle-copy)
+ (global-set-key (vcursor-cs-binding "home") #'vcursor-beginning-of-buffer)
+ (global-set-key (vcursor-cs-binding "up" t) #'vcursor-beginning-of-buffer)
+ (global-set-key (vcursor-cs-binding "end") #'vcursor-end-of-buffer)
+ (global-set-key (vcursor-cs-binding "down" t) #'vcursor-end-of-buffer)
+ (global-set-key (vcursor-cs-binding "prior") #'vcursor-scroll-down)
+ (global-set-key (vcursor-cs-binding "next") #'vcursor-scroll-up)
+
+ (global-set-key (vcursor-cs-binding "f6") #'vcursor-other-window)
+ (global-set-key (vcursor-cs-binding "f7") #'vcursor-goto)
(global-set-key (vcursor-cs-binding "select")
- 'vcursor-swap-point) ; DEC keyboards
- (global-set-key (vcursor-cs-binding "tab" t) 'vcursor-swap-point)
+ #'vcursor-swap-point) ; DEC keyboards
+ (global-set-key (vcursor-cs-binding "tab" t) #'vcursor-swap-point)
(global-set-key (vcursor-cs-binding "find")
- 'vcursor-isearch-forward) ; DEC keyboards
- (global-set-key (vcursor-cs-binding "f8") 'vcursor-isearch-forward)
+ #'vcursor-isearch-forward) ; DEC keyboards
+ (global-set-key (vcursor-cs-binding "f8") #'vcursor-isearch-forward)
- (global-set-key (vcursor-cs-binding "left" t) 'vcursor-beginning-of-line)
- (global-set-key (vcursor-cs-binding "right" t) 'vcursor-end-of-line)
+ (global-set-key (vcursor-cs-binding "left" t) #'vcursor-beginning-of-line)
+ (global-set-key (vcursor-cs-binding "right" t) #'vcursor-end-of-line)
- (global-set-key (vcursor-cs-binding "prior" t) 'vcursor-backward-word)
- (global-set-key (vcursor-cs-binding "next" t) 'vcursor-forward-word)
+ (global-set-key (vcursor-cs-binding "prior" t) #'vcursor-backward-word)
+ (global-set-key (vcursor-cs-binding "next" t) #'vcursor-forward-word)
- (global-set-key (vcursor-cs-binding "return" t) 'vcursor-copy-line)
+ (global-set-key (vcursor-cs-binding "return" t) #'vcursor-copy-line)
- (global-set-key (vcursor-cs-binding "f9") 'vcursor-execute-key)
- (global-set-key (vcursor-cs-binding "f10") 'vcursor-execute-command)
+ (global-set-key (vcursor-cs-binding "f9") #'vcursor-execute-key)
+ (global-set-key (vcursor-cs-binding "f10") #'vcursor-execute-command)
)))
(defcustom vcursor-key-bindings nil
@@ -465,8 +464,7 @@ define any key bindings.
Default is nil."
:type '(choice (const t) (const nil) (const xterm) (const oemacs))
- :group 'vcursor
- :set 'vcursor-bind-keys
+ :set #'vcursor-bind-keys
:version "20.3")
(defcustom vcursor-interpret-input nil
@@ -475,13 +473,11 @@ This will cause text insertion to be much slower. Note
that no special
interpretation of strings is done: \"\C-x\" is a string of four
characters. The default is simply to copy strings."
:type 'boolean
- :group 'vcursor
:version "20.3")
(defcustom vcursor-string "**>"
"String used to show the vcursor position on dumb terminals."
:type 'string
- :group 'vcursor
:version "20.3")
(defvar vcursor-overlay nil
@@ -501,42 +497,41 @@ scrolling set this. It is used by the
`vcursor-auto-disable' code.")
(defcustom vcursor-copy-flag nil
"Non-nil means moving vcursor should copy characters moved over to point."
- :type 'boolean
- :group 'vcursor)
+ :type 'boolean)
(defvar vcursor-temp-goal-column nil
"Keeps track of temporary goal columns for the virtual cursor.")
(defvar vcursor-map
(let ((map (make-sparse-keymap)))
- (define-key map "t" 'vcursor-use-vcursor-map)
-
- (define-key map "\C-p" 'vcursor-previous-line)
- (define-key map "\C-n" 'vcursor-next-line)
- (define-key map "\C-b" 'vcursor-backward-char)
- (define-key map "\C-f" 'vcursor-forward-char)
-
- (define-key map "\r" 'vcursor-disable)
- (define-key map " " 'vcursor-copy)
- (define-key map "\C-y" 'vcursor-copy-word)
- (define-key map "\C-i" 'vcursor-toggle-copy)
- (define-key map "<" 'vcursor-beginning-of-buffer)
- (define-key map ">" 'vcursor-end-of-buffer)
- (define-key map "\M-v" 'vcursor-scroll-down)
- (define-key map "\C-v" 'vcursor-scroll-up)
- (define-key map "o" 'vcursor-other-window)
- (define-key map "g" 'vcursor-goto)
- (define-key map "x" 'vcursor-swap-point)
- (define-key map "\C-s" 'vcursor-isearch-forward)
- (define-key map "\C-r" 'vcursor-isearch-backward)
- (define-key map "\C-a" 'vcursor-beginning-of-line)
- (define-key map "\C-e" 'vcursor-end-of-line)
- (define-key map "\M-w" 'vcursor-forward-word)
- (define-key map "\M-b" 'vcursor-backward-word)
- (define-key map "\M-l" 'vcursor-copy-line)
- (define-key map "c" 'vcursor-compare-windows)
- (define-key map "k" 'vcursor-execute-key)
- (define-key map "\M-x" 'vcursor-execute-command)
+ (define-key map "t" #'vcursor-use-vcursor-map)
+
+ (define-key map "\C-p" #'vcursor-previous-line)
+ (define-key map "\C-n" #'vcursor-next-line)
+ (define-key map "\C-b" #'vcursor-backward-char)
+ (define-key map "\C-f" #'vcursor-forward-char)
+
+ (define-key map "\r" #'vcursor-disable)
+ (define-key map " " #'vcursor-copy)
+ (define-key map "\C-y" #'vcursor-copy-word)
+ (define-key map "\C-i" #'vcursor-toggle-copy)
+ (define-key map "<" #'vcursor-beginning-of-buffer)
+ (define-key map ">" #'vcursor-end-of-buffer)
+ (define-key map "\M-v" #'vcursor-scroll-down)
+ (define-key map "\C-v" #'vcursor-scroll-up)
+ (define-key map "o" #'vcursor-other-window)
+ (define-key map "g" #'vcursor-goto)
+ (define-key map "x" #'vcursor-swap-point)
+ (define-key map "\C-s" #'vcursor-isearch-forward)
+ (define-key map "\C-r" #'vcursor-isearch-backward)
+ (define-key map "\C-a" #'vcursor-beginning-of-line)
+ (define-key map "\C-e" #'vcursor-end-of-line)
+ (define-key map "\M-w" #'vcursor-forward-word)
+ (define-key map "\M-b" #'vcursor-backward-word)
+ (define-key map "\M-l" #'vcursor-copy-line)
+ (define-key map "c" #'vcursor-compare-windows)
+ (define-key map "k" #'vcursor-execute-key)
+ (define-key map "\M-x" #'vcursor-execute-command)
map)
"Keymap for vcursor command.")
;; This seems unused, but it was done as part of define-prefix-command,
@@ -611,7 +606,8 @@ Set `vcursor-window' to the returned value as a side
effect."
(cond
(winok) ; choice 2
((and vcursor-window ; choice 3
- (not (eq thiswin vcursor-window))) vcursor-window)
+ (not (eq thiswin vcursor-window)))
+ vcursor-window)
(winbuf) ; choice 4
(new-win (display-buffer (current-buffer) t)) ; choice 5
(t nil))))))) ; default (choice 6)
@@ -719,16 +715,14 @@ not be visible otherwise, display it in another window."
The vcursor will always appear in an unselected window."
(interactive "P")
- (vcursor-window-funcall 'scroll-up n)
-)
+ (vcursor-window-funcall #'scroll-up n))
(defun vcursor-scroll-down (&optional n)
"Scroll down the vcursor window ARG lines or near full screen if none.
The vcursor will always appear in an unselected window."
(interactive "P")
- (vcursor-window-funcall 'scroll-down n)
- )
+ (vcursor-window-funcall #'scroll-down n))
(defun vcursor-isearch-forward (&optional rep norecurs)
"Perform forward incremental search in the virtual cursor window.
@@ -736,7 +730,7 @@ The virtual cursor is moved to the resulting point; the
ordinary
cursor stays where it was."
(interactive "P")
- (vcursor-window-funcall 'isearch-forward rep norecurs)
+ (vcursor-window-funcall #'isearch-forward rep norecurs)
)
(defun vcursor-isearch-backward (&optional rep norecurs)
@@ -745,7 +739,7 @@ The virtual cursor is moved to the resulting point; the
ordinary
cursor stays where it was."
(interactive "P")
- (vcursor-window-funcall 'isearch-backward rep norecurs)
+ (vcursor-window-funcall #'isearch-backward rep norecurs)
)
(defun vcursor-window-funcall (func &rest args)
@@ -891,7 +885,7 @@ A prefix argument, if any, means ignore changes in
whitespace.
The variable `compare-windows-whitespace' controls how whitespace is skipped.
If `compare-ignore-case' is non-nil, changes in case are also ignored."
(interactive "P")
- ;; (vcursor-window-funcall 'compare-windows arg)
+ ;; (vcursor-window-funcall #'compare-windows arg)
(require 'compare-w)
(let* (p1 p2 maxp1 maxp2 b1 b2 w2
success
@@ -1005,32 +999,32 @@ If `compare-ignore-case' is non-nil, changes in case are
also ignored."
(defun vcursor-forward-char (arg)
"Move the virtual cursor forward ARG characters."
(interactive "p")
- (vcursor-relative-move 'forward-char arg)
+ (vcursor-relative-move #'forward-char arg)
)
(defun vcursor-backward-char (arg)
"Move the virtual cursor backward ARG characters."
(interactive "p")
- (vcursor-relative-move 'backward-char arg)
+ (vcursor-relative-move #'backward-char arg)
)
(defun vcursor-forward-word (arg)
"Move the virtual cursor forward ARG words."
(interactive "p")
- (vcursor-relative-move 'forward-word arg)
+ (vcursor-relative-move #'forward-word arg)
)
(defun vcursor-backward-word (arg)
"Move the virtual cursor backward ARG words."
(interactive "p")
- (vcursor-relative-move 'backward-word arg)
+ (vcursor-relative-move #'backward-word arg)
)
(defun vcursor-beginning-of-line (arg)
"Move the virtual cursor to beginning of its current line.
ARG is as for `beginning-of-line'."
(interactive "P")
- (vcursor-relative-move 'beginning-of-line
+ (vcursor-relative-move #'beginning-of-line
(if arg (prefix-numeric-value arg)))
)
@@ -1038,7 +1032,7 @@ ARG is as for `beginning-of-line'."
"Move the virtual cursor to end of its current line.
ARG is as for `end-of-line'."
(interactive "P")
- (vcursor-relative-move 'end-of-line
+ (vcursor-relative-move #'end-of-line
(if arg (prefix-numeric-value arg)))
)
@@ -1110,7 +1104,7 @@ is called interactively, so prefix argument etc. are
usable."
(defun vcursor-copy-word (arg)
"Copy ARG words from the virtual cursor position to point."
(interactive "p")
- (vcursor-copy (vcursor-get-char-count 'forward-word arg))
+ (vcursor-copy (vcursor-get-char-count #'forward-word arg))
)
(defun vcursor-copy-line (arg)
@@ -1123,7 +1117,7 @@ line is treated like ordinary characters."
(interactive "P")
(let* ((num (prefix-numeric-value arg))
- (count (vcursor-get-char-count 'end-of-line num)))
+ (count (vcursor-get-char-count #'end-of-line num)))
(vcursor-copy (if (or (= count 0) arg) (1+ count) count)))
)
@@ -1136,7 +1130,7 @@ line is treated like ordinary characters."
(setq vcursor-last-command nil)
)
-(add-hook 'post-command-hook 'vcursor-post-command)
+(add-hook 'post-command-hook #'vcursor-post-command)
(provide 'vcursor)
diff --git a/lisp/vt-control.el b/lisp/vt-control.el
index 0bd5132..bac0069 100644
--- a/lisp/vt-control.el
+++ b/lisp/vt-control.el
@@ -83,26 +83,24 @@
(defun vt-keypad-on (&optional tell)
"Turn on the VT applications keypad."
- (interactive)
+ (interactive "p")
(send-string-to-terminal "\e=")
(setq vt-applications-keypad-p t)
- (if (or tell (called-interactively-p 'interactive))
- (message "Applications keypad enabled.")))
+ (if tell (message "Applications keypad enabled.")))
(defun vt-keypad-off (&optional tell)
"Turn off the VT applications keypad."
(interactive "p")
(send-string-to-terminal "\e>")
(setq vt-applications-keypad-p nil)
- (if (or tell (called-interactively-p 'interactive))
- (message "Applications keypad disabled.")))
+ (if tell (message "Applications keypad disabled.")))
-(defun vt-numlock nil
+(defun vt-numlock (&optional tell)
"Toggle VT application keypad on and off."
- (interactive)
+ (interactive "p")
(if vt-applications-keypad-p
- (vt-keypad-off (called-interactively-p 'interactive))
- (vt-keypad-on (called-interactively-p 'interactive))))
+ (vt-keypad-off tell)
+ (vt-keypad-on tell)))
(provide 'vt-control)
diff --git a/lisp/wdired.el b/lisp/wdired.el
index ff42d78..35211bc 100644
--- a/lisp/wdired.el
+++ b/lisp/wdired.el
@@ -292,28 +292,31 @@ or \\[wdired-abort-changes] to abort changes")))
(call-interactively (or (if map (lookup-key map (this-command-keys)))
#'self-insert-command)))))
+(put 'wdired--self-insert 'delete-selection 'delete-selection-uses-region-p)
+
(defun wdired--before-change-fn (beg end)
- (save-excursion
- ;; Make sure to process entire lines.
- (goto-char end)
- (setq end (line-end-position))
- (goto-char beg)
- (forward-line 0)
-
- (while (< (point) end)
- (unless (wdired--line-preprocessed-p)
+ (save-match-data
+ (save-excursion
+ ;; Make sure to process entire lines.
+ (goto-char end)
+ (setq end (line-end-position))
+ (goto-char beg)
+ (forward-line 0)
+
+ (while (< (point) end)
+ (unless (wdired--line-preprocessed-p)
+ (with-silent-modifications
+ (put-text-property (point) (1+ (point)) 'front-sticky t)
+ (wdired--preprocess-files)
+ (when wdired-allow-to-change-permissions
+ (wdired--preprocess-perms))
+ (when (fboundp 'make-symbolic-link)
+ (wdired--preprocess-symlinks))))
+ (forward-line))
+ (when (eobp)
(with-silent-modifications
- (put-text-property (point) (1+ (point)) 'front-sticky t)
- (wdired--preprocess-files)
- (when wdired-allow-to-change-permissions
- (wdired--preprocess-perms))
- (when (fboundp 'make-symbolic-link)
- (wdired--preprocess-symlinks))))
- (forward-line))
- (when (eobp)
- (with-silent-modifications
- ;; Is this good enough? Assumes no extra white lines from dired.
- (put-text-property (1- (point-max)) (point-max) 'read-only t)))))
+ ;; Is this good enough? Assumes no extra white lines from dired.
+ (put-text-property (1- (point-max)) (point-max) 'read-only t))))))
(defun wdired-isearch-filter-read-only (beg end)
"Skip matches that have a read-only property."
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index e71290c..49baab6 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -750,7 +750,7 @@ automatically."
:type 'boolean)
(defcustom widget-image-conversion
- '((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg")
+ '((svg ".svg") (xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg")
(xbm ".xbm"))
"Conversion alist from image formats to file name suffixes."
:group 'widgets
@@ -1878,20 +1878,9 @@ as the argument to `documentation-property'."
(let ((value (widget-get widget :value)))
(and (listp value)
(<= (length value) (length vals))
- (let ((head (widget-sublist vals 0 (length value))))
+ (let ((head (seq-subseq vals 0 (length value))))
(and (equal head value)
- (cons head (widget-sublist vals (length value))))))))
-
-(defun widget-sublist (list start &optional end)
- "Return the sublist of LIST from START to END.
-If END is omitted, it defaults to the length of LIST."
- (if (> start 0) (setq list (nthcdr start list)))
- (if end
- (unless (<= end start)
- (setq list (copy-sequence list))
- (setcdr (nthcdr (- end start 1) list) nil)
- list)
- (copy-sequence list)))
+ (cons head (seq-subseq vals (length value))))))))
(defun widget-item-action (widget &optional event)
;; Just notify itself.
@@ -2575,9 +2564,9 @@ Return an alist of (TYPE MATCH)."
:button-suffix ""
:button-prefix ""
:on "(*)"
- :on-glyph "radio1"
+ :on-glyph "radio-checked"
:off "( )"
- :off-glyph "radio0")
+ :off-glyph "radio")
(defun widget-radio-button-notify (widget _child &optional event)
;; Tell daddy.
@@ -4117,7 +4106,9 @@ is inline."
(setq help-echo (funcall help-echo widget)))
(if help-echo (message "%s" (eval help-echo)))))
-;;; The End:
+;;; Obsolete.
+
+(define-obsolete-function-alias 'widget-sublist #'seq-subseq "28.1")
(provide 'wid-edit)
diff --git a/lisp/widget.el b/lisp/widget.el
index 401b4cf..d258e6f 100644
--- a/lisp/widget.el
+++ b/lisp/widget.el
@@ -94,8 +94,6 @@ The third argument DOC is a documentation string for the
widget."
;; This is used by external widget code (in W3, at least).
(define-obsolete-function-alias 'widget-plist-member #'plist-member "26.1")
-;;; The End.
-
(provide 'widget)
;;; widget.el ends here
diff --git a/lisp/window.el b/lisp/window.el
index f27631b..cf57521 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -3755,8 +3755,6 @@ WINDOW must be a valid window and defaults to the
selected one.
If the option `window-resize-pixelwise' is non-nil minimize
WINDOW pixelwise."
(interactive)
- (when switch-to-buffer-preserve-window-point
- (window--before-delete-windows window))
(setq window (window-normalize-window window))
(window-resize
window
@@ -4142,41 +4140,6 @@ frame can be safely deleted."
(throw 'done t)
(setq parent (window-parent parent))))))))
-;; This function is called by `delete-window' and
-;; `delete-other-windows' when `switch-to-buffer-preserve-window-point'
-;; evaluates non-nil: it allows `winner-undo' to restore the
-;; buffer point from deleted windows (Bug#23621).
-(defun window--before-delete-windows (&optional window)
- "Update `window-prev-buffers' before delete a window.
-Optional arg WINDOW, if non-nil, update WINDOW-START and POS
-in `window-prev-buffers' for all windows displaying same
-buffer as WINDOW. Otherwise, update `window-prev-buffers' for
-all windows.
-
-The new values for WINDOW-START and POS are those
-returned by `window-start' and `window-point' respectively.
-
-This function is called only if `switch-to-buffer-preserve-window-point'
-evaluates non-nil."
- (dolist (win (window-list nil 'no-minibuf))
- (let* ((buf (window-buffer (or window win)))
- (start (window-start win))
- (pos (window-point win))
- (entry (assq buf (window-prev-buffers win))))
- (cond (entry
- (let ((marker (nth 2 entry)))
- (unless (= pos marker)
- (set-marker (nth 1 entry) start buf)
- (set-marker marker pos buf))))
- (t
- (let ((prev-buf (window-prev-buffers win))
- (start-m (make-marker))
- (pos-m (make-marker)))
- (set-marker start-m start buf)
- (set-marker pos-m pos buf)
- (push (list buf start-m pos-m) prev-buf)
- (set-window-prev-buffers win prev-buf)))))))
-
(defun delete-window (&optional window)
"Delete WINDOW.
WINDOW must be a valid window and defaults to the selected one.
@@ -4195,8 +4158,6 @@ argument. Signal an error if WINDOW is either the only
window on
its frame, the last non-side window, or part of an atomic window
that is its frame's root window."
(interactive)
- (when switch-to-buffer-preserve-window-point
- (window--before-delete-windows))
(setq window (window-normalize-window window))
(let* ((frame (window-frame window))
(function (window-parameter window 'delete-window))
@@ -6172,29 +6133,27 @@ value can be also stored on disk and read back in a new
session."
;; Select window if it's the selected one.
(when (cdr (assq 'selected state))
(select-window window))
- (when next-buffers
- (set-window-next-buffers
- window
- (delq nil (mapcar (lambda (buffer)
- (setq buffer (get-buffer buffer))
- (when (buffer-live-p buffer) buffer))
- next-buffers))))
- (when prev-buffers
- (set-window-prev-buffers
- window
- (delq nil (mapcar (lambda (entry)
- (let ((buffer (get-buffer (nth 0
entry)))
- (m1 (nth 1 entry))
- (m2 (nth 2 entry)))
- (when (buffer-live-p buffer)
- (list buffer
- (if (markerp m1) m1
- (set-marker (make-marker) m1
- buffer))
- (if (markerp m2) m2
- (set-marker (make-marker) m2
- buffer))))))
- prev-buffers)))))
+ (set-window-next-buffers
+ window
+ (delq nil (mapcar (lambda (buffer)
+ (setq buffer (get-buffer buffer))
+ (when (buffer-live-p buffer) buffer))
+ next-buffers)))
+ (set-window-prev-buffers
+ window
+ (delq nil (mapcar (lambda (entry)
+ (let ((buffer (get-buffer (nth 0 entry)))
+ (m1 (nth 1 entry))
+ (m2 (nth 2 entry)))
+ (when (buffer-live-p buffer)
+ (list buffer
+ (if (markerp m1) m1
+ (set-marker (make-marker) m1
+ buffer))
+ (if (markerp m2) m2
+ (set-marker (make-marker) m2
+ buffer))))))
+ prev-buffers))))
;; We don't want to raise an error in case the buffer does
;; not exist anymore, so we switch to a previous one and
;; save the window with the intention of deleting it later
@@ -7411,8 +7370,8 @@ For instance:
Buffer display can be further customized to a very high degree;
the rest of this docstring explains some of the many
-possibilities, and also see `(emacs)Window Choice' for more
-information.
+possibilities, and also see Info node `(emacs)Window Choice' for
+more information.
BUFFER-OR-NAME must be a buffer or a string naming a live buffer.
Return the window chosen for displaying that buffer, or nil if no
@@ -10256,6 +10215,10 @@ displaying that processes's buffer."
(defvar other-window-repeat-map
(let ((map (make-sparse-keymap)))
(define-key map "o" 'other-window)
+ (define-key map "O" (lambda ()
+ (interactive)
+ (setq repeat-map 'other-window-repeat-map)
+ (other-window -1)))
map)
"Keymap to repeat other-window key sequences. Used in `repeat-mode'.")
(put 'other-window 'repeat-map 'other-window-repeat-map)
diff --git a/lisp/winner.el b/lisp/winner.el
index 9506ac5..8062fba 100644
--- a/lisp/winner.el
+++ b/lisp/winner.el
@@ -1,4 +1,4 @@
-;;; winner.el --- Restore old window configurations
+;;; winner.el --- Restore old window configurations -*- lexical-binding: t -*-
;; Copyright (C) 1997-1998, 2001-2021 Free Software Foundation, Inc.
@@ -33,14 +33,13 @@
;;; Code:
(eval-when-compile (require 'cl-lib))
+(require 'ring)
(defun winner-active-region ()
(declare (gv-setter (lambda (store)
`(if ,store (activate-mark) (deactivate-mark)))))
(region-active-p))
-(require 'ring)
-
(defgroup winner nil
"Restoring window configurations."
:group 'windows)
@@ -273,7 +272,7 @@ You may want to include buffer names such as *Help*,
*Apropos*,
(let* ((buffers nil)
(alive
;; Possibly update `winner-point-alist'
- (cl-loop for buf in (mapcar 'cdr (cdr conf))
+ (cl-loop for buf in (mapcar #'cdr (cdr conf))
for pos = (winner-get-point buf nil)
if (and pos (not (memq buf buffers)))
do (push buf buffers)
@@ -284,17 +283,8 @@ You may want to include buffer names such as *Help*,
*Apropos*,
;; Restore points
(dolist (win (winner-sorted-window-list))
(unless (and (pop alive)
- (let* ((buf (window-buffer win))
- (pos (winner-get-point (window-buffer win) win))
- (entry (assq buf (window-prev-buffers win))))
- ;; Try to restore point of buffer in the selected
- ;; window (Bug#23621).
- (let ((marker (nth 2 entry)))
- (when (and switch-to-buffer-preserve-window-point
- marker
- (not (= marker pos)))
- (setq pos marker))
- (setf (window-point win) pos)))
+ (setf (window-point win)
+ (winner-get-point (window-buffer win) win))
(not (or (member (buffer-name (window-buffer win))
winner-boring-buffers)
(and winner-boring-buffers-regexp
@@ -317,7 +307,7 @@ You may want to include buffer names such as *Help*,
*Apropos*,
;; Return t if this is still a possible configuration.
(or (null xwins)
(progn
- (mapc 'delete-window (cdr xwins)) ; delete all but one
+ (mapc #'delete-window (cdr xwins)) ; delete all but one
(unless (one-window-p t)
(delete-window (car xwins))
t))))))
@@ -328,22 +318,20 @@ You may want to include buffer names such as *Help*,
*Apropos*,
(defcustom winner-mode-hook nil
"Functions to run whenever Winner mode is turned on or off."
- :type 'hook
- :group 'winner)
+ :type 'hook)
(define-obsolete-variable-alias 'winner-mode-leave-hook
'winner-mode-off-hook "24.3")
(defcustom winner-mode-off-hook nil
"Functions to run whenever Winner mode is turned off."
- :type 'hook
- :group 'winner)
+ :type 'hook)
(defvar winner-mode-map
(let ((map (make-sparse-keymap)))
(unless winner-dont-bind-my-keys
- (define-key map [(control c) left] 'winner-undo)
- (define-key map [(control c) right] 'winner-redo))
+ (define-key map [(control c) left] #'winner-undo)
+ (define-key map [(control c) right] #'winner-redo))
map)
"Keymap for Winner mode.")
diff --git a/lisp/woman.el b/lisp/woman.el
index 505fdb4..d9aa573 100644
--- a/lisp/woman.el
+++ b/lisp/woman.el
@@ -390,9 +390,6 @@
(eval-when-compile (require 'cl-lib))
-(defvar woman-version "0.551 (beta)" "WoMan version information.")
-(make-obsolete-variable 'woman-version nil "28.1")
-
(require 'man)
(define-button-type 'WoMan-xref-man-page
:supertype 'Man-abstract-xref-man-page
@@ -4580,6 +4577,11 @@ logging the message."
(bookmark-default-handler
`("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bookmark)))))
+;; Obsolete.
+
+(defvar woman-version "0.551 (beta)" "WoMan version information.")
+(make-obsolete-variable 'woman-version 'emacs-version "28.1")
+
(provide 'woman)
;;; woman.el ends here
diff --git a/lwlib/Makefile.in b/lwlib/Makefile.in
index fb0ae0e..ce77789 100644
--- a/lwlib/Makefile.in
+++ b/lwlib/Makefile.in
@@ -93,9 +93,9 @@ globals_h = ../src/globals.h
$(globals_h):
$(MAKE) -C ../src globals.h
-.PHONY: mostlyclean clean distclean bootstrap-clean maintainer-clean
+.PHONY: mostlyclean clean distclean bootstrap-clean maintainer-clean extraclean
-clean mostlyclean:
+clean mostlyclean extraclean:
rm -f ./*.o liblw.a \#* $(DEPDIR)/*
distclean: clean
diff --git a/nt/epaths.nt b/nt/epaths.nt
index ad60f6c..a75ed52 100644
--- a/nt/epaths.nt
+++ b/nt/epaths.nt
@@ -49,6 +49,11 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
*/
#define PATH_SITELOADSEARCH
"%emacs_dir%/share/emacs/@VER@/site-lisp;%emacs_dir%/share/emacs/site-lisp"
+/* Like PATH_LOADSEARCH, but contains the relative path from the
+ installation directory.
+*/
+#define PATH_REL_LOADSEARCH ""
+
/* Like PATH_LOADSEARCH, but used only during the build process
when Emacs is dumping. Configure (using "make epaths-force-w32") sets
this to $buildlisppath, which normally has the value: <srcdir>/lisp.
diff --git a/nt/mingw-cfg.site b/nt/mingw-cfg.site
index 9630077..431fdab 100644
--- a/nt/mingw-cfg.site
+++ b/nt/mingw-cfg.site
@@ -158,6 +158,10 @@ gl_cv_func_copy_file_range=yes
# We don't want to build Emacs so it depends on bcrypt.dll, since then
# it will refuse to start on systems where that DLL is absent.
gl_cv_lib_assume_bcrypt=no
+# Force 'ac_cv_func_strsignal' to no as mingw64 libgccjit exports this
+# symbol erroneously
+# <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=45303#83>.
+ac_cv_func_strsignal=no
# Don't build the Gnulib free.c: it is not needed, since the w32
# implementation of 'free' doesn't touch errno, and it emits a
# compilation warning.
diff --git a/src/Makefile.in b/src/Makefile.in
index f3c545d..b8bad73 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -242,7 +242,7 @@ LIBZ = @LIBZ@
## system-specific libs for dynamic modules, else empty
LIBMODULES = @LIBMODULES@
-## dynlib.o emacs-module.o if modules enabled, else empty
+## emacs-module.o if modules enabled, else empty
MODULES_OBJ = @MODULES_OBJ@
XRANDR_LIBS = @XRANDR_LIBS@
@@ -326,6 +326,11 @@ GETLOADAVG_LIBS = @GETLOADAVG_LIBS@
LIBGMP = @LIBGMP@
+LIBGCCJIT = @LIBGCCJIT_LIB@
+
+## dynlib.o if necessary, else empty
+DYNLIB_OBJ = @DYNLIB_OBJ@
+
RUN_TEMACS = ./temacs
# Whether builds should contain details. '--no-build-details' or empty.
@@ -392,7 +397,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o
$(XMENU_OBJ) window.o \
cmds.o casetab.o casefiddle.o indent.o search.o regex-emacs.o undo.o \
alloc.o pdumper.o data.o doc.o editfns.o callint.o \
eval.o floatfns.o fns.o font.o print.o lread.o $(MODULES_OBJ) \
- syntax.o $(UNEXEC_OBJ) bytecode.o \
+ syntax.o $(UNEXEC_OBJ) bytecode.o comp.o $(DYNLIB_OBJ) \
process.o gnutls.o callproc.o \
region-cache.o sound.o timefns.o atimer.o \
doprnt.o intervals.o textprop.o composite.o xml.o lcms.o $(NOTIFY_OBJ) \
@@ -495,6 +500,7 @@ shortlisp := $(filter-out ${shortlisp_filter},${shortlisp})
## the critical path (relevant in parallel compilations).
## We don't really need to sort, but may as well use it to remove duplicates.
shortlisp := loaddefs.el loadup.el $(sort ${shortlisp})
+export LISP_PRELOADED = ${shortlisp}
lisp = $(addprefix ${lispsource}/,${shortlisp})
## Construct full set of libraries to be linked.
@@ -510,7 +516,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE)
$(LIBIMAGE) \
$(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(HARFBUZZ_LIBS) $(LIBOTF_LIBS)
$(M17N_FLT_LIBS) \
$(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LCMS2_LIBS) \
$(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \
- $(JSON_LIBS) $(LIBGMP)
+ $(JSON_LIBS) $(LIBGMP) $(LIBGCCJIT)
## FORCE it so that admin/unidata can decide whether this file is
## up-to-date. Although since charprop depends on bootstrap-emacs,
@@ -560,7 +566,8 @@ endif
ifeq ($(DUMPING),pdumper)
$(pdmp): emacs$(EXEEXT)
- LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=pdump
+ LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=pdump
\
+ --bin-dest $(BIN_DESTDIR) --eln-dest $(ELN_DESTDIR)
cp -f $@ $(bootstrap_pdmp)
endif
@@ -791,7 +798,8 @@ endif
ifeq ($(DUMPING),pdumper)
$(bootstrap_pdmp): bootstrap-emacs$(EXEEXT)
rm -f $@
- $(RUN_TEMACS) --batch $(BUILD_DETAILS) -l loadup --temacs=pbootstrap
+ $(RUN_TEMACS) --batch $(BUILD_DETAILS) -l loadup --temacs=pbootstrap \
+ --bin-dest $(BIN_DESTDIR) --eln-dest $(ELN_DESTDIR)
@: Compile some files earlier to speed up further compilation.
$(MAKE) -C ../lisp compile-first EMACS="$(bootstrap_exe)"
endif
diff --git a/src/alloc.c b/src/alloc.c
index e72fc4c..76d8c7d 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3152,6 +3152,26 @@ cleanup_vector (struct Lisp_Vector *vector)
module_finalize_function (function);
}
#endif
+ else if (NATIVE_COMP_FLAG
+ && PSEUDOVECTOR_TYPEP (&vector->header, PVEC_NATIVE_COMP_UNIT))
+ {
+ struct Lisp_Native_Comp_Unit *cu =
+ PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit);
+ unload_comp_unit (cu);
+ }
+ else if (NATIVE_COMP_FLAG
+ && PSEUDOVECTOR_TYPEP (&vector->header, PVEC_SUBR))
+ {
+ struct Lisp_Subr *subr =
+ PSEUDOVEC_STRUCT (vector, Lisp_Subr);
+ if (!NILP (subr->native_comp_u[0]))
+ {
+ /* FIXME Alternative and non invasive solution to this
+ cast? */
+ xfree ((char *)subr->symbol_name);
+ xfree (subr->native_c_name[0]);
+ }
+ }
}
/* Reclaim space used by unmarked vectors. */
@@ -6248,7 +6268,7 @@ For further details, see Info node `(elisp)Garbage
Collection'. */)
}
DEFUN ("garbage-collect-maybe", Fgarbage_collect_maybe,
-Sgarbage_collect_maybe, 1, 1, "",
+Sgarbage_collect_maybe, 1, 1, 0,
doc: /* Call `garbage-collect' if enough allocation happened.
FACTOR determines what "enough" means here:
If FACTOR is a positive number N, it means to run GC if more than
@@ -6725,6 +6745,15 @@ mark_object (Lisp_Object arg)
break;
case PVEC_SUBR:
+ if (SUBR_NATIVE_COMPILEDP (obj))
+ {
+ set_vector_marked (ptr);
+ struct Lisp_Subr *subr = XSUBR (obj);
+ mark_object (subr->native_intspec);
+ mark_object (subr->native_comp_u[0]);
+ mark_object (subr->lambda_list[0]);
+ mark_object (subr->type[0]);
+ }
break;
case PVEC_FREE:
@@ -6869,7 +6898,9 @@ survives_gc_p (Lisp_Object obj)
break;
case Lisp_Vectorlike:
- survives_p = SUBRP (obj) || vector_marked_p (XVECTOR (obj));
+ survives_p =
+ (SUBRP (obj) && !SUBR_NATIVE_COMPILEDP (obj)) ||
+ vector_marked_p (XVECTOR (obj));
break;
case Lisp_Cons:
@@ -7629,14 +7660,14 @@ N should be nonnegative. */);
static union Aligned_Lisp_Subr Swatch_gc_cons_threshold =
{{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) },
{ .a4 = watch_gc_cons_threshold },
- 4, 4, "watch_gc_cons_threshold", 0, 0}};
+ 4, 4, "watch_gc_cons_threshold", {0}, 0}};
XSETSUBR (watcher, &Swatch_gc_cons_threshold.s);
Fadd_variable_watcher (Qgc_cons_threshold, watcher);
static union Aligned_Lisp_Subr Swatch_gc_cons_percentage =
{{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) },
{ .a4 = watch_gc_cons_percentage },
- 4, 4, "watch_gc_cons_percentage", 0, 0}};
+ 4, 4, "watch_gc_cons_percentage", {0}, 0}};
XSETSUBR (watcher, &Swatch_gc_cons_percentage.s);
Fadd_variable_watcher (Qgc_cons_percentage, watcher);
}
diff --git a/src/callproc.c b/src/callproc.c
index cd0f67f..5aa2cba 100644
--- a/src/callproc.c
+++ b/src/callproc.c
@@ -457,7 +457,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int
filefd,
int ok;
ok = openp (Vexec_path, args[0], Vexec_suffixes, &path,
- make_fixnum (X_OK), false);
+ make_fixnum (X_OK), false, false);
if (ok < 0)
report_file_error ("Searching for program", args[0]);
}
diff --git a/src/character.c b/src/character.c
index a599a03..41abb83 100644
--- a/src/character.c
+++ b/src/character.c
@@ -321,28 +321,32 @@ strwidth (const char *str, ptrdiff_t len)
return c_string_width ((const unsigned char *) str, len, -1, NULL, NULL);
}
-/* Return width of Lisp string STRING when displayed in the current
- buffer. The width is measured by how many columns it occupies on
- the screen while paying attention to compositions. If PRECISION >
- 0, return the width of longest substring that doesn't exceed
- PRECISION, and set number of characters and bytes of the substring
- in *NCHARS and *NBYTES respectively. */
+/* Return width of a (substring of a) Lisp string STRING when
+ displayed in the current buffer. The width is measured by how many
+ columns it occupies on the screen while paying attention to
+ compositions. If PRECISION > 0, return the width of longest
+ substring that doesn't exceed PRECISION, and set number of
+ characters and bytes of the substring in *NCHARS and *NBYTES
+ respectively. FROM and TO are zero-based character indices
+ that define the substring of STRING to consider. */
ptrdiff_t
-lisp_string_width (Lisp_Object string, ptrdiff_t precision,
- ptrdiff_t *nchars, ptrdiff_t *nbytes)
+lisp_string_width (Lisp_Object string, ptrdiff_t from, ptrdiff_t to,
+ ptrdiff_t precision, ptrdiff_t *nchars, ptrdiff_t *nbytes)
{
- ptrdiff_t len = SCHARS (string);
/* This set multibyte to 0 even if STRING is multibyte when it
contains only ascii and eight-bit-graphic, but that's
intentional. */
- bool multibyte = len < SBYTES (string);
+ bool multibyte = SCHARS (string) < SBYTES (string);
unsigned char *str = SDATA (string);
- ptrdiff_t i = 0, i_byte = 0;
+ ptrdiff_t i = from, i_byte = from ? string_char_to_byte (string, from) : 0;
+ ptrdiff_t from_byte = i_byte;
ptrdiff_t width = 0;
struct Lisp_Char_Table *dp = buffer_display_table ();
- while (i < len)
+ eassert (precision <= 0 || (nchars && nbytes));
+
+ while (i < to)
{
ptrdiff_t chars, bytes, thiswidth;
Lisp_Object val;
@@ -375,8 +379,8 @@ lisp_string_width (Lisp_Object string, ptrdiff_t precision,
if (0 < precision && precision - width < thiswidth)
{
- *nchars = i;
- *nbytes = i_byte;
+ *nchars = i - from;
+ *nbytes = i_byte - from_byte;
return width;
}
if (INT_ADD_WRAPV (thiswidth, width, &width))
@@ -387,27 +391,37 @@ lisp_string_width (Lisp_Object string, ptrdiff_t
precision,
if (precision > 0)
{
- *nchars = i;
- *nbytes = i_byte;
+ *nchars = i - from;
+ *nbytes = i_byte - from_byte;
}
return width;
}
-DEFUN ("string-width", Fstring_width, Sstring_width, 1, 1, 0,
+DEFUN ("string-width", Fstring_width, Sstring_width, 1, 3, 0,
doc: /* Return width of STRING when displayed in the current buffer.
Width is measured by how many columns it occupies on the screen.
+Optional arguments FROM and TO specify the substring of STRING to
+consider, and are interpreted as in `substring'.
+
When calculating width of a multibyte character in STRING,
only the base leading-code is considered; the validity of
the following bytes is not checked. Tabs in STRING are always
-taken to occupy `tab-width' columns.
-usage: (string-width STRING) */)
- (Lisp_Object str)
+taken to occupy `tab-width' columns. The effect of faces and fonts
+used for non-Latin and other unusual characters (such as emoji) is
+ignored as well, as are display properties and invisible text.
+For these reasons, the results are not generally reliable;
+for accurate dimensions of text as it will be displayed,
+use `window-text-pixel-size' instead.
+usage: (string-width STRING &optional FROM TO) */)
+ (Lisp_Object str, Lisp_Object from, Lisp_Object to)
{
Lisp_Object val;
+ ptrdiff_t ifrom, ito;
CHECK_STRING (str);
- XSETFASTINT (val, lisp_string_width (str, -1, NULL, NULL));
+ validate_subarray (str, from, to, SCHARS (str), &ifrom, &ito);
+ XSETFASTINT (val, lisp_string_width (str, ifrom, ito, -1, NULL, NULL));
return val;
}
diff --git a/src/character.h b/src/character.h
index cbf4309..75351cd 100644
--- a/src/character.h
+++ b/src/character.h
@@ -42,7 +42,7 @@ INLINE_HEADER_BEGIN
F9..FF 11111yyy
In each bit pattern, 'x' and 'y' each represent a single bit of the
- character code payload, and least one 'y' must be a 1 bit.
+ character code payload, and at least one 'y' must be a 1 bit.
In the 5-byte sequence, the 22-bit payload cannot exceed 3FFF7F.
*/
@@ -572,8 +572,8 @@ extern ptrdiff_t str_to_unibyte (const unsigned char *,
unsigned char *,
extern ptrdiff_t strwidth (const char *, ptrdiff_t);
extern ptrdiff_t c_string_width (const unsigned char *, ptrdiff_t, int,
ptrdiff_t *, ptrdiff_t *);
-extern ptrdiff_t lisp_string_width (Lisp_Object, ptrdiff_t,
- ptrdiff_t *, ptrdiff_t *);
+extern ptrdiff_t lisp_string_width (Lisp_Object, ptrdiff_t, ptrdiff_t,
+ ptrdiff_t, ptrdiff_t *, ptrdiff_t *);
extern Lisp_Object Vchar_unify_table;
extern Lisp_Object string_escape_byte8 (Lisp_Object);
diff --git a/src/charset.c b/src/charset.c
index eb388d1..7cd0fa7 100644
--- a/src/charset.c
+++ b/src/charset.c
@@ -486,7 +486,7 @@ load_charset_map_from_file (struct charset *charset,
Lisp_Object mapfile,
ptrdiff_t count = SPECPDL_INDEX ();
record_unwind_protect_nothing ();
specbind (Qfile_name_handler_alist, Qnil);
- fd = openp (Vcharset_map_path, mapfile, suffixes, NULL, Qnil, false);
+ fd = openp (Vcharset_map_path, mapfile, suffixes, NULL, Qnil, false, false);
fp = fd < 0 ? 0 : fdopen (fd, "r");
if (!fp)
{
diff --git a/src/comp.c b/src/comp.c
new file mode 100644
index 0000000..a4dba43
--- /dev/null
+++ b/src/comp.c
@@ -0,0 +1,5410 @@
+/* Compile Emacs Lisp into native code.
+ Copyright (C) 2019-2021 Free Software Foundation, Inc.
+
+Author: Andrea Corallo <akrl@sdf.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/>. */
+
+#include <config.h>
+
+#include "lisp.h"
+
+#ifdef HAVE_NATIVE_COMP
+
+#include <setjmp.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <signal.h>
+#include <libgccjit.h>
+#include <epaths.h>
+
+#include "puresize.h"
+#include "window.h"
+#include "dynlib.h"
+#include "buffer.h"
+#include "blockinput.h"
+#include "coding.h"
+#include "md5.h"
+#include "sysstdio.h"
+#include "zlib.h"
+
+
+/********************************/
+/* Dynamic loading of libgccjit */
+/********************************/
+
+#ifdef WINDOWSNT
+# include "w32common.h"
+
+#undef gcc_jit_block_add_assignment
+#undef gcc_jit_block_add_comment
+#undef gcc_jit_block_add_eval
+#undef gcc_jit_block_end_with_conditional
+#undef gcc_jit_block_end_with_jump
+#undef gcc_jit_block_end_with_return
+#undef gcc_jit_block_end_with_void_return
+#undef gcc_jit_context_acquire
+#undef gcc_jit_context_add_command_line_option
+#undef gcc_jit_context_add_driver_option
+#undef gcc_jit_context_compile_to_file
+#undef gcc_jit_context_dump_reproducer_to_file
+#undef gcc_jit_context_dump_to_file
+#undef gcc_jit_context_get_builtin_function
+#undef gcc_jit_context_get_first_error
+#undef gcc_jit_context_get_int_type
+#undef gcc_jit_context_get_type
+#undef gcc_jit_context_new_array_access
+#undef gcc_jit_context_new_array_type
+#undef gcc_jit_context_new_binary_op
+#undef gcc_jit_context_new_call
+#undef gcc_jit_context_new_call_through_ptr
+#undef gcc_jit_context_new_comparison
+#undef gcc_jit_context_new_field
+#undef gcc_jit_context_new_function
+#undef gcc_jit_context_new_function_ptr_type
+#undef gcc_jit_context_new_global
+#undef gcc_jit_context_new_opaque_struct
+#undef gcc_jit_context_new_param
+#undef gcc_jit_context_new_rvalue_from_int
+#undef gcc_jit_context_new_rvalue_from_long
+#undef gcc_jit_context_new_rvalue_from_ptr
+#undef gcc_jit_context_new_string_literal
+#undef gcc_jit_context_new_struct_type
+#undef gcc_jit_context_new_unary_op
+#undef gcc_jit_context_new_union_type
+#undef gcc_jit_context_release
+#undef gcc_jit_context_set_bool_option
+#undef gcc_jit_context_set_int_option
+#undef gcc_jit_context_set_logfile
+#undef gcc_jit_context_set_str_option
+#undef gcc_jit_function_get_param
+#undef gcc_jit_function_new_block
+#undef gcc_jit_function_new_local
+#undef gcc_jit_global_set_initializer
+#undef gcc_jit_lvalue_access_field
+#undef gcc_jit_lvalue_as_rvalue
+#undef gcc_jit_lvalue_get_address
+#undef gcc_jit_param_as_lvalue
+#undef gcc_jit_param_as_rvalue
+#undef gcc_jit_rvalue_access_field
+#undef gcc_jit_rvalue_dereference
+#undef gcc_jit_rvalue_dereference_field
+#undef gcc_jit_rvalue_get_type
+#undef gcc_jit_struct_as_type
+#undef gcc_jit_struct_set_fields
+#undef gcc_jit_type_get_const
+#undef gcc_jit_type_get_pointer
+#undef gcc_jit_version_major
+#undef gcc_jit_version_minor
+#undef gcc_jit_version_patchlevel
+
+/* In alphabetical order */
+DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_int,
+ (gcc_jit_context *ctxt, gcc_jit_type *numeric_type, int value));
+DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_lvalue_as_rvalue,
+ (gcc_jit_lvalue *lvalue));
+DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_rvalue_access_field,
+ (gcc_jit_rvalue *struct_or_union, gcc_jit_location *loc,
+ gcc_jit_field *field));
+DEF_DLL_FN (void, gcc_jit_block_add_comment,
+ (gcc_jit_block *block, gcc_jit_location *loc, const char *text));
+DEF_DLL_FN (void, gcc_jit_context_release, (gcc_jit_context *ctxt));
+DEF_DLL_FN (const char *, gcc_jit_context_get_first_error,
+ (gcc_jit_context *ctxt));
+DEF_DLL_FN (gcc_jit_block *, gcc_jit_function_new_block,
+ (gcc_jit_function *func, const char *name));
+DEF_DLL_FN (gcc_jit_context *, gcc_jit_context_acquire, (void));
+DEF_DLL_FN (void, gcc_jit_context_add_command_line_option,
+ (gcc_jit_context *ctxt, const char *optname));
+DEF_DLL_FN (void, gcc_jit_context_add_driver_option,
+ (gcc_jit_context *ctxt, const char *optname));
+DEF_DLL_FN (gcc_jit_field *, gcc_jit_context_new_field,
+ (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_type *type,
+ const char *name));
+DEF_DLL_FN (gcc_jit_function *, gcc_jit_context_get_builtin_function,
+ (gcc_jit_context *ctxt, const char *name));
+DEF_DLL_FN (gcc_jit_function *, gcc_jit_context_new_function,
+ (gcc_jit_context *ctxt, gcc_jit_location *loc,
+ enum gcc_jit_function_kind kind, gcc_jit_type *return_type,
+ const char *name, int num_params, gcc_jit_param **params,
+ int is_variadic));
+DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_context_new_array_access,
+ (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_rvalue *ptr,
+ gcc_jit_rvalue *index));
+DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_context_new_global,
+ (gcc_jit_context *ctxt, gcc_jit_location *loc,
+ enum gcc_jit_global_kind kind, gcc_jit_type *type,
+ const char *name));
+DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_function_new_local,
+ (gcc_jit_function *func, gcc_jit_location *loc, gcc_jit_type *type,
+ const char *name));
+DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_global_set_initializer,
+ (gcc_jit_lvalue *global, const void *blob, size_t num_bytes));
+DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_lvalue_access_field,
+ (gcc_jit_lvalue *struct_or_union, gcc_jit_location *loc,
+ gcc_jit_field *field));
+DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_param_as_lvalue, (gcc_jit_param *param));
+DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_rvalue_dereference,
+ (gcc_jit_rvalue *rvalue, gcc_jit_location *loc));
+DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_rvalue_dereference_field,
+ (gcc_jit_rvalue *ptr, gcc_jit_location *loc, gcc_jit_field
*field));
+DEF_DLL_FN (gcc_jit_param *, gcc_jit_context_new_param,
+ (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_type *type,
+ const char *name));
+DEF_DLL_FN (gcc_jit_param *, gcc_jit_function_get_param,
+ (gcc_jit_function *func, int index));
+DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_binary_op,
+ (gcc_jit_context *ctxt, gcc_jit_location *loc,
+ enum gcc_jit_binary_op op, gcc_jit_type *result_type,
+ gcc_jit_rvalue *a, gcc_jit_rvalue *b));
+DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_call,
+ (gcc_jit_context *ctxt, gcc_jit_location *loc,
+ gcc_jit_function *func, int numargs , gcc_jit_rvalue **args));
+DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_call_through_ptr,
+ (gcc_jit_context *ctxt, gcc_jit_location *loc,
+ gcc_jit_rvalue *fn_ptr, int numargs, gcc_jit_rvalue **args));
+DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_comparison,
+ (gcc_jit_context *ctxt, gcc_jit_location *loc,
+ enum gcc_jit_comparison op, gcc_jit_rvalue *a, gcc_jit_rvalue
*b));
+DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_long,
+ (gcc_jit_context *ctxt, gcc_jit_type *numeric_type, long value));
+#if LISP_WORDS_ARE_POINTERS
+DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_ptr,
+ (gcc_jit_context *ctxt, gcc_jit_type *pointer_type, void *value));
+#endif
+DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_string_literal,
+ (gcc_jit_context *ctxt, const char *value));
+DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_unary_op,
+ (gcc_jit_context *ctxt, gcc_jit_location *loc,
+ enum gcc_jit_unary_op op, gcc_jit_type *result_type,
+ gcc_jit_rvalue *rvalue));
+DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_lvalue_get_address,
+ (gcc_jit_lvalue *lvalue, gcc_jit_location *loc));
+DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_param_as_rvalue, (gcc_jit_param *param));
+DEF_DLL_FN (gcc_jit_struct *, gcc_jit_context_new_opaque_struct,
+ (gcc_jit_context *ctxt, gcc_jit_location *loc, const char *name));
+DEF_DLL_FN (gcc_jit_struct *, gcc_jit_context_new_struct_type,
+ (gcc_jit_context *ctxt, gcc_jit_location *loc, const char *name,
+ int num_fields, gcc_jit_field **fields));
+DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_get_int_type,
+ (gcc_jit_context *ctxt, int num_bytes, int is_signed));
+DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_get_type,
+ (gcc_jit_context *ctxt, enum gcc_jit_types type_));
+DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_array_type,
+ (gcc_jit_context *ctxt, gcc_jit_location *loc,
+ gcc_jit_type *element_type, int num_elements));
+DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_function_ptr_type,
+ (gcc_jit_context *ctxt, gcc_jit_location *loc,
+ gcc_jit_type *return_type, int num_params,
+ gcc_jit_type **param_types, int is_variadic));
+DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_union_type,
+ (gcc_jit_context *ctxt, gcc_jit_location *loc, const char *name,
+ int num_fields, gcc_jit_field **fields));
+DEF_DLL_FN (gcc_jit_type *, gcc_jit_rvalue_get_type, (gcc_jit_rvalue *rvalue));
+DEF_DLL_FN (gcc_jit_type *, gcc_jit_struct_as_type,
+ (gcc_jit_struct *struct_type));
+DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_get_const, (gcc_jit_type *type));
+DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_get_pointer, (gcc_jit_type *type));
+DEF_DLL_FN (void, gcc_jit_block_add_assignment,
+ (gcc_jit_block *block, gcc_jit_location *loc, gcc_jit_lvalue
*lvalue,
+ gcc_jit_rvalue *rvalue));
+DEF_DLL_FN (void, gcc_jit_block_add_eval,
+ (gcc_jit_block *block, gcc_jit_location *loc,
+ gcc_jit_rvalue *rvalue));
+DEF_DLL_FN (void, gcc_jit_block_end_with_conditional,
+ (gcc_jit_block *block, gcc_jit_location *loc,
+ gcc_jit_rvalue *boolval, gcc_jit_block *on_true,
+ gcc_jit_block *on_false));
+DEF_DLL_FN (void, gcc_jit_block_end_with_jump,
+ (gcc_jit_block *block, gcc_jit_location *loc,
+ gcc_jit_block *target));
+DEF_DLL_FN (void, gcc_jit_block_end_with_return,
+ (gcc_jit_block *block, gcc_jit_location *loc,
+ gcc_jit_rvalue *rvalue));
+DEF_DLL_FN (void, gcc_jit_block_end_with_void_return,
+ (gcc_jit_block *block, gcc_jit_location *loc));
+DEF_DLL_FN (void, gcc_jit_context_compile_to_file,
+ (gcc_jit_context *ctxt, enum gcc_jit_output_kind output_kind,
+ const char *output_path));
+DEF_DLL_FN (void, gcc_jit_context_dump_reproducer_to_file,
+ (gcc_jit_context *ctxt, const char *path));
+DEF_DLL_FN (void, gcc_jit_context_dump_to_file,
+ (gcc_jit_context *ctxt, const char *path, int update_locations));
+DEF_DLL_FN (void, gcc_jit_context_set_bool_option,
+ (gcc_jit_context *ctxt, enum gcc_jit_bool_option opt, int value));
+DEF_DLL_FN (void, gcc_jit_context_set_int_option,
+ (gcc_jit_context *ctxt, enum gcc_jit_int_option opt, int value));
+DEF_DLL_FN (void, gcc_jit_context_set_logfile,
+ (gcc_jit_context *ctxt, FILE *logfile, int flags, int verbosity));
+DEF_DLL_FN (void, gcc_jit_context_set_str_option,
+ (gcc_jit_context *ctxt, enum gcc_jit_str_option opt,
+ const char *value));
+DEF_DLL_FN (void, gcc_jit_struct_set_fields,
+ (gcc_jit_struct *struct_type, gcc_jit_location *loc, int
num_fields,
+ gcc_jit_field **fields));
+DEF_DLL_FN (int, gcc_jit_version_major, (void));
+DEF_DLL_FN (int, gcc_jit_version_minor, (void));
+DEF_DLL_FN (int, gcc_jit_version_patchlevel, (void));
+
+static bool
+init_gccjit_functions (void)
+{
+ HMODULE library = w32_delayed_load (Qgccjit);
+
+ if (!library)
+ return false;
+
+ /* In alphabetical order */
+ LOAD_DLL_FN (library, gcc_jit_block_add_assignment);
+ LOAD_DLL_FN (library, gcc_jit_block_add_comment);
+ LOAD_DLL_FN (library, gcc_jit_block_add_eval);
+ LOAD_DLL_FN (library, gcc_jit_block_end_with_conditional);
+ LOAD_DLL_FN (library, gcc_jit_block_end_with_jump);
+ LOAD_DLL_FN (library, gcc_jit_block_end_with_return);
+ LOAD_DLL_FN (library, gcc_jit_block_end_with_void_return);
+ LOAD_DLL_FN (library, gcc_jit_context_acquire);
+ LOAD_DLL_FN (library, gcc_jit_context_compile_to_file);
+ LOAD_DLL_FN (library, gcc_jit_context_dump_reproducer_to_file);
+ LOAD_DLL_FN (library, gcc_jit_context_dump_to_file);
+ LOAD_DLL_FN (library, gcc_jit_context_get_builtin_function);
+ LOAD_DLL_FN (library, gcc_jit_context_get_first_error);
+ LOAD_DLL_FN (library, gcc_jit_context_get_int_type);
+ LOAD_DLL_FN (library, gcc_jit_context_get_type);
+ LOAD_DLL_FN (library, gcc_jit_context_new_array_access);
+ LOAD_DLL_FN (library, gcc_jit_context_new_array_type);
+ LOAD_DLL_FN (library, gcc_jit_context_new_binary_op);
+ LOAD_DLL_FN (library, gcc_jit_context_new_call);
+ LOAD_DLL_FN (library, gcc_jit_context_new_call_through_ptr);
+ LOAD_DLL_FN (library, gcc_jit_context_new_comparison);
+ LOAD_DLL_FN (library, gcc_jit_context_new_field);
+ LOAD_DLL_FN (library, gcc_jit_context_new_function);
+ LOAD_DLL_FN (library, gcc_jit_context_new_function_ptr_type);
+ LOAD_DLL_FN (library, gcc_jit_context_new_global);
+ LOAD_DLL_FN (library, gcc_jit_context_new_opaque_struct);
+ LOAD_DLL_FN (library, gcc_jit_context_new_param);
+ LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_int);
+ LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_long);
+#if LISP_WORDS_ARE_POINTERS
+ LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_ptr);
+#endif
+ LOAD_DLL_FN (library, gcc_jit_context_new_string_literal);
+ LOAD_DLL_FN (library, gcc_jit_context_new_struct_type);
+ LOAD_DLL_FN (library, gcc_jit_context_new_unary_op);
+ LOAD_DLL_FN (library, gcc_jit_context_new_union_type);
+ LOAD_DLL_FN (library, gcc_jit_context_release);
+ LOAD_DLL_FN (library, gcc_jit_context_set_bool_option);
+ LOAD_DLL_FN (library, gcc_jit_context_set_int_option);
+ LOAD_DLL_FN (library, gcc_jit_context_set_logfile);
+ LOAD_DLL_FN (library, gcc_jit_context_set_str_option);
+ LOAD_DLL_FN (library, gcc_jit_function_get_param);
+ LOAD_DLL_FN (library, gcc_jit_function_new_block);
+ LOAD_DLL_FN (library, gcc_jit_function_new_local);
+ LOAD_DLL_FN (library, gcc_jit_lvalue_access_field);
+ LOAD_DLL_FN (library, gcc_jit_lvalue_as_rvalue);
+ LOAD_DLL_FN (library, gcc_jit_lvalue_get_address);
+ LOAD_DLL_FN (library, gcc_jit_param_as_lvalue);
+ LOAD_DLL_FN (library, gcc_jit_param_as_rvalue);
+ LOAD_DLL_FN (library, gcc_jit_rvalue_access_field);
+ LOAD_DLL_FN (library, gcc_jit_rvalue_dereference);
+ LOAD_DLL_FN (library, gcc_jit_rvalue_dereference_field);
+ LOAD_DLL_FN (library, gcc_jit_rvalue_get_type);
+ LOAD_DLL_FN (library, gcc_jit_struct_as_type);
+ LOAD_DLL_FN (library, gcc_jit_struct_set_fields);
+ LOAD_DLL_FN (library, gcc_jit_type_get_const);
+ LOAD_DLL_FN (library, gcc_jit_type_get_pointer);
+ LOAD_DLL_FN_OPT (library, gcc_jit_context_add_command_line_option);
+ LOAD_DLL_FN_OPT (library, gcc_jit_context_add_driver_option);
+ LOAD_DLL_FN_OPT (library, gcc_jit_global_set_initializer);
+ LOAD_DLL_FN_OPT (library, gcc_jit_version_major);
+ LOAD_DLL_FN_OPT (library, gcc_jit_version_minor);
+ LOAD_DLL_FN_OPT (library, gcc_jit_version_patchlevel);
+
+ return true;
+}
+
+/* In alphabetical order */
+#define gcc_jit_block_add_assignment fn_gcc_jit_block_add_assignment
+#define gcc_jit_block_add_comment fn_gcc_jit_block_add_comment
+#define gcc_jit_block_add_eval fn_gcc_jit_block_add_eval
+#define gcc_jit_block_end_with_conditional
fn_gcc_jit_block_end_with_conditional
+#define gcc_jit_block_end_with_jump fn_gcc_jit_block_end_with_jump
+#define gcc_jit_block_end_with_return fn_gcc_jit_block_end_with_return
+#define gcc_jit_block_end_with_void_return
fn_gcc_jit_block_end_with_void_return
+#define gcc_jit_context_acquire fn_gcc_jit_context_acquire
+#define gcc_jit_context_add_command_line_option
fn_gcc_jit_context_add_command_line_option
+#define gcc_jit_context_add_driver_option fn_gcc_jit_context_add_driver_option
+#define gcc_jit_context_compile_to_file fn_gcc_jit_context_compile_to_file
+#define gcc_jit_context_dump_reproducer_to_file
fn_gcc_jit_context_dump_reproducer_to_file
+#define gcc_jit_context_dump_to_file fn_gcc_jit_context_dump_to_file
+#define gcc_jit_context_get_builtin_function
fn_gcc_jit_context_get_builtin_function
+#define gcc_jit_context_get_first_error fn_gcc_jit_context_get_first_error
+#define gcc_jit_context_get_int_type fn_gcc_jit_context_get_int_type
+#define gcc_jit_context_get_type fn_gcc_jit_context_get_type
+#define gcc_jit_context_new_array_access fn_gcc_jit_context_new_array_access
+#define gcc_jit_context_new_array_type fn_gcc_jit_context_new_array_type
+#define gcc_jit_context_new_binary_op fn_gcc_jit_context_new_binary_op
+#define gcc_jit_context_new_call fn_gcc_jit_context_new_call
+#define gcc_jit_context_new_call_through_ptr
fn_gcc_jit_context_new_call_through_ptr
+#define gcc_jit_context_new_comparison fn_gcc_jit_context_new_comparison
+#define gcc_jit_context_new_field fn_gcc_jit_context_new_field
+#define gcc_jit_context_new_function fn_gcc_jit_context_new_function
+#define gcc_jit_context_new_function_ptr_type
fn_gcc_jit_context_new_function_ptr_type
+#define gcc_jit_context_new_global fn_gcc_jit_context_new_global
+#define gcc_jit_context_new_opaque_struct fn_gcc_jit_context_new_opaque_struct
+#define gcc_jit_context_new_param fn_gcc_jit_context_new_param
+#define gcc_jit_context_new_rvalue_from_int
fn_gcc_jit_context_new_rvalue_from_int
+#define gcc_jit_context_new_rvalue_from_long
fn_gcc_jit_context_new_rvalue_from_long
+#if LISP_WORDS_ARE_POINTERS
+# define gcc_jit_context_new_rvalue_from_ptr
fn_gcc_jit_context_new_rvalue_from_ptr
+#endif
+#define gcc_jit_context_new_string_literal
fn_gcc_jit_context_new_string_literal
+#define gcc_jit_context_new_struct_type fn_gcc_jit_context_new_struct_type
+#define gcc_jit_context_new_unary_op fn_gcc_jit_context_new_unary_op
+#define gcc_jit_context_new_union_type fn_gcc_jit_context_new_union_type
+#define gcc_jit_context_release fn_gcc_jit_context_release
+#define gcc_jit_context_set_bool_option fn_gcc_jit_context_set_bool_option
+#define gcc_jit_context_set_int_option fn_gcc_jit_context_set_int_option
+#define gcc_jit_context_set_logfile fn_gcc_jit_context_set_logfile
+#define gcc_jit_context_set_str_option fn_gcc_jit_context_set_str_option
+#define gcc_jit_function_get_param fn_gcc_jit_function_get_param
+#define gcc_jit_function_new_block fn_gcc_jit_function_new_block
+#define gcc_jit_function_new_local fn_gcc_jit_function_new_local
+#define gcc_jit_global_set_initializer fn_gcc_jit_global_set_initializer
+#define gcc_jit_lvalue_access_field fn_gcc_jit_lvalue_access_field
+#define gcc_jit_lvalue_as_rvalue fn_gcc_jit_lvalue_as_rvalue
+#define gcc_jit_lvalue_get_address fn_gcc_jit_lvalue_get_address
+#define gcc_jit_param_as_lvalue fn_gcc_jit_param_as_lvalue
+#define gcc_jit_param_as_rvalue fn_gcc_jit_param_as_rvalue
+#define gcc_jit_rvalue_access_field fn_gcc_jit_rvalue_access_field
+#define gcc_jit_rvalue_dereference fn_gcc_jit_rvalue_dereference
+#define gcc_jit_rvalue_dereference_field fn_gcc_jit_rvalue_dereference_field
+#define gcc_jit_rvalue_get_type fn_gcc_jit_rvalue_get_type
+#define gcc_jit_struct_as_type fn_gcc_jit_struct_as_type
+#define gcc_jit_struct_set_fields fn_gcc_jit_struct_set_fields
+#define gcc_jit_type_get_const fn_gcc_jit_type_get_const
+#define gcc_jit_type_get_pointer fn_gcc_jit_type_get_pointer
+#define gcc_jit_version_major fn_gcc_jit_version_major
+#define gcc_jit_version_minor fn_gcc_jit_version_minor
+#define gcc_jit_version_patchlevel fn_gcc_jit_version_patchlevel
+
+#endif
+
+static bool
+load_gccjit_if_necessary (bool mandatory)
+{
+#ifdef WINDOWSNT
+ static bool tried_to_initialize_once;
+ static bool gccjit_initialized;
+
+ if (!tried_to_initialize_once)
+ {
+ tried_to_initialize_once = true;
+ Lisp_Object status;
+ gccjit_initialized = init_gccjit_functions ();
+ status = gccjit_initialized ? Qt : Qnil;
+ Vlibrary_cache = Fcons (Fcons (Qgccjit, status), Vlibrary_cache);
+ }
+
+ if (mandatory && !gccjit_initialized)
+ xsignal1 (Qnative_compiler_error, build_string ("libgccjit not found"));
+
+ return gccjit_initialized;
+#else
+ return true;
+#endif
+}
+
+
+/* Increase this number to force a new Vcomp_abi_hash to be generated. */
+#define ABI_VERSION "4"
+
+/* Length of the hashes used for eln file naming. */
+#define HASH_LENGTH 8
+
+/* C symbols emitted for the load relocation mechanism. */
+#define CURRENT_THREAD_RELOC_SYM "current_thread_reloc"
+#define PURE_RELOC_SYM "pure_reloc"
+#define DATA_RELOC_SYM "d_reloc"
+#define DATA_RELOC_IMPURE_SYM "d_reloc_imp"
+#define DATA_RELOC_EPHEMERAL_SYM "d_reloc_eph"
+
+#define FUNC_LINK_TABLE_SYM "freloc_link_table"
+#define LINK_TABLE_HASH_SYM "freloc_hash"
+#define COMP_UNIT_SYM "comp_unit"
+#define TEXT_DATA_RELOC_SYM "text_data_reloc"
+#define TEXT_DATA_RELOC_IMPURE_SYM "text_data_reloc_imp"
+#define TEXT_DATA_RELOC_EPHEMERAL_SYM "text_data_reloc_eph"
+
+#define TEXT_OPTIM_QLY_SYM "text_optim_qly"
+#define TEXT_FDOC_SYM "text_data_fdoc"
+
+#define STR_VALUE(s) #s
+#define STR(s) STR_VALUE (s)
+
+#define FIRST(x) \
+ XCAR(x)
+#define SECOND(x) \
+ XCAR (XCDR (x))
+#define THIRD(x) \
+ XCAR (XCDR (XCDR (x)))
+
+/* Like call1 but stringify and intern. */
+#define CALL1I(fun, arg) \
+ CALLN (Ffuncall, intern_c_string (STR (fun)), arg)
+
+/* Like call2 but stringify and intern. */
+#define CALL2I(fun, arg1, arg2) \
+ CALLN (Ffuncall, intern_c_string (STR (fun)), arg1, arg2)
+
+#define DECL_BLOCK(name, func) \
+ gcc_jit_block *(name) = \
+ gcc_jit_function_new_block ((func), STR (name))
+
+#ifndef WINDOWSNT
+# ifdef HAVE__SETJMP
+# define SETJMP _setjmp
+# else
+# define SETJMP setjmp
+# endif
+#else
+/* snippet from MINGW-64 setjmp.h */
+# define SETJMP _setjmp
+#endif
+#define SETJMP_NAME SETJMP
+
+/* Max number function importable by native compiled code. */
+#define F_RELOC_MAX_SIZE 1500
+
+typedef struct {
+ void *link_table[F_RELOC_MAX_SIZE];
+ ptrdiff_t size;
+} f_reloc_t;
+
+sigset_t saved_sigset;
+
+static f_reloc_t freloc;
+
+#define NUM_CAST_TYPES 15
+
+enum cast_kind_of_type
+ {
+ kind_unsigned,
+ kind_signed,
+ kind_pointer
+ };
+
+typedef struct {
+ EMACS_INT len;
+ gcc_jit_rvalue *r_val;
+} reloc_array_t;
+
+/* C side of the compiler context. */
+
+typedef struct {
+ EMACS_INT speed;
+ EMACS_INT debug;
+ Lisp_Object driver_options;
+ gcc_jit_context *ctxt;
+ gcc_jit_type *void_type;
+ gcc_jit_type *bool_type;
+ gcc_jit_type *char_type;
+ gcc_jit_type *int_type;
+ gcc_jit_type *unsigned_type;
+ gcc_jit_type *long_type;
+ gcc_jit_type *unsigned_long_type;
+ gcc_jit_type *long_long_type;
+ gcc_jit_type *unsigned_long_long_type;
+ gcc_jit_type *emacs_int_type;
+ gcc_jit_type *emacs_uint_type;
+ gcc_jit_type *void_ptr_type;
+ gcc_jit_type *char_ptr_type;
+ gcc_jit_type *ptrdiff_type;
+ gcc_jit_type *uintptr_type;
+ gcc_jit_type *size_t_type;
+ gcc_jit_type *lisp_word_type;
+ gcc_jit_type *lisp_word_tag_type;
+#ifdef LISP_OBJECT_IS_STRUCT
+ gcc_jit_field *lisp_obj_i;
+ gcc_jit_struct *lisp_obj_s;
+#endif
+ gcc_jit_type *lisp_obj_type;
+ gcc_jit_type *lisp_obj_ptr_type;
+ /* struct Lisp_Cons */
+ gcc_jit_struct *lisp_cons_s;
+ gcc_jit_field *lisp_cons_u;
+ gcc_jit_field *lisp_cons_u_s;
+ gcc_jit_field *lisp_cons_u_s_car;
+ gcc_jit_field *lisp_cons_u_s_u;
+ gcc_jit_field *lisp_cons_u_s_u_cdr;
+ gcc_jit_type *lisp_cons_type;
+ gcc_jit_type *lisp_cons_ptr_type;
+ /* struct jmp_buf. */
+ gcc_jit_struct *jmp_buf_s;
+ /* struct handler. */
+ gcc_jit_struct *handler_s;
+ gcc_jit_field *handler_jmp_field;
+ gcc_jit_field *handler_val_field;
+ gcc_jit_field *handler_next_field;
+ gcc_jit_type *handler_ptr_type;
+ gcc_jit_lvalue *loc_handler;
+ /* struct thread_state. */
+ gcc_jit_struct *thread_state_s;
+ gcc_jit_field *m_handlerlist;
+ gcc_jit_type *thread_state_ptr_type;
+ gcc_jit_rvalue *current_thread_ref;
+ /* Other globals. */
+ gcc_jit_rvalue *pure_ptr;
+ /* libgccjit has really limited support for casting therefore this union will
+ be used for the scope. */
+ gcc_jit_type *cast_union_type;
+ gcc_jit_function *cast_functions_from_to[NUM_CAST_TYPES][NUM_CAST_TYPES];
+ /* We add one to make space for the last member which is the "biggest_type"
+ member. */
+ gcc_jit_type *cast_types[NUM_CAST_TYPES + 1];
+ size_t cast_type_sizes[NUM_CAST_TYPES + 1];
+ enum cast_kind_of_type cast_type_kind[NUM_CAST_TYPES + 1];
+ const char *cast_type_names[NUM_CAST_TYPES + 1];
+ gcc_jit_field *cast_union_fields[NUM_CAST_TYPES + 1];
+ size_t cast_union_field_biggest_type;
+ gcc_jit_function *func; /* Current function being compiled. */
+ bool func_has_non_local; /* From comp-func has-non-local slot. */
+ EMACS_INT func_speed; /* From comp-func speed slot. */
+ gcc_jit_block *block; /* Current basic block being compiled. */
+ gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence
(switch). */
+ ptrdiff_t frame_size; /* Size of the following array in elements. */
+ gcc_jit_lvalue **frame; /* Frame slot n -> gcc_jit_lvalue *. */
+ gcc_jit_rvalue *zero;
+ gcc_jit_rvalue *one;
+ gcc_jit_rvalue *inttypebits;
+ gcc_jit_rvalue *lisp_int0;
+ gcc_jit_function *pseudovectorp;
+ gcc_jit_function *bool_to_lisp_obj;
+ gcc_jit_function *add1;
+ gcc_jit_function *sub1;
+ gcc_jit_function *negate;
+ gcc_jit_function *car;
+ gcc_jit_function *cdr;
+ gcc_jit_function *setcar;
+ gcc_jit_function *setcdr;
+ gcc_jit_function *check_type;
+ gcc_jit_function *check_impure;
+ gcc_jit_function *maybe_gc_or_quit;
+ Lisp_Object func_blocks_h; /* blk_name -> gcc_block. */
+ Lisp_Object exported_funcs_h; /* c-func-name -> gcc_jit_function *. */
+ Lisp_Object imported_funcs_h; /* subr_name -> gcc_jit_field *reloc_field. */
+ Lisp_Object emitter_dispatcher;
+ /* Synthesized struct holding data relocs. */
+ reloc_array_t data_relocs;
+ /* Same as before but can't go in pure space. */
+ reloc_array_t data_relocs_impure;
+ /* Same as before but content does not survive load phase. */
+ reloc_array_t data_relocs_ephemeral;
+ /* Global structure holding function relocations. */
+ gcc_jit_lvalue *func_relocs;
+ gcc_jit_type *func_relocs_ptr_type;
+ /* Pointer to this structure local to each function. */
+ gcc_jit_lvalue *func_relocs_local;
+ gcc_jit_function *memcpy;
+ Lisp_Object d_default_idx;
+ Lisp_Object d_impure_idx;
+ Lisp_Object d_ephemeral_idx;
+} comp_t;
+
+static comp_t comp;
+
+FILE *logfile = NULL;
+
+/* This is used for serialized objects by the reload mechanism. */
+typedef struct {
+ ptrdiff_t len;
+ char data[];
+} static_obj_t;
+
+typedef struct {
+ reloc_array_t array;
+ gcc_jit_rvalue *idx;
+} imm_reloc_t;
+
+
+/*
+ Helper functions called by the run-time.
+*/
+
+void helper_unwind_protect (Lisp_Object handler);
+Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x);
+Lisp_Object helper_unbind_n (Lisp_Object n);
+void helper_save_restriction (void);
+bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code);
+
+void *helper_link_table[] =
+ { wrong_type_argument,
+ helper_PSEUDOVECTOR_TYPEP_XUNTAG,
+ pure_write_error,
+ push_handler,
+ record_unwind_protect_excursion,
+ helper_unbind_n,
+ helper_save_restriction,
+ record_unwind_current_buffer,
+ set_internal,
+ helper_unwind_protect,
+ specbind,
+ maybe_gc,
+ maybe_quit };
+
+
+static char * ATTRIBUTE_FORMAT_PRINTF (1, 2)
+format_string (const char *format, ...)
+{
+ static char scratch_area[512];
+ va_list va;
+ va_start (va, format);
+ int res = vsnprintf (scratch_area, sizeof (scratch_area), format, va);
+ if (res >= sizeof (scratch_area))
+ {
+ scratch_area[sizeof (scratch_area) - 4] = '.';
+ scratch_area[sizeof (scratch_area) - 3] = '.';
+ scratch_area[sizeof (scratch_area) - 2] = '.';
+ }
+ va_end (va);
+ return scratch_area;
+}
+
+static Lisp_Object
+comp_hash_string (Lisp_Object string)
+{
+ Lisp_Object digest = make_uninit_string (MD5_DIGEST_SIZE * 2);
+ md5_buffer (SSDATA (string), SCHARS (string), SSDATA (digest));
+ hexbuf_digest (SSDATA (digest), SDATA (digest), MD5_DIGEST_SIZE);
+
+ return Fsubstring (digest, Qnil, make_fixnum (HASH_LENGTH));
+}
+
+static Lisp_Object
+comp_hash_source_file (Lisp_Object filename)
+{
+ /* Can't use Finsert_file_contents + Fbuffer_hash as this is called
+ by Fcomp_el_to_eln_filename too early during bootstrap. */
+ bool is_gz = suffix_p (filename, ".gz");
+ Lisp_Object encoded_filename = ENCODE_FILE (filename);
+ FILE *f = emacs_fopen (SSDATA (encoded_filename), is_gz ? "rb" : "r");
+
+ if (!f)
+ report_file_error ("Opening source file", filename);
+
+ Lisp_Object digest = make_uninit_string (MD5_DIGEST_SIZE * 2);
+
+ int res = is_gz
+ ? md5_gz_stream (f, SSDATA (digest))
+ : md5_stream (f, SSDATA (digest));
+ fclose (f);
+
+ if (res)
+ xsignal2 (Qfile_notify_error, build_string ("hashing failed"), filename);
+
+ hexbuf_digest (SSDATA (digest), SSDATA (digest), MD5_DIGEST_SIZE);
+
+ return Fsubstring (digest, Qnil, make_fixnum (HASH_LENGTH));
+}
+
+DEFUN ("comp--subr-signature", Fcomp__subr_signature,
+ Scomp__subr_signature, 1, 1, 0,
+ doc: /* Support function to 'hash_native_abi'.
+For internal use. */)
+ (Lisp_Object subr)
+{
+ return concat2 (Fsubr_name (subr),
+ Fprin1_to_string (Fsubr_arity (subr), Qnil));
+}
+
+/* Produce a key hashing Vcomp_subr_list. */
+
+void
+hash_native_abi (void)
+{
+ /* Check runs once. */
+ eassert (NILP (Vcomp_abi_hash));
+
+ Vcomp_abi_hash =
+ comp_hash_string (
+ concat3 (build_string (ABI_VERSION),
+ concat3 (Vemacs_version, Vsystem_configuration,
+ Vsystem_configuration_options),
+ Fmapconcat (intern_c_string ("comp--subr-signature"),
+ Vcomp_subr_list, build_string (""))));
+ Vcomp_native_version_dir =
+ concat3 (Vemacs_version, build_string ("-"), Vcomp_abi_hash);
+}
+
+static void
+freloc_check_fill (void)
+{
+ if (freloc.size)
+ return;
+
+ eassert (!NILP (Vcomp_subr_list));
+
+ if (ARRAYELTS (helper_link_table) > F_RELOC_MAX_SIZE)
+ goto overflow;
+ memcpy (freloc.link_table, helper_link_table, sizeof (helper_link_table));
+ freloc.size = ARRAYELTS (helper_link_table);
+
+ Lisp_Object subr_l = Vcomp_subr_list;
+ FOR_EACH_TAIL (subr_l)
+ {
+ if (freloc.size == F_RELOC_MAX_SIZE)
+ goto overflow;
+ struct Lisp_Subr *subr = XSUBR (XCAR (subr_l));
+ freloc.link_table[freloc.size] = subr->function.a0;
+ freloc.size++;
+ }
+ return;
+
+ overflow:
+ fatal ("Overflowing function relocation table, increase F_RELOC_MAX_SIZE");
+}
+
+static void
+bcall0 (Lisp_Object f)
+{
+ Ffuncall (1, &f);
+}
+
+static gcc_jit_block *
+retrive_block (Lisp_Object block_name)
+{
+ Lisp_Object value = Fgethash (block_name, comp.func_blocks_h, Qnil);
+
+ if (NILP (value))
+ xsignal2 (Qnative_ice, build_string ("missing basic block"), block_name);
+
+ return (gcc_jit_block *) xmint_pointer (value);
+}
+
+static void
+declare_block (Lisp_Object block_name)
+{
+ char *name_str = SSDATA (SYMBOL_NAME (block_name));
+ gcc_jit_block *block = gcc_jit_function_new_block (comp.func, name_str);
+ Lisp_Object value = make_mint_ptr (block);
+
+ if (!NILP (Fgethash (block_name, comp.func_blocks_h, Qnil)))
+ xsignal1 (Qnative_ice, build_string ("double basic block declaration"));
+
+ Fputhash (block_name, value, comp.func_blocks_h);
+}
+
+static gcc_jit_lvalue *
+emit_mvar_lval (Lisp_Object mvar)
+{
+ Lisp_Object mvar_slot = CALL1I (comp-mvar-slot, mvar);
+
+ if (EQ (mvar_slot, Qscratch))
+ {
+ if (!comp.scratch)
+ comp.scratch = gcc_jit_function_new_local (comp.func,
+ NULL,
+ comp.lisp_obj_type,
+ "scratch");
+ return comp.scratch;
+ }
+
+ EMACS_INT slot_n = XFIXNUM (mvar_slot);
+ eassert (slot_n < comp.frame_size);
+ return comp.frame[slot_n];
+}
+
+static void
+register_emitter (Lisp_Object key, void *func)
+{
+ Lisp_Object value = make_mint_ptr (func);
+ Fputhash (key, value, comp.emitter_dispatcher);
+}
+
+static imm_reloc_t
+obj_to_reloc (Lisp_Object obj)
+{
+ imm_reloc_t reloc;
+ Lisp_Object idx;
+
+ idx = Fgethash (obj, comp.d_default_idx, Qnil);
+ if (!NILP (idx)) {
+ reloc.array = comp.data_relocs;
+ goto found;
+ }
+
+ idx = Fgethash (obj, comp.d_impure_idx, Qnil);
+ if (!NILP (idx))
+ {
+ reloc.array = comp.data_relocs_impure;
+ goto found;
+ }
+
+ idx = Fgethash (obj, comp.d_ephemeral_idx, Qnil);
+ if (!NILP (idx))
+ {
+ reloc.array = comp.data_relocs_ephemeral;
+ goto found;
+ }
+
+ xsignal1 (Qnative_ice,
+ build_string ("cant't find data in relocation containers"));
+ assume (false);
+
+ found:
+ eassert (XFIXNUM (idx) < reloc.array.len);
+ if (!FIXNUMP (idx))
+ xsignal1 (Qnative_ice,
+ build_string ("inconsistent data relocation container"));
+ reloc.idx = gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.ptrdiff_type,
+ XFIXNUM (idx));
+ return reloc;
+}
+
+static void
+emit_comment (const char *str)
+{
+ if (comp.debug)
+ gcc_jit_block_add_comment (comp.block,
+ NULL,
+ str);
+}
+
+/*
+ Declare an imported function.
+ When nargs is MANY (ptrdiff_t nargs, Lisp_Object *args) signature is assumed.
+ When types is NULL args are assumed to be all Lisp_Objects.
+*/
+static gcc_jit_field *
+declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type,
+ int nargs, gcc_jit_type **types)
+{
+ USE_SAFE_ALLOCA;
+ /* Don't want to declare the same function two times. */
+ if (!NILP (Fgethash (subr_sym, comp.imported_funcs_h, Qnil)))
+ xsignal2 (Qnative_ice,
+ build_string ("unexpected double function declaration"),
+ subr_sym);
+
+ if (nargs == MANY)
+ {
+ nargs = 2;
+ types = SAFE_ALLOCA (nargs * sizeof (* types));
+ types[0] = comp.ptrdiff_type;
+ types[1] = comp.lisp_obj_ptr_type;
+ }
+ else if (nargs == UNEVALLED)
+ {
+ nargs = 1;
+ types = SAFE_ALLOCA (nargs * sizeof (* types));
+ types[0] = comp.lisp_obj_type;
+ }
+ else if (!types)
+ {
+ types = SAFE_ALLOCA (nargs * sizeof (* types));
+ for (ptrdiff_t i = 0; i < nargs; i++)
+ types[i] = comp.lisp_obj_type;
+ }
+
+ /* String containing the function ptr name. */
+ Lisp_Object f_ptr_name =
+ CALLN (Ffuncall, intern_c_string ("comp-c-func-name"),
+ subr_sym, make_string ("R", 1));
+
+ gcc_jit_type *f_ptr_type =
+ gcc_jit_type_get_const (
+ gcc_jit_context_new_function_ptr_type (comp.ctxt,
+ NULL,
+ ret_type,
+ nargs,
+ types,
+ 0));
+ gcc_jit_field *field =
+ gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ f_ptr_type,
+ SSDATA (f_ptr_name));
+
+ Fputhash (subr_sym, make_mint_ptr (field), comp.imported_funcs_h);
+ SAFE_FREE ();
+ return field;
+}
+
+/* Emit calls fetching from existing declarations. */
+
+static gcc_jit_rvalue *
+emit_call (Lisp_Object func, gcc_jit_type *ret_type, ptrdiff_t nargs,
+ gcc_jit_rvalue **args, bool direct)
+{
+ Lisp_Object gcc_func =
+ Fgethash (func,
+ direct ? comp.exported_funcs_h : comp.imported_funcs_h,
+ Qnil);
+
+ if (NILP (gcc_func))
+ xsignal2 (Qnative_ice,
+ build_string ("missing function declaration"),
+ func);
+
+ if (direct)
+ {
+ emit_comment (format_string ("direct call to: %s",
+ SSDATA (func)));
+ return gcc_jit_context_new_call (comp.ctxt,
+ NULL,
+ xmint_pointer (gcc_func),
+ nargs,
+ args);
+ }
+ else
+ {
+ /* Inline functions so far don't have a local variable for
+ function reloc table so we fall back to the global one. Even
+ if this is not aesthetic calling into C from open-code is
+ always a fallback and therefore not be performance critical.
+ To fix this could think do the inline our-self without
+ relying on GCC. */
+ gcc_jit_lvalue *f_ptr =
+ gcc_jit_rvalue_dereference_field (
+ gcc_jit_lvalue_as_rvalue (comp.func_relocs_local
+ ? comp.func_relocs_local
+ : comp.func_relocs),
+ NULL,
+ (gcc_jit_field *) xmint_pointer (gcc_func));
+
+ if (!f_ptr)
+ xsignal2 (Qnative_ice,
+ build_string ("missing function relocation"),
+ func);
+ emit_comment (format_string ("calling subr: %s",
+ SSDATA (SYMBOL_NAME (func))));
+ return gcc_jit_context_new_call_through_ptr (comp.ctxt,
+ NULL,
+ gcc_jit_lvalue_as_rvalue
(f_ptr),
+ nargs,
+ args);
+ }
+}
+
+static gcc_jit_rvalue *
+emit_call_ref (Lisp_Object func, ptrdiff_t nargs,
+ gcc_jit_lvalue *base_arg, bool direct)
+{
+ gcc_jit_rvalue *args[] =
+ { gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.ptrdiff_type,
+ nargs),
+ gcc_jit_lvalue_get_address (base_arg, NULL) };
+ return emit_call (func, comp.lisp_obj_type, 2, args, direct);
+}
+
+/* Close current basic block emitting a conditional. */
+
+static void
+emit_cond_jump (gcc_jit_rvalue *test,
+ gcc_jit_block *then_target, gcc_jit_block *else_target)
+{
+ if (gcc_jit_rvalue_get_type (test) == comp.bool_type)
+ gcc_jit_block_end_with_conditional (comp.block,
+ NULL,
+ test,
+ then_target,
+ else_target);
+ else
+ /* In case test is not bool we do a logical negation to obtain a bool as
+ result. */
+ gcc_jit_block_end_with_conditional (
+ comp.block,
+ NULL,
+ gcc_jit_context_new_unary_op (comp.ctxt,
+ NULL,
+ GCC_JIT_UNARY_OP_LOGICAL_NEGATE,
+ comp.bool_type,
+ test),
+ else_target,
+ then_target);
+
+}
+
+static int
+type_to_cast_index (gcc_jit_type * type)
+{
+ for (int i = 0; i < NUM_CAST_TYPES; ++i)
+ if (type == comp.cast_types[i])
+ return i;
+
+ xsignal1 (Qnative_ice, build_string ("unsupported cast"));
+}
+
+static gcc_jit_rvalue *
+emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj)
+{
+ gcc_jit_type *old_type = gcc_jit_rvalue_get_type (obj);
+
+ if (new_type == old_type)
+ return obj;
+
+#ifdef LISP_OBJECT_IS_STRUCT
+ if (old_type == comp.lisp_obj_type)
+ {
+ gcc_jit_rvalue *lwordobj =
+ gcc_jit_rvalue_access_field (obj, NULL, comp.lisp_obj_i);
+ return emit_coerce (new_type, lwordobj);
+ }
+
+ if (new_type == comp.lisp_obj_type)
+ {
+ gcc_jit_rvalue *lwordobj =
+ emit_coerce (comp.lisp_word_type, obj);
+
+ static ptrdiff_t i;
+ gcc_jit_lvalue *tmp_s =
+ gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type,
+ format_string ("lisp_obj_%td", i++));
+
+ gcc_jit_block_add_assignment (
+ comp.block, NULL,
+ gcc_jit_lvalue_access_field (tmp_s, NULL,
+ comp.lisp_obj_i),
+ lwordobj);
+ return gcc_jit_lvalue_as_rvalue (tmp_s);
+ }
+#endif
+
+ int old_index = type_to_cast_index (old_type);
+ int new_index = type_to_cast_index (new_type);
+
+ if (comp.cast_type_sizes[old_index] < comp.cast_type_sizes[new_index]
+ && comp.cast_type_kind[new_index] == kind_signed)
+ xsignal3 (Qnative_ice,
+ build_string ("FIXME: sign extension not implemented"),
+ build_string (comp.cast_type_names[old_index]),
+ build_string (comp.cast_type_names[new_index]));
+
+ /* Lookup the appropriate cast function in the cast matrix. */
+ return gcc_jit_context_new_call (comp.ctxt,
+ NULL,
+ comp.cast_functions_from_to[old_index][new_index],
+ 1, &obj);
+}
+
+static gcc_jit_rvalue *
+emit_binary_op (enum gcc_jit_binary_op op,
+ gcc_jit_type *result_type,
+ gcc_jit_rvalue *a, gcc_jit_rvalue *b)
+{
+ /* FIXME Check here for possible UB. */
+ return gcc_jit_context_new_binary_op (comp.ctxt, NULL,
+ op,
+ result_type,
+ emit_coerce (result_type, a),
+ emit_coerce (result_type, b));
+}
+
+/* Should come with libgccjit. */
+
+static gcc_jit_rvalue *
+emit_rvalue_from_long_long (gcc_jit_type *type, long long n)
+{
+ emit_comment (format_string ("emit long long: %lld", n));
+
+ gcc_jit_rvalue *high =
+ gcc_jit_context_new_rvalue_from_long (comp.ctxt,
+ comp.unsigned_long_long_type,
+ (unsigned long long)n >> 32);
+ gcc_jit_rvalue *low =
+ emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT,
+ comp.unsigned_long_long_type,
+ emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT,
+ comp.unsigned_long_long_type,
+ gcc_jit_context_new_rvalue_from_long (
+ comp.ctxt,
+ comp.unsigned_long_long_type,
+ n),
+ gcc_jit_context_new_rvalue_from_int (
+ comp.ctxt,
+ comp.unsigned_long_long_type,
+ 32)),
+ gcc_jit_context_new_rvalue_from_int (
+ comp.ctxt,
+ comp.unsigned_long_long_type,
+ 32));
+
+ return
+ emit_coerce (type,
+ emit_binary_op (
+ GCC_JIT_BINARY_OP_BITWISE_OR,
+ comp.unsigned_long_long_type,
+ emit_binary_op (
+ GCC_JIT_BINARY_OP_LSHIFT,
+ comp.unsigned_long_long_type,
+ high,
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.unsigned_long_long_type,
+ 32)),
+ low));
+}
+
+static gcc_jit_rvalue *
+emit_rvalue_from_emacs_uint (EMACS_UINT val)
+{
+#ifdef WIDE_EMACS_INT
+ if (val > ULONG_MAX)
+ return emit_rvalue_from_long_long (comp.emacs_uint_type, val);
+#endif
+ return gcc_jit_context_new_rvalue_from_long (comp.ctxt,
+ comp.emacs_uint_type,
+ val);
+}
+
+static gcc_jit_rvalue *
+emit_rvalue_from_emacs_int (EMACS_INT val)
+{
+ if (val > LONG_MAX || val < LONG_MIN)
+ return emit_rvalue_from_long_long (comp.emacs_int_type, val);
+ else
+ return gcc_jit_context_new_rvalue_from_long (comp.ctxt,
+ comp.emacs_int_type, val);
+}
+
+static gcc_jit_rvalue *
+emit_rvalue_from_lisp_word_tag (Lisp_Word_tag val)
+{
+#ifdef WIDE_EMACS_INT
+ if (val > ULONG_MAX)
+ return emit_rvalue_from_long_long (comp.lisp_word_tag_type, val);
+#endif
+ return gcc_jit_context_new_rvalue_from_long (comp.ctxt,
+ comp.lisp_word_tag_type,
+ val);
+}
+
+static gcc_jit_rvalue *
+emit_rvalue_from_lisp_word (Lisp_Word val)
+{
+#if LISP_WORDS_ARE_POINTERS
+ return gcc_jit_context_new_rvalue_from_ptr (comp.ctxt,
+ comp.lisp_word_type,
+ val);
+#else
+ if (val > LONG_MAX || val < LONG_MIN)
+ return emit_rvalue_from_long_long (comp.lisp_word_type, val);
+ else
+ return gcc_jit_context_new_rvalue_from_long (comp.ctxt,
+ comp.lisp_word_type,
+ val);
+#endif
+}
+
+static gcc_jit_rvalue *
+emit_rvalue_from_lisp_obj (Lisp_Object obj)
+{
+#ifdef LISP_OBJECT_IS_STRUCT
+ return emit_coerce (comp.lisp_obj_type,
+ emit_rvalue_from_lisp_word (obj.i));
+#else
+ return emit_rvalue_from_lisp_word (obj);
+#endif
+}
+
+/*
+ Emit the equivalent of:
+ (typeof_ptr) ((uintptr) ptr + size_of_ptr_ref * i)
+*/
+
+static gcc_jit_rvalue *
+emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type,
+ int size_of_ptr_ref, gcc_jit_rvalue *i)
+{
+ emit_comment ("ptr_arithmetic");
+
+ gcc_jit_rvalue *offset =
+ emit_binary_op (
+ GCC_JIT_BINARY_OP_MULT,
+ comp.uintptr_type,
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.uintptr_type,
+ size_of_ptr_ref),
+ i);
+
+ return
+ emit_coerce (
+ ptr_type,
+ emit_binary_op (
+ GCC_JIT_BINARY_OP_PLUS,
+ comp.uintptr_type,
+ ptr,
+ offset));
+}
+
+static gcc_jit_rvalue *
+emit_XLI (gcc_jit_rvalue *obj)
+{
+ emit_comment ("XLI");
+ return emit_coerce (comp.emacs_int_type, obj);
+}
+
+static gcc_jit_rvalue *
+emit_XLP (gcc_jit_rvalue *obj)
+{
+ emit_comment ("XLP");
+
+ return emit_coerce (comp.void_ptr_type, obj);
+}
+
+static gcc_jit_rvalue *
+emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, Lisp_Word_tag
lisp_word_tag)
+{
+ /* #define XUNTAG(a, type, ctype) ((ctype *)
+ ((char *) XLP (a) - LISP_WORD_TAG (type))) */
+ emit_comment ("XUNTAG");
+
+ return emit_coerce (
+ gcc_jit_type_get_pointer (type),
+ emit_binary_op (
+ GCC_JIT_BINARY_OP_MINUS,
+ comp.uintptr_type,
+ emit_XLP (a),
+ emit_rvalue_from_lisp_word_tag (lisp_word_tag)));
+}
+
+static gcc_jit_rvalue *
+emit_XCONS (gcc_jit_rvalue *a)
+{
+ emit_comment ("XCONS");
+
+ return emit_XUNTAG (a,
+ gcc_jit_struct_as_type (comp.lisp_cons_s),
+ LISP_WORD_TAG (Lisp_Cons));
+}
+
+static gcc_jit_rvalue *
+emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
+{
+ emit_comment ("EQ");
+
+ return gcc_jit_context_new_comparison (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_COMPARISON_EQ,
+ emit_XLI (x),
+ emit_XLI (y));
+}
+
+static gcc_jit_rvalue *
+emit_TAGGEDP (gcc_jit_rvalue *obj, Lisp_Word_tag tag)
+{
+ /* (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \
+ - (unsigned) (tag)) \
+ & ((1 << GCTYPEBITS) - 1))) */
+ emit_comment ("TAGGEDP");
+
+ gcc_jit_rvalue *sh_res =
+ emit_binary_op (
+ GCC_JIT_BINARY_OP_RSHIFT,
+ comp.emacs_int_type,
+ emit_XLI (obj),
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.emacs_int_type,
+ (USE_LSB_TAG ? 0 : VALBITS)));
+
+ gcc_jit_rvalue *minus_res =
+ emit_binary_op (
+ GCC_JIT_BINARY_OP_MINUS,
+ comp.unsigned_type,
+ sh_res,
+ gcc_jit_context_new_rvalue_from_int (
+ comp.ctxt,
+ comp.unsigned_type,
+ tag));
+
+ gcc_jit_rvalue *res =
+ gcc_jit_context_new_unary_op (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_UNARY_OP_LOGICAL_NEGATE,
+ comp.int_type,
+ emit_binary_op (
+ GCC_JIT_BINARY_OP_BITWISE_AND,
+ comp.unsigned_type,
+ minus_res,
+ gcc_jit_context_new_rvalue_from_int (
+ comp.ctxt,
+ comp.unsigned_type,
+ ((1 << GCTYPEBITS) - 1))));
+
+ return res;
+}
+
+static gcc_jit_rvalue *
+emit_VECTORLIKEP (gcc_jit_rvalue *obj)
+{
+ emit_comment ("VECTORLIKEP");
+
+ return emit_TAGGEDP (obj, Lisp_Vectorlike);
+}
+
+static gcc_jit_rvalue *
+emit_CONSP (gcc_jit_rvalue *obj)
+{
+ emit_comment ("CONSP");
+
+ return emit_TAGGEDP (obj, Lisp_Cons);
+}
+
+static gcc_jit_rvalue *
+emit_FLOATP (gcc_jit_rvalue *obj)
+{
+ emit_comment ("FLOATP");
+
+ return emit_TAGGEDP (obj, Lisp_Float);
+}
+
+static gcc_jit_rvalue *
+emit_BIGNUMP (gcc_jit_rvalue *obj)
+{
+ /* PSEUDOVECTORP (x, PVEC_BIGNUM); */
+ emit_comment ("BIGNUMP");
+
+ gcc_jit_rvalue *args[] =
+ { obj,
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.int_type,
+ PVEC_BIGNUM) };
+
+ return gcc_jit_context_new_call (comp.ctxt,
+ NULL,
+ comp.pseudovectorp,
+ 2,
+ args);
+}
+
+static gcc_jit_rvalue *
+emit_FIXNUMP (gcc_jit_rvalue *obj)
+{
+ /* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS))
+ - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG))
+ & ((1 << INTTYPEBITS) - 1))) */
+ emit_comment ("FIXNUMP");
+
+ gcc_jit_rvalue *sh_res =
+ USE_LSB_TAG ? obj
+ : emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT,
+ comp.emacs_int_type,
+ emit_XLI (obj),
+ gcc_jit_context_new_rvalue_from_int (
+ comp.ctxt,
+ comp.emacs_int_type,
+ FIXNUM_BITS));
+
+ gcc_jit_rvalue *minus_res =
+ emit_binary_op (
+ GCC_JIT_BINARY_OP_MINUS,
+ comp.unsigned_type,
+ sh_res,
+ gcc_jit_context_new_rvalue_from_int (
+ comp.ctxt,
+ comp.unsigned_type,
+ (Lisp_Int0 >> !USE_LSB_TAG)));
+
+ gcc_jit_rvalue *res =
+ gcc_jit_context_new_unary_op (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_UNARY_OP_LOGICAL_NEGATE,
+ comp.int_type,
+ emit_binary_op (
+ GCC_JIT_BINARY_OP_BITWISE_AND,
+ comp.unsigned_type,
+ minus_res,
+ gcc_jit_context_new_rvalue_from_int (
+ comp.ctxt,
+ comp.unsigned_type,
+ ((1 << INTTYPEBITS) - 1))));
+
+ return res;
+}
+
+static gcc_jit_rvalue *
+emit_XFIXNUM (gcc_jit_rvalue *obj)
+{
+ emit_comment ("XFIXNUM");
+ gcc_jit_rvalue *i = emit_coerce (comp.emacs_uint_type, emit_XLI (obj));
+
+ /* FIXME: Implementation dependent (both RSHIFT are arithmetic). */
+
+ if (!USE_LSB_TAG)
+ {
+ i = emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT,
+ comp.emacs_uint_type,
+ i,
+ comp.inttypebits);
+
+ return emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT,
+ comp.emacs_int_type,
+ i,
+ comp.inttypebits);
+ }
+ else
+ return emit_coerce (comp.emacs_int_type,
+ emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT,
+ comp.emacs_int_type,
+ i,
+ comp.inttypebits));
+}
+
+static gcc_jit_rvalue *
+emit_INTEGERP (gcc_jit_rvalue *obj)
+{
+ emit_comment ("INTEGERP");
+
+ return emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR,
+ comp.bool_type,
+ emit_FIXNUMP (obj),
+ emit_BIGNUMP (obj));
+}
+
+static gcc_jit_rvalue *
+emit_NUMBERP (gcc_jit_rvalue *obj)
+{
+ emit_comment ("NUMBERP");
+
+ return emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR,
+ comp.bool_type,
+ emit_INTEGERP (obj),
+ emit_FLOATP (obj));
+}
+
+static gcc_jit_rvalue *
+emit_make_fixnum_LSB_TAG (gcc_jit_rvalue *n)
+{
+ /*
+ EMACS_UINT u = n;
+ n = u << INTTYPEBITS;
+ n += int0;
+ */
+
+ gcc_jit_rvalue *tmp =
+ emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT,
+ comp.emacs_int_type,
+ n, comp.inttypebits);
+
+ tmp = emit_binary_op (GCC_JIT_BINARY_OP_PLUS,
+ comp.emacs_int_type,
+ tmp, comp.lisp_int0);
+
+ return emit_coerce (comp.lisp_obj_type, tmp);
+}
+
+static gcc_jit_rvalue *
+emit_make_fixnum_MSB_TAG (gcc_jit_rvalue *n)
+{
+ /*
+ n &= INTMASK;
+ n += (int0 << VALBITS);
+ return XIL (n);
+ */
+
+ gcc_jit_rvalue *intmask = emit_rvalue_from_emacs_uint (INTMASK);
+
+ n = emit_binary_op (GCC_JIT_BINARY_OP_BITWISE_AND,
+ comp.emacs_uint_type,
+ intmask, n);
+
+ n =
+ emit_binary_op (GCC_JIT_BINARY_OP_PLUS,
+ comp.emacs_uint_type,
+ emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT,
+ comp.emacs_uint_type,
+ comp.lisp_int0,
+ emit_rvalue_from_emacs_uint (VALBITS)),
+ n);
+
+ return emit_coerce (comp.lisp_obj_type, n);
+}
+
+
+static gcc_jit_rvalue *
+emit_make_fixnum (gcc_jit_rvalue *obj)
+{
+ emit_comment ("make_fixnum");
+ return USE_LSB_TAG
+ ? emit_make_fixnum_LSB_TAG (obj)
+ : emit_make_fixnum_MSB_TAG (obj);
+}
+
+static gcc_jit_lvalue *
+emit_lisp_obj_reloc_lval (Lisp_Object obj)
+{
+ emit_comment (format_string ("l-value for lisp obj: %s",
+ SSDATA (Fprin1_to_string (obj, Qnil))));
+
+ imm_reloc_t reloc = obj_to_reloc (obj);
+ return gcc_jit_context_new_array_access (comp.ctxt,
+ NULL,
+ reloc.array.r_val,
+ reloc.idx);
+}
+
+static gcc_jit_rvalue *
+emit_lisp_obj_rval (Lisp_Object obj)
+{
+ emit_comment (format_string ("const lisp obj: %s",
+ SSDATA (Fprin1_to_string (obj, Qnil))));
+
+ if (EQ (obj, Qnil))
+ {
+ gcc_jit_rvalue *n;
+ n = emit_rvalue_from_lisp_word ((Lisp_Word) iQnil);
+ return emit_coerce (comp.lisp_obj_type, n);
+ }
+
+ return gcc_jit_lvalue_as_rvalue (emit_lisp_obj_reloc_lval (obj));
+}
+
+static gcc_jit_rvalue *
+emit_NILP (gcc_jit_rvalue *x)
+{
+ emit_comment ("NILP");
+ return emit_EQ (x, emit_lisp_obj_rval (Qnil));
+}
+
+static gcc_jit_rvalue *
+emit_XCAR (gcc_jit_rvalue *c)
+{
+ emit_comment ("XCAR");
+
+ /* XCONS (c)->u.s.car */
+ return
+ gcc_jit_rvalue_access_field (
+ /* XCONS (c)->u.s */
+ gcc_jit_rvalue_access_field (
+ /* XCONS (c)->u */
+ gcc_jit_lvalue_as_rvalue (
+ gcc_jit_rvalue_dereference_field (
+ emit_XCONS (c),
+ NULL,
+ comp.lisp_cons_u)),
+ NULL,
+ comp.lisp_cons_u_s),
+ NULL,
+ comp.lisp_cons_u_s_car);
+}
+
+static gcc_jit_lvalue *
+emit_lval_XCAR (gcc_jit_rvalue *c)
+{
+ emit_comment ("lval_XCAR");
+
+ /* XCONS (c)->u.s.car */
+ return
+ gcc_jit_lvalue_access_field (
+ /* XCONS (c)->u.s */
+ gcc_jit_lvalue_access_field (
+ /* XCONS (c)->u */
+ gcc_jit_rvalue_dereference_field (
+ emit_XCONS (c),
+ NULL,
+ comp.lisp_cons_u),
+ NULL,
+ comp.lisp_cons_u_s),
+ NULL,
+ comp.lisp_cons_u_s_car);
+}
+
+static gcc_jit_rvalue *
+emit_XCDR (gcc_jit_rvalue *c)
+{
+ emit_comment ("XCDR");
+ /* XCONS (c)->u.s.u.cdr */
+ return
+ gcc_jit_rvalue_access_field (
+ /* XCONS (c)->u.s.u */
+ gcc_jit_rvalue_access_field (
+ /* XCONS (c)->u.s */
+ gcc_jit_rvalue_access_field (
+ /* XCONS (c)->u */
+ gcc_jit_lvalue_as_rvalue (
+ gcc_jit_rvalue_dereference_field (
+ emit_XCONS (c),
+ NULL,
+ comp.lisp_cons_u)),
+ NULL,
+ comp.lisp_cons_u_s),
+ NULL,
+ comp.lisp_cons_u_s_u),
+ NULL,
+ comp.lisp_cons_u_s_u_cdr);
+}
+
+static gcc_jit_lvalue *
+emit_lval_XCDR (gcc_jit_rvalue *c)
+{
+ emit_comment ("lval_XCDR");
+
+ /* XCONS (c)->u.s.u.cdr */
+ return
+ gcc_jit_lvalue_access_field (
+ /* XCONS (c)->u.s.u */
+ gcc_jit_lvalue_access_field (
+ /* XCONS (c)->u.s */
+ gcc_jit_lvalue_access_field (
+ /* XCONS (c)->u */
+ gcc_jit_rvalue_dereference_field (
+ emit_XCONS (c),
+ NULL,
+ comp.lisp_cons_u),
+ NULL,
+ comp.lisp_cons_u_s),
+ NULL,
+ comp.lisp_cons_u_s_u),
+ NULL,
+ comp.lisp_cons_u_s_u_cdr);
+}
+
+static void
+emit_CHECK_CONS (gcc_jit_rvalue *x)
+{
+ emit_comment ("CHECK_CONS");
+
+ gcc_jit_rvalue *args[] =
+ { emit_CONSP (x),
+ emit_lisp_obj_rval (Qconsp),
+ x };
+
+ gcc_jit_block_add_eval (
+ comp.block,
+ NULL,
+ gcc_jit_context_new_call (comp.ctxt,
+ NULL,
+ comp.check_type,
+ 3,
+ args));
+}
+
+static gcc_jit_rvalue *
+emit_car_addr (gcc_jit_rvalue *c)
+{
+ emit_comment ("car_addr");
+
+ return gcc_jit_lvalue_get_address (emit_lval_XCAR (c), NULL);
+}
+
+static gcc_jit_rvalue *
+emit_cdr_addr (gcc_jit_rvalue *c)
+{
+ emit_comment ("cdr_addr");
+
+ return gcc_jit_lvalue_get_address (emit_lval_XCDR (c), NULL);
+}
+
+static void
+emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n)
+{
+ emit_comment ("XSETCAR");
+
+ gcc_jit_block_add_assignment (
+ comp.block,
+ NULL,
+ gcc_jit_rvalue_dereference (
+ emit_car_addr (c),
+ NULL),
+ n);
+}
+
+static void
+emit_XSETCDR (gcc_jit_rvalue *c, gcc_jit_rvalue *n)
+{
+ emit_comment ("XSETCDR");
+
+ gcc_jit_block_add_assignment (
+ comp.block,
+ NULL,
+ gcc_jit_rvalue_dereference (
+ emit_cdr_addr (c),
+ NULL),
+ n);
+}
+
+static gcc_jit_rvalue *
+emit_PURE_P (gcc_jit_rvalue *ptr)
+{
+
+ emit_comment ("PURE_P");
+
+ return
+ gcc_jit_context_new_comparison (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_COMPARISON_LE,
+ emit_binary_op (
+ GCC_JIT_BINARY_OP_MINUS,
+ comp.uintptr_type,
+ ptr,
+ comp.pure_ptr),
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.uintptr_type,
+ PURESIZE));
+}
+
+
+/*************************************/
+/* Code emitted by LIMPLE statemes. */
+/*************************************/
+
+/* Emit an r-value from an mvar meta variable.
+ In case this is a constant that was propagated return it otherwise load it
+ from frame. */
+
+static gcc_jit_rvalue *
+emit_mvar_rval (Lisp_Object mvar)
+{
+ Lisp_Object const_vld = CALL1I (comp-cstr-imm-vld-p, mvar);
+
+ if (!NILP (const_vld))
+ {
+ Lisp_Object value = CALL1I (comp-cstr-imm, mvar);
+ if (comp.debug > 1)
+ {
+ Lisp_Object func =
+ Fgethash (value,
+ CALL1I (comp-ctxt-byte-func-to-func-h, Vcomp_ctxt),
+ Qnil);
+
+ emit_comment (
+ SSDATA (
+ Fprin1_to_string (
+ NILP (func) ? value : CALL1I (comp-func-c-name, func),
+ Qnil)));
+ }
+ if (FIXNUMP (value))
+ {
+ /* We can still emit directly objects that are self-contained in a
+ word (read fixnums). */
+ return emit_rvalue_from_lisp_obj (value);
+ }
+ /* Other const objects are fetched from the reloc array. */
+ return emit_lisp_obj_rval (value);
+ }
+
+ return gcc_jit_lvalue_as_rvalue (emit_mvar_lval (mvar));
+}
+
+static void
+emit_frame_assignment (Lisp_Object dst_mvar, gcc_jit_rvalue *val)
+{
+
+ gcc_jit_block_add_assignment (
+ comp.block,
+ NULL,
+ emit_mvar_lval (dst_mvar),
+ val);
+}
+
+static gcc_jit_rvalue *
+emit_set_internal (Lisp_Object args)
+{
+ /*
+ Ex: (set_internal #s(comp-mvar nil nil t comp-test-up-val nil nil)
+ #s(comp-mvar 1 4 t nil symbol nil)).
+ */
+ /* TODO: Inline the most common case. */
+ if (list_length (args) != 3)
+ xsignal2 (Qnative_ice,
+ build_string ("unexpected arg length for insns"),
+ args);
+
+ args = XCDR (args);
+ int i = 0;
+ gcc_jit_rvalue *gcc_args[4];
+ FOR_EACH_TAIL (args)
+ gcc_args[i++] = emit_mvar_rval (XCAR (args));
+ gcc_args[2] = emit_lisp_obj_rval (Qnil);
+ gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.int_type,
+ SET_INTERNAL_SET);
+ return emit_call (intern_c_string ("set_internal"), comp.void_type , 4,
+ gcc_args, false);
+}
+
+/* This is for a regular function with arguments as m-var. */
+
+static gcc_jit_rvalue *
+emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type, bool direct)
+{
+ USE_SAFE_ALLOCA;
+ int i = 0;
+ Lisp_Object callee = FIRST (args);
+ args = XCDR (args);
+ ptrdiff_t nargs = list_length (args);
+ gcc_jit_rvalue **gcc_args = SAFE_ALLOCA (nargs * sizeof (*gcc_args));
+ FOR_EACH_TAIL (args)
+ gcc_args[i++] = emit_mvar_rval (XCAR (args));
+
+ SAFE_FREE ();
+ return emit_call (callee, ret_type, nargs, gcc_args, direct);
+}
+
+static gcc_jit_rvalue *
+emit_simple_limple_call_lisp_ret (Lisp_Object args)
+{
+ /*
+ Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) #s(comp-mvar 4 nil t nil nil)).
+ */
+ return emit_simple_limple_call (args, comp.lisp_obj_type, false);
+}
+
+static gcc_jit_rvalue *
+emit_simple_limple_call_void_ret (Lisp_Object args)
+{
+ return emit_simple_limple_call (args, comp.void_type, false);
+}
+
+/* Entry point to dispatch emitting (call fun ...). */
+
+static gcc_jit_rvalue *
+emit_limple_call (Lisp_Object insn)
+{
+ Lisp_Object callee_sym = FIRST (insn);
+ Lisp_Object emitter = Fgethash (callee_sym, comp.emitter_dispatcher, Qnil);
+
+ if (!NILP (emitter))
+ {
+ gcc_jit_rvalue * (* emitter_ptr) (Lisp_Object) = xmint_pointer (emitter);
+ return emitter_ptr (insn);
+ }
+
+ return emit_simple_limple_call_lisp_ret (insn);
+}
+
+static gcc_jit_rvalue *
+emit_limple_call_ref (Lisp_Object insn, bool direct)
+{
+ /* Ex: (funcall #s(comp-mvar 1 5 t eql symbol t)
+ #s(comp-mvar 2 6 nil nil nil t)
+ #s(comp-mvar 3 7 t 0 fixnum t)). */
+ static int i = 0;
+ Lisp_Object callee = FIRST (insn);
+ EMACS_INT nargs = XFIXNUM (Flength (CDR (insn)));
+
+ if (!nargs)
+ return emit_call_ref (callee, 0, comp.frame[0], direct);
+
+ if (comp.func_has_non_local || !comp.func_speed)
+ {
+ /* FIXME: See bug#42360. */
+ Lisp_Object first_arg = SECOND (insn);
+ EMACS_INT first_slot = XFIXNUM (CALL1I (comp-mvar-slot, first_arg));
+ return emit_call_ref (callee, nargs, comp.frame[first_slot], direct);
+ }
+
+ gcc_jit_lvalue *tmp_arr =
+ gcc_jit_function_new_local (
+ comp.func,
+ NULL,
+ gcc_jit_context_new_array_type (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ nargs),
+ format_string ("call_arr_%d", i++));
+
+ ptrdiff_t j = 0;
+ Lisp_Object arg = CDR (insn);
+ FOR_EACH_TAIL (arg)
+ {
+ gcc_jit_block_add_assignment (
+ comp.block,
+ NULL,
+ gcc_jit_context_new_array_access (
+ comp.ctxt,
+ NULL,
+ gcc_jit_lvalue_as_rvalue (tmp_arr),
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.int_type,
+ j)),
+ emit_mvar_rval (XCAR (arg)));
+ ++j;
+ }
+
+ return emit_call_ref (
+ callee,
+ nargs,
+ gcc_jit_context_new_array_access (comp.ctxt,
+ NULL,
+ gcc_jit_lvalue_as_rvalue (tmp_arr),
+ comp.zero),
+ direct);
+}
+
+static gcc_jit_rvalue *
+emit_setjmp (gcc_jit_rvalue *buf)
+{
+#ifndef WINDOWSNT
+ gcc_jit_rvalue *args[] = {buf};
+ gcc_jit_param *params[] =
+ {
+ gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "buf"),
+ };
+ /* Don't call setjmp through a function pointer (Bug#46824) */
+ gcc_jit_function *f =
+ gcc_jit_context_new_function (comp.ctxt, NULL,
+ GCC_JIT_FUNCTION_IMPORTED,
+ comp.int_type, STR (SETJMP_NAME),
+ ARRAYELTS (params), params,
+ false);
+
+ return gcc_jit_context_new_call (comp.ctxt, NULL, f, 1, args);
+#else
+ /* _setjmp (buf, __builtin_frame_address (0)) */
+ gcc_jit_param *params[] =
+ {
+ gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "buf"),
+ gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "frame"),
+ };
+ gcc_jit_rvalue *args[2];
+
+ args[0] =
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.unsigned_type, 0);
+
+ args[1] =
+ gcc_jit_context_new_call (
+ comp.ctxt,
+ NULL,
+ gcc_jit_context_get_builtin_function (comp.ctxt,
+ "__builtin_frame_address"),
+ 1, args);
+ args[0] = buf;
+ gcc_jit_function *f =
+ gcc_jit_context_new_function (comp.ctxt, NULL,
+ GCC_JIT_FUNCTION_IMPORTED,
+ comp.int_type, STR (SETJMP_NAME),
+ ARRAYELTS (params), params,
+ false);
+
+ return gcc_jit_context_new_call (comp.ctxt, NULL, f, 2, args);
+#endif
+}
+
+/* Register an handler for a non local exit. */
+
+static void
+emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue
*handler_type,
+ gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb,
+ Lisp_Object clobbered_mvar)
+{
+ /* struct handler *c = push_handler (POP, type); */
+
+ gcc_jit_rvalue *args[] = { handler, handler_type };
+ gcc_jit_block_add_assignment (
+ comp.block,
+ NULL,
+ comp.loc_handler,
+ emit_call (intern_c_string ("push_handler"),
+ comp.handler_ptr_type, 2, args, false));
+
+ args[0] =
+ gcc_jit_lvalue_get_address (
+ gcc_jit_rvalue_dereference_field (
+ gcc_jit_lvalue_as_rvalue (comp.loc_handler),
+ NULL,
+ comp.handler_jmp_field),
+ NULL);
+
+ gcc_jit_rvalue *res;
+ res = emit_setjmp (args[0]);
+ emit_cond_jump (res, handler_bb, guarded_bb);
+}
+
+static void
+emit_limple_insn (Lisp_Object insn)
+{
+ Lisp_Object op = XCAR (insn);
+ Lisp_Object args = XCDR (insn);
+ gcc_jit_rvalue *res;
+ Lisp_Object arg[6];
+
+ Lisp_Object p = XCDR (insn);
+ ptrdiff_t i = 0;
+ FOR_EACH_TAIL (p)
+ {
+ if (i == sizeof (arg) / sizeof (Lisp_Object))
+ break;
+ arg[i++] = XCAR (p);
+ }
+
+ if (EQ (op, Qjump))
+ {
+ /* Unconditional branch. */
+ gcc_jit_block *target = retrive_block (arg[0]);
+ gcc_jit_block_end_with_jump (comp.block, NULL, target);
+ }
+ else if (EQ (op, Qcond_jump))
+ {
+ /* Conditional branch. */
+ gcc_jit_rvalue *a = emit_mvar_rval (arg[0]);
+ gcc_jit_rvalue *b = emit_mvar_rval (arg[1]);
+ gcc_jit_block *target1 = retrive_block (arg[2]);
+ gcc_jit_block *target2 = retrive_block (arg[3]);
+
+ emit_cond_jump (emit_EQ (a, b), target1, target2);
+ }
+ else if (EQ (op, Qcond_jump_narg_leq))
+ {
+ /*
+ Limple: (cond-jump-narg-less 2 entry_2 entry_fallback_2)
+ C: if (nargs < 2) goto entry2_fallback; else goto entry_2;
+ */
+ gcc_jit_lvalue *nargs =
+ gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0));
+ eassert (XFIXNUM (arg[0]) < INT_MAX);
+ gcc_jit_rvalue *n =
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.ptrdiff_type,
+ XFIXNUM (arg[0]));
+ gcc_jit_block *target1 = retrive_block (arg[1]);
+ gcc_jit_block *target2 = retrive_block (arg[2]);
+ gcc_jit_rvalue *test = gcc_jit_context_new_comparison (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_COMPARISON_LE,
+ gcc_jit_lvalue_as_rvalue (nargs),
+ n);
+ emit_cond_jump (test, target1, target2);
+ }
+ else if (EQ (op, Qphi) || EQ (op, Qassume))
+ {
+ /* Nothing to do for phis or assumes in the backend. */
+ }
+ else if (EQ (op, Qpush_handler))
+ {
+ /* (push-handler condition-case #s(comp-mvar 0 3 t (arith-error) cons
nil) 1 bb_2 bb_1) */
+ int h_num UNINIT;
+ Lisp_Object handler_spec = arg[0];
+ gcc_jit_rvalue *handler = emit_mvar_rval (arg[1]);
+ if (EQ (handler_spec, Qcatcher))
+ h_num = CATCHER;
+ else if (EQ (handler_spec, Qcondition_case))
+ h_num = CONDITION_CASE;
+ else
+ xsignal2 (Qnative_ice, build_string ("incoherent insn"), insn);
+ gcc_jit_rvalue *handler_type =
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.int_type,
+ h_num);
+ gcc_jit_block *handler_bb = retrive_block (arg[2]);
+ gcc_jit_block *guarded_bb = retrive_block (arg[3]);
+ emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb,
+ arg[0]);
+ }
+ else if (EQ (op, Qpop_handler))
+ {
+ /*
+ C: current_thread->m_handlerlist =
+ current_thread->m_handlerlist->next;
+ */
+ gcc_jit_lvalue *m_handlerlist =
+ gcc_jit_rvalue_dereference_field (
+ gcc_jit_lvalue_as_rvalue (
+ gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)),
+ NULL,
+ comp.m_handlerlist);
+
+ gcc_jit_block_add_assignment (
+ comp.block,
+ NULL,
+ m_handlerlist,
+ gcc_jit_lvalue_as_rvalue (
+ gcc_jit_rvalue_dereference_field (
+ gcc_jit_lvalue_as_rvalue (m_handlerlist),
+ NULL,
+ comp.handler_next_field)));
+
+ }
+ else if (EQ (op, Qfetch_handler))
+ {
+ gcc_jit_lvalue *m_handlerlist =
+ gcc_jit_rvalue_dereference_field (
+ gcc_jit_lvalue_as_rvalue (
+ gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)),
+ NULL,
+ comp.m_handlerlist);
+ gcc_jit_block_add_assignment (comp.block,
+ NULL,
+ comp.loc_handler,
+ gcc_jit_lvalue_as_rvalue (m_handlerlist));
+
+ gcc_jit_block_add_assignment (
+ comp.block,
+ NULL,
+ m_handlerlist,
+ gcc_jit_lvalue_as_rvalue (
+ gcc_jit_rvalue_dereference_field (
+ gcc_jit_lvalue_as_rvalue (comp.loc_handler),
+ NULL,
+ comp.handler_next_field)));
+ emit_frame_assignment (
+ arg[0],
+ gcc_jit_lvalue_as_rvalue (
+ gcc_jit_rvalue_dereference_field (
+ gcc_jit_lvalue_as_rvalue (comp.loc_handler),
+ NULL,
+ comp.handler_val_field)));
+ }
+ else if (EQ (op, Qcall))
+ {
+ gcc_jit_block_add_eval (comp.block, NULL,
+ emit_limple_call (args));
+ }
+ else if (EQ (op, Qcallref))
+ {
+ gcc_jit_block_add_eval (comp.block, NULL,
+ emit_limple_call_ref (args, false));
+ }
+ else if (EQ (op, Qdirect_call))
+ {
+ gcc_jit_block_add_eval (
+ comp.block, NULL,
+ emit_simple_limple_call (XCDR (insn), comp.lisp_obj_type, true));
+ }
+ else if (EQ (op, Qdirect_callref))
+ {
+ gcc_jit_block_add_eval (comp.block, NULL,
+ emit_limple_call_ref (XCDR (insn), true));
+ }
+ else if (EQ (op, Qset))
+ {
+ Lisp_Object arg1 = arg[1];
+
+ if (EQ (Ftype_of (arg1), Qcomp_mvar))
+ res = emit_mvar_rval (arg1);
+ else if (EQ (FIRST (arg1), Qcall))
+ res = emit_limple_call (XCDR (arg1));
+ else if (EQ (FIRST (arg1), Qcallref))
+ res = emit_limple_call_ref (XCDR (arg1), false);
+ else if (EQ (FIRST (arg1), Qdirect_call))
+ res = emit_simple_limple_call (XCDR (arg1), comp.lisp_obj_type, true);
+ else if (EQ (FIRST (arg1), Qdirect_callref))
+ res = emit_limple_call_ref (XCDR (arg1), true);
+ else
+ xsignal2 (Qnative_ice,
+ build_string ("LIMPLE inconsistent arg1 for insn"),
+ insn);
+
+ if (!res)
+ xsignal1 (Qnative_ice,
+ build_string (gcc_jit_context_get_first_error (comp.ctxt)));
+
+ emit_frame_assignment (arg[0], res);
+ }
+ else if (EQ (op, Qset_par_to_local))
+ {
+ /* Ex: (set-par-to-local #s(comp-mvar 0 3 nil nil nil nil) 0). */
+ EMACS_INT param_n = XFIXNUM (arg[1]);
+ eassert (param_n < INT_MAX);
+ gcc_jit_rvalue *param =
+ gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func,
+ param_n));
+ emit_frame_assignment (arg[0], param);
+ }
+ else if (EQ (op, Qset_args_to_local))
+ {
+ /*
+ Ex: (set-args-to-local #s(comp-mvar 1 6 nil nil nil nil))
+ C: local[1] = *args;
+ */
+ gcc_jit_rvalue *gcc_args =
+ gcc_jit_lvalue_as_rvalue (
+ gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)));
+
+ gcc_jit_rvalue *res =
+ gcc_jit_lvalue_as_rvalue (gcc_jit_rvalue_dereference (gcc_args, NULL));
+
+ emit_frame_assignment (arg[0], res);
+ }
+ else if (EQ (op, Qset_rest_args_to_local))
+ {
+ /*
+ Ex: (set-rest-args-to-local #s(comp-mvar 2 9 nil nil nil nil))
+ C: local[2] = list (nargs - 2, args);
+ */
+
+ EMACS_INT slot_n = XFIXNUM (CALL1I (comp-mvar-slot, arg[0]));
+ eassert (slot_n < INT_MAX);
+ gcc_jit_rvalue *n =
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.ptrdiff_type,
+ slot_n);
+ gcc_jit_lvalue *nargs =
+ gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0));
+ gcc_jit_lvalue *args =
+ gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1));
+
+ gcc_jit_rvalue *list_args[] =
+ { emit_binary_op (GCC_JIT_BINARY_OP_MINUS,
+ comp.ptrdiff_type,
+ gcc_jit_lvalue_as_rvalue (nargs),
+ n),
+ gcc_jit_lvalue_as_rvalue (args) };
+
+ res = emit_call (Qlist, comp.lisp_obj_type, 2,
+ list_args, false);
+
+ emit_frame_assignment (arg[0], res);
+ }
+ else if (EQ (op, Qinc_args))
+ {
+ /*
+ Ex: (inc-args)
+ C: ++args;
+ */
+ gcc_jit_lvalue *args =
+ gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1));
+
+ gcc_jit_block_add_assignment (comp.block,
+ NULL,
+ args,
+ emit_ptr_arithmetic (
+ gcc_jit_lvalue_as_rvalue (args),
+ comp.lisp_obj_ptr_type,
+ sizeof (Lisp_Object),
+ comp.one));
+ }
+ else if (EQ (op, Qsetimm))
+ {
+ /* Ex: (setimm #s(comp-mvar 9 1 t 3 nil) a). */
+ emit_comment (SSDATA (Fprin1_to_string (arg[1], Qnil)));
+ imm_reloc_t reloc = obj_to_reloc (arg[1]);
+ emit_frame_assignment (
+ arg[0],
+ gcc_jit_lvalue_as_rvalue (
+ gcc_jit_context_new_array_access (comp.ctxt,
+ NULL,
+ reloc.array.r_val,
+ reloc.idx)));
+ }
+ else if (EQ (op, Qcomment))
+ {
+ /* Ex: (comment "Function: foo"). */
+ emit_comment (SSDATA (arg[0]));
+ }
+ else if (EQ (op, Qreturn))
+ {
+ gcc_jit_block_end_with_return (comp.block,
+ NULL,
+ emit_mvar_rval (arg[0]));
+ }
+ else if (EQ (op, Qunreachable))
+ {
+ /* Libgccjit has no __builtin_unreachable. */
+ gcc_jit_block_end_with_return (comp.block,
+ NULL,
+ emit_lisp_obj_rval (Qnil));
+ }
+ else
+ {
+ xsignal2 (Qnative_ice,
+ build_string ("LIMPLE op inconsistent"),
+ op);
+ }
+}
+
+
+/**************/
+/* Inliners. */
+/**************/
+
+static gcc_jit_rvalue *
+emit_call_with_type_hint (gcc_jit_function *func, Lisp_Object insn,
+ Lisp_Object type)
+{
+ bool hint_match =
+ !NILP (CALL2I (comp-mvar-type-hint-match-p, SECOND (insn), type));
+ gcc_jit_rvalue *args[] =
+ { emit_mvar_rval (SECOND (insn)),
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.bool_type,
+ hint_match) };
+
+ return gcc_jit_context_new_call (comp.ctxt, NULL, func, 2, args);
+}
+
+/* Same as before but with two args. The type hint is on the 2th. */
+static gcc_jit_rvalue *
+emit_call2_with_type_hint (gcc_jit_function *func, Lisp_Object insn,
+ Lisp_Object type)
+{
+ bool hint_match =
+ !NILP (CALL2I (comp-mvar-type-hint-match-p, SECOND (insn), type));
+ gcc_jit_rvalue *args[] =
+ { emit_mvar_rval (SECOND (insn)),
+ emit_mvar_rval (THIRD (insn)),
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.bool_type,
+ hint_match) };
+
+ return gcc_jit_context_new_call (comp.ctxt, NULL, func, 3, args);
+}
+
+
+static gcc_jit_rvalue *
+emit_add1 (Lisp_Object insn)
+{
+ return emit_call_with_type_hint (comp.add1, insn, Qfixnum);
+}
+
+static gcc_jit_rvalue *
+emit_sub1 (Lisp_Object insn)
+{
+ return emit_call_with_type_hint (comp.sub1, insn, Qfixnum);
+}
+
+static gcc_jit_rvalue *
+emit_negate (Lisp_Object insn)
+{
+ return emit_call_with_type_hint (comp.negate, insn, Qfixnum);
+}
+
+static gcc_jit_rvalue *
+emit_consp (Lisp_Object insn)
+{
+ gcc_jit_rvalue *x = emit_mvar_rval (SECOND (insn));
+ gcc_jit_rvalue *res = emit_coerce (comp.bool_type,
+ emit_CONSP (x));
+ return gcc_jit_context_new_call (comp.ctxt,
+ NULL,
+ comp.bool_to_lisp_obj,
+ 1, &res);
+}
+
+static gcc_jit_rvalue *
+emit_car (Lisp_Object insn)
+{
+ return emit_call_with_type_hint (comp.car, insn, Qcons);
+}
+
+static gcc_jit_rvalue *
+emit_cdr (Lisp_Object insn)
+{
+ return emit_call_with_type_hint (comp.cdr, insn, Qcons);
+}
+
+static gcc_jit_rvalue *
+emit_setcar (Lisp_Object insn)
+{
+ return emit_call2_with_type_hint (comp.setcar, insn, Qcons);
+}
+
+static gcc_jit_rvalue *
+emit_setcdr (Lisp_Object insn)
+{
+ return emit_call2_with_type_hint (comp.setcdr, insn, Qcons);
+}
+
+static gcc_jit_rvalue *
+emit_numperp (Lisp_Object insn)
+{
+ gcc_jit_rvalue *x = emit_mvar_rval (SECOND (insn));
+ gcc_jit_rvalue *res = emit_NUMBERP (x);
+ return gcc_jit_context_new_call (comp.ctxt, NULL, comp.bool_to_lisp_obj, 1,
+ &res);
+}
+
+static gcc_jit_rvalue *
+emit_integerp (Lisp_Object insn)
+{
+ gcc_jit_rvalue *x = emit_mvar_rval (SECOND (insn));
+ gcc_jit_rvalue *res = emit_INTEGERP (x);
+ return gcc_jit_context_new_call (comp.ctxt, NULL, comp.bool_to_lisp_obj, 1,
+ &res);
+}
+
+static gcc_jit_rvalue *
+emit_maybe_gc_or_quit (Lisp_Object insn)
+{
+ return gcc_jit_context_new_call (comp.ctxt, NULL, comp.maybe_gc_or_quit, 0,
+ NULL);
+}
+
+/* This is in charge of serializing an object and export a function to
+ retrieve it at load time. */
+#pragma GCC diagnostic ignored "-Waddress"
+static void
+emit_static_object (const char *name, Lisp_Object obj)
+{
+ /* libgccjit has no support for initialized static data.
+ The mechanism below is certainly not aesthetic but I assume the bottle
neck
+ in terms of performance at load time will still be the reader.
+ NOTE: we can not rely on libgccjit even for valid NULL terminated C
+ strings cause of this funny bug that will affect all pre gcc10 era gccs:
+ https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html */
+
+ ptrdiff_t count = SPECPDL_INDEX ();
+ /* Preserve uninterned symbols, this is specifically necessary for
+ CL macro expansion in dynamic scope code (bug#42088). See
+ `byte-compile-output-file-form'. */
+ specbind (intern_c_string ("print-escape-newlines"), Qt);
+ specbind (intern_c_string ("print-length"), Qnil);
+ specbind (intern_c_string ("print-level"), Qnil);
+ specbind (intern_c_string ("print-quoted"), Qt);
+ specbind (intern_c_string ("print-gensym"), Qt);
+ specbind (intern_c_string ("print-circle"), Qt);
+ Lisp_Object str = Fprin1_to_string (obj, Qnil);
+ unbind_to (count, Qnil);
+
+ ptrdiff_t len = SBYTES (str);
+ const char *p = SSDATA (str);
+
+#if defined (LIBGCCJIT_HAVE_gcc_jit_global_set_initializer) \
+ || defined (WINDOWSNT)
+ if (gcc_jit_global_set_initializer)
+ {
+ ptrdiff_t str_size = len + 1;
+ ptrdiff_t size = sizeof (static_obj_t) + str_size;
+ static_obj_t *static_obj = xmalloc (size);
+ static_obj->len = str_size;
+ memcpy (static_obj->data, p, str_size);
+ gcc_jit_lvalue *blob =
+ gcc_jit_context_new_global (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_GLOBAL_EXPORTED,
+ gcc_jit_context_new_array_type (comp.ctxt, NULL,
+ comp.char_type,
+ size),
+ format_string ("%s_blob", name));
+ gcc_jit_global_set_initializer (blob, static_obj, size);
+ xfree (static_obj);
+
+ return;
+ }
+#endif
+
+ gcc_jit_type *a_type =
+ gcc_jit_context_new_array_type (comp.ctxt,
+ NULL,
+ comp.char_type,
+ len + 1);
+ gcc_jit_field *fields[] =
+ { gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ comp.ptrdiff_type,
+ "len"),
+ gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ a_type,
+ "data") };
+
+ gcc_jit_type *data_struct_t =
+ gcc_jit_struct_as_type (
+ gcc_jit_context_new_struct_type (comp.ctxt,
+ NULL,
+ format_string ("%s_struct", name),
+ ARRAYELTS (fields), fields));
+
+ gcc_jit_lvalue *data_struct =
+ gcc_jit_context_new_global (comp.ctxt,
+ NULL,
+ GCC_JIT_GLOBAL_INTERNAL,
+ data_struct_t,
+ format_string ("%s_s", name));
+
+ gcc_jit_function *f =
+ gcc_jit_context_new_function (comp.ctxt, NULL,
+ GCC_JIT_FUNCTION_EXPORTED,
+ gcc_jit_type_get_pointer (data_struct_t),
+ name,
+ 0, NULL, 0);
+ DECL_BLOCK (block, f);
+
+ if (comp.debug > 1)
+ {
+ char *comment = memcpy (xmalloc (len), p, len);
+ for (ptrdiff_t i = 0; i < len - 1; i++)
+ if (!comment[i])
+ comment[i] = '\n';
+ gcc_jit_block_add_comment (block, NULL, comment);
+ xfree (comment);
+ }
+
+ gcc_jit_lvalue *arr =
+ gcc_jit_lvalue_access_field (data_struct, NULL, fields[1]);
+
+ gcc_jit_lvalue *ptrvar = gcc_jit_function_new_local (f, NULL,
+ comp.char_ptr_type,
+ "ptr");
+
+ gcc_jit_block_add_assignment (
+ block,
+ NULL,
+ ptrvar,
+ gcc_jit_lvalue_get_address (
+ gcc_jit_context_new_array_access (
+ comp.ctxt,
+ NULL,
+ gcc_jit_lvalue_as_rvalue (arr),
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, 0)),
+ NULL));
+
+ /* We can't use always string literals longer that 200 bytes because
+ they cause a crash in pre GCC 10 libgccjit.
+ <https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html>.
+
+ Adjust if possible to reduce the number of function calls. */
+ size_t chunck_size = NILP (Fcomp_libgccjit_version ()) ? 200 : 1024;
+ char *buff = xmalloc (chunck_size);
+ for (ptrdiff_t i = 0; i < len;)
+ {
+ strncpy (buff, p, chunck_size);
+ buff[chunck_size - 1] = 0;
+ uintptr_t l = strlen (buff);
+
+ if (l != 0)
+ {
+ p += l;
+ i += l;
+
+ gcc_jit_rvalue *args[] =
+ { gcc_jit_lvalue_as_rvalue (ptrvar),
+ gcc_jit_context_new_string_literal (comp.ctxt, buff),
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.size_t_type,
+ l) };
+
+ gcc_jit_block_add_eval (block, NULL,
+ gcc_jit_context_new_call (comp.ctxt, NULL,
+ comp.memcpy,
+ ARRAYELTS (args),
+ args));
+ gcc_jit_block_add_assignment (block, NULL, ptrvar,
+ gcc_jit_lvalue_get_address (
+ gcc_jit_context_new_array_access (comp.ctxt, NULL,
+ gcc_jit_lvalue_as_rvalue (ptrvar),
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.uintptr_type,
+ l)),
+ NULL));
+ }
+ else
+ {
+ /* If strlen returned 0 that means that the static object
+ contains a NULL byte. In that case just move over to the
+ next block. We can rely on the byte being zero because
+ of the previous call to bzero and because the dynamic
+ linker cleared it. */
+ p++;
+ i++;
+ gcc_jit_block_add_assignment (
+ block, NULL, ptrvar,
+ gcc_jit_lvalue_get_address (
+ gcc_jit_context_new_array_access (
+ comp.ctxt, NULL, gcc_jit_lvalue_as_rvalue (ptrvar),
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.uintptr_type, 1)),
+ NULL));
+ }
+ }
+ xfree (buff);
+
+ gcc_jit_block_add_assignment (
+ block,
+ NULL,
+ gcc_jit_lvalue_access_field (data_struct, NULL, fields[0]),
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.ptrdiff_type,
+ len));
+ gcc_jit_rvalue *res = gcc_jit_lvalue_get_address (data_struct, NULL);
+ gcc_jit_block_end_with_return (block, NULL, res);
+}
+#pragma GCC diagnostic pop
+
+static reloc_array_t
+declare_imported_data_relocs (Lisp_Object container, const char *code_symbol,
+ const char *text_symbol)
+{
+ /* Imported objects. */
+ reloc_array_t res;
+ res.len =
+ XFIXNUM (CALL1I (hash-table-count,
+ CALL1I (comp-data-container-idx, container)));
+ Lisp_Object d_reloc = CALL1I (comp-data-container-l, container);
+ d_reloc = Fvconcat (1, &d_reloc);
+
+ res.r_val =
+ gcc_jit_lvalue_as_rvalue (
+ gcc_jit_context_new_global (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_GLOBAL_EXPORTED,
+ gcc_jit_context_new_array_type (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ res.len),
+ code_symbol));
+
+ emit_static_object (text_symbol, d_reloc);
+
+ return res;
+}
+
+static void
+declare_imported_data (void)
+{
+ /* Imported objects. */
+ comp.data_relocs =
+ declare_imported_data_relocs (CALL1I (comp-ctxt-d-default, Vcomp_ctxt),
+ DATA_RELOC_SYM,
+ TEXT_DATA_RELOC_SYM);
+ comp.data_relocs_impure =
+ declare_imported_data_relocs (CALL1I (comp-ctxt-d-impure, Vcomp_ctxt),
+ DATA_RELOC_IMPURE_SYM,
+ TEXT_DATA_RELOC_IMPURE_SYM);
+ comp.data_relocs_ephemeral =
+ declare_imported_data_relocs (CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt),
+ DATA_RELOC_EPHEMERAL_SYM,
+ TEXT_DATA_RELOC_EPHEMERAL_SYM);
+}
+
+/*
+ Declare as imported all the functions that are requested from the runtime.
+ These are either subrs or not.
+*/
+static Lisp_Object
+declare_runtime_imported_funcs (void)
+{
+ Lisp_Object field_list = Qnil;
+
+#define ADD_IMPORTED(f_name, ret_type, nargs, args) \
+ { \
+ Lisp_Object name = intern_c_string (STR (f_name)); \
+ Lisp_Object field =
\
+ make_mint_ptr (declare_imported_func (name, ret_type, nargs, args));
\
+ Lisp_Object el = Fcons (name, field); \
+ field_list = Fcons (el, field_list); \
+ } while (0)
+
+ gcc_jit_type *args[4];
+
+ ADD_IMPORTED (wrong_type_argument, comp.void_type, 2, NULL);
+
+ args[0] = comp.lisp_obj_type;
+ args[1] = comp.int_type;
+ ADD_IMPORTED (helper_PSEUDOVECTOR_TYPEP_XUNTAG, comp.bool_type, 2, args);
+
+ ADD_IMPORTED (pure_write_error, comp.void_type, 1, NULL);
+
+ args[0] = comp.lisp_obj_type;
+ args[1] = comp.int_type;
+ ADD_IMPORTED (push_handler, comp.handler_ptr_type, 2, args);
+
+ ADD_IMPORTED (record_unwind_protect_excursion, comp.void_type, 0, NULL);
+
+ args[0] = comp.lisp_obj_type;
+ ADD_IMPORTED (helper_unbind_n, comp.lisp_obj_type, 1, args);
+
+ ADD_IMPORTED (helper_save_restriction, comp.void_type, 0, NULL);
+
+ ADD_IMPORTED (record_unwind_current_buffer, comp.void_type, 0, NULL);
+
+ args[0] = args[1] = args[2] = comp.lisp_obj_type;
+ args[3] = comp.int_type;
+ ADD_IMPORTED (set_internal, comp.void_type, 4, args);
+
+ args[0] = comp.lisp_obj_type;
+ ADD_IMPORTED (helper_unwind_protect, comp.void_type, 1, args);
+
+ args[0] = args[1] = comp.lisp_obj_type;
+ ADD_IMPORTED (specbind, comp.void_type, 2, args);
+
+ ADD_IMPORTED (maybe_gc, comp.void_type, 0, NULL);
+
+ ADD_IMPORTED (maybe_quit, comp.void_type, 0, NULL);
+
+#undef ADD_IMPORTED
+
+ return Freverse (field_list);
+}
+
+/*
+ This emit the code needed by every compilation unit to be loaded.
+*/
+static void
+emit_ctxt_code (void)
+{
+ /* Emit optimize qualities. */
+ Lisp_Object opt_qly[] =
+ { Fcons (Qcomp_speed, make_fixnum (comp.speed)),
+ Fcons (Qcomp_debug, make_fixnum (comp.debug)),
+ Fcons (Qgccjit,
+ Fcomp_libgccjit_version ()) };
+ emit_static_object (TEXT_OPTIM_QLY_SYM, Flist (ARRAYELTS (opt_qly),
opt_qly));
+
+ emit_static_object (TEXT_FDOC_SYM,
+ CALL1I (comp-ctxt-function-docs, Vcomp_ctxt));
+
+ comp.current_thread_ref =
+ gcc_jit_lvalue_as_rvalue (
+ gcc_jit_context_new_global (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_GLOBAL_EXPORTED,
+ gcc_jit_type_get_pointer (comp.thread_state_ptr_type),
+ CURRENT_THREAD_RELOC_SYM));
+
+ comp.pure_ptr =
+ gcc_jit_lvalue_as_rvalue (
+ gcc_jit_context_new_global (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_GLOBAL_EXPORTED,
+ comp.void_ptr_type,
+ PURE_RELOC_SYM));
+
+ gcc_jit_context_new_global (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_GLOBAL_EXPORTED,
+ comp.lisp_obj_type,
+ COMP_UNIT_SYM);
+
+ declare_imported_data ();
+
+ /* Functions imported from Lisp code. */
+ freloc_check_fill ();
+ gcc_jit_field **fields = xmalloc (freloc.size * sizeof (*fields));
+ ptrdiff_t n_frelocs = 0;
+ Lisp_Object f_runtime = declare_runtime_imported_funcs ();
+ FOR_EACH_TAIL (f_runtime)
+ {
+ Lisp_Object el = XCAR (f_runtime);
+ eassert (n_frelocs < freloc.size);
+ fields[n_frelocs++] = xmint_pointer (XCDR (el));
+ }
+
+ /* Sign the .eln for the exposed ABI it expects at load. */
+ eassert (!NILP (Vcomp_abi_hash));
+ emit_static_object (LINK_TABLE_HASH_SYM, Vcomp_abi_hash);
+
+ Lisp_Object subr_l = Vcomp_subr_list;
+ FOR_EACH_TAIL (subr_l)
+ {
+ struct Lisp_Subr *subr = XSUBR (XCAR (subr_l));
+ Lisp_Object subr_sym = intern_c_string (subr->symbol_name);
+ eassert (n_frelocs < freloc.size);
+ fields[n_frelocs++] = declare_imported_func (subr_sym,
comp.lisp_obj_type,
+ subr->max_args, NULL);
+ }
+
+ gcc_jit_struct *f_reloc_struct =
+ gcc_jit_context_new_struct_type (comp.ctxt,
+ NULL,
+ "freloc_link_table",
+ n_frelocs, fields);
+ comp.func_relocs_ptr_type =
+ gcc_jit_type_get_pointer (
+ gcc_jit_struct_as_type (f_reloc_struct));
+
+ comp.func_relocs =
+ gcc_jit_context_new_global (comp.ctxt,
+ NULL,
+ GCC_JIT_GLOBAL_EXPORTED,
+ comp.func_relocs_ptr_type,
+ FUNC_LINK_TABLE_SYM);
+
+ xfree (fields);
+}
+
+
+/****************************************************************/
+/* Inline function definition and lisp data structure follows. */
+/****************************************************************/
+
+/* struct Lisp_Cons definition. */
+
+static void
+define_lisp_cons (void)
+{
+ /*
+ union cdr_u
+ {
+ Lisp_Object cdr;
+ struct Lisp_Cons *chain;
+ };
+
+ struct cons_s
+ {
+ Lisp_Object car;
+ union cdr_u u;
+ };
+
+ union cons_u
+ {
+ struct cons_s s;
+ char align_pad[sizeof (struct Lisp_Cons)];
+ };
+
+ struct Lisp_Cons
+ {
+ union cons_u u;
+ };
+ */
+
+ comp.lisp_cons_s =
+ gcc_jit_context_new_opaque_struct (comp.ctxt,
+ NULL,
+ "comp_Lisp_Cons");
+ comp.lisp_cons_type =
+ gcc_jit_struct_as_type (comp.lisp_cons_s);
+ comp.lisp_cons_ptr_type =
+ gcc_jit_type_get_pointer (comp.lisp_cons_type);
+
+ comp.lisp_cons_u_s_u_cdr =
+ gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ "cdr");
+
+ gcc_jit_field *cdr_u_fields[] =
+ { comp.lisp_cons_u_s_u_cdr,
+ gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ comp.lisp_cons_ptr_type,
+ "chain") };
+
+ gcc_jit_type *cdr_u =
+ gcc_jit_context_new_union_type (comp.ctxt,
+ NULL,
+ "comp_cdr_u",
+ ARRAYELTS (cdr_u_fields),
+ cdr_u_fields);
+
+ comp.lisp_cons_u_s_car = gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ "car");
+ comp.lisp_cons_u_s_u = gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ cdr_u,
+ "u");
+ gcc_jit_field *cons_s_fields[] =
+ { comp.lisp_cons_u_s_car,
+ comp.lisp_cons_u_s_u };
+
+ gcc_jit_struct *cons_s =
+ gcc_jit_context_new_struct_type (comp.ctxt,
+ NULL,
+ "comp_cons_s",
+ ARRAYELTS (cons_s_fields),
+ cons_s_fields);
+
+ comp.lisp_cons_u_s = gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ gcc_jit_struct_as_type (cons_s),
+ "s");
+
+ gcc_jit_field *cons_u_fields[] =
+ { comp.lisp_cons_u_s,
+ gcc_jit_context_new_field (
+ comp.ctxt,
+ NULL,
+ gcc_jit_context_new_array_type (comp.ctxt,
+ NULL,
+ comp.char_type,
+ sizeof (struct Lisp_Cons)),
+ "align_pad") };
+
+ gcc_jit_type *lisp_cons_u_type =
+ gcc_jit_context_new_union_type (comp.ctxt,
+ NULL,
+ "comp_cons_u",
+ ARRAYELTS (cons_u_fields),
+ cons_u_fields);
+
+ comp.lisp_cons_u =
+ gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ lisp_cons_u_type,
+ "u");
+ gcc_jit_struct_set_fields (comp.lisp_cons_s,
+ NULL, 1, &comp.lisp_cons_u);
+
+}
+
+/* Opaque jmp_buf definition. */
+
+static void
+define_jmp_buf (void)
+{
+ gcc_jit_field *field =
+ gcc_jit_context_new_field (
+ comp.ctxt,
+ NULL,
+ gcc_jit_context_new_array_type (comp.ctxt,
+ NULL,
+ comp.char_type,
+ sizeof (sys_jmp_buf)),
+ "stuff");
+ comp.jmp_buf_s =
+ gcc_jit_context_new_struct_type (comp.ctxt,
+ NULL,
+ "comp_jmp_buf",
+ 1, &field);
+}
+
+static void
+define_memcpy (void)
+{
+
+ gcc_jit_param *params[] =
+ { gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "dest"),
+ gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "src"),
+ gcc_jit_context_new_param (comp.ctxt, NULL, comp.size_t_type, "n") };
+
+ comp.memcpy =
+ gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_IMPORTED,
+ comp.void_ptr_type, "memcpy",
+ ARRAYELTS (params), params, false);
+}
+
+/* struct handler definition */
+
+static void
+define_handler_struct (void)
+{
+ comp.handler_s =
+ gcc_jit_context_new_opaque_struct (comp.ctxt, NULL, "comp_handler");
+ comp.handler_ptr_type =
+ gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.handler_s));
+
+ comp.handler_jmp_field = gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ gcc_jit_struct_as_type (
+ comp.jmp_buf_s),
+ "jmp");
+ comp.handler_val_field = gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ "val");
+ comp.handler_next_field = gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ comp.handler_ptr_type,
+ "next");
+ gcc_jit_field *fields[] =
+ { gcc_jit_context_new_field (
+ comp.ctxt,
+ NULL,
+ gcc_jit_context_new_array_type (comp.ctxt,
+ NULL,
+ comp.char_type,
+ offsetof (struct handler, val)),
+ "pad0"),
+ comp.handler_val_field,
+ comp.handler_next_field,
+ gcc_jit_context_new_field (
+ comp.ctxt,
+ NULL,
+ gcc_jit_context_new_array_type (comp.ctxt,
+ NULL,
+ comp.char_type,
+ offsetof (struct handler, jmp)
+ - offsetof (struct handler, next)
+ - sizeof (((struct handler *)
0)->next)),
+ "pad1"),
+ comp.handler_jmp_field,
+ gcc_jit_context_new_field (
+ comp.ctxt,
+ NULL,
+ gcc_jit_context_new_array_type (comp.ctxt,
+ NULL,
+ comp.char_type,
+ sizeof (struct handler)
+ - offsetof (struct handler, jmp)
+ - sizeof (((struct handler *) 0)->jmp)),
+ "pad2") };
+ gcc_jit_struct_set_fields (comp.handler_s,
+ NULL,
+ ARRAYELTS (fields),
+ fields);
+
+}
+
+static void
+define_thread_state_struct (void)
+{
+ /* Partially opaque definition for `thread_state'.
+ Because we need to access just m_handlerlist hopefully this is requires
+ less manutention then the full deifnition. */
+
+ comp.m_handlerlist = gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ comp.handler_ptr_type,
+ "m_handlerlist");
+ gcc_jit_field *fields[] =
+ { gcc_jit_context_new_field (
+ comp.ctxt,
+ NULL,
+ gcc_jit_context_new_array_type (comp.ctxt,
+ NULL,
+ comp.char_type,
+ offsetof (struct thread_state,
+ m_handlerlist)),
+ "pad0"),
+ comp.m_handlerlist,
+ gcc_jit_context_new_field (
+ comp.ctxt,
+ NULL,
+ gcc_jit_context_new_array_type (
+ comp.ctxt,
+ NULL,
+ comp.char_type,
+ sizeof (struct thread_state)
+ - offsetof (struct thread_state,
+ m_handlerlist)
+ - sizeof (((struct thread_state *) 0)->m_handlerlist)),
+ "pad1") };
+
+ comp.thread_state_s =
+ gcc_jit_context_new_struct_type (comp.ctxt,
+ NULL,
+ "comp_thread_state",
+ ARRAYELTS (fields),
+ fields);
+ comp.thread_state_ptr_type =
+ gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.thread_state_s));
+}
+
+struct cast_type
+{
+ gcc_jit_type *type;
+ const char *name;
+ size_t bytes_size;
+ enum cast_kind_of_type kind;
+};
+
+static gcc_jit_function *
+define_cast_from_to (struct cast_type from, int from_index, struct cast_type
to,
+ int to_index)
+{
+ /* FIXME: sign extension not implemented. */
+ if (comp.cast_type_sizes[from_index] < comp.cast_type_sizes[to_index]
+ && comp.cast_type_kind[to_index] == kind_signed)
+ return NULL;
+
+ char *name = format_string ("cast_from_%s_to_%s", from.name, to.name);
+ gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, NULL,
+ from.type, "arg");
+ gcc_jit_function *result = gcc_jit_context_new_function (comp.ctxt,
+ NULL,
+ GCC_JIT_FUNCTION_INTERNAL,
+ to.type,
+ name,
+ 1,
+ ¶m,
+ 0);
+
+ DECL_BLOCK (entry_block, result);
+
+ gcc_jit_lvalue *tmp_union
+ = gcc_jit_function_new_local (result,
+ NULL,
+ comp.cast_union_type,
+ "union_cast");
+
+ /* Zero the union first. */
+ gcc_jit_block_add_assignment (entry_block, NULL,
+ gcc_jit_lvalue_access_field (tmp_union, NULL,
+ comp.cast_union_fields[NUM_CAST_TYPES]),
+ gcc_jit_context_new_rvalue_from_int (
+ comp.ctxt,
+ comp.cast_types[NUM_CAST_TYPES],
+ 0));
+
+ gcc_jit_block_add_assignment (entry_block, NULL,
+ gcc_jit_lvalue_access_field (tmp_union, NULL,
+ comp.cast_union_fields[from_index]),
+ gcc_jit_param_as_rvalue (param));
+
+ gcc_jit_block_end_with_return (entry_block,
+ NULL,
+ gcc_jit_rvalue_access_field (
+ gcc_jit_lvalue_as_rvalue (tmp_union),
+ NULL,
+ comp.cast_union_fields[to_index]));
+
+ return result;
+}
+
+static void
+define_cast_functions (void)
+{
+ struct cast_type cast_types[NUM_CAST_TYPES]
+ = { { comp.bool_type, "bool", sizeof (bool), kind_unsigned },
+ { comp.char_ptr_type, "char_ptr", sizeof (char *), kind_pointer },
+ { comp.int_type, "int", sizeof (int), kind_signed },
+ { comp.lisp_cons_ptr_type, "cons_ptr", sizeof (struct Lisp_Cons *),
+ kind_pointer },
+ { comp.lisp_obj_ptr_type, "lisp_obj_ptr", sizeof (Lisp_Object *),
+ kind_pointer },
+ { comp.lisp_word_tag_type, "lisp_word_tag", sizeof (Lisp_Word_tag),
+ kind_unsigned },
+ { comp.lisp_word_type, "lisp_word", sizeof (Lisp_Word),
+ LISP_WORDS_ARE_POINTERS ? kind_pointer : kind_signed },
+ { comp.long_long_type, "long_long", sizeof (long long), kind_signed },
+ { comp.long_type, "long", sizeof (long), kind_signed },
+ { comp.ptrdiff_type, "ptrdiff", sizeof (ptrdiff_t), kind_signed },
+ { comp.uintptr_type, "uintptr", sizeof (uintptr_t), kind_unsigned },
+ { comp.unsigned_long_long_type, "unsigned_long_long",
+ sizeof (unsigned long long), kind_unsigned },
+ { comp.unsigned_long_type, "unsigned_long", sizeof (unsigned long),
+ kind_unsigned },
+ { comp.unsigned_type, "unsigned", sizeof (unsigned), kind_unsigned },
+ { comp.void_ptr_type, "void_ptr", sizeof (void*), kind_pointer } };
+
+ /* Find the biggest size. It should be unsigned long long, but to be
+ sure we find it programmatically. */
+ size_t biggest_size = 0;
+ for (int i = 0; i < NUM_CAST_TYPES; ++i)
+ biggest_size = max (biggest_size, cast_types[i].bytes_size);
+
+ /* Define the union used for casting. */
+ for (int i = 0; i < NUM_CAST_TYPES; ++i)
+ {
+ comp.cast_types[i] = cast_types[i].type;
+ comp.cast_union_fields[i] = gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ cast_types[i].type,
+ cast_types[i].name);
+ comp.cast_type_names[i] = cast_types[i].name;
+ comp.cast_type_sizes[i] = cast_types[i].bytes_size;
+ comp.cast_type_kind[i] = cast_types[i].kind;
+ }
+
+ gcc_jit_type *biggest_type = gcc_jit_context_get_int_type (comp.ctxt,
+ biggest_size,
+ false);
+ comp.cast_types[NUM_CAST_TYPES] = biggest_type;
+ comp.cast_union_fields[NUM_CAST_TYPES] =
+ gcc_jit_context_new_field (comp.ctxt, NULL, biggest_type, "biggest_type");
+ comp.cast_type_names[NUM_CAST_TYPES] = "biggest_type";
+ comp.cast_type_sizes[NUM_CAST_TYPES] = biggest_size;
+ comp.cast_type_kind[NUM_CAST_TYPES] = kind_unsigned;
+
+ comp.cast_union_type =
+ gcc_jit_context_new_union_type (comp.ctxt,
+ NULL,
+ "cast_union",
+ NUM_CAST_TYPES + 1,
+ comp.cast_union_fields);
+
+ /* Define the cast functions using a matrix. */
+ for (int i = 0; i < NUM_CAST_TYPES; ++i)
+ for (int j = 0; j < NUM_CAST_TYPES; ++j)
+ comp.cast_functions_from_to[i][j] =
+ define_cast_from_to (cast_types[i], i, cast_types[j], j);
+}
+
+static void
+define_CHECK_TYPE (void)
+{
+ gcc_jit_param *param[] =
+ { gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.int_type,
+ "ok"),
+ gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ "predicate"),
+ gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ "x") };
+ comp.check_type =
+ gcc_jit_context_new_function (comp.ctxt, NULL,
+ GCC_JIT_FUNCTION_INTERNAL,
+ comp.void_type,
+ "CHECK_TYPE",
+ 3,
+ param,
+ 0);
+ gcc_jit_rvalue *ok = gcc_jit_param_as_rvalue (param[0]);
+ gcc_jit_rvalue *predicate = gcc_jit_param_as_rvalue (param[1]);
+ gcc_jit_rvalue *x = gcc_jit_param_as_rvalue (param[2]);
+
+ DECL_BLOCK (entry_block, comp.check_type);
+ DECL_BLOCK (ok_block, comp.check_type);
+ DECL_BLOCK (not_ok_block, comp.check_type);
+
+ comp.block = entry_block;
+ comp.func = comp.check_type;
+
+ emit_cond_jump (ok, ok_block, not_ok_block);
+
+ gcc_jit_block_end_with_void_return (ok_block, NULL);
+
+ comp.block = not_ok_block;
+
+ gcc_jit_rvalue *wrong_type_args[] = { predicate, x };
+
+ gcc_jit_block_add_eval (comp.block,
+ NULL,
+ emit_call (intern_c_string ("wrong_type_argument"),
+ comp.void_type, 2, wrong_type_args,
+ false));
+
+ gcc_jit_block_end_with_void_return (not_ok_block, NULL);
+}
+
+/* Define a substitute for CAR as always inlined function. */
+
+static void
+define_CAR_CDR (void)
+{
+ gcc_jit_function *func[2];
+ char const *f_name[] = { "CAR", "CDR" };
+ for (int i = 0; i < 2; i++)
+ {
+ gcc_jit_param *param[] =
+ { gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ "c"),
+ gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.bool_type,
+ "cert_cons") };
+ /* TODO: understand why after ipa-prop pass gcc is less keen on inlining
+ and as consequence can refuse to compile these. (see dhrystone.el)
+ Flag this and all the one involved in ipa-prop as
+ GCC_JIT_FUNCTION_INTERNAL not to fail compilation in case.
+ This seems at least to have no perf downside. */
+ func[i] =
+ gcc_jit_context_new_function (comp.ctxt, NULL,
+ GCC_JIT_FUNCTION_INTERNAL,
+ comp.lisp_obj_type,
+ f_name[i],
+ 2, param, 0);
+
+ gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param[0]);
+ DECL_BLOCK (entry_block, func[i]);
+ DECL_BLOCK (is_cons_b, func[i]);
+ DECL_BLOCK (not_a_cons_b, func[i]);
+ comp.block = entry_block;
+ comp.func = func[i];
+ emit_cond_jump (emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR,
+ comp.bool_type,
+ gcc_jit_param_as_rvalue (param[1]),
+ emit_CONSP (c)),
+ is_cons_b,
+ not_a_cons_b);
+ comp.block = is_cons_b;
+ if (i == 0)
+ gcc_jit_block_end_with_return (comp.block, NULL, emit_XCAR (c));
+ else
+ gcc_jit_block_end_with_return (comp.block, NULL, emit_XCDR (c));
+
+ comp.block = not_a_cons_b;
+
+ DECL_BLOCK (is_nil_b, func[i]);
+ DECL_BLOCK (not_nil_b, func[i]);
+
+ emit_cond_jump (emit_NILP (c), is_nil_b, not_nil_b);
+
+ comp.block = is_nil_b;
+ gcc_jit_block_end_with_return (comp.block,
+ NULL,
+ emit_lisp_obj_rval (Qnil));
+
+ comp.block = not_nil_b;
+ gcc_jit_rvalue *wrong_type_args[] =
+ { emit_lisp_obj_rval (Qlistp), c };
+
+ gcc_jit_block_add_eval (comp.block,
+ NULL,
+ emit_call (intern_c_string
("wrong_type_argument"),
+ comp.void_type, 2, wrong_type_args,
+ false));
+ gcc_jit_block_end_with_return (comp.block,
+ NULL,
+ emit_lisp_obj_rval (Qnil));
+ }
+ comp.car = func[0];
+ comp.cdr = func[1];
+}
+
+static void
+define_setcar_setcdr (void)
+{
+ char const *f_name[] = { "setcar", "setcdr" };
+ char const *par_name[] = { "new_car", "new_cdr" };
+
+ for (int i = 0; i < 2; i++)
+ {
+ gcc_jit_param *cell =
+ gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ "cell");
+ gcc_jit_param *new_el =
+ gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ par_name[i]);
+
+ gcc_jit_param *param[] =
+ { cell,
+ new_el,
+ gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.bool_type,
+ "cert_cons") };
+
+ gcc_jit_function **f_ref = !i ? &comp.setcar : &comp.setcdr;
+ *f_ref = gcc_jit_context_new_function (comp.ctxt, NULL,
+ GCC_JIT_FUNCTION_INTERNAL,
+ comp.lisp_obj_type,
+ f_name[i],
+ 3, param, 0);
+ DECL_BLOCK (entry_block, *f_ref);
+ comp.func = *f_ref;
+ comp.block = entry_block;
+
+ /* CHECK_CONS (cell); */
+ emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell));
+
+ /* CHECK_IMPURE (cell, XCONS (cell)); */
+ gcc_jit_rvalue *args[] =
+ { gcc_jit_param_as_rvalue (cell),
+ emit_XCONS (gcc_jit_param_as_rvalue (cell)) };
+
+ gcc_jit_block_add_eval (entry_block,
+ NULL,
+ gcc_jit_context_new_call (comp.ctxt,
+ NULL,
+ comp.check_impure,
+ 2,
+ args));
+
+ /* XSETCDR (cell, newel); */
+ if (!i)
+ emit_XSETCAR (gcc_jit_param_as_rvalue (cell),
+ gcc_jit_param_as_rvalue (new_el));
+ else
+ emit_XSETCDR (gcc_jit_param_as_rvalue (cell),
+ gcc_jit_param_as_rvalue (new_el));
+
+ /* return newel; */
+ gcc_jit_block_end_with_return (entry_block,
+ NULL,
+ gcc_jit_param_as_rvalue (new_el));
+ }
+}
+
+/*
+ Define a substitute for Fadd1 Fsub1.
+ Currently expose just fixnum arithmetic.
+*/
+
+static void
+define_add1_sub1 (void)
+{
+ gcc_jit_block *bb_orig = comp.block;
+ gcc_jit_function *func[2];
+ char const *f_name[] = { "add1", "sub1" };
+ char const *fall_back_func[] = { "1+", "1-" };
+ enum gcc_jit_binary_op op[] =
+ { GCC_JIT_BINARY_OP_PLUS, GCC_JIT_BINARY_OP_MINUS };
+ for (ptrdiff_t i = 0; i < 2; i++)
+ {
+ gcc_jit_param *param[] =
+ { gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ "n"),
+ gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.bool_type,
+ "cert_fixnum") };
+ comp.func = func[i] =
+ gcc_jit_context_new_function (comp.ctxt, NULL,
+ GCC_JIT_FUNCTION_INTERNAL,
+ comp.lisp_obj_type,
+ f_name[i],
+ 2,
+ param, 0);
+ DECL_BLOCK (entry_block, func[i]);
+ DECL_BLOCK (inline_block, func[i]);
+ DECL_BLOCK (fcall_block, func[i]);
+
+ comp.block = entry_block;
+
+ /* cert_fixnum ||
+ ((FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM
+ ? (XFIXNUM (n) + 1)
+ : Fadd1 (n)) */
+
+ gcc_jit_rvalue *n = gcc_jit_param_as_rvalue (param[0]);
+ gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (n);
+ gcc_jit_rvalue *sure_fixnum =
+ emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR,
+ comp.bool_type,
+ gcc_jit_param_as_rvalue (param[1]),
+ emit_FIXNUMP (n));
+ emit_cond_jump (
+ emit_binary_op (
+ GCC_JIT_BINARY_OP_LOGICAL_AND,
+ comp.bool_type,
+ sure_fixnum,
+ gcc_jit_context_new_comparison (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_COMPARISON_NE,
+ n_fixnum,
+ i == 0
+ ? emit_rvalue_from_emacs_int (MOST_POSITIVE_FIXNUM)
+ : emit_rvalue_from_emacs_int (MOST_NEGATIVE_FIXNUM))),
+ inline_block,
+ fcall_block);
+
+ comp.block = inline_block;
+ gcc_jit_rvalue *inline_res =
+ emit_binary_op (op[i], comp.emacs_int_type, n_fixnum, comp.one);
+
+ gcc_jit_block_end_with_return (inline_block,
+ NULL,
+ emit_make_fixnum (inline_res));
+
+ comp.block = fcall_block;
+ gcc_jit_rvalue *call_res = emit_call (intern_c_string
(fall_back_func[i]),
+ comp.lisp_obj_type, 1, &n, false);
+ gcc_jit_block_end_with_return (fcall_block,
+ NULL,
+ call_res);
+ }
+ comp.block = bb_orig;
+ comp.add1 = func[0];
+ comp.sub1 = func[1];
+}
+
+static void
+define_negate (void)
+{
+ gcc_jit_block *bb_orig = comp.block;
+ gcc_jit_param *param[] =
+ { gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ "n"),
+ gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.bool_type,
+ "cert_fixnum") };
+
+ comp.func = comp.negate =
+ gcc_jit_context_new_function (comp.ctxt, NULL,
+ GCC_JIT_FUNCTION_INTERNAL,
+ comp.lisp_obj_type,
+ "negate",
+ 2, param, 0);
+
+ DECL_BLOCK (entry_block, comp.negate);
+ DECL_BLOCK (inline_block, comp.negate);
+ DECL_BLOCK (fcall_block, comp.negate);
+
+ comp.block = entry_block;
+
+ /* (cert_fixnum || FIXNUMP (TOP)) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM
+ ? make_fixnum (- XFIXNUM (TOP)) : Fminus (1, &TOP)) */
+
+ gcc_jit_lvalue *n = gcc_jit_param_as_lvalue (param[0]);
+ gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (n));
+ gcc_jit_rvalue *sure_fixnum =
+ emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR,
+ comp.bool_type,
+ gcc_jit_param_as_rvalue (param[1]),
+ emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n)));
+
+ emit_cond_jump (emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_AND,
+ comp.bool_type,
+ sure_fixnum,
+ gcc_jit_context_new_comparison (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_COMPARISON_NE,
+ n_fixnum,
+ emit_rvalue_from_emacs_int (
+ MOST_NEGATIVE_FIXNUM))),
+ inline_block,
+ fcall_block);
+
+ comp.block = inline_block;
+ gcc_jit_rvalue *inline_res =
+ gcc_jit_context_new_unary_op (comp.ctxt,
+ NULL,
+ GCC_JIT_UNARY_OP_MINUS,
+ comp.emacs_int_type,
+ n_fixnum);
+
+ gcc_jit_block_end_with_return (inline_block,
+ NULL,
+ emit_make_fixnum (inline_res));
+
+ comp.block = fcall_block;
+ gcc_jit_rvalue *call_res = emit_call_ref (Qminus, 1, n, false);
+ gcc_jit_block_end_with_return (fcall_block,
+ NULL,
+ call_res);
+ comp.block = bb_orig;
+}
+
+/* Define a substitute for PSEUDOVECTORP as always inlined function. */
+
+static void
+define_PSEUDOVECTORP (void)
+{
+ gcc_jit_param *param[] =
+ { gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ "a"),
+ gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.int_type,
+ "code") };
+
+ comp.pseudovectorp =
+ gcc_jit_context_new_function (comp.ctxt, NULL,
+ GCC_JIT_FUNCTION_INTERNAL,
+ comp.bool_type,
+ "PSEUDOVECTORP",
+ 2,
+ param,
+ 0);
+
+ DECL_BLOCK (entry_block, comp.pseudovectorp);
+ DECL_BLOCK (ret_false_b, comp.pseudovectorp);
+ DECL_BLOCK (call_pseudovector_typep_b, comp.pseudovectorp);
+
+ comp.block = entry_block;
+ comp.func = comp.pseudovectorp;
+
+ emit_cond_jump (emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0])),
+ call_pseudovector_typep_b,
+ ret_false_b);
+
+ comp.block = ret_false_b;
+ gcc_jit_block_end_with_return (ret_false_b,
+ NULL,
+ gcc_jit_context_new_rvalue_from_int (
+ comp.ctxt,
+ comp.bool_type,
+ false));
+
+ gcc_jit_rvalue *args[] =
+ { gcc_jit_param_as_rvalue (param[0]),
+ gcc_jit_param_as_rvalue (param[1]) };
+ comp.block = call_pseudovector_typep_b;
+ /* FIXME use XUNTAG now that's available. */
+ gcc_jit_block_end_with_return (
+ call_pseudovector_typep_b,
+ NULL,
+ emit_call (intern_c_string ("helper_PSEUDOVECTOR_TYPEP_XUNTAG"),
+ comp.bool_type, 2, args, false));
+}
+
+static void
+define_CHECK_IMPURE (void)
+{
+ gcc_jit_param *param[] =
+ { gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ "obj"),
+ gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.void_ptr_type,
+ "ptr") };
+ comp.check_impure =
+ gcc_jit_context_new_function (comp.ctxt, NULL,
+ GCC_JIT_FUNCTION_INTERNAL,
+ comp.void_type,
+ "CHECK_IMPURE",
+ 2,
+ param,
+ 0);
+
+ DECL_BLOCK (entry_block, comp.check_impure);
+ DECL_BLOCK (err_block, comp.check_impure);
+ DECL_BLOCK (ok_block, comp.check_impure);
+
+ comp.block = entry_block;
+ comp.func = comp.check_impure;
+
+ emit_cond_jump (emit_PURE_P (gcc_jit_param_as_rvalue (param[0])), /* FIXME
*/
+ err_block,
+ ok_block);
+ gcc_jit_block_end_with_void_return (ok_block, NULL);
+
+ gcc_jit_rvalue *pure_write_error_arg =
+ gcc_jit_param_as_rvalue (param[0]);
+
+ comp.block = err_block;
+ gcc_jit_block_add_eval (comp.block,
+ NULL,
+ emit_call (intern_c_string ("pure_write_error"),
+ comp.void_type, 1,&pure_write_error_arg,
+ false));
+
+ gcc_jit_block_end_with_void_return (err_block, NULL);
+}
+
+static void
+define_maybe_gc_or_quit (void)
+{
+
+ /*
+ void
+ maybe_gc_or_quit (void)
+ {
+ static unsigned quitcounter;
+ inc:
+ quitcounter++;
+ if (quitcounter >> 14) goto maybe_do_it else goto pass;
+ maybe_do_it:
+ quitcounter = 0;
+ maybe_gc ();
+ maybe_quit ();
+ return;
+ pass:
+ return;
+ }
+ */
+
+ gcc_jit_block *bb_orig = comp.block;
+
+ gcc_jit_lvalue *quitcounter =
+ gcc_jit_context_new_global (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_GLOBAL_INTERNAL,
+ comp.unsigned_type,
+ "quitcounter");
+
+ comp.func = comp.maybe_gc_or_quit =
+ gcc_jit_context_new_function (comp.ctxt, NULL,
+ GCC_JIT_FUNCTION_INTERNAL,
+ comp.void_type,
+ "maybe_gc_quit",
+ 0, NULL, 0);
+ DECL_BLOCK (increment_block, comp.maybe_gc_or_quit);
+ DECL_BLOCK (maybe_do_it_block, comp.maybe_gc_or_quit);
+ DECL_BLOCK (pass_block, comp.maybe_gc_or_quit);
+
+ comp.block = increment_block;
+
+ gcc_jit_block_add_assignment (
+ comp.block,
+ NULL,
+ quitcounter,
+ emit_binary_op (GCC_JIT_BINARY_OP_PLUS,
+ comp.unsigned_type,
+ gcc_jit_lvalue_as_rvalue (quitcounter),
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.unsigned_type,
+ 1)));
+ emit_cond_jump (
+ emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT,
+ comp.unsigned_type,
+ gcc_jit_lvalue_as_rvalue (quitcounter),
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.unsigned_type,
+ 9)),
+ /* 9 translates into checking for GC or quit every 512 calls to
+ 'maybe_gc_quit'. This is the smallest value I could find with
+ no performance impact running elisp-banechmarks and the same
+ used by the byte interpreter (see 'exec_byte_code'). */
+ maybe_do_it_block,
+ pass_block);
+
+ comp.block = maybe_do_it_block;
+
+ gcc_jit_block_add_assignment (
+ comp.block,
+ NULL,
+ quitcounter,
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.unsigned_type,
+ 0));
+ gcc_jit_block_add_eval (comp.block, NULL,
+ emit_call (intern_c_string ("maybe_gc"),
+ comp.void_type, 0, NULL, false));
+ gcc_jit_block_add_eval (comp.block, NULL,
+ emit_call (intern_c_string ("maybe_quit"),
+ comp.void_type, 0, NULL, false));
+ gcc_jit_block_end_with_void_return (comp.block, NULL);
+
+ gcc_jit_block_end_with_void_return (pass_block, NULL);
+
+ comp.block = bb_orig;
+}
+
+/* Define a function to convert boolean into t or nil */
+
+static void
+define_bool_to_lisp_obj (void)
+{
+ /* x ? Qt : Qnil */
+ gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.bool_type,
+ "x");
+ comp.bool_to_lisp_obj =
+ gcc_jit_context_new_function (comp.ctxt, NULL,
+ GCC_JIT_FUNCTION_INTERNAL,
+ comp.lisp_obj_type,
+ "bool_to_lisp_obj",
+ 1,
+ ¶m,
+ 0);
+ DECL_BLOCK (entry_block, comp.bool_to_lisp_obj);
+ DECL_BLOCK (ret_t_block, comp.bool_to_lisp_obj);
+ DECL_BLOCK (ret_nil_block, comp.bool_to_lisp_obj);
+ comp.block = entry_block;
+ comp.func = comp.bool_to_lisp_obj;
+
+ emit_cond_jump (gcc_jit_param_as_rvalue (param),
+ ret_t_block,
+ ret_nil_block);
+
+ comp.block = ret_t_block;
+ gcc_jit_block_end_with_return (ret_t_block,
+ NULL,
+ emit_lisp_obj_rval (Qt));
+
+ comp.block = ret_nil_block;
+ gcc_jit_block_end_with_return (ret_nil_block,
+ NULL,
+ emit_lisp_obj_rval (Qnil));
+}
+
+static gcc_jit_function *
+declare_lex_function (Lisp_Object func)
+{
+ gcc_jit_function *res;
+ Lisp_Object c_name = CALL1I (comp-func-c-name, func);
+ Lisp_Object args = CALL1I (comp-func-l-args, func);
+ bool nargs = !NILP (CALL1I (comp-nargs-p, args));
+ USE_SAFE_ALLOCA;
+
+ if (!nargs)
+ {
+ EMACS_INT max_args = XFIXNUM (CALL1I (comp-args-max, args));
+ eassert (max_args < INT_MAX);
+ gcc_jit_type **type = SAFE_ALLOCA (max_args * sizeof (*type));
+ for (ptrdiff_t i = 0; i < max_args; i++)
+ type[i] = comp.lisp_obj_type;
+
+ gcc_jit_param **params = SAFE_ALLOCA (max_args * sizeof (*params));
+ for (int i = 0; i < max_args; ++i)
+ params[i] = gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ type[i],
+ format_string ("par_%d", i));
+ res = gcc_jit_context_new_function (comp.ctxt, NULL,
+ GCC_JIT_FUNCTION_EXPORTED,
+ comp.lisp_obj_type,
+ SSDATA (c_name),
+ max_args,
+ params,
+ 0);
+ }
+ else
+ {
+ gcc_jit_param *params[] =
+ { gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.ptrdiff_type,
+ "nargs"),
+ gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.lisp_obj_ptr_type,
+ "args") };
+ res =
+ gcc_jit_context_new_function (comp.ctxt,
+ NULL,
+ GCC_JIT_FUNCTION_EXPORTED,
+ comp.lisp_obj_type,
+ SSDATA (c_name),
+ ARRAYELTS (params), params, 0);
+ }
+ SAFE_FREE ();
+ return res;
+}
+
+/* Declare a function being compiled and add it to comp.exported_funcs_h. */
+
+static void
+declare_function (Lisp_Object func)
+{
+ gcc_jit_function *gcc_func =
+ !NILP (CALL1I (comp-func-l-p, func))
+ ? declare_lex_function (func)
+ : gcc_jit_context_new_function (comp.ctxt,
+ NULL,
+ GCC_JIT_FUNCTION_EXPORTED,
+ comp.lisp_obj_type,
+ SSDATA (CALL1I (comp-func-c-name, func)),
+ 0, NULL, 0);
+ Fputhash (CALL1I (comp-func-c-name, func),
+ make_mint_ptr (gcc_func),
+ comp.exported_funcs_h);
+}
+
+static void
+compile_function (Lisp_Object func)
+{
+ USE_SAFE_ALLOCA;
+ comp.frame_size = XFIXNUM (CALL1I (comp-func-frame-size, func));
+ eassert (comp.frame_size < INT_MAX);
+
+ comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-c-name, func),
+ comp.exported_funcs_h, Qnil));
+
+ comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func));
+ comp.func_speed = XFIXNUM (CALL1I (comp-func-speed, func));
+
+ comp.func_relocs_local =
+ gcc_jit_function_new_local (comp.func,
+ NULL,
+ comp.func_relocs_ptr_type,
+ "freloc");
+
+ comp.frame = SAFE_ALLOCA (comp.frame_size * sizeof (*comp.frame));
+ if (comp.func_has_non_local || !comp.func_speed)
+ {
+ /* FIXME: See bug#42360. */
+ gcc_jit_lvalue *arr =
+ gcc_jit_function_new_local (
+ comp.func,
+ NULL,
+ gcc_jit_context_new_array_type (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ comp.frame_size),
+ "frame");
+
+ for (ptrdiff_t i = 0; i < comp.frame_size; ++i)
+ comp.frame[i] =
+ gcc_jit_context_new_array_access (
+ comp.ctxt,
+ NULL,
+ gcc_jit_lvalue_as_rvalue (arr),
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.int_type,
+ i));
+ }
+ else
+ for (ptrdiff_t i = 0; i < comp.frame_size; ++i)
+ comp.frame[i] =
+ gcc_jit_function_new_local (comp.func,
+ NULL,
+ comp.lisp_obj_type,
+ format_string ("slot_%td", i));
+
+ comp.scratch = NULL;
+
+ comp.loc_handler = gcc_jit_function_new_local (comp.func,
+ NULL,
+ comp.handler_ptr_type,
+ "c");
+
+ comp.func_blocks_h = CALLN (Fmake_hash_table);
+
+ /* Pre-declare all basic blocks to gcc.
+ The "entry" block must be declared as first. */
+ declare_block (Qentry);
+ Lisp_Object blocks = CALL1I (comp-func-blocks, func);
+ struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks);
+ for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++)
+ {
+ Lisp_Object block_name = HASH_KEY (ht, i);
+ if (!EQ (block_name, Qentry)
+ && !EQ (block_name, Qunbound))
+ declare_block (block_name);
+ }
+
+ gcc_jit_block_add_assignment (retrive_block (Qentry),
+ NULL,
+ comp.func_relocs_local,
+ gcc_jit_lvalue_as_rvalue (comp.func_relocs));
+
+
+ for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++)
+ {
+ Lisp_Object block_name = HASH_KEY (ht, i);
+ if (!EQ (block_name, Qunbound))
+ {
+ Lisp_Object block = HASH_VALUE (ht, i);
+ Lisp_Object insns = CALL1I (comp-block-insns, block);
+ if (NILP (block) || NILP (insns))
+ xsignal1 (Qnative_ice,
+ build_string ("basic block is missing or empty"));
+
+ comp.block = retrive_block (block_name);
+ while (CONSP (insns))
+ {
+ Lisp_Object insn = XCAR (insns);
+ emit_limple_insn (insn);
+ insns = XCDR (insns);
+ }
+ }
+ }
+ const char *err = gcc_jit_context_get_first_error (comp.ctxt);
+ if (err)
+ xsignal3 (Qnative_ice,
+ build_string ("failing to compile function"),
+ CALL1I (comp-func-name, func),
+ build_string (err));
+ SAFE_FREE ();
+}
+
+
+/**********************************/
+/* Entry points exposed to lisp. */
+/**********************************/
+
+/* In use by Fcomp_el_to_eln_filename. */
+static Lisp_Object loadsearch_re_list;
+
+static Lisp_Object
+make_directory_wrapper (Lisp_Object directory)
+{
+ CALL2I (make-directory, directory, Qt);
+ return Qnil;
+}
+
+static Lisp_Object
+make_directory_wrapper_1 (Lisp_Object ignore)
+{
+ return Qt;
+}
+
+DEFUN ("comp-el-to-eln-rel-filename", Fcomp_el_to_eln_rel_filename,
+ Scomp_el_to_eln_rel_filename, 1, 1, 0,
+ doc: /* Return the corresponding .eln relative filename. */)
+ (Lisp_Object filename)
+{
+ CHECK_STRING (filename);
+
+ /* Use `file-truename' or fall back to `expand-file-name' when the
+ first is not available (bug#44701).
+
+ `file-truename' is not available only for a short phases of the
+ bootstrap before file.el is loaded, given we do not symlink
+ inside the build directory this should work. */
+ filename = NILP (Ffboundp (intern_c_string ("file-truename")))
+ ? Fexpand_file_name (filename, Qnil)
+ : CALL1I (file-truename, filename);
+
+ if (NILP (Ffile_exists_p (filename)))
+ xsignal1 (Qfile_missing, filename);
+
+#ifdef WINDOWSNT
+ filename = Fw32_long_file_name (filename);
+#endif
+
+ Lisp_Object content_hash = comp_hash_source_file (filename);
+
+ if (suffix_p (filename, ".gz"))
+ filename = Fsubstring (filename, Qnil, make_fixnum (-3));
+
+ /* We create eln filenames with an hash in order to look-up these
+ starting from the source filename, IOW have a relation
+
+ /absolute/path/filename.el + content ->
+ eln-cache/filename-path_hash-content_hash.eln.
+
+ 'dlopen' can return the same handle if two shared with the same
+ filename are loaded in two different times (even if the first was
+ deleted!). To prevent this scenario the source file content is
+ included in the hashing algorithm.
+
+ As at any point in time no more then one file can exist with the
+ same filename, should be possible to clean up all
+ filename-path_hash-* except the most recent one (or the new one
+ being recompiled).
+
+ As installing .eln files compiled during the build changes their
+ absolute path we need an hashing mechanism that is not sensitive
+ to that. For this we replace if match PATH_DUMPLOADSEARCH or
+ *PATH_REL_LOADSEARCH with '//' before computing the hash. */
+
+ if (NILP (loadsearch_re_list))
+ {
+ Lisp_Object sys_re =
+ concat2 (build_string ("\\`[[:ascii:]]+"),
+ Fregexp_quote (build_string ("/" PATH_REL_LOADSEARCH "/")));
+ Lisp_Object dump_load_search = build_string (PATH_DUMPLOADSEARCH "/");
+#ifdef WINDOWSNT
+ dump_load_search = Fw32_long_file_name (dump_load_search);
+#endif
+ loadsearch_re_list = list2 (sys_re, Fregexp_quote (dump_load_search));
+ }
+
+ Lisp_Object lds_re_tail = loadsearch_re_list;
+ FOR_EACH_TAIL (lds_re_tail)
+ {
+ Lisp_Object match_idx =
+ Fstring_match (XCAR (lds_re_tail), filename, Qnil);
+ if (EQ (match_idx, make_fixnum (0)))
+ {
+ filename =
+ Freplace_match (build_string ("//"), Qt, Qt, filename, Qnil);
+ break;
+ }
+ }
+ Lisp_Object separator = build_string ("-");
+ Lisp_Object path_hash = comp_hash_string (filename);
+ filename = concat2 (Ffile_name_nondirectory (Fsubstring (filename, Qnil,
+ make_fixnum (-3))),
+ separator);
+ Lisp_Object hash = concat3 (path_hash, separator, content_hash);
+ return concat3 (filename, hash, build_string (NATIVE_ELISP_SUFFIX));
+}
+
+DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename,
+ Scomp_el_to_eln_filename, 1, 2, 0,
+ doc: /* Return the .eln filename for source FILENAME to used
+for new compilations.
+If BASE-DIR is non-nil use it as a base directory, look for a suitable
+directory in `comp-eln-load-path' otherwise. */)
+ (Lisp_Object filename, Lisp_Object base_dir)
+{
+ Lisp_Object source_filename = filename;
+ filename = Fcomp_el_to_eln_rel_filename (filename);
+
+ /* If base_dir was not specified search inside Vcomp_eln_load_path
+ for the first directory where we have write access. */
+ if (NILP (base_dir))
+ {
+ Lisp_Object eln_load_paths = Vcomp_eln_load_path;
+ FOR_EACH_TAIL (eln_load_paths)
+ {
+ Lisp_Object dir = XCAR (eln_load_paths);
+ if (!NILP (Ffile_exists_p (dir)))
+ {
+ if (!NILP (Ffile_writable_p (dir)))
+ {
+ base_dir = dir;
+ break;
+ }
+ }
+ else
+ {
+ /* Try to create the directory and if succeeds use it. */
+ if (NILP (internal_condition_case_1 (make_directory_wrapper,
+ dir, Qt,
+ make_directory_wrapper_1)))
+ {
+ base_dir = dir;
+ break;
+ }
+ }
+ }
+ if (NILP (base_dir))
+ error ("Cannot find suitable directory for output in "
+ "`comp-native-load-path'.");
+ }
+
+ if (!file_name_absolute_p (SSDATA (base_dir)))
+ base_dir = Fexpand_file_name (base_dir, Vinvocation_directory);
+
+ /* In case the file being compiled is found in 'LISP_PRELOADED' or
+ `comp-file-preloaded-p' is non-nil target for output the
+ 'preloaded' subfolder. */
+ Lisp_Object lisp_preloaded =
+ Fgetenv_internal (build_string ("LISP_PRELOADED"), Qnil);
+ base_dir = Fexpand_file_name (Vcomp_native_version_dir, base_dir);
+ if (comp_file_preloaded_p
+ || (!NILP (lisp_preloaded)
+ && !NILP (Fmember (CALL1I (file-name-base, source_filename),
+ Fmapcar (intern_c_string ("file-name-base"),
+ CALL1I (split-string, lisp_preloaded))))))
+ base_dir = Fexpand_file_name (build_string ("preloaded"), base_dir);
+
+ return Fexpand_file_name (filename, base_dir);
+}
+
+DEFUN ("comp--install-trampoline", Fcomp__install_trampoline,
+ Scomp__install_trampoline, 2, 2, 0,
+ doc: /* Install a TRAMPOLINE for primitive SUBR-NAME. */)
+ (Lisp_Object subr_name, Lisp_Object trampoline)
+{
+ CHECK_SYMBOL (subr_name);
+ CHECK_SUBR (trampoline);
+ Lisp_Object orig_subr = Fsymbol_function (subr_name);
+ CHECK_SUBR (orig_subr);
+
+ /* FIXME: add a post dump load trampoline machinery to remove this
+ check. */
+ if (will_dump_p ())
+ signal_error ("Trying to advice unexpected primitive before dumping",
+ subr_name);
+
+ Lisp_Object subr_l = Vcomp_subr_list;
+ ptrdiff_t i = ARRAYELTS (helper_link_table);
+ FOR_EACH_TAIL (subr_l)
+ {
+ Lisp_Object subr = XCAR (subr_l);
+ if (EQ (subr, orig_subr))
+ {
+ freloc.link_table[i] = XSUBR (trampoline)->function.a0;
+ Fputhash (subr_name, trampoline, Vcomp_installed_trampolines_h);
+ return Qt;
+ }
+ i++;
+ }
+ signal_error ("Trying to install trampoline for non existent subr",
+ subr_name);
+ return Qnil;
+}
+
+DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt,
+ 0, 0, 0,
+ doc: /* Initialize the native compiler context.
+Return t on success. */)
+ (void)
+{
+ load_gccjit_if_necessary (true);
+
+ if (comp.ctxt)
+ {
+ xsignal1 (Qnative_ice,
+ build_string ("compiler context already taken"));
+ return Qnil;
+ }
+
+ if (NILP (comp.emitter_dispatcher))
+ {
+ /* Move this into syms_of_comp the day will be dumpable. */
+ comp.emitter_dispatcher = CALLN (Fmake_hash_table);
+ register_emitter (Qset_internal, emit_set_internal);
+ register_emitter (Qhelper_unbind_n, emit_simple_limple_call_lisp_ret);
+ register_emitter (Qhelper_unwind_protect,
+ emit_simple_limple_call_void_ret);
+ register_emitter (Qrecord_unwind_current_buffer,
+ emit_simple_limple_call_lisp_ret);
+ register_emitter (Qrecord_unwind_protect_excursion,
+ emit_simple_limple_call_void_ret);
+ register_emitter (Qhelper_save_restriction,
+ emit_simple_limple_call_void_ret);
+ /* Inliners. */
+ register_emitter (Qadd1, emit_add1);
+ register_emitter (Qsub1, emit_sub1);
+ register_emitter (Qconsp, emit_consp);
+ register_emitter (Qcar, emit_car);
+ register_emitter (Qcdr, emit_cdr);
+ register_emitter (Qsetcar, emit_setcar);
+ register_emitter (Qsetcdr, emit_setcdr);
+ register_emitter (Qnegate, emit_negate);
+ register_emitter (Qnumberp, emit_numperp);
+ register_emitter (Qintegerp, emit_integerp);
+ register_emitter (Qcomp_maybe_gc_or_quit, emit_maybe_gc_or_quit);
+ }
+
+ comp.ctxt = gcc_jit_context_acquire ();
+
+ comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID);
+ comp.void_ptr_type =
+ gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR);
+ comp.bool_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_BOOL);
+ comp.char_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_CHAR);
+ comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT);
+ comp.unsigned_type = gcc_jit_context_get_type (comp.ctxt,
+ GCC_JIT_TYPE_UNSIGNED_INT);
+ comp.long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG);
+ comp.unsigned_long_type =
+ gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG);
+ comp.long_long_type =
+ gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG_LONG);
+ comp.unsigned_long_long_type =
+ gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG_LONG);
+ comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type);
+ comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt,
+ sizeof (EMACS_INT),
+ true);
+ comp.emacs_uint_type = gcc_jit_context_get_int_type (comp.ctxt,
+ sizeof (EMACS_UINT),
+ false);
+#if LISP_WORDS_ARE_POINTERS
+ comp.lisp_word_type =
+ gcc_jit_type_get_pointer (
+ gcc_jit_struct_as_type (
+ gcc_jit_context_new_opaque_struct (comp.ctxt,
+ NULL,
+ "Lisp_X")));
+#else
+ comp.lisp_word_type = comp.emacs_int_type;
+#endif
+ comp.lisp_word_tag_type
+ = gcc_jit_context_get_int_type (comp.ctxt, sizeof (Lisp_Word_tag), false);
+#ifdef LISP_OBJECT_IS_STRUCT
+ comp.lisp_obj_i = gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ comp.lisp_word_type,
+ "i");
+ comp.lisp_obj_s = gcc_jit_context_new_struct_type (comp.ctxt,
+ NULL,
+ "Lisp_Object",
+ 1,
+ &comp.lisp_obj_i);
+ comp.lisp_obj_type = gcc_jit_struct_as_type (comp.lisp_obj_s);
+#else
+ comp.lisp_obj_type = comp.lisp_word_type;
+#endif
+ comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type);
+ comp.zero =
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.emacs_int_type,
+ 0);
+ comp.one =
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.emacs_int_type,
+ 1);
+ comp.inttypebits =
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.emacs_uint_type,
+ INTTYPEBITS);
+ comp.lisp_int0 =
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.emacs_int_type,
+ Lisp_Int0);
+ comp.ptrdiff_type = gcc_jit_context_get_int_type (comp.ctxt,
+ sizeof (void *),
+ true);
+ comp.uintptr_type = gcc_jit_context_get_int_type (comp.ctxt,
+ sizeof (void *),
+ false);
+ comp.size_t_type = gcc_jit_context_get_int_type (comp.ctxt,
+ sizeof (size_t),
+ false);
+
+ comp.exported_funcs_h = CALLN (Fmake_hash_table, QCtest, Qequal);
+ /*
+ Always reinitialize this cause old function definitions are garbage
+ collected by libgccjit when the ctxt is released.
+ */
+ comp.imported_funcs_h = CALLN (Fmake_hash_table);
+
+ define_memcpy ();
+
+ /* Define data structures. */
+
+ define_lisp_cons ();
+ define_jmp_buf ();
+ define_handler_struct ();
+ define_thread_state_struct ();
+ define_cast_functions ();
+
+ return Qt;
+}
+
+DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt,
+ 0, 0, 0,
+ doc: /* Release the native compiler context. */)
+ (void)
+{
+ load_gccjit_if_necessary (true);
+
+ if (comp.ctxt)
+ gcc_jit_context_release (comp.ctxt);
+
+ if (logfile)
+ fclose (logfile);
+ comp.ctxt = NULL;
+
+ return Qt;
+}
+
+#pragma GCC diagnostic ignored "-Waddress"
+DEFUN ("comp-native-driver-options-effective-p",
+ Fcomp_native_driver_options_effective_p,
+ Scomp_native_driver_options_effective_p,
+ 0, 0, 0,
+ doc: /* Return t if `comp-native-driver-options' is effective. */)
+ (void)
+{
+#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \
+ || defined (WINDOWSNT)
+ if (gcc_jit_context_add_driver_option)
+ return Qt;
+#endif
+ return Qnil;
+}
+#pragma GCC diagnostic pop
+
+static void
+add_driver_options (void)
+{
+ Lisp_Object options = Fsymbol_value (Qcomp_native_driver_options);
+
+#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \
+ || defined (WINDOWSNT)
+ load_gccjit_if_necessary (true);
+ if (!NILP (Fcomp_native_driver_options_effective_p ()))
+ FOR_EACH_TAIL (options)
+ gcc_jit_context_add_driver_option (comp.ctxt,
+ /* FIXME: Need to encode
+ this, but how? either
+ ENCODE_FILE or
+ ENCODE_SYSTEM. */
+ SSDATA (XCAR (options)));
+#endif
+ if (CONSP (options))
+ xsignal1 (Qnative_compiler_error,
+ build_string ("Customizing native compiler options"
+ " via `comp-native-driver-options' is"
+ " only available on libgccjit version 9"
+ " and above."));
+
+ /* Captured `comp-native-driver-options' because file-local. */
+#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \
+ || defined (WINDOWSNT)
+ options = comp.driver_options;
+ if (!NILP (Fcomp_native_driver_options_effective_p ()))
+ FOR_EACH_TAIL (options)
+ gcc_jit_context_add_driver_option (comp.ctxt,
+ /* FIXME: Need to encode
+ this, but how? either
+ ENCODE_FILE or
+ ENCODE_SYSTEM. */
+ SSDATA (XCAR (options)));
+#endif
+}
+
+DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file,
+ Scomp__compile_ctxt_to_file,
+ 1, 1, 0,
+ doc: /* Compile the current context as native code to file FILENAME.
*/)
+ (Lisp_Object filename)
+{
+ load_gccjit_if_necessary (true);
+
+ CHECK_STRING (filename);
+ Lisp_Object base_name = Fsubstring (filename, Qnil, make_fixnum (-4));
+ Lisp_Object ebase_name = ENCODE_FILE (base_name);
+
+ comp.func_relocs_local = NULL;
+
+#ifdef WINDOWSNT
+ ebase_name = ansi_encode_filename (ebase_name);
+ /* Tell libgccjit the actual file name of the loaded DLL, otherwise
+ it will use 'libgccjit.so', which is not useful. */
+ Lisp_Object libgccjit_loaded_from = Fget (Qgccjit, QCloaded_from);
+ Lisp_Object libgccjit_fname;
+
+ if (CONSP (libgccjit_loaded_from))
+ {
+ /* Use the absolute file name if available, otherwise the name
+ we looked for in w32_delayed_load. */
+ libgccjit_fname = XCDR (libgccjit_loaded_from);
+ if (NILP (libgccjit_fname))
+ libgccjit_fname = XCAR (libgccjit_loaded_from);
+ /* Must encode to ANSI, as libgccjit will not be able to handle
+ UTF-8 encoded file names. */
+ libgccjit_fname = ENCODE_FILE (libgccjit_fname);
+ libgccjit_fname = ansi_encode_filename (libgccjit_fname);
+ gcc_jit_context_set_str_option (comp.ctxt, GCC_JIT_STR_OPTION_PROGNAME,
+ SSDATA (libgccjit_fname));
+ }
+ else /* this should never happen */
+ gcc_jit_context_set_str_option (comp.ctxt, GCC_JIT_STR_OPTION_PROGNAME,
+ "libgccjit-0.dll");
+#endif
+
+ comp.speed = XFIXNUM (CALL1I (comp-ctxt-speed, Vcomp_ctxt));
+ eassert (comp.speed < INT_MAX);
+ comp.debug = XFIXNUM (CALL1I (comp-ctxt-debug, Vcomp_ctxt));
+ eassert (comp.debug < INT_MAX);
+ comp.driver_options = CALL1I (comp-ctxt-driver-options, Vcomp_ctxt);
+
+ if (comp.debug)
+ gcc_jit_context_set_bool_option (comp.ctxt,
+ GCC_JIT_BOOL_OPTION_DEBUGINFO,
+ 1);
+ if (comp.debug >= 3)
+ {
+ logfile = emacs_fopen ("libgccjit.log", "w");
+ gcc_jit_context_set_logfile (comp.ctxt,
+ logfile,
+ 0, 0);
+ gcc_jit_context_set_bool_option (comp.ctxt,
+ GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES,
+ 1);
+ gcc_jit_context_set_bool_option (comp.ctxt,
+ GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING,
+ 1);
+ }
+
+ gcc_jit_context_set_int_option (comp.ctxt,
+ GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL,
+ comp.speed < 0 ? 0
+ : (comp.speed > 3 ? 3 : comp.speed));
+ comp.d_default_idx =
+ CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-default, Vcomp_ctxt));
+ comp.d_impure_idx =
+ CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-impure, Vcomp_ctxt));
+ comp.d_ephemeral_idx =
+ CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-ephemeral,
Vcomp_ctxt));
+
+ emit_ctxt_code ();
+
+ /* Define inline functions. */
+ define_CAR_CDR ();
+ define_PSEUDOVECTORP ();
+ define_CHECK_TYPE ();
+ define_CHECK_IMPURE ();
+ define_bool_to_lisp_obj ();
+ define_setcar_setcdr ();
+ define_add1_sub1 ();
+ define_negate ();
+ define_maybe_gc_or_quit ();
+
+ struct Lisp_Hash_Table *func_h =
+ XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt));
+ for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (func_h); i++)
+ if (!EQ (HASH_VALUE (func_h, i), Qunbound))
+ declare_function (HASH_VALUE (func_h, i));
+ /* Compile all functions. Can't be done before because the
+ relocation structs has to be already defined. */
+ for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (func_h); i++)
+ if (!EQ (HASH_VALUE (func_h, i), Qunbound))
+ compile_function (HASH_VALUE (func_h, i));
+
+ /* Work around bug#46495 (GCC PR99126). */
+#if defined (WIDE_EMACS_INT) \
+ && (defined (LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option) \
+ || defined (WINDOWSNT))
+ Lisp_Object version = Fcomp_libgccjit_version ();
+ if (NILP (version)
+ || XFIXNUM (XCAR (version)) < 11)
+ gcc_jit_context_add_command_line_option (comp.ctxt,
+ "-fdisable-tree-isolate-paths");
+#endif
+
+ add_driver_options ();
+
+ if (comp.debug > 1)
+ gcc_jit_context_dump_to_file (comp.ctxt,
+ format_string ("%s.c", SSDATA (ebase_name)),
+ 1);
+ if (!NILP (Fsymbol_value (Qcomp_libgccjit_reproducer)))
+ gcc_jit_context_dump_reproducer_to_file (
+ comp.ctxt,
+ format_string ("%s_libgccjit_repro.c", SSDATA (ebase_name)));
+
+ Lisp_Object tmp_file =
+ Fmake_temp_file_internal (base_name, Qnil, build_string (".eln.tmp"),
Qnil);
+ Lisp_Object encoded_tmp_file = ENCODE_FILE (tmp_file);
+#ifdef WINDOWSNT
+ encoded_tmp_file = ansi_encode_filename (encoded_tmp_file);
+#endif
+ gcc_jit_context_compile_to_file (comp.ctxt,
+ GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY,
+ SSDATA (encoded_tmp_file));
+
+ const char *err = gcc_jit_context_get_first_error (comp.ctxt);
+ if (err)
+ xsignal3 (Qnative_ice,
+ build_string ("failed to compile"),
+ filename,
+ build_string (err));
+
+ CALL1I (comp-clean-up-stale-eln, filename);
+ CALL2I (comp-delete-or-replace-file, filename, tmp_file);
+
+ return filename;
+}
+
+#pragma GCC diagnostic ignored "-Waddress"
+DEFUN ("comp-libgccjit-version", Fcomp_libgccjit_version,
+ Scomp_libgccjit_version, 0, 0, 0,
+ doc: /* Return libgccjit version in use.
+
+The return value has the form (MAJOR MINOR PATCHLEVEL) or nil if
+unknown (before GCC version 10). */)
+ (void)
+{
+#if defined (LIBGCCJIT_HAVE_gcc_jit_version) || defined (WINDOWSNT)
+ load_gccjit_if_necessary (true);
+
+ return gcc_jit_version_major
+ ? list3 (make_fixnum (gcc_jit_version_major ()),
+ make_fixnum (gcc_jit_version_minor ()),
+ make_fixnum (gcc_jit_version_patchlevel ()))
+ : Qnil;
+#else
+ return Qnil;
+#endif
+}
+#pragma GCC diagnostic pop
+
+
+/******************************************************************************/
+/* Helper functions called from the run-time. */
+/* These can't be statics till shared mechanism is used to solve relocations.
*/
+/* Note: this are all potentially definable directly to gcc and are here just
*/
+/* for laziness. Change this if a performance impact is measured.
*/
+/******************************************************************************/
+
+void
+helper_unwind_protect (Lisp_Object handler)
+{
+ /* Support for a function here is new in 24.4. */
+ record_unwind_protect (FUNCTIONP (handler) ? bcall0 : prog_ignore,
+ handler);
+}
+
+Lisp_Object
+helper_temp_output_buffer_setup (Lisp_Object x)
+{
+ CHECK_STRING (x);
+ temp_output_buffer_setup (SSDATA (x));
+ return Vstandard_output;
+}
+
+Lisp_Object
+helper_unbind_n (Lisp_Object n)
+{
+ return unbind_to (SPECPDL_INDEX () - XFIXNUM (n), Qnil);
+}
+
+void
+helper_save_restriction (void)
+{
+ record_unwind_protect (save_restriction_restore,
+ save_restriction_save ());
+}
+
+bool
+helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code)
+{
+ return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike,
+ union vectorlike_header),
+ code);
+}
+
+
+/* `comp-eln-load-path' clean-up support code. */
+
+static Lisp_Object all_loaded_comp_units_h;
+
+#ifdef WINDOWSNT
+static Lisp_Object
+return_nil (Lisp_Object arg)
+{
+ return Qnil;
+}
+#endif
+
+/* Windows does not let us delete a .eln file that is currently loaded
+ by a process. The strategy is to rename .eln files into .old.eln
+ instead of removing them when this is not possible and clean-up
+ `comp-eln-load-path' when exiting.
+
+ Any error is ignored because it may be due to the file being loaded
+ in another Emacs instance. */
+void
+eln_load_path_final_clean_up (void)
+{
+#ifdef WINDOWSNT
+ Lisp_Object dir_tail = Vcomp_eln_load_path;
+ FOR_EACH_TAIL (dir_tail)
+ {
+ Lisp_Object files_in_dir =
+ internal_condition_case_5 (Fdirectory_files,
+ Fexpand_file_name (Vcomp_native_version_dir,
+ XCAR (dir_tail)),
+ Qt, build_string ("\\.eln\\.old\\'"), Qnil,
+ Qnil, Qt, return_nil);
+ FOR_EACH_TAIL (files_in_dir)
+ internal_delete_file (XCAR (files_in_dir));
+ }
+#endif
+}
+
+/* This function puts the compilation unit in the
+ `all_loaded_comp_units_h` hashmap. */
+static void
+register_native_comp_unit (Lisp_Object comp_u)
+{
+ Fputhash (XNATIVE_COMP_UNIT (comp_u)->file, comp_u, all_loaded_comp_units_h);
+}
+
+
+/***********************************/
+/* Deferred compilation mechanism. */
+/***********************************/
+
+/* List of sources we'll compile and load after having conventionally
+ loaded the compiler and its dependencies. */
+static Lisp_Object delayed_sources;
+
+/* Queue an asynchronous compilation for the source file defining
+ FUNCTION_NAME and perform a late load.
+
+ NOTE: ideally would be nice to move its call simply into Fload but
+ we need DEFINITION to guard against function redefinition while
+ async compilation happen. */
+
+void
+maybe_defer_native_compilation (Lisp_Object function_name,
+ Lisp_Object definition)
+{
+#if 0
+#include <sys/types.h>
+#include <unistd.h>
+ if (!NILP (function_name) &&
+ STRINGP (Vload_true_file_name))
+ {
+ static FILE *f;
+ if (!f)
+ {
+ char str[128];
+ sprintf (str, "log_%d", getpid ());
+ f = fopen (str, "w");
+ }
+ if (!f)
+ exit (1);
+ fprintf (f, "function %s file %s\n",
+ SSDATA (Fsymbol_name (function_name)),
+ SSDATA (Vload_true_file_name));
+ fflush (f);
+ }
+#endif
+ if (!load_gccjit_if_necessary (false))
+ return;
+
+ if (!comp_deferred_compilation
+ || noninteractive
+ || !NILP (Vpurify_flag)
+ || !COMPILEDP (definition)
+ || !STRINGP (Vload_true_file_name)
+ || !suffix_p (Vload_true_file_name, ".elc")
+ || !NILP (Fgethash (Vload_true_file_name, V_comp_no_native_file_h,
Qnil)))
+ return;
+
+ Lisp_Object src =
+ concat2 (CALL1I (file-name-sans-extension, Vload_true_file_name),
+ build_pure_c_string (".el"));
+ if (NILP (Ffile_exists_p (src)))
+ {
+ src = concat2 (src, build_pure_c_string (".gz"));
+ if (NILP (Ffile_exists_p (src)))
+ return;
+ }
+
+ /* This is so deferred compilation is able to compile comp
+ dependencies breaking circularity. */
+ if (!NILP (Ffeaturep (Qcomp, Qnil)))
+ {
+ /* Comp already loaded. */
+ if (!NILP (delayed_sources))
+ {
+ CALLN (Ffuncall, intern_c_string ("native--compile-async"),
+ delayed_sources, Qnil, Qlate);
+ delayed_sources = Qnil;
+ }
+ Fputhash (function_name, definition, Vcomp_deferred_pending_h);
+ CALLN (Ffuncall, intern_c_string ("native--compile-async"),
+ src, Qnil, Qlate);
+ }
+ else
+ {
+ delayed_sources = Fcons (src, delayed_sources);
+ /* Require comp only once. */
+ static bool comp_required = false;
+ if (!comp_required)
+ {
+ comp_required = true;
+ Frequire (Qcomp, Qnil, Qnil);
+ }
+ }
+}
+
+
+/**************************************/
+/* Functions used to load eln files. */
+/**************************************/
+
+/* Fixup the system eln-cache directory, which is the last entry in
+ `comp-eln-load-path'. Argument is a .eln file in that directory. */
+void
+fixup_eln_load_path (Lisp_Object eln_filename)
+{
+ Lisp_Object last_cell = Qnil;
+ Lisp_Object tem = Vcomp_eln_load_path;
+ FOR_EACH_TAIL (tem)
+ if (CONSP (tem))
+ last_cell = tem;
+
+ const char preloaded[] = "/preloaded/";
+ Lisp_Object eln_cache_sys = Ffile_name_directory (eln_filename);
+ const char *p_preloaded =
+ SSDATA (eln_cache_sys) + SBYTES (eln_cache_sys) - sizeof (preloaded) + 1;
+ bool preloaded_p = strcmp (p_preloaded, preloaded) == 0;
+
+ /* One or two directories up... */
+ for (int i = 0; i < (preloaded_p ? 2 : 1); i++)
+ eln_cache_sys =
+ Ffile_name_directory (Fsubstring_no_properties (eln_cache_sys, Qnil,
+ make_fixnum (-1)));
+ Fsetcar (last_cell, eln_cache_sys);
+}
+
+typedef char *(*comp_lit_str_func) (void);
+
+/* Deserialize read and return static object. */
+static Lisp_Object
+load_static_obj (struct Lisp_Native_Comp_Unit *comp_u, const char *name)
+{
+ static_obj_t *blob =
+ dynlib_sym (comp_u->handle, format_string ("%s_blob", name));
+ if (blob)
+ /* New blob format. */
+ return Fread (make_string (blob->data, blob->len));
+
+ static_obj_t *(*f)(void) = dynlib_sym (comp_u->handle, name);
+ if (!f)
+ xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file);
+
+ blob = f ();
+ return Fread (make_string (blob->data, blob->len));
+
+}
+
+/* Return false when something is wrong or true otherwise. */
+
+static bool
+check_comp_unit_relocs (struct Lisp_Native_Comp_Unit *comp_u)
+{
+ dynlib_handle_ptr handle = comp_u->handle;
+ Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM);
+ Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM);
+
+ EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec));
+ for (ptrdiff_t i = 0; i < d_vec_len; i++)
+ if (!EQ (data_relocs[i], AREF (comp_u->data_vec, i)))
+ return false;
+
+ d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec));
+ for (ptrdiff_t i = 0; i < d_vec_len; i++)
+ {
+ Lisp_Object x = data_imp_relocs[i];
+ if (EQ (x, Qlambda_fixup))
+ return false;
+ else if (SUBR_NATIVE_COMPILEDP (x))
+ {
+ if (NILP (Fgethash (x, comp_u->lambda_gc_guard_h, Qnil)))
+ return false;
+ }
+ else if (!EQ (data_imp_relocs[i], AREF (comp_u->data_impure_vec, i)))
+ return false;
+ }
+ return true;
+}
+
+static void
+unset_cu_load_ongoing (Lisp_Object comp_u)
+{
+ XNATIVE_COMP_UNIT (comp_u)->load_ongoing = false;
+}
+
+Lisp_Object
+load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump,
+ bool late_load)
+{
+ Lisp_Object res = Qnil;
+ dynlib_handle_ptr handle = comp_u->handle;
+ Lisp_Object comp_u_lisp_obj;
+ XSETNATIVE_COMP_UNIT (comp_u_lisp_obj, comp_u);
+
+ Lisp_Object *saved_cu = dynlib_sym (handle, COMP_UNIT_SYM);
+ if (!saved_cu)
+ xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file);
+ comp_u->loaded_once = !NILP (*saved_cu);
+ Lisp_Object *data_eph_relocs =
+ dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM);
+
+ /* While resurrecting from an image dump loading more than once the
+ same compilation unit does not make any sense. */
+ eassert (!(loading_dump && comp_u->loaded_once));
+
+ if (comp_u->loaded_once)
+ /* 'dlopen' returns the same handle when trying to load two times
+ the same shared. In this case touching 'd_reloc' etc leads to
+ fails in case a frame with a reference to it in a live reg is
+ active (comp-speed > 0).
+
+ We must *never* mess with static pointers in an already loaded
+ eln. */
+ {
+ comp_u_lisp_obj = *saved_cu;
+ comp_u = XNATIVE_COMP_UNIT (comp_u_lisp_obj);
+ comp_u->loaded_once = true;
+ }
+ else
+ *saved_cu = comp_u_lisp_obj;
+
+ /* Once we are sure to have the right compilation unit we want to
+ identify is we have at least another load active on it. */
+ bool recursive_load = comp_u->load_ongoing;
+ comp_u->load_ongoing = true;
+ ptrdiff_t count = SPECPDL_INDEX ();
+ if (!recursive_load)
+ record_unwind_protect (unset_cu_load_ongoing, comp_u_lisp_obj);
+
+ freloc_check_fill ();
+
+ Lisp_Object (*top_level_run)(Lisp_Object)
+ = dynlib_sym (handle,
+ late_load ? "late_top_level_run" : "top_level_run");
+
+ /* Always set data_imp_relocs pointer in the compilation unit (in can be
+ used in 'dump_do_dump_relocation'). */
+ comp_u->data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM);
+
+ if (!comp_u->loaded_once)
+ {
+ struct thread_state ***current_thread_reloc =
+ dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM);
+ void **pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM);
+ Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM);
+ Lisp_Object *data_imp_relocs = comp_u->data_imp_relocs;
+ void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM);
+
+ if (!(current_thread_reloc
+ && pure_reloc
+ && data_relocs
+ && data_imp_relocs
+ && data_eph_relocs
+ && freloc_link_table
+ && top_level_run)
+ || NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM),
+ Vcomp_abi_hash)))
+ xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file);
+
+ *current_thread_reloc = ¤t_thread;
+ *pure_reloc = pure;
+
+ /* Imported functions. */
+ *freloc_link_table = freloc.link_table;
+
+ /* Imported data. */
+ if (!loading_dump)
+ {
+ comp_u->optimize_qualities =
+ load_static_obj (comp_u, TEXT_OPTIM_QLY_SYM);
+ comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM);
+ comp_u->data_impure_vec =
+ load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM);
+
+ if (!NILP (Vpurify_flag))
+ /* Non impure can be copied into pure space. */
+ comp_u->data_vec = Fpurecopy (comp_u->data_vec);
+ }
+
+ EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec));
+ for (EMACS_INT i = 0; i < d_vec_len; i++)
+ data_relocs[i] = AREF (comp_u->data_vec, i);
+
+ d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec));
+ for (EMACS_INT i = 0; i < d_vec_len; i++)
+ data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i);
+ }
+
+ if (!loading_dump)
+ {
+ /* Note: data_ephemeral_vec is not GC protected except than by
+ this function frame. After this functions will be
+ deactivated GC will be free to collect it, but it MUST
+ survive till 'top_level_run' has finished his job. We store
+ into the ephemeral allocation class only objects that we know
+ are necessary exclusively during the first load. Once these
+ are collected we don't have to maintain them in the heap
+ forever. */
+ Lisp_Object volatile data_ephemeral_vec;
+ /* In case another load of the same CU is active on the stack
+ all ephemeral data is hold by that frame. Re-writing
+ 'data_ephemeral_vec' would be not only a waste of cycles but
+ more importantly would lead to crashes if the contained data
+ is not cons hashed. */
+ if (!recursive_load)
+ {
+ data_ephemeral_vec =
+ load_static_obj (comp_u, TEXT_DATA_RELOC_EPHEMERAL_SYM);
+
+ EMACS_INT d_vec_len = XFIXNUM (Flength (data_ephemeral_vec));
+ for (EMACS_INT i = 0; i < d_vec_len; i++)
+ data_eph_relocs[i] = AREF (data_ephemeral_vec, i);
+ }
+ /* Executing this will perform all the expected environment
+ modifications. */
+ res = top_level_run (comp_u_lisp_obj);
+ /* Make sure data_ephemeral_vec still exists after top_level_run has run.
+ Guard against sibling call optimization (or any other). */
+ data_ephemeral_vec = data_ephemeral_vec;
+ eassert (check_comp_unit_relocs (comp_u));
+ }
+
+ if (!recursive_load)
+ /* Clean-up the load ongoing flag in case. */
+ unbind_to (count, Qnil);
+
+ register_native_comp_unit (comp_u_lisp_obj);
+
+ return res;
+}
+
+void
+unload_comp_unit (struct Lisp_Native_Comp_Unit *cu)
+{
+ if (cu->handle == NULL)
+ return;
+
+ Lisp_Object *saved_cu = dynlib_sym (cu->handle, COMP_UNIT_SYM);
+ Lisp_Object this_cu;
+ XSETNATIVE_COMP_UNIT (this_cu, cu);
+ if (EQ (this_cu, *saved_cu))
+ *saved_cu = Qnil;
+ dynlib_close (cu->handle);
+}
+
+Lisp_Object
+native_function_doc (Lisp_Object function)
+{
+ struct Lisp_Native_Comp_Unit *cu =
+ XNATIVE_COMP_UNIT (Fsubr_native_comp_unit (function));
+
+ if (NILP (cu->data_fdoc_v))
+ cu->data_fdoc_v = load_static_obj (cu, TEXT_FDOC_SYM);
+ if (!VECTORP (cu->data_fdoc_v))
+ xsignal2 (Qnative_lisp_file_inconsistent, cu->file,
+ build_string ("missing documentation vector"));
+ return AREF (cu->data_fdoc_v, XSUBR (function)->doc);
+}
+
+static Lisp_Object
+make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg,
+ Lisp_Object c_name, Lisp_Object type, Lisp_Object doc_idx,
+ Lisp_Object intspec, Lisp_Object comp_u)
+{
+ struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u);
+ dynlib_handle_ptr handle = cu->handle;
+ if (!handle)
+ xsignal0 (Qwrong_register_subr_call);
+
+ void *func = dynlib_sym (handle, SSDATA (c_name));
+ eassert (func);
+ union Aligned_Lisp_Subr *x =
+ (union Aligned_Lisp_Subr *) allocate_pseudovector (
+ VECSIZE (union Aligned_Lisp_Subr),
+ 0, VECSIZE (union Aligned_Lisp_Subr),
+ PVEC_SUBR);
+ if (CONSP (minarg))
+ {
+ /* Dynamic code. */
+ x->s.lambda_list[0] = maxarg;
+ maxarg = XCDR (minarg);
+ minarg = XCAR (minarg);
+ }
+ else
+ x->s.lambda_list[0] = Qnil;
+ x->s.function.a0 = func;
+ x->s.min_args = XFIXNUM (minarg);
+ x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY;
+ x->s.symbol_name = xstrdup (SSDATA (symbol_name));
+ x->s.native_intspec = intspec;
+ x->s.doc = XFIXNUM (doc_idx);
+ x->s.native_comp_u[0] = comp_u;
+ x->s.native_c_name[0] = xstrdup (SSDATA (c_name));
+ x->s.type[0] = type;
+ Lisp_Object tem;
+ XSETSUBR (tem, &x->s);
+
+ return tem;
+}
+
+DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda,
+ 7, 7, 0,
+ doc: /* Register anonymous lambda.
+This gets called by top_level_run during the load phase. */)
+ (Lisp_Object reloc_idx, Lisp_Object c_name, Lisp_Object minarg,
+ Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest,
+ Lisp_Object comp_u)
+{
+ Lisp_Object doc_idx = FIRST (rest);
+ Lisp_Object intspec = SECOND (rest);
+ struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u);
+ if (cu->loaded_once)
+ return Qnil;
+
+ Lisp_Object tem =
+ make_subr (c_name, minarg, maxarg, c_name, type, doc_idx, intspec, comp_u);
+
+ /* We must protect it against GC because the function is not
+ reachable through symbols. */
+ Fputhash (tem, Qt, cu->lambda_gc_guard_h);
+ /* This is for fixing up the value in d_reloc while resurrecting
+ from dump. See 'dump_do_dump_relocation'. */
+ eassert (NILP (Fgethash (c_name, cu->lambda_c_name_idx_h, Qnil)));
+ Fputhash (c_name, reloc_idx, cu->lambda_c_name_idx_h);
+ /* Do the real relocation fixup. */
+ cu->data_imp_relocs[XFIXNUM (reloc_idx)] = tem;
+
+ return tem;
+}
+
+DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr,
+ 7, 7, 0,
+ doc: /* Register exported subr.
+This gets called by top_level_run during the load phase. */)
+ (Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg,
+ Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest,
+ Lisp_Object comp_u)
+{
+ Lisp_Object doc_idx = FIRST (rest);
+ Lisp_Object intspec = SECOND (rest);
+ Lisp_Object tem =
+ make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, type, doc_idx,
+ intspec, comp_u);
+
+ if (AUTOLOADP (XSYMBOL (name)->u.s.function))
+ /* Remember that the function was already an autoload. */
+ LOADHIST_ATTACH (Fcons (Qt, name));
+ LOADHIST_ATTACH (Fcons (Qdefun, name));
+
+ { /* Handle automatic advice activation (bug#42038).
+ See `defalias'. */
+ Lisp_Object hook = Fget (name, Qdefalias_fset_function);
+ if (!NILP (hook))
+ call2 (hook, name, tem);
+ else
+ Ffset (name, tem);
+ }
+
+ return tem;
+}
+
+DEFUN ("comp--late-register-subr", Fcomp__late_register_subr,
+ Scomp__late_register_subr, 7, 7, 0,
+ doc: /* Register exported subr.
+This gets called by late_top_level_run during the load phase. */)
+ (Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg,
+ Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest,
+ Lisp_Object comp_u)
+{
+ if (!NILP (Fequal (Fsymbol_function (name),
+ Fgethash (name, Vcomp_deferred_pending_h, Qnil))))
+ Fcomp__register_subr (name, c_name, minarg, maxarg, type, rest, comp_u);
+ Fremhash (name, Vcomp_deferred_pending_h);
+ return Qnil;
+}
+
+static bool
+file_in_eln_sys_dir (Lisp_Object filename)
+{
+ Lisp_Object eln_sys_dir = Qnil;
+ Lisp_Object tmp = Vcomp_eln_load_path;
+ FOR_EACH_TAIL (tmp)
+ eln_sys_dir = XCAR (tmp);
+ return !NILP (Fstring_match (Fregexp_quote (Fexpand_file_name (eln_sys_dir,
+ Qnil)),
+ Fexpand_file_name (filename, Qnil), Qnil));
+}
+
+/* Load related routines. */
+DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0,
+ doc: /* Load native elisp code FILENAME.
+LATE_LOAD has to be non-nil when loading for deferred compilation. */)
+ (Lisp_Object filename, Lisp_Object late_load)
+{
+ CHECK_STRING (filename);
+ if (NILP (Ffile_exists_p (filename)))
+ xsignal2 (Qnative_lisp_load_failed, build_string ("file does not exists"),
+ filename);
+ struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit ();
+ Lisp_Object encoded_filename = ENCODE_FILE (filename);
+
+ if (!NILP (Fgethash (filename, all_loaded_comp_units_h, Qnil))
+ && !file_in_eln_sys_dir (filename)
+ && !NILP (Ffile_writable_p (filename)))
+ {
+ /* If in this session there was ever a file loaded with this
+ name, rename it before loading, to make sure we always get a
+ new handle! */
+ Lisp_Object tmp_filename =
+ Fmake_temp_file_internal (filename, Qnil, build_string (".eln.tmp"),
+ Qnil);
+ if (NILP (Ffile_writable_p (tmp_filename)))
+ comp_u->handle = dynlib_open (SSDATA (encoded_filename));
+ else
+ {
+ Frename_file (filename, tmp_filename, Qt);
+ comp_u->handle = dynlib_open (SSDATA (ENCODE_FILE (tmp_filename)));
+ Frename_file (tmp_filename, filename, Qnil);
+ }
+ }
+ else
+ comp_u->handle = dynlib_open (SSDATA (encoded_filename));
+
+ if (!comp_u->handle)
+ xsignal2 (Qnative_lisp_load_failed, filename,
+ build_string (dynlib_error ()));
+ comp_u->file = filename;
+ comp_u->data_vec = Qnil;
+ comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq);
+ comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal);
+ return load_comp_unit (comp_u, false, !NILP (late_load));
+}
+
+#endif /* HAVE_NATIVE_COMP */
+
+DEFUN ("native-comp-available-p", Fnative_comp_available_p,
+ Snative_comp_available_p, 0, 0, 0,
+ doc: /* Return non-nil if native compilation support is built-in. */)
+ (void)
+{
+#ifdef HAVE_NATIVE_COMP
+ return load_gccjit_if_necessary (false) ? Qt : Qnil;
+#else
+ return Qnil;
+#endif
+}
+
+
+void
+syms_of_comp (void)
+{
+#ifdef HAVE_NATIVE_COMP
+ /* Compiler control customizes. */
+ DEFVAR_BOOL ("comp-deferred-compilation", comp_deferred_compilation,
+ doc: /* If non-nil compile loaded .elc files asynchronously.
+
+After compilation, each function definition is updated to the native
+compiled one. */);
+ comp_deferred_compilation = true;
+
+ DEFSYM (Qcomp_speed, "comp-speed");
+ DEFSYM (Qcomp_debug, "comp-debug");
+ DEFSYM (Qcomp_native_driver_options, "comp-native-driver-options");
+ DEFSYM (Qcomp_libgccjit_reproducer, "comp-libgccjit-reproducer");
+
+ /* Limple instruction set. */
+ DEFSYM (Qcomment, "comment");
+ DEFSYM (Qjump, "jump");
+ DEFSYM (Qcall, "call");
+ DEFSYM (Qcallref, "callref");
+ DEFSYM (Qdirect_call, "direct-call");
+ DEFSYM (Qdirect_callref, "direct-callref");
+ DEFSYM (Qassume, "assume");
+ DEFSYM (Qsetimm, "setimm");
+ DEFSYM (Qreturn, "return");
+ DEFSYM (Qunreachable, "unreachable");
+ DEFSYM (Qcomp_mvar, "comp-mvar");
+ DEFSYM (Qcond_jump, "cond-jump");
+ DEFSYM (Qphi, "phi");
+ /* Ops in use for prologue emission. */
+ DEFSYM (Qset_par_to_local, "set-par-to-local");
+ DEFSYM (Qset_args_to_local, "set-args-to-local");
+ DEFSYM (Qset_rest_args_to_local, "set-rest-args-to-local");
+ DEFSYM (Qinc_args, "inc-args");
+ DEFSYM (Qcond_jump_narg_leq, "cond-jump-narg-leq");
+ /* Others. */
+ DEFSYM (Qpush_handler, "push-handler");
+ DEFSYM (Qpop_handler, "pop-handler");
+ DEFSYM (Qfetch_handler, "fetch-handler");
+ DEFSYM (Qcondition_case, "condition-case");
+ /* call operands. */
+ DEFSYM (Qcatcher, "catcher");
+ DEFSYM (Qentry, "entry");
+ DEFSYM (Qset_internal, "set_internal");
+ DEFSYM (Qrecord_unwind_current_buffer, "record_unwind_current_buffer");
+ DEFSYM (Qrecord_unwind_protect_excursion, "record_unwind_protect_excursion");
+ DEFSYM (Qhelper_unbind_n, "helper_unbind_n");
+ DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect");
+ DEFSYM (Qhelper_save_restriction, "helper_save_restriction");
+ /* Inliners. */
+ DEFSYM (Qadd1, "1+");
+ DEFSYM (Qsub1, "1-");
+ DEFSYM (Qconsp, "consp");
+ DEFSYM (Qcar, "car");
+ DEFSYM (Qcdr, "cdr");
+ DEFSYM (Qsetcar, "setcar");
+ DEFSYM (Qsetcdr, "setcdr");
+ DEFSYM (Qnegate, "negate");
+ DEFSYM (Qnumberp, "numberp");
+ DEFSYM (Qintegerp, "integerp");
+ DEFSYM (Qcomp_maybe_gc_or_quit, "comp-maybe-gc-or-quit");
+
+ /* Allocation classes. */
+ DEFSYM (Qd_default, "d-default");
+ DEFSYM (Qd_impure, "d-impure");
+ DEFSYM (Qd_ephemeral, "d-ephemeral");
+
+ /* Others. */
+ DEFSYM (Qcomp, "comp");
+ DEFSYM (Qfixnum, "fixnum");
+ DEFSYM (Qscratch, "scratch");
+ DEFSYM (Qlate, "late");
+ DEFSYM (Qlambda_fixup, "lambda-fixup");
+ DEFSYM (Qgccjit, "gccjit");
+ DEFSYM (Qcomp_subr_trampoline_install, "comp-subr-trampoline-install");
+ DEFSYM (Qcomp_warning_on_missing_source, "comp-warning-on-missing-source");
+
+ /* To be signaled by the compiler. */
+ DEFSYM (Qnative_compiler_error, "native-compiler-error");
+ Fput (Qnative_compiler_error, Qerror_conditions,
+ pure_list (Qnative_compiler_error, Qerror));
+ Fput (Qnative_compiler_error, Qerror_message,
+ build_pure_c_string ("Native compiler error"));
+
+ DEFSYM (Qnative_ice, "native-ice");
+ Fput (Qnative_ice, Qerror_conditions,
+ pure_list (Qnative_ice, Qnative_compiler_error, Qerror));
+ Fput (Qnative_ice, Qerror_message,
+ build_pure_c_string ("Internal native compiler error"));
+
+ /* By the load machinery. */
+ DEFSYM (Qnative_lisp_load_failed, "native-lisp-load-failed");
+ Fput (Qnative_lisp_load_failed, Qerror_conditions,
+ pure_list (Qnative_lisp_load_failed, Qerror));
+ Fput (Qnative_lisp_load_failed, Qerror_message,
+ build_pure_c_string ("Native elisp load failed"));
+
+ DEFSYM (Qnative_lisp_wrong_reloc, "native-lisp-wrong-reloc");
+ Fput (Qnative_lisp_wrong_reloc, Qerror_conditions,
+ pure_list (Qnative_lisp_wrong_reloc, Qnative_lisp_load_failed, Qerror));
+ Fput (Qnative_lisp_wrong_reloc, Qerror_message,
+ build_pure_c_string ("Primitive redefined or wrong relocation"));
+
+ DEFSYM (Qwrong_register_subr_call, "wrong-register-subr-call");
+ Fput (Qwrong_register_subr_call, Qerror_conditions,
+ pure_list (Qwrong_register_subr_call, Qnative_lisp_load_failed,
Qerror));
+ Fput (Qwrong_register_subr_call, Qerror_message,
+ build_pure_c_string ("comp--register-subr can only be called during "
+ "native lisp load phase."));
+
+ DEFSYM (Qnative_lisp_file_inconsistent, "native-lisp-file-inconsistent");
+ Fput (Qnative_lisp_file_inconsistent, Qerror_conditions,
+ pure_list (Qnative_lisp_file_inconsistent, Qnative_lisp_load_failed,
Qerror));
+ Fput (Qnative_lisp_file_inconsistent, Qerror_message,
+ build_pure_c_string ("eln file inconsistent with current runtime "
+ "configuration, please recompile"));
+
+ defsubr (&Scomp__subr_signature);
+ defsubr (&Scomp_el_to_eln_rel_filename);
+ defsubr (&Scomp_el_to_eln_filename);
+ defsubr (&Scomp_native_driver_options_effective_p);
+ defsubr (&Scomp__install_trampoline);
+ defsubr (&Scomp__init_ctxt);
+ defsubr (&Scomp__release_ctxt);
+ defsubr (&Scomp__compile_ctxt_to_file);
+ defsubr (&Scomp_libgccjit_version);
+ defsubr (&Scomp__register_lambda);
+ defsubr (&Scomp__register_subr);
+ defsubr (&Scomp__late_register_subr);
+ defsubr (&Snative_elisp_load);
+
+ staticpro (&comp.exported_funcs_h);
+ comp.exported_funcs_h = Qnil;
+ staticpro (&comp.imported_funcs_h);
+ comp.imported_funcs_h = Qnil;
+ staticpro (&comp.func_blocks_h);
+ staticpro (&comp.emitter_dispatcher);
+ comp.emitter_dispatcher = Qnil;
+ staticpro (&delayed_sources);
+ delayed_sources = Qnil;
+ staticpro (&loadsearch_re_list);
+ loadsearch_re_list = Qnil;
+
+ staticpro (&all_loaded_comp_units_h);
+ all_loaded_comp_units_h =
+ CALLN (Fmake_hash_table, QCweakness, Qkey_and_value, QCtest, Qequal);
+
+ DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt,
+ doc: /* The compiler context. */);
+ Vcomp_ctxt = Qnil;
+
+ /* FIXME should be initialized but not here... Plus this don't have
+ to be necessarily exposed to lisp but can easy debug for now. */
+ DEFVAR_LISP ("comp-subr-list", Vcomp_subr_list,
+ doc: /* List of all defined subrs. */);
+ DEFVAR_LISP ("comp-abi-hash", Vcomp_abi_hash,
+ doc: /* String signing the .eln files ABI. */);
+ Vcomp_abi_hash = Qnil;
+ DEFVAR_LISP ("comp-native-version-dir", Vcomp_native_version_dir,
+ doc: /* Directory in use to disambiguate eln compatibility. */);
+ Vcomp_native_version_dir = Qnil;
+
+ DEFVAR_LISP ("comp-deferred-pending-h", Vcomp_deferred_pending_h,
+ doc: /* Hash table symbol-name -> function-value.
+For internal use. */);
+ Vcomp_deferred_pending_h = CALLN (Fmake_hash_table, QCtest, Qeq);
+
+ DEFVAR_LISP ("comp-eln-to-el-h", Vcomp_eln_to_el_h,
+ doc: /* Hash table eln-filename -> el-filename. */);
+ Vcomp_eln_to_el_h = CALLN (Fmake_hash_table, QCtest, Qequal);
+
+ DEFVAR_LISP ("comp-eln-load-path", Vcomp_eln_load_path,
+ doc: /* List of eln cache directories.
+
+If a directory is non absolute is assumed to be relative to
+`invocation-directory'.
+`comp-native-version-dir' value is used as a sub-folder name inside
+each eln cache directory.
+The last directory of this list is assumed to be the system one. */);
+
+ /* Temporary value in use for bootstrap. We can't do better as
+ `invocation-directory' is still unset, will be fixed up during
+ dump reload. */
+ Vcomp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil);
+
+ DEFVAR_BOOL ("comp-enable-subr-trampolines", comp_enable_subr_trampolines,
+ doc: /* If non-nil enable primitive trampoline synthesis.
+This makes primitive functions redefinable or advisable effectively. */);
+
+ DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h,
+ doc: /* Hash table subr-name -> installed trampoline.
+This is used to prevent double trampoline instantiation but also to
+protect the trampolines against GC. */);
+ Vcomp_installed_trampolines_h = CALLN (Fmake_hash_table);
+
+ DEFVAR_LISP ("comp-no-native-file-h", V_comp_no_native_file_h,
+ doc: /* Files for which no deferred compilation has to
+be performed because the bytecode version was explicitly requested by
+the user during load.
+For internal use. */);
+ V_comp_no_native_file_h = CALLN (Fmake_hash_table, QCtest, Qequal);
+
+ DEFVAR_BOOL ("comp-file-preloaded-p", comp_file_preloaded_p,
+ doc: /* When non-nil assume the file being compiled to
+be preloaded. */);
+
+ Fprovide (intern_c_string ("nativecomp"), Qnil);
+#endif /* #ifdef HAVE_NATIVE_COMP */
+
+ defsubr (&Snative_comp_available_p);
+}
diff --git a/src/comp.h b/src/comp.h
new file mode 100644
index 0000000..c4af419
--- /dev/null
+++ b/src/comp.h
@@ -0,0 +1,114 @@
+/* Elisp native compiler definitions
+
+Copyright (C) 2019-2021 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
+
+#ifndef COMP_H
+#define COMP_H
+
+/* To keep ifdefs under control. */
+enum {
+ NATIVE_COMP_FLAG =
+#ifdef HAVE_NATIVE_COMP
+ 1
+#else
+ 0
+#endif
+};
+
+#include <dynlib.h>
+
+struct Lisp_Native_Comp_Unit
+{
+ union vectorlike_header header;
+ /* The original eln file loaded. In the pdumper file this is stored
+ as a cons cell of 2 alternative file names: the car is the
+ filename relative to the directory of an installed binary, the
+ cdr is the filename relative to the directory of an uninstalled
+ binary. This is arranged in loadup.el. */
+ Lisp_Object file;
+ Lisp_Object optimize_qualities;
+ /* Guard anonymous lambdas against Garbage Collection and serve
+ sanity checks. */
+ Lisp_Object lambda_gc_guard_h;
+ /* Hash c_name -> d_reloc_imp index. */
+ Lisp_Object lambda_c_name_idx_h;
+ /* Hash doc-idx -> function documentation. */
+ Lisp_Object data_fdoc_v;
+ /* Analogous to the constant vector but per compilation unit. */
+ Lisp_Object data_vec;
+ /* 'data_impure_vec' must be last (see allocate_native_comp_unit).
+ Same as data_vec but for data that cannot be moved to pure space. */
+ Lisp_Object data_impure_vec;
+ /* STUFFS WE DO NOT DUMP!! */
+ Lisp_Object *data_imp_relocs;
+ bool loaded_once;
+ bool load_ongoing;
+ dynlib_handle_ptr handle;
+} GCALIGNED_STRUCT;
+
+#ifdef HAVE_NATIVE_COMP
+
+INLINE bool
+NATIVE_COMP_UNITP (Lisp_Object a)
+{
+ return PSEUDOVECTORP (a, PVEC_NATIVE_COMP_UNIT);
+}
+
+INLINE struct Lisp_Native_Comp_Unit *
+XNATIVE_COMP_UNIT (Lisp_Object a)
+{
+ eassert (NATIVE_COMP_UNITP (a));
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Native_Comp_Unit);
+}
+
+/* Defined in comp.c. */
+
+extern void hash_native_abi (void);
+
+extern Lisp_Object load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u,
+ bool loading_dump, bool late_load);
+
+extern void unload_comp_unit (struct Lisp_Native_Comp_Unit *);
+
+extern Lisp_Object native_function_doc (Lisp_Object function);
+
+extern void syms_of_comp (void);
+
+extern void maybe_defer_native_compilation (Lisp_Object function_name,
+ Lisp_Object definition);
+
+extern void eln_load_path_final_clean_up (void);
+
+extern void fixup_eln_load_path (Lisp_Object directory);
+
+#else /* #ifdef HAVE_NATIVE_COMP */
+
+static inline void
+maybe_defer_native_compilation (Lisp_Object function_name,
+ Lisp_Object definition)
+{}
+
+static inline
+void unload_comp_unit (struct Lisp_Native_Comp_Unit *cu)
+{}
+
+extern void syms_of_comp (void);
+
+#endif /* #ifdef HAVE_NATIVE_COMP */
+
+#endif /* #ifndef COMP_H */
diff --git a/src/data.c b/src/data.c
index 3667b03..d547f5d 100644
--- a/src/data.c
+++ b/src/data.c
@@ -88,12 +88,6 @@ XOBJFWD (lispfwd a)
}
static void
-CHECK_SUBR (Lisp_Object x)
-{
- CHECK_TYPE (SUBRP (x), Qsubrp, x);
-}
-
-static void
set_blv_found (struct Lisp_Buffer_Local_Value *blv, int found)
{
eassert (found == !EQ (blv->defcell, blv->valcell));
@@ -259,6 +253,8 @@ for example, (type-of 1) returns `integer'. */)
}
case PVEC_MODULE_FUNCTION:
return Qmodule_function;
+ case PVEC_NATIVE_COMP_UNIT:
+ return Qnative_comp_unit;
case PVEC_XWIDGET:
return Qxwidget;
case PVEC_XWIDGET_VIEW:
@@ -779,6 +775,13 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
eassert (valid_lisp_object_p (definition));
+#ifdef HAVE_NATIVE_COMP
+ if (comp_enable_subr_trampolines
+ && SUBRP (function)
+ && !SUBR_NATIVE_COMPILEDP (function))
+ CALLN (Ffuncall, Qcomp_subr_trampoline_install, symbol);
+#endif
+
set_symbol_function (symbol, definition);
return definition;
@@ -824,6 +827,8 @@ The return value is undefined. */)
Ffset (symbol, definition);
}
+ maybe_defer_native_compilation (symbol, definition);
+
if (!NILP (docstring))
Fput (symbol, Qfunction_documentation, docstring);
/* We used to return `definition', but now that `defun' and `defmacro' expand
@@ -870,6 +875,72 @@ SUBR must be a built-in function. */)
return build_string (name);
}
+DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1,
+ 0, doc: /* Return t if the object is native compiled lisp
+function, nil otherwise. */)
+ (Lisp_Object object)
+{
+ return SUBR_NATIVE_COMPILEDP (object) ? Qt : Qnil;
+}
+
+DEFUN ("subr-native-lambda-list", Fsubr_native_lambda_list,
+ Ssubr_native_lambda_list, 1, 1, 0,
+ doc: /* Return the lambda list for a native compiled lisp/d
+function or t otherwise. */)
+ (Lisp_Object subr)
+{
+ CHECK_SUBR (subr);
+
+ return SUBR_NATIVE_COMPILED_DYNP (subr)
+ ? XSUBR (subr)->lambda_list[0]
+ : Qt;
+}
+
+DEFUN ("subr-type", Fsubr_type,
+ Ssubr_type, 1, 1, 0,
+ doc: /* Return the type of SUBR. */)
+ (Lisp_Object subr)
+{
+ CHECK_SUBR (subr);
+#ifdef HAVE_NATIVE_COMP
+ return SUBR_TYPE (subr);
+#else
+ return Qnil;
+#endif
+}
+
+#ifdef HAVE_NATIVE_COMP
+
+DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit,
+ Ssubr_native_comp_unit, 1, 1, 0,
+ doc: /* Return the native compilation unit. */)
+ (Lisp_Object subr)
+{
+ CHECK_SUBR (subr);
+ return XSUBR (subr)->native_comp_u[0];
+}
+
+DEFUN ("native-comp-unit-file", Fnative_comp_unit_file,
+ Snative_comp_unit_file, 1, 1, 0,
+ doc: /* Return the file of the native compilation unit. */)
+ (Lisp_Object comp_unit)
+{
+ CHECK_TYPE (NATIVE_COMP_UNITP (comp_unit), Qnative_comp_unit, comp_unit);
+ return XNATIVE_COMP_UNIT (comp_unit)->file;
+}
+
+DEFUN ("native-comp-unit-set-file", Fnative_comp_unit_set_file,
+ Snative_comp_unit_set_file, 2, 2, 0,
+ doc: /* Return the file of the native compilation unit. */)
+ (Lisp_Object comp_unit, Lisp_Object new_file)
+{
+ CHECK_TYPE (NATIVE_COMP_UNITP (comp_unit), Qnative_comp_unit, comp_unit);
+ XNATIVE_COMP_UNIT (comp_unit)->file = new_file;
+ return comp_unit;
+}
+
+#endif
+
DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0,
doc: /* Return the interactive form of CMD or nil if none.
If CMD is not a command, the return value is nil.
@@ -895,6 +966,9 @@ Value, if non-nil, is a list (interactive SPEC). */)
if (SUBRP (fun))
{
+ if (SUBR_NATIVE_COMPILEDP (fun) && !NILP (XSUBR (fun)->native_intspec))
+ return XSUBR (fun)->native_intspec;
+
const char *spec = XSUBR (fun)->intspec;
if (spec)
return list2 (Qinteractive,
@@ -3961,6 +4035,7 @@ syms_of_data (void)
DEFSYM (Qoverlay, "overlay");
DEFSYM (Qfinalizer, "finalizer");
DEFSYM (Qmodule_function, "module-function");
+ DEFSYM (Qnative_comp_unit, "native-comp-unit");
DEFSYM (Quser_ptr, "user-ptr");
DEFSYM (Qfloat, "float");
DEFSYM (Qwindow_configuration, "window-configuration");
@@ -4085,6 +4160,14 @@ syms_of_data (void)
defsubr (&Sbyteorder);
defsubr (&Ssubr_arity);
defsubr (&Ssubr_name);
+ defsubr (&Ssubr_native_elisp_p);
+ defsubr (&Ssubr_native_lambda_list);
+ defsubr (&Ssubr_type);
+#ifdef HAVE_NATIVE_COMP
+ defsubr (&Ssubr_native_comp_unit);
+ defsubr (&Snative_comp_unit_file);
+ defsubr (&Snative_comp_unit_set_file);
+#endif
#ifdef HAVE_MODULES
defsubr (&Suser_ptrp);
#endif
diff --git a/src/decompress.c b/src/decompress.c
index 4839249..17224f6 100644
--- a/src/decompress.c
+++ b/src/decompress.c
@@ -25,6 +25,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "lisp.h"
#include "buffer.h"
#include "composite.h"
+#include "md5.h"
#include <verify.h>
@@ -66,6 +67,107 @@ init_zlib_functions (void)
#endif /* WINDOWSNT */
+
+#define MD5_BLOCKSIZE 32768 /* From md5.c */
+
+static char acc_buff[2 * MD5_BLOCKSIZE];
+static size_t acc_size;
+
+static void
+accumulate_and_process_md5 (void *data, size_t len, struct md5_ctx *ctxt)
+{
+ eassert (len <= MD5_BLOCKSIZE);
+ /* We may optimize this saving some of these memcpy/move using
+ directly the outer buffers but so far don't bother. */
+ memcpy (acc_buff + acc_size, data, len);
+ acc_size += len;
+ if (acc_size >= MD5_BLOCKSIZE)
+ {
+ acc_size -= MD5_BLOCKSIZE;
+ md5_process_block (acc_buff, MD5_BLOCKSIZE, ctxt);
+ memmove (acc_buff, acc_buff + MD5_BLOCKSIZE, acc_size);
+ }
+}
+
+static void
+final_process_md5 (struct md5_ctx *ctxt)
+{
+ if (acc_size)
+ {
+ md5_process_bytes (acc_buff, acc_size, ctxt);
+ acc_size = 0;
+ }
+}
+
+int
+md5_gz_stream (FILE *source, void *resblock)
+{
+ z_stream stream;
+ unsigned char in[MD5_BLOCKSIZE];
+ unsigned char out[MD5_BLOCKSIZE];
+
+#ifdef WINDOWSNT
+ if (!zlib_initialized)
+ zlib_initialized = init_zlib_functions ();
+ if (!zlib_initialized)
+ {
+ message1 ("zlib library not found");
+ return -1;
+ }
+#endif
+
+ eassert (!acc_size);
+
+ struct md5_ctx ctx;
+ md5_init_ctx (&ctx);
+
+ /* allocate inflate state */
+ stream.zalloc = Z_NULL;
+ stream.zfree = Z_NULL;
+ stream.opaque = Z_NULL;
+ stream.avail_in = 0;
+ stream.next_in = Z_NULL;
+ int res = inflateInit2 (&stream, MAX_WBITS + 32);
+ if (res != Z_OK)
+ return -1;
+
+ do {
+ stream.avail_in = fread (in, 1, MD5_BLOCKSIZE, source);
+ if (ferror (source)) {
+ inflateEnd (&stream);
+ return -1;
+ }
+ if (stream.avail_in == 0)
+ break;
+ stream.next_in = in;
+
+ do {
+ stream.avail_out = MD5_BLOCKSIZE;
+ stream.next_out = out;
+ res = inflate (&stream, Z_NO_FLUSH);
+
+ if (res != Z_OK && res != Z_STREAM_END)
+ return -1;
+
+ accumulate_and_process_md5 (out, MD5_BLOCKSIZE - stream.avail_out, &ctx);
+ } while (!stream.avail_out);
+
+ } while (res != Z_STREAM_END);
+
+ final_process_md5 (&ctx);
+ inflateEnd (&stream);
+
+ if (res != Z_STREAM_END)
+ return -1;
+
+ md5_finish_ctx (&ctx, resblock);
+
+ return 0;
+}
+#undef MD5_BLOCKSIZE
+
+
+
struct decompress_unwind_data
{
ptrdiff_t old_point, orig, start, nbytes;
diff --git a/src/dispextern.h b/src/dispextern.h
index f4e8726..213032d 100644
--- a/src/dispextern.h
+++ b/src/dispextern.h
@@ -1262,7 +1262,7 @@ extern struct glyph space_glyph;
/* True means last display completed. False means it was preempted. */
extern bool display_completed;
-
+extern bool delayed_size_change;
/************************************************************************
@@ -3066,6 +3066,11 @@ struct image
is created. */
unsigned long face_foreground, face_background;
+ /* Details of the font, only really relevant for types like SVG that
+ allow us to draw text. */
+ int face_font_size;
+ char *face_font_family;
+
/* True if this image has a `transparent' background -- that is, is
uses an image mask. The accessor macro for this is
`IMAGE_BACKGROUND_TRANSPARENT'. */
@@ -3636,7 +3641,7 @@ extern void gui_update_window_begin (struct window *);
extern void gui_update_window_end (struct window *, bool, bool);
#endif
void do_pending_window_change (bool);
-void change_frame_size (struct frame *, int, int, bool, bool, bool, bool);
+void change_frame_size (struct frame *, int, int, bool, bool, bool);
void init_display (void);
void syms_of_display (void);
extern void spec_glyph_lookup_face (struct window *, GLYPH *);
diff --git a/src/dispnew.c b/src/dispnew.c
index f613f7b..b3f7be6 100644
--- a/src/dispnew.c
+++ b/src/dispnew.c
@@ -102,7 +102,7 @@ bool display_completed;
/* True means SIGWINCH happened when not safe. */
-static bool delayed_size_change;
+bool delayed_size_change;
/* A glyph for a space. */
@@ -5770,32 +5770,34 @@ handle_window_change_signal (int sig)
termcap-controlled terminal, but we can't decide which.
Therefore, we resize the frames corresponding to each tty.
*/
- for (tty = tty_list; tty; tty = tty->next) {
+ for (tty = tty_list; tty; tty = tty->next)
+ {
+ if (! tty->term_initted)
+ continue;
- if (! tty->term_initted)
- continue;
+ /* Suspended tty frames have tty->input == NULL avoid trying to
+ use it. */
+ if (!tty->input)
+ continue;
- /* Suspended tty frames have tty->input == NULL avoid trying to
- use it. */
- if (!tty->input)
- continue;
+ get_tty_size (fileno (tty->input), &width, &height);
- get_tty_size (fileno (tty->input), &width, &height);
+ if (width > 5 && height > 2)
+ {
+ Lisp_Object tail, frame;
- if (width > 5 && height > 2) {
- Lisp_Object tail, frame;
+ FOR_EACH_FRAME (tail, frame)
+ {
+ struct frame *f = XFRAME (frame);
- FOR_EACH_FRAME (tail, frame)
- if (FRAME_TERMCAP_P (XFRAME (frame)) && FRAME_TTY (XFRAME (frame)) ==
tty)
- /* Record the new sizes, but don't reallocate the data
- structures now. Let that be done later outside of the
- signal handler. */
- change_frame_size (XFRAME (frame), width,
- height - FRAME_MENU_BAR_LINES (XFRAME (frame))
- - FRAME_TAB_BAR_LINES (XFRAME (frame)),
- 0, 1, 0, 0);
+ if (FRAME_TERMCAP_P (f) && FRAME_TTY (f) == tty)
+ /* Record the new sizes, but don't reallocate the data
+ structures now. Let that be done later outside of the
+ signal handler. */
+ change_frame_size (f, width, height, false, true, false);
+ }
+ }
}
- }
}
static void
@@ -5821,15 +5823,17 @@ do_pending_window_change (bool safe)
{
Lisp_Object tail, frame;
- delayed_size_change = 0;
+ delayed_size_change = false;
FOR_EACH_FRAME (tail, frame)
{
struct frame *f = XFRAME (frame);
- if (f->new_height != 0 || f->new_width != 0)
+ /* Negative new_width or new_height values mean no change is
+ required (a native size can never drop below zero). */
+ if (f->new_height >= 0 || f->new_width >= 0)
change_frame_size (f, f->new_width, f->new_height,
- 0, 0, safe, f->new_pixelwise);
+ false, false, safe);
}
}
}
@@ -5837,47 +5841,43 @@ do_pending_window_change (bool safe)
static void
change_frame_size_1 (struct frame *f, int new_width, int new_height,
- bool pretend, bool delay, bool safe, bool pixelwise)
+ bool pretend, bool delay, bool safe)
{
- /* If we can't deal with the change now, queue it for later. */
if (delay || (redisplaying_p && !safe))
{
+ if (CONSP (frame_size_history)
+ && ((new_width != f->new_width
+ || new_height != f->new_height
+ || new_width != FRAME_PIXEL_WIDTH (f)
+ || new_height != FRAME_PIXEL_HEIGHT (f))))
+ frame_size_history_extra
+ (f, build_string ("change_frame_size_1, delayed"),
+ FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f),
+ new_width, new_height, f->new_width, f->new_height);
+
+ /* We can't deal with the change now, queue it for later. */
f->new_width = new_width;
f->new_height = new_height;
- f->new_pixelwise = pixelwise;
- delayed_size_change = 1;
+ delayed_size_change = true;
}
else
{
- /* This size-change overrides any pending one for this frame. */
- f->new_height = 0;
- f->new_width = 0;
- f->new_pixelwise = 0;
-
- /* If an argument is zero, set it to the current value. */
- if (pixelwise)
- {
- new_width = (new_width <= 0) ? FRAME_TEXT_WIDTH (f) : new_width;
- new_height = (new_height <= 0) ? FRAME_TEXT_HEIGHT (f) : new_height;
- }
- else
- {
- new_width = (((new_width <= 0) ? FRAME_COLS (f) : new_width)
- * FRAME_COLUMN_WIDTH (f));
- new_height = (((new_height <= 0) ? FRAME_LINES (f) : new_height)
- * FRAME_LINE_HEIGHT (f));
- }
-
- /* Adjust frame size but make sure set_window_size_hook does not
- get called. */
- adjust_frame_size (f, new_width, new_height, 5, pretend,
- Qchange_frame_size);
+ /* Storing -1 in the new_width/new_height slots means that no size
+ change is pending. Native sizes are always non-negative. */
+ f->new_height = -1;
+ f->new_width = -1;
+ /* adjust_frame_size wants its arguments in terms of text_width
+ and text_height, so convert them here. For pathologically
+ small frames, the resulting values may be negative though. */
+ adjust_frame_size (f, FRAME_PIXEL_TO_TEXT_WIDTH (f, new_width),
+ FRAME_PIXEL_TO_TEXT_HEIGHT (f, new_height), 5,
+ pretend, Qchange_frame_size);
}
}
-/* Change text height/width of frame F. Values may be given as zero to
- indicate that no change is needed.
+/* Change native height/width of frame F to NEW_WIDTH/NEW_HEIGHT pixels.
+ Values may be given as -1 to indicate that no change is needed.
If DELAY, assume we're being called from a signal handler, and queue
the change for later - perhaps the next redisplay. Since this tries
@@ -5887,7 +5887,7 @@ change_frame_size_1 (struct frame *f, int new_width, int
new_height,
change frame sizes while a redisplay is in progress. */
void
change_frame_size (struct frame *f, int new_width, int new_height,
- bool pretend, bool delay, bool safe, bool pixelwise)
+ bool pretend, bool delay, bool safe)
{
Lisp_Object tail, frame;
@@ -5897,13 +5897,12 @@ change_frame_size (struct frame *f, int new_width, int
new_height,
size affects all frames. Termcap now supports multiple
ttys. */
FOR_EACH_FRAME (tail, frame)
- if (! FRAME_WINDOW_P (XFRAME (frame)))
+ if (!FRAME_WINDOW_P (XFRAME (frame)))
change_frame_size_1 (XFRAME (frame), new_width, new_height,
- pretend, delay, safe, pixelwise);
+ pretend, delay, safe);
}
else
- change_frame_size_1 (f, new_width, new_height, pretend, delay, safe,
- pixelwise);
+ change_frame_size_1 (f, new_width, new_height, pretend, delay, safe);
}
/***********************************************************************
@@ -6492,9 +6491,8 @@ init_display_interactive (void)
t->display_info.tty->top_frame = selected_frame;
change_frame_size (XFRAME (selected_frame),
FrameCols (t->display_info.tty),
- FrameRows (t->display_info.tty)
- - FRAME_MENU_BAR_LINES (f)
- - FRAME_TAB_BAR_LINES (f), 0, 0, 1, 0);
+ FrameRows (t->display_info.tty),
+ false, false, true);
/* Delete the initial terminal. */
if (--initial_terminal->reference_count == 0
diff --git a/src/doc.c b/src/doc.c
index 1307aa5..01f4368 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -327,6 +327,11 @@ string is passed through `substitute-command-keys'. */)
xsignal1 (Qvoid_function, function);
if (CONSP (fun) && EQ (XCAR (fun), Qmacro))
fun = XCDR (fun);
+#ifdef HAVE_NATIVE_COMP
+ if (!NILP (Fsubr_native_elisp_p (fun)))
+ doc = native_function_doc (fun);
+ else
+#endif
if (SUBRP (fun))
doc = make_fixnum (XSUBR (fun)->doc);
#ifdef HAVE_MODULES
@@ -495,10 +500,11 @@ store_function_docstring (Lisp_Object obj, EMACS_INT
offset)
XSETCAR (tem, make_fixnum (offset));
}
}
-
/* Lisp_Subrs have a slot for it. */
- else if (SUBRP (fun))
- XSUBR (fun)->doc = offset;
+ else if (SUBRP (fun) && !SUBR_NATIVE_COMPILEDP (fun))
+ {
+ XSUBR (fun)->doc = offset;
+ }
/* Bytecode objects sometimes have slots for it. */
else if (COMPILEDP (fun))
diff --git a/src/dynlib.c b/src/dynlib.c
index 86f8b7e..1338e91 100644
--- a/src/dynlib.c
+++ b/src/dynlib.c
@@ -301,15 +301,11 @@ dynlib_error (void)
return dlerror ();
}
-/* FIXME: Currently there is no way to unload a module, so this
- function is never used. */
-#if false
int
dynlib_close (dynlib_handle_ptr h)
{
return dlclose (h) == 0;
}
-#endif
#else
diff --git a/src/editfns.c b/src/editfns.c
index 87e743a..04b8e85 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -2941,6 +2941,8 @@ DEFUN ("propertize", Fpropertize, Spropertize, 1, MANY, 0,
First argument is the string to copy.
Remaining arguments form a sequence of PROPERTY VALUE pairs for text
properties to add to the result.
+
+See Info node `(elisp) Text Properties' for more information.
usage: (propertize STRING &rest PROPERTIES) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
@@ -3386,12 +3388,11 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool
message)
else
{
ptrdiff_t nch, nby;
- width = lisp_string_width (arg, prec, &nch, &nby);
+ nchars_string = SCHARS (arg);
+ width = lisp_string_width (arg, 0, nchars_string, prec,
+ &nch, &nby);
if (prec < 0)
- {
- nchars_string = SCHARS (arg);
- nbytes = SBYTES (arg);
- }
+ nbytes = SBYTES (arg);
else
{
nchars_string = nch;
diff --git a/src/emacs.c b/src/emacs.c
index fd08667..9157cd84 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -37,6 +37,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include <fcntl.h>
#include <sys/socket.h>
#include <mbstring.h>
+#include <filename.h> /* for IS_ABSOLUTE_FILE_NAME */
#include "w32.h"
#include "w32heap.h"
#endif
@@ -61,6 +62,21 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
# include <sys/socket.h>
#endif
+#if defined HAVE_LINUX_SECCOMP_H && defined HAVE_LINUX_FILTER_H \
+ && HAVE_DECL_SECCOMP_SET_MODE_FILTER \
+ && HAVE_DECL_SECCOMP_FILTER_FLAG_TSYNC
+# define SECCOMP_USABLE 1
+#else
+# define SECCOMP_USABLE 0
+#endif
+
+#if SECCOMP_USABLE
+# include <linux/seccomp.h>
+# include <linux/filter.h>
+# include <sys/prctl.h>
+# include <sys/syscall.h>
+#endif
+
#ifdef HAVE_WINDOW_SYSTEM
#include TERM_HEADER
#endif /* HAVE_WINDOW_SYSTEM */
@@ -241,6 +257,11 @@ Initialization options:\n\
--dump-file FILE read dumped state from FILE\n\
",
#endif
+#if SECCOMP_USABLE
+ "\
+--sandbox=FILE read Seccomp BPF filter from FILE\n\
+"
+#endif
"\
--no-build-details do not add build details such as time stamps\n\
--no-desktop do not load a saved desktop\n\
@@ -418,9 +439,9 @@ terminate_due_to_signal (int sig, int backtrace_limit)
/* This shouldn't be executed, but it prevents a warning. */
exit (1);
}
+
/* Code for dealing with Lisp access to the Unix command line. */
-
static void
init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd)
{
@@ -462,8 +483,8 @@ init_cmdargs (int argc, char **argv, int skip_args, char
const *original_pwd)
if (NILP (Vinvocation_directory))
{
Lisp_Object found;
- int yes = openp (Vexec_path, Vinvocation_name,
- Vexec_suffixes, &found, make_fixnum (X_OK), false);
+ int yes = openp (Vexec_path, Vinvocation_name, Vexec_suffixes,
+ &found, make_fixnum (X_OK), false, false);
if (yes == 1)
{
/* Add /: to the front of the name
@@ -718,15 +739,29 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t
*candidate_size)
implementation of malloc, since the caller calls our free. */
#ifdef WINDOWSNT
char *prog_fname = w32_my_exename ();
+ if (prog_fname)
+ *candidate_size = strlen (prog_fname) + 1;
return prog_fname ? xstrdup (prog_fname) : NULL;
#else /* !WINDOWSNT */
char *candidate = NULL;
/* If the executable name contains a slash, we have some kind of
- path already, so just copy it. */
+ path already, so just resolve symlinks and return the result. */
eassert (argv0);
if (strchr (argv0, DIRECTORY_SEP))
- return xstrdup (argv0);
+ {
+ char *real_name = realpath (argv0, NULL);
+
+ if (real_name)
+ {
+ *candidate_size = strlen (real_name) + 1;
+ return real_name;
+ }
+
+ char *val = xstrdup (argv0);
+ *candidate_size = strlen (val) + 1;
+ return val;
+ }
ptrdiff_t argv0_length = strlen (argv0);
const char *path = getenv ("PATH");
@@ -763,7 +798,22 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t
*candidate_size)
struct stat st;
if (file_access_p (candidate, X_OK)
&& stat (candidate, &st) == 0 && S_ISREG (st.st_mode))
- return candidate;
+ {
+ /* People put on PATH a symlink to the real Emacs
+ executable, with all the auxiliary files where the real
+ executable lives. Support that. */
+ if (lstat (candidate, &st) == 0 && S_ISLNK (st.st_mode))
+ {
+ char *real_name = realpath (candidate, NULL);
+
+ if (real_name)
+ {
+ *candidate_size = strlen (real_name) + 1;
+ return real_name;
+ }
+ }
+ return candidate;
+ }
*candidate = '\0';
}
while (*path++ != '\0');
@@ -777,6 +827,7 @@ load_pdump (int argc, char **argv)
{
const char *const suffix = ".pdmp";
int result;
+ char *emacs_executable = argv[0];
const char *strip_suffix =
#if defined DOS_NT || defined CYGWIN
".exe"
@@ -784,6 +835,7 @@ load_pdump (int argc, char **argv)
NULL
#endif
;
+ const char *argv0_base = "emacs";
/* TODO: maybe more thoroughly scrub process environment in order to
make this use case (loading a dump file in an unexeced emacs)
@@ -806,9 +858,19 @@ load_pdump (int argc, char **argv)
skip_args++;
}
+ /* Where's our executable? */
+ ptrdiff_t bufsize, exec_bufsize;
+ emacs_executable = load_pdump_find_executable (argv[0], &bufsize);
+ exec_bufsize = bufsize;
+
+ /* If we couldn't find our executable, go straight to looking for
+ the dump in the hardcoded location. */
+ if (!(emacs_executable && *emacs_executable))
+ goto hardcoded;
+
if (dump_file)
{
- result = pdumper_load (dump_file);
+ result = pdumper_load (dump_file, emacs_executable);
if (result != PDUMPER_LOAD_SUCCESS)
fatal ("could not load dump file \"%s\": %s",
@@ -822,49 +884,29 @@ load_pdump (int argc, char **argv)
so we can't use decode_env_path. We're working in whatever
encoding the system natively uses for filesystem access, so
there's no need for character set conversion. */
- ptrdiff_t bufsize;
- dump_file = load_pdump_find_executable (argv[0], &bufsize);
-
- /* If we couldn't find our executable, go straight to looking for
- the dump in the hardcoded location. */
- if (dump_file && *dump_file)
+ ptrdiff_t exenamelen = strlen (emacs_executable);
+ if (strip_suffix)
{
-#ifdef WINDOWSNT
- /* w32_my_exename resolves symlinks internally, so no need to
- call realpath. */
-#else
- char *real_exename = realpath (dump_file, NULL);
- if (!real_exename)
- fatal ("could not resolve realpath of \"%s\": %s",
- dump_file, strerror (errno));
- xfree (dump_file);
- dump_file = real_exename;
-#endif
- ptrdiff_t exenamelen = strlen (dump_file);
-#ifndef WINDOWSNT
- bufsize = exenamelen + 1;
-#endif
- if (strip_suffix)
- {
- ptrdiff_t strip_suffix_length = strlen (strip_suffix);
- ptrdiff_t prefix_length = exenamelen - strip_suffix_length;
- if (0 <= prefix_length
- && !memcmp (&dump_file[prefix_length], strip_suffix,
- strip_suffix_length))
- exenamelen = prefix_length;
- }
- ptrdiff_t needed = exenamelen + strlen (suffix) + 1;
- if (bufsize < needed)
- dump_file = xpalloc (dump_file, &bufsize, needed - bufsize, -1, 1);
- strcpy (dump_file + exenamelen, suffix);
- result = pdumper_load (dump_file);
- if (result == PDUMPER_LOAD_SUCCESS)
- goto out;
-
- if (result != PDUMPER_LOAD_FILE_NOT_FOUND)
- fatal ("could not load dump file \"%s\": %s",
- dump_file, dump_error_to_string (result));
+ ptrdiff_t strip_suffix_length = strlen (strip_suffix);
+ ptrdiff_t prefix_length = exenamelen - strip_suffix_length;
+ if (0 <= prefix_length
+ && !memcmp (&emacs_executable[prefix_length], strip_suffix,
+ strip_suffix_length))
+ exenamelen = prefix_length;
}
+ ptrdiff_t needed = exenamelen + strlen (suffix) + 1;
+ dump_file = xpalloc (NULL, &bufsize, needed - bufsize, -1, 1);
+ memcpy (dump_file, emacs_executable, exenamelen);
+ strcpy (dump_file + exenamelen, suffix);
+ result = pdumper_load (dump_file, emacs_executable);
+ if (result == PDUMPER_LOAD_SUCCESS)
+ goto out;
+
+ if (result != PDUMPER_LOAD_FILE_NOT_FOUND)
+ fatal ("could not load dump file \"%s\": %s",
+ dump_file, dump_error_to_string (result));
+
+ hardcoded:
#ifdef WINDOWSNT
/* On MS-Windows, PATH_EXEC normally starts with a literal
@@ -875,12 +917,11 @@ load_pdump (int argc, char **argv)
/* Look for "emacs.pdmp" in PATH_EXEC. We hardcode "emacs" in
"emacs.pdmp" so that the Emacs binary still works if the user
copies and renames it. */
- const char *argv0_base = "emacs";
- ptrdiff_t needed = (strlen (path_exec)
- + 1
- + strlen (argv0_base)
- + strlen (suffix)
- + 1);
+ needed = (strlen (path_exec)
+ + 1
+ + strlen (argv0_base)
+ + strlen (suffix)
+ + 1);
if (bufsize < needed)
{
xfree (dump_file);
@@ -888,7 +929,21 @@ load_pdump (int argc, char **argv)
}
sprintf (dump_file, "%s%c%s%s",
path_exec, DIRECTORY_SEP, argv0_base, suffix);
- result = pdumper_load (dump_file);
+ /* Assume the Emacs binary lives in a sibling directory as set up by
+ the default installation configuration. */
+ const char *go_up = "../../../../bin/";
+ needed += (strip_suffix ? strlen (strip_suffix) : 0)
+ - strlen (suffix) + strlen (go_up);
+ if (exec_bufsize < needed)
+ {
+ xfree (emacs_executable);
+ emacs_executable = xpalloc (NULL, &exec_bufsize, needed - exec_bufsize,
+ -1, 1);
+ }
+ sprintf (emacs_executable, "%s%c%s%s%s",
+ path_exec, DIRECTORY_SEP, go_up, argv0_base,
+ strip_suffix ? strip_suffix : "");
+ result = pdumper_load (dump_file, emacs_executable);
if (result == PDUMPER_LOAD_FILE_NOT_FOUND)
{
@@ -923,7 +978,7 @@ load_pdump (int argc, char **argv)
#endif
sprintf (dump_file, "%s%c%s%s",
path_exec, DIRECTORY_SEP, argv0_base, suffix);
- result = pdumper_load (dump_file);
+ result = pdumper_load (dump_file, emacs_executable);
}
if (result != PDUMPER_LOAD_SUCCESS)
@@ -935,9 +990,185 @@ load_pdump (int argc, char **argv)
out:
xfree (dump_file);
+ xfree (emacs_executable);
}
#endif /* HAVE_PDUMPER */
+#if SECCOMP_USABLE
+
+/* Wrapper function for the `seccomp' system call on GNU/Linux. This
+ system call usually doesn't have a wrapper function. See the
+ manual page of `seccomp' for the signature. */
+
+static int
+emacs_seccomp (unsigned int operation, unsigned int flags, void *args)
+{
+#ifdef SYS_seccomp
+ return syscall (SYS_seccomp, operation, flags, args);
+#else
+ errno = ENOSYS;
+ return -1;
+#endif
+}
+
+/* Read SIZE bytes into BUFFER. Return the number of bytes read, or
+ -1 if reading failed altogether. */
+
+static ptrdiff_t
+read_full (int fd, void *buffer, ptrdiff_t size)
+{
+ eassert (0 <= fd);
+ eassert (buffer != NULL);
+ eassert (0 <= size);
+ enum
+ {
+ /* See MAX_RW_COUNT in sysdep.c. */
+#ifdef MAX_RW_COUNT
+ max_size = MAX_RW_COUNT
+#else
+ max_size = INT_MAX >> 18 << 18
+#endif
+ };
+ if (PTRDIFF_MAX < size || max_size < size)
+ {
+ errno = EFBIG;
+ return -1;
+ }
+ char *ptr = buffer;
+ ptrdiff_t read = 0;
+ while (size != 0)
+ {
+ ptrdiff_t n = emacs_read (fd, ptr, size);
+ if (n < 0)
+ return -1;
+ if (n == 0)
+ break; /* Avoid infinite loop on encountering EOF. */
+ eassert (n <= size);
+ size -= n;
+ ptr += n;
+ read += n;
+ }
+ return read;
+}
+
+/* Attempt to load Secure Computing filters from FILE. Return false
+ if that doesn't work for some reason. */
+
+static bool
+load_seccomp (const char *file)
+{
+ bool success = false;
+ void *buffer = NULL;
+ int fd
+ = emacs_open_noquit (file, O_RDONLY | O_CLOEXEC | O_BINARY, 0);
+ if (fd < 0)
+ {
+ emacs_perror ("open");
+ goto out;
+ }
+ struct stat stat;
+ if (fstat (fd, &stat) != 0)
+ {
+ emacs_perror ("fstat");
+ goto out;
+ }
+ if (! S_ISREG (stat.st_mode))
+ {
+ fprintf (stderr, "seccomp file %s is not regular\n", file);
+ goto out;
+ }
+ struct sock_fprog program;
+ if (stat.st_size <= 0 || SIZE_MAX <= stat.st_size
+ || PTRDIFF_MAX <= stat.st_size
+ || stat.st_size % sizeof *program.filter != 0)
+ {
+ fprintf (stderr, "seccomp filter %s has invalid size %ld\n",
+ file, (long) stat.st_size);
+ goto out;
+ }
+ size_t size = stat.st_size;
+ size_t count = size / sizeof *program.filter;
+ eassert (0 < count && count < SIZE_MAX);
+ if (USHRT_MAX < count)
+ {
+ fprintf (stderr, "seccomp filter %s is too big\n", file);
+ goto out;
+ }
+ /* Try reading one more byte to detect file size changes. */
+ buffer = malloc (size + 1);
+ if (buffer == NULL)
+ {
+ emacs_perror ("malloc");
+ goto out;
+ }
+ ptrdiff_t read = read_full (fd, buffer, size + 1);
+ if (read < 0)
+ {
+ emacs_perror ("read");
+ goto out;
+ }
+ eassert (read <= SIZE_MAX);
+ if (read != size)
+ {
+ fprintf (stderr,
+ "seccomp filter %s changed size while reading\n",
+ file);
+ goto out;
+ }
+ if (emacs_close (fd) != 0)
+ emacs_perror ("close"); /* not a fatal error */
+ fd = -1;
+ program.len = count;
+ program.filter = buffer;
+
+ /* See man page of `seccomp' why this is necessary. Note that we
+ intentionally don't check the return value: a parent process
+ might have made this call before, in which case it would fail;
+ or, if enabling privilege-restricting mode fails, the `seccomp'
+ syscall will fail anyway. */
+ prctl (PR_SET_NO_NEW_PRIVS, 1, 0, 0, 0);
+ /* Install the filter. Make sure that potential other threads can't
+ escape it. */
+ if (emacs_seccomp (SECCOMP_SET_MODE_FILTER,
+ SECCOMP_FILTER_FLAG_TSYNC, &program)
+ != 0)
+ {
+ emacs_perror ("seccomp");
+ goto out;
+ }
+ success = true;
+
+ out:
+ if (0 <= fd)
+ emacs_close (fd);
+ free (buffer);
+ return success;
+}
+
+/* Load Secure Computing filter from file specified with the --seccomp
+ option. Exit if that fails. */
+
+static void
+maybe_load_seccomp (int argc, char **argv)
+{
+ int skip_args = 0;
+ char *file = NULL;
+ while (skip_args < argc - 1)
+ {
+ if (argmatch (argv, argc, "-seccomp", "--seccomp", 9, &file,
+ &skip_args)
+ || argmatch (argv, argc, "--", NULL, 2, NULL, &skip_args))
+ break;
+ ++skip_args;
+ }
+ if (file == NULL)
+ return;
+ if (! load_seccomp (file))
+ fatal ("cannot enable seccomp filter from %s", file);
+}
+
+#endif /* SECCOMP_USABLE */
+
int
main (int argc, char **argv)
{
@@ -945,6 +1176,13 @@ main (int argc, char **argv)
for pointers. */
void *stack_bottom_variable;
+ /* First, check whether we should apply a seccomp filter. This
+ should come at the very beginning to allow the filter to protect
+ the initialization phase. */
+#if SECCOMP_USABLE
+ maybe_load_seccomp (argc, argv);
+#endif
+
bool no_loadup = false;
char *junk = 0;
char *dname_arg = 0;
@@ -1607,6 +1845,9 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
init_json ();
#endif
+ if (!initialized)
+ syms_of_comp ();
+
no_loadup
= argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args);
@@ -1778,7 +2019,8 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
/* Init buffer storage and default directory of main buffer. */
init_buffer ();
- init_callproc_1 (); /* Must precede init_cmdargs and init_sys_modes. */
+ /* Must precede init_cmdargs and init_sys_modes. */
+ init_callproc_1 ();
/* Must precede init_lread. */
init_cmdargs (argc, argv, skip_args, original_pwd);
@@ -1958,6 +2200,11 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
#endif
keys_of_keyboard ();
+
+#ifdef HAVE_NATIVE_COMP
+ /* Must be after the last defsubr has run. */
+ hash_native_abi ();
+#endif
}
else
{
@@ -2133,12 +2380,15 @@ static const struct standard_args standard_args[] =
{ "-color", "--color", 5, 0},
{ "-no-splash", "--no-splash", 3, 0 },
{ "-no-desktop", "--no-desktop", 3, 0 },
- /* The following two must be just above the file-name args, to get
+ /* The following three must be just above the file-name args, to get
them out of our way, but without mixing them with file names. */
{ "-temacs", "--temacs", 1, 1 },
#ifdef HAVE_PDUMPER
{ "-dump-file", "--dump-file", 1, 1 },
#endif
+#if SECCOMP_USABLE
+ { "-seccomp", "--seccomp", 1, 1 },
+#endif
#ifdef HAVE_NS
{ "-NSAutoLaunch", 0, 5, 1 },
{ "-NXAutoLaunch", 0, 5, 1 },
@@ -2393,6 +2643,10 @@ all of which are called before Emacs is actually killed.
*/
unlink (SSDATA (listfile));
}
+#ifdef HAVE_NATIVE_COMP
+ eln_load_path_final_clean_up ();
+#endif
+
if (FIXNUMP (arg))
exit_code = (XFIXNUM (arg) < 0
? XFIXNUM (arg) | INT_MIN
@@ -3043,7 +3297,18 @@ because they do not depend on external libraries and are
always available.
Also note that this is not a generic facility for accessing external
libraries; only those already known by Emacs will be loaded. */);
+#ifdef WINDOWSNT
+ /* FIXME: We may need to load libgccjit when dumping before
+ term/w32-win.el defines `dynamic-library-alist`. This will fail
+ if that variable is empty, so add libgccjit-0.dll to it. */
+ if (will_dump_p ())
+ Vdynamic_library_alist = list1 (list2 (Qgccjit,
+ build_string ("libgccjit-0.dll")));
+ else
+ Vdynamic_library_alist = Qnil;
+#else
Vdynamic_library_alist = Qnil;
+#endif
Fput (intern_c_string ("dynamic-library-alist"), Qrisky_local_variable, Qt);
#ifdef WINDOWSNT
diff --git a/src/epaths.in b/src/epaths.in
index 1de1e05..0c72610 100644
--- a/src/epaths.in
+++ b/src/epaths.in
@@ -27,6 +27,10 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
*/
#define PATH_LOADSEARCH "/usr/local/share/emacs/lisp"
+/* Like PATH_LOADSEARCH, but contains the relative path from the
+ installation directory.
+*/
+#define PATH_REL_LOADSEARCH ""
/* Like PATH_LOADSEARCH, but contains the non-standard pieces.
These are the site-lisp directories. Configure sets this to
diff --git a/src/eval.c b/src/eval.c
index ddaa8ed..aeedcc5 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -219,8 +219,17 @@ void
init_eval_once (void)
{
/* Don't forget to update docs (lispref node "Local Variables"). */
- max_specpdl_size = 1800; /* See bug#46818. */
- max_lisp_eval_depth = 800;
+ if (!NATIVE_COMP_FLAG)
+ {
+ max_specpdl_size = 1800; /* See bug#46818. */
+ max_lisp_eval_depth = 800;
+ }
+ else
+ {
+ /* Original values increased for comp.el. */
+ max_specpdl_size = 2500;
+ max_lisp_eval_depth = 1600;
+ }
Vrun_hooks = Qnil;
pdumper_do_now_and_after_load (init_eval_once_for_pdumper);
}
@@ -1301,7 +1310,7 @@ DEFUN ("condition-case", Fcondition_case,
Scondition_case, 2, UNEVALLED, 0,
doc: /* Regain control when an error is signaled.
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.
+or (:success 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. Handlers may also apply when non-error
@@ -1323,6 +1332,10 @@ with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the
error.
Then the value of the last BODY form is returned from the `condition-case'
expression.
+The special handler (:success BODY...) is invoked if BODYFORM terminated
+without signalling an error. BODY is then evaluated with VAR bound to
+the value returned by BODYFORM.
+
See also the function `signal' for more info.
usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
(Lisp_Object args)
@@ -1346,16 +1359,21 @@ internal_lisp_condition_case (Lisp_Object var,
Lisp_Object bodyform,
CHECK_SYMBOL (var);
+ Lisp_Object success_handler = Qnil;
+
for (Lisp_Object tail = handlers; CONSP (tail); tail = XCDR (tail))
{
Lisp_Object tem = XCAR (tail);
- clausenb++;
if (! (NILP (tem)
|| (CONSP (tem)
&& (SYMBOLP (XCAR (tem))
|| CONSP (XCAR (tem))))))
error ("Invalid condition handler: %s",
SDATA (Fprin1_to_string (tem, Qt)));
+ if (EQ (XCAR (tem), QCsuccess))
+ success_handler = XCDR (tem);
+ else
+ clausenb++;
}
/* The first clause is the one that should be checked first, so it
@@ -1369,7 +1387,8 @@ internal_lisp_condition_case (Lisp_Object var,
Lisp_Object bodyform,
Lisp_Object volatile *clauses = alloca (clausenb * sizeof *clauses);
clauses += clausenb;
for (Lisp_Object tail = handlers; CONSP (tail); tail = XCDR (tail))
- *--clauses = XCAR (tail);
+ if (!EQ (XCAR (XCAR (tail)), QCsuccess))
+ *--clauses = XCAR (tail);
for (ptrdiff_t i = 0; i < clausenb; i++)
{
Lisp_Object clause = clauses[i];
@@ -1409,6 +1428,23 @@ internal_lisp_condition_case (Lisp_Object var,
Lisp_Object bodyform,
Lisp_Object result = eval_sub (bodyform);
handlerlist = oldhandlerlist;
+ if (!NILP (success_handler))
+ {
+ if (NILP (var))
+ return Fprogn (success_handler);
+
+ Lisp_Object handler_var = var;
+ if (!NILP (Vinternal_interpreter_environment))
+ {
+ result = Fcons (Fcons (var, result),
+ Vinternal_interpreter_environment);
+ handler_var = Qinternal_interpreter_environment;
+ }
+
+ ptrdiff_t count = SPECPDL_INDEX ();
+ specbind (handler_var, result);
+ return unbind_to (count, Fprogn (success_handler));
+ }
return result;
}
@@ -1494,6 +1530,90 @@ internal_condition_case_2 (Lisp_Object (*bfun)
(Lisp_Object, Lisp_Object),
}
}
+/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3 as
+ its arguments. */
+
+Lisp_Object
+internal_condition_case_3 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object,
+ Lisp_Object),
+ Lisp_Object arg1, Lisp_Object arg2, Lisp_Object
arg3,
+ Lisp_Object handlers,
+ Lisp_Object (*hfun) (Lisp_Object))
+{
+ struct handler *c = push_handler (handlers, CONDITION_CASE);
+ if (sys_setjmp (c->jmp))
+ {
+ Lisp_Object val = handlerlist->val;
+ clobbered_eassert (handlerlist == c);
+ handlerlist = handlerlist->next;
+ return hfun (val);
+ }
+ else
+ {
+ Lisp_Object val = bfun (arg1, arg2, arg3);
+ eassert (handlerlist == c);
+ handlerlist = c->next;
+ return val;
+ }
+}
+
+/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3, ARG4 as
+ its arguments. */
+
+Lisp_Object
+internal_condition_case_4 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object,
+ Lisp_Object, Lisp_Object),
+ Lisp_Object arg1, Lisp_Object arg2,
+ Lisp_Object arg3, Lisp_Object arg4,
+ Lisp_Object handlers,
+ Lisp_Object (*hfun) (Lisp_Object))
+{
+ struct handler *c = push_handler (handlers, CONDITION_CASE);
+ if (sys_setjmp (c->jmp))
+ {
+ Lisp_Object val = handlerlist->val;
+ clobbered_eassert (handlerlist == c);
+ handlerlist = handlerlist->next;
+ return hfun (val);
+ }
+ else
+ {
+ Lisp_Object val = bfun (arg1, arg2, arg3, arg4);
+ eassert (handlerlist == c);
+ handlerlist = c->next;
+ return val;
+ }
+}
+
+/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3,
+ ARG4, ARG5 as its arguments. */
+
+Lisp_Object
+internal_condition_case_5 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object,
+ Lisp_Object, Lisp_Object,
+ Lisp_Object),
+ Lisp_Object arg1, Lisp_Object arg2,
+ Lisp_Object arg3, Lisp_Object arg4,
+ Lisp_Object arg5, Lisp_Object handlers,
+ Lisp_Object (*hfun) (Lisp_Object))
+{
+ struct handler *c = push_handler (handlers, CONDITION_CASE);
+ if (sys_setjmp (c->jmp))
+ {
+ Lisp_Object val = handlerlist->val;
+ clobbered_eassert (handlerlist == c);
+ handlerlist = handlerlist->next;
+ return hfun (val);
+ }
+ else
+ {
+ Lisp_Object val = bfun (arg1, arg2, arg3, arg4, arg5);
+ eassert (handlerlist == c);
+ handlerlist = c->next;
+ return val;
+ }
+}
+
/* Like internal_condition_case but call BFUN with NARGS as first,
and ARGS as second argument. */
@@ -2329,7 +2449,7 @@ eval_sub (Lisp_Object form)
else if (!NILP (fun) && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun)))
fun = indirect_function (fun);
- if (SUBRP (fun))
+ if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun))
{
Lisp_Object args_left = original_args;
ptrdiff_t numargs = list_length (args_left);
@@ -2432,7 +2552,9 @@ eval_sub (Lisp_Object form)
}
}
}
- else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun))
+ else if (COMPILEDP (fun)
+ || SUBR_NATIVE_COMPILED_DYNP (fun)
+ || MODULE_FUNCTIONP (fun))
return apply_lambda (fun, original_args, count);
else
{
@@ -2910,9 +3032,11 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
&& (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun)))
fun = indirect_function (fun);
- if (SUBRP (fun))
+ if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun))
val = funcall_subr (XSUBR (fun), numargs, args + 1);
- else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun))
+ else if (COMPILEDP (fun)
+ || SUBR_NATIVE_COMPILED_DYNP (fun)
+ || MODULE_FUNCTIONP (fun))
val = funcall_lambda (fun, numargs, args + 1);
else
{
@@ -3122,6 +3246,11 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
else if (MODULE_FUNCTIONP (fun))
return funcall_module (fun, nargs, arg_vector);
#endif
+ else if (SUBR_NATIVE_COMPILED_DYNP (fun))
+ {
+ syms_left = XSUBR (fun)->lambda_list[0];
+ lexenv = Qnil;
+ }
else
emacs_abort ();
@@ -3182,6 +3311,13 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
if (CONSP (fun))
val = Fprogn (XCDR (XCDR (fun)));
+ else if (SUBR_NATIVE_COMPILEDP (fun))
+ {
+ eassert (SUBR_NATIVE_COMPILED_DYNP (fun));
+ /* No need to use funcall_subr as we have zero arguments by
+ construction. */
+ val = XSUBR (fun)->function.a0 ();
+ }
else
val = fetch_and_exec_byte_code (fun, Qnil, 0, NULL);
@@ -4381,6 +4517,7 @@ alist of active lexical bindings. */);
defsubr (&Sthrow);
defsubr (&Sunwind_protect);
defsubr (&Scondition_case);
+ DEFSYM (QCsuccess, ":success");
defsubr (&Ssignal);
defsubr (&Scommandp);
defsubr (&Sautoload);
diff --git a/src/fns.c b/src/fns.c
index 1758148..41429c8 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -4492,6 +4492,15 @@ check_mutable_hash_table (Lisp_Object obj, struct
Lisp_Hash_Table *h)
eassert (!PURE_P (h));
}
+static void
+collect_interval (INTERVAL interval, Lisp_Object collector)
+{
+ nconc2 (collector,
+ list1(list3 (make_fixnum (interval->position),
+ make_fixnum (interval->position + LENGTH (interval)),
+ interval->plist)));
+}
+
/* Put an entry into hash table H that associates KEY with VALUE.
HASH is a previously computed hash code of KEY.
Value is the index of the entry in H matching KEY. */
@@ -4949,6 +4958,30 @@ Hash codes are not guaranteed to be preserved across
Emacs sessions. */)
return hashfn_equal (obj, NULL);
}
+DEFUN ("sxhash-equal-including-properties", Fsxhash_equal_including_properties,
+ Ssxhash_equal_including_properties, 1, 1, 0,
+ doc: /* Return an integer hash code for OBJ suitable for
+`equal-including-properties'.
+If (sxhash-equal-including-properties A B), then
+(= (sxhash-equal-including-properties A) (sxhash-equal-including-properties
B)).
+
+Hash codes are not guaranteed to be preserved across Emacs sessions. */)
+ (Lisp_Object obj)
+{
+ if (STRINGP (obj))
+ {
+ Lisp_Object collector = Fcons (Qnil, Qnil);
+ traverse_intervals (string_intervals (obj), 0, collect_interval,
+ collector);
+ return
+ make_ufixnum (
+ SXHASH_REDUCE (sxhash_combine (sxhash (obj),
+ sxhash (CDR (collector)))));
+ }
+
+ return hashfn_equal (obj, NULL);
+}
+
DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
doc: /* Create and return a new hash table.
@@ -5832,15 +5865,6 @@ Case is always significant and text properties are
ignored. */)
return make_int (string_byte_to_char (haystack, res - SSDATA (haystack)));
}
-static void
-collect_interval (INTERVAL interval, Lisp_Object collector)
-{
- nconc2 (collector,
- list1(list3 (make_fixnum (interval->position),
- make_fixnum (interval->position + LENGTH (interval)),
- interval->plist)));
-}
-
DEFUN ("object-intervals", Fobject_intervals, Sobject_intervals, 1, 1, 0,
doc: /* Return a copy of the text properties of OBJECT.
OBJECT must be a buffer or a string.
@@ -5922,6 +5946,7 @@ syms_of_fns (void)
defsubr (&Ssxhash_eq);
defsubr (&Ssxhash_eql);
defsubr (&Ssxhash_equal);
+ defsubr (&Ssxhash_equal_including_properties);
defsubr (&Smake_hash_table);
defsubr (&Scopy_hash_table);
defsubr (&Shash_table_count);
diff --git a/src/frame.c b/src/frame.c
index 66ae494..4129a70 100644
--- a/src/frame.c
+++ b/src/frame.c
@@ -150,29 +150,6 @@ get_frame_param (struct frame *frame, Lisp_Object prop)
}
-void
-frame_size_history_add (struct frame *f, Lisp_Object fun_symbol,
- int width, int height, Lisp_Object rest)
-{
- Lisp_Object frame;
-
- XSETFRAME (frame, f);
- if (CONSP (frame_size_history)
- && FIXNUMP (XCAR (frame_size_history))
- && 0 < XFIXNUM (XCAR (frame_size_history)))
- frame_size_history =
- Fcons (make_fixnum (XFIXNUM (XCAR (frame_size_history)) - 1),
- Fcons (list4
- (frame, fun_symbol,
- ((width > 0)
- ? list4i (FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f),
- width, height)
- : Qnil),
- rest),
- XCDR (frame_size_history)));
-}
-
-
/* Return 1 if `frame-inhibit-implied-resize' is non-nil or fullscreen
state of frame F would be affected by a vertical (horizontal if
HORIZONTAL is true) resize. PARAMETER is the symbol of the frame
@@ -193,78 +170,54 @@ frame_inhibit_resize (struct frame *f, bool horizontal,
Lisp_Object parameter)
|| FRAME_TERMCAP_P (f) || FRAME_MSDOS_P (f))
: ((horizontal && f->inhibit_horizontal_resize)
|| (!horizontal && f->inhibit_vertical_resize)));
- if (inhibit && !FRAME_TERMCAP_P (f) && !FRAME_MSDOS_P (f))
- frame_size_history_add
- (f, Qframe_inhibit_resize, 0, 0,
- list5 (horizontal ? Qt : Qnil, parameter,
- f->after_make_frame ? Qt : Qnil,
- frame_inhibit_implied_resize,
- fullscreen));
return inhibit;
}
+
+/** Set menu bar lines for a TTY frame. */
static void
set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
{
- int nlines;
int olines = FRAME_MENU_BAR_LINES (f);
+ int nlines = TYPE_RANGED_FIXNUMP (int, value) ? XFIXNUM (value) : 0;
/* Right now, menu bars don't work properly in minibuf-only frames;
most of the commands try to apply themselves to the minibuffer
frame itself, and get an error because you can't switch buffers
in or split the minibuffer window. */
- if (FRAME_MINIBUF_ONLY_P (f))
- return;
-
- if (TYPE_RANGED_FIXNUMP (int, value))
- nlines = XFIXNUM (value);
- else
- nlines = 0;
-
- if (nlines != olines)
+ if (!FRAME_MINIBUF_ONLY_P (f) && nlines != olines)
{
windows_or_buffers_changed = 14;
- FRAME_MENU_BAR_LINES (f) = nlines;
- FRAME_MENU_BAR_HEIGHT (f) = nlines * FRAME_LINE_HEIGHT (f);
- change_frame_size (f, FRAME_COLS (f),
- FRAME_LINES (f) + olines - nlines,
- 0, 1, 0, 0);
+ FRAME_MENU_BAR_LINES (f) = FRAME_MENU_BAR_HEIGHT (f) = nlines;
+ change_frame_size (f, FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f),
+ false, true, false);
}
}
+
+/** Set tab bar lines for a TTY frame. */
static void
set_tab_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
{
- int nlines;
int olines = FRAME_TAB_BAR_LINES (f);
+ int nlines = TYPE_RANGED_FIXNUMP (int, value) ? XFIXNUM (value) : 0;
/* Right now, tab bars don't work properly in minibuf-only frames;
most of the commands try to apply themselves to the minibuffer
frame itself, and get an error because you can't switch buffers
in or split the minibuffer window. */
- if (FRAME_MINIBUF_ONLY_P (f))
- return;
-
- if (TYPE_RANGED_FIXNUMP (int, value))
- nlines = XFIXNUM (value);
- else
- nlines = 0;
-
- if (nlines != olines)
+ if (!FRAME_MINIBUF_ONLY_P (f) && nlines != olines)
{
windows_or_buffers_changed = 14;
- FRAME_TAB_BAR_LINES (f) = nlines;
- FRAME_TAB_BAR_HEIGHT (f) = nlines * FRAME_LINE_HEIGHT (f);
- change_frame_size (f, FRAME_COLS (f),
- FRAME_LINES (f) + olines - nlines,
- 0, 1, 0, 0);
+ FRAME_TAB_BAR_LINES (f) = FRAME_TAB_BAR_HEIGHT (f) = nlines;
+ change_frame_size (f, FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f),
+ false, true, false);
}
}
Lisp_Object Vframe_list;
-
DEFUN ("framep", Fframep, Sframep, 1, 1, 0,
doc: /* Return non-nil if OBJECT is a frame.
Value is:
@@ -366,14 +319,15 @@ DEFUN ("frame-windows-min-size", Fframe_windows_min_size,
*
* If `frame-windows-min-size' is called, it will make sure that the
* return value accommodates all windows of FRAME respecting the values
- * of `window-min-height' (`window-min-width' if HORIZONTAL is non-nil).
- * With IGNORE non-nil the values of these variables are ignored.
+ * of `window-min-height' (`window-min-width' if HORIZONTAL is
+ * non-nil) and `window-safe-min-height' (`window-safe-min-width')
+ * according to IGNORE (see `window-min-size').
*
* In either case, never return a value less than 1. For TTY frames,
* additionally limit the minimum frame height to a value large enough
- * to support the menu bar, the mode line, and the echo area.
+ * to support menu bar, tab bar, mode line and echo area.
*/
-static int
+int
frame_windows_min_size (Lisp_Object frame, Lisp_Object horizontal,
Lisp_Object ignore, Lisp_Object pixelwise)
{
@@ -405,6 +359,7 @@ frame_windows_min_size (Lisp_Object frame, Lisp_Object
horizontal,
else
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. */
if ((FRAME_TERMCAP_P (f) || FRAME_MSDOS_P (f)) && NILP (horizontal))
@@ -413,6 +368,7 @@ frame_windows_min_size (Lisp_Object frame, Lisp_Object
horizontal,
+ FRAME_TAB_BAR_LINES (f)
+ FRAME_WANTS_MODELINE_P (f)
+ 2); /* one text line and one echo-area line */
+
if (retval < min_height)
retval = min_height;
}
@@ -474,9 +430,10 @@ keep_ratio (struct frame *f, struct frame *p, int
old_width, int old_height,
if (CONSP (keep_ratio)
&& (NILP (Fcar (keep_ratio))
|| EQ (Fcar (keep_ratio), Qheight_only))
- && p->pixel_width - f->pixel_width < pos_x)
+ && FRAME_PIXEL_WIDTH (p) - FRAME_PIXEL_WIDTH (f) < pos_x)
{
- int p_f_width = p->pixel_width - f->pixel_width;
+ int p_f_width
+ = FRAME_PIXEL_WIDTH (p) - FRAME_PIXEL_WIDTH (f);
if (p_f_width <= 0)
pos_x = 0;
@@ -496,14 +453,15 @@ keep_ratio (struct frame *f, struct frame *p, int
old_width, int old_height,
if (CONSP (keep_ratio)
&& (NILP (Fcar (keep_ratio))
|| EQ (Fcar (keep_ratio), Qwidth_only))
- && p->pixel_height - f->pixel_height < pos_y)
+ && FRAME_PIXEL_HEIGHT (p) - FRAME_PIXEL_HEIGHT (f) < pos_y)
/* When positional adjustment was requested and the
width of F should remain unaltered, try to constrain
F to its parent. This means that when the parent
frame is enlarged later the child's original position
won't get restored. */
{
- int p_f_height = p->pixel_height - f->pixel_height;
+ int p_f_height
+ = FRAME_PIXEL_HEIGHT (p) - FRAME_PIXEL_HEIGHT (f);
if (p_f_height <= 0)
pos_y = 0;
@@ -523,60 +481,143 @@ keep_ratio (struct frame *f, struct frame *p, int
old_width, int old_height,
if (CONSP (keep_ratio) && EQ (Fcar (keep_ratio), Qheight_only))
pixel_width = -1;
else
- {
- pixel_width = (int)(f->pixel_width * width_factor + 0.5);
- pixel_width = FRAME_PIXEL_TO_TEXT_WIDTH (f, pixel_width);
- }
+ pixel_width
+ = (int)(FRAME_PIXEL_WIDTH (f) * width_factor + 0.5);
if (CONSP (keep_ratio) && EQ (Fcar (keep_ratio), Qwidth_only))
pixel_height = -1;
else
- {
- pixel_height = (int)(f->pixel_height * height_factor + 0.5);
- pixel_height = FRAME_PIXEL_TO_TEXT_HEIGHT (f, pixel_height);
- }
+ pixel_height
+ = (int)(FRAME_PIXEL_HEIGHT (f) * height_factor + 0.5);
- adjust_frame_size (f, pixel_width, pixel_height, 1, 0,
- Qkeep_ratio);
+ adjust_frame_size (f, FRAME_PIXEL_TO_TEXT_WIDTH (f, pixel_width),
+ FRAME_PIXEL_TO_TEXT_HEIGHT (f, pixel_height), 1,
+ false, Qkeep_ratio);
}
}
}
#endif
+static void
+frame_size_history_adjust (struct frame *f, int inhibit, Lisp_Object parameter,
+ int old_text_width, int old_text_height,
+ int new_text_width, int new_text_height,
+ int old_text_cols, int old_text_lines,
+ int new_text_cols, int new_text_lines,
+ int old_native_width, int old_native_height,
+ int new_native_width, int new_native_height,
+ int old_inner_width, int old_inner_height,
+ int new_inner_width, int new_inner_height,
+ int min_inner_width, int min_inner_height,
+ bool inhibit_horizontal, bool inhibit_vertical)
+{
+ Lisp_Object frame;
+
+ XSETFRAME (frame, f);
+ if (CONSP (frame_size_history)
+ && FIXNUMP (XCAR (frame_size_history))
+ && 0 < XFIXNUM (XCAR (frame_size_history)))
+ frame_size_history =
+ Fcons (make_fixnum (XFIXNUM (XCAR (frame_size_history)) - 1),
+ Fcons (Fcons (list4 (frame, make_fixnum (5),
+ make_fixnum (inhibit), parameter),
+ list5 (list4i (old_text_width, old_text_height,
+ new_text_width, new_text_height),
+ list4i (old_text_cols, old_text_lines,
+ new_text_cols, new_text_lines),
+ list4i (old_native_width, old_native_height,
+ new_native_width, new_native_height),
+ list4i (old_inner_width, old_inner_height,
+ new_inner_width, new_inner_height),
+ list4 (make_fixnum (min_inner_width),
+ make_fixnum (min_inner_height),
+ inhibit_horizontal ? Qt : Qnil,
+ inhibit_vertical ? Qt : Qnil))),
+ XCDR (frame_size_history)));
+}
+
+
+void
+frame_size_history_plain (struct frame *f, Lisp_Object parameter)
+{
+ Lisp_Object frame;
+
+ XSETFRAME (frame, f);
+ if (CONSP (frame_size_history)
+ && FIXNUMP (XCAR (frame_size_history))
+ && 0 < XFIXNUM (XCAR (frame_size_history)))
+ frame_size_history =
+ Fcons (make_fixnum (XFIXNUM (XCAR (frame_size_history)) - 1),
+ Fcons (Fcons (list3 (frame, make_fixnum (1), parameter), Qt),
+ XCDR (frame_size_history)));
+}
+
+
+void
+frame_size_history_extra (struct frame *f, Lisp_Object parameter,
+ int pixel_width, int pixel_height,
+ int extra_width, int extra_height,
+ int delayed_width, int delayed_height)
+{
+ Lisp_Object frame;
+
+ XSETFRAME (frame, f);
+ if (CONSP (frame_size_history)
+ && FIXNUMP (XCAR (frame_size_history))
+ && 0 < XFIXNUM (XCAR (frame_size_history)))
+ frame_size_history =
+ Fcons (make_fixnum (XFIXNUM (XCAR (frame_size_history)) - 1),
+ Fcons (Fcons (list3 (frame, make_fixnum (2), parameter),
+ list2 (list4i (pixel_width, pixel_height,
+ extra_width, extra_height),
+ list2i (delayed_width, delayed_height))),
+ XCDR (frame_size_history)));
+}
+
+
/**
* adjust_frame_size:
*
- * Adjust size of frame F. NEW_WIDTH and NEW_HEIGHT specify the new
- * text size of F in pixels. A value of -1 means no change is requested
- * for that direction (but the frame may still have to be resized to
- * accommodate windows with their minimum sizes). This can either issue
- * a request to resize the frame externally (via set_window_size_hook), to
- * resize the frame internally (via resize_frame_windows) or do nothing
- * at all.
+ * Adjust size of frame F. NEW_TEXT_WIDTH and NEW_TEXT_HEIGHT specify
+ * the new text size of F in pixels. When INHIBIT equals 2, 3 or 4, a
+ * value of -1 means to leave the text size of F unchanged and adjust,
+ * if necessary and possible, F's native size accordingly. When INHIBIT
+ * equals 0, 1 or 5, a negative value means that the frame has been (or
+ * should be) made pathologically small which usually means that parts
+ * of the frame's windows may not be entirely visible.
*
- * The argument INHIBIT can assume the following values:
+ * The effect of calling this function can be to either issue a request
+ * to resize the frame externally (via set_window_size_hook), to resize
+ * the frame internally (via resize_frame_windows) or to do nothing.
+ *
+ * The argument INHIBIT controls whether set_window_size_hook may be
+ * called and can assume the following values:
*
* 0 means to unconditionally call set_window_size_hook even if sizes
* apparently do not change. Fx_create_frame uses this to pass the
* initial size to the window manager.
*
- * 1 means to call set_window_size_hook if the native frame size really
- * changes. Fset_frame_size, Fset_frame_height, ... use this.
+ * 1 means to call set_window_size_hook if the native frame size should
+ * change. Fset_frame_size and friends and width and height parameter
+ * changes use this.
*
* 2 means to call set_window_size_hook provided frame_inhibit_resize
- * allows it. The menu and tool bar code use this ("3" won't work
- * here in general because menu and tool bar are often not counted in
- * the frame's text height).
+ * allows it. The code updating external menu and tool bars uses this
+ * to keep the height of the native frame unaltered when one of these
+ * bars is added or removed. This means that Emacs has to work
+ * against the window manager which usually tries to keep the combined
+ * height (native frame plus bar) unaltered.
*
- * 3 means call set_window_size_hook if window minimum sizes must be
- * preserved or frame_inhibit_resize allows it.
- * gui_set_left_fringe, gui_set_scroll_bar_width, gui_new_font
- * ... use (or should use) this.
+ * 3 means to call set_window_size_hook if window minimum sizes must be
+ * preserved or frame_inhibit_resize allows it. This is the default
+ * for parameters accounted for in a frame's text size like fringes,
+ * scroll bars, internal border, tab bar, internal tool and menu bars.
+ * It's also used when the frame's default font changes.
*
- * 4 means call set_window_size_hook only if window minimum sizes must
- * be preserved. x_set_right_divider_width, x_set_border_width and
- * the code responsible for wrapping the tool bar use this.
+ * 4 means to call set_window_size_hook only if window minimum sizes
+ * must be preserved. The code for setting up window dividers and
+ * that responsible for wrapping the (internal) tool bar use this.
*
* 5 means to never call set_window_size_hook. change_frame_size uses
* this.
@@ -588,146 +629,172 @@ keep_ratio (struct frame *f, struct frame *p, int
old_width, int old_height,
* PRETEND is as for change_frame_size. PARAMETER, if non-nil, is the
* symbol of the parameter changed (like `menu-bar-lines', `font', ...).
* This is passed on to frame_inhibit_resize to let the latter decide on
- * a case-by-case basis whether the frame may be resized externally.
+ * a case-by-case basis whether set_window_size_hook should be called.
*/
void
-adjust_frame_size (struct frame *f, int new_width, int new_height, int inhibit,
- bool pretend, Lisp_Object parameter)
+adjust_frame_size (struct frame *f, int new_text_width, int new_text_height,
+ int inhibit, bool pretend, Lisp_Object parameter)
{
int unit_width = FRAME_COLUMN_WIDTH (f);
int unit_height = FRAME_LINE_HEIGHT (f);
- int old_pixel_width = FRAME_PIXEL_WIDTH (f);
- int old_pixel_height = FRAME_PIXEL_HEIGHT (f);
- int old_cols = FRAME_COLS (f);
- int old_lines = FRAME_LINES (f);
- int new_pixel_width, new_pixel_height;
- /* The following two values are calculated from the old frame pixel
- sizes and any "new" settings for tool bar, menu bar and internal
- borders. We do it this way to detect whether we have to call
- set_window_size_hook as consequence of the new settings. */
- int windows_width = FRAME_WINDOWS_WIDTH (f);
- int windows_height = FRAME_WINDOWS_HEIGHT (f);
- int min_windows_width, min_windows_height;
- /* These are a bit tedious, maybe we should use a macro. */
+ int old_native_width = FRAME_PIXEL_WIDTH (f);
+ int old_native_height = FRAME_PIXEL_HEIGHT (f);
+ int new_native_width, new_native_height;
+ /* The desired minimum inner width and height of the frame calculated
+ via 'frame-windows-min-size'. */
+ int min_inner_width, min_inner_height;
+ /* Get the "old" inner width, height and position of F via its root
+ window and the minibuffer window. We cannot use FRAME_INNER_WIDTH
+ and FRAME_INNER_HEIGHT here since the internal border and the top
+ margin may have been already set to new values. */
struct window *r = XWINDOW (FRAME_ROOT_WINDOW (f));
- int old_windows_width = WINDOW_PIXEL_WIDTH (r);
- int old_windows_height
+ int old_inner_width = WINDOW_PIXEL_WIDTH (r);
+ int old_inner_height
= (WINDOW_PIXEL_HEIGHT (r)
+ ((FRAME_HAS_MINIBUF_P (f) && !FRAME_MINIBUF_ONLY_P (f))
? WINDOW_PIXEL_HEIGHT (XWINDOW (FRAME_MINIBUF_WINDOW (f)))
: 0));
- int new_windows_width, new_windows_height;
+ int new_inner_width, new_inner_height;
+ int old_text_cols = FRAME_COLS (f);
+ int old_text_lines = FRAME_LINES (f);
+ int new_text_cols, new_text_lines;
int old_text_width = FRAME_TEXT_WIDTH (f);
int old_text_height = FRAME_TEXT_HEIGHT (f);
- /* If a size is < 0 use the old value. */
- int new_text_width = (new_width >= 0) ? new_width : old_text_width;
- int new_text_height = (new_height >= 0) ? new_height : old_text_height;
- int new_cols, new_lines;
bool inhibit_horizontal, inhibit_vertical;
Lisp_Object frame;
XSETFRAME (frame, f);
- frame_size_history_add
- (f, Qadjust_frame_size_1, new_text_width, new_text_height,
- 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
- margins (though the latter should have been processed already). */
- min_windows_width
- = frame_windows_min_size (frame, Qt, (inhibit == 5) ? Qt : Qnil, Qt);
- min_windows_height
- = frame_windows_min_size (frame, Qnil, (inhibit == 5) ? Qt : Qnil, Qt);
+ min_inner_width
+ = frame_windows_min_size (frame, Qt, (inhibit == 5) ? Qsafe : Qnil, Qt);
+ min_inner_height
+ = frame_windows_min_size (frame, Qnil, (inhibit == 5) ? Qsafe : Qnil, Qt);
if (inhibit >= 2 && inhibit <= 4)
/* When INHIBIT is in [2..4] inhibit if the "old" window sizes stay
within the limits and either resizing is inhibited or INHIBIT
equals 4. */
{
- inhibit_horizontal = (windows_width >= min_windows_width
+ if (new_text_width == -1)
+ new_text_width = FRAME_TEXT_WIDTH (f);
+ if (new_text_height == -1)
+ new_text_height = FRAME_TEXT_HEIGHT (f);
+
+ inhibit_horizontal = (FRAME_INNER_WIDTH (f) >= min_inner_width
&& (inhibit == 4
|| frame_inhibit_resize (f, true, parameter)));
- inhibit_vertical = (windows_height >= min_windows_height
+ inhibit_vertical = (FRAME_INNER_HEIGHT (f) >= min_inner_height
&& (inhibit == 4
|| frame_inhibit_resize (f, false, parameter)));
}
else
- /* Otherwise inhibit if INHIBIT equals 5. */
+ /* Otherwise inhibit if INHIBIT equals 5. If we wanted to overrule
+ the WM do that here (could lead to some sort of eternal fight
+ with the WM). */
inhibit_horizontal = inhibit_vertical = inhibit == 5;
- new_pixel_width = ((inhibit_horizontal && (inhibit < 5))
- ? old_pixel_width
- : max (FRAME_TEXT_TO_PIXEL_WIDTH (f, new_text_width),
- min_windows_width
- + 2 * FRAME_INTERNAL_BORDER_WIDTH (f)));
- new_windows_width = new_pixel_width - 2 * FRAME_INTERNAL_BORDER_WIDTH (f);
- new_text_width = FRAME_PIXEL_TO_TEXT_WIDTH (f, new_pixel_width);
- new_cols = new_text_width / unit_width;
-
- new_pixel_height = ((inhibit_vertical && (inhibit < 5))
- ? old_pixel_height
- : max (FRAME_TEXT_TO_PIXEL_HEIGHT (f, new_text_height),
- min_windows_height
- + FRAME_TOP_MARGIN_HEIGHT (f)
+ new_native_width = ((inhibit_horizontal && inhibit < 5)
+ ? old_native_width
+ : max (FRAME_TEXT_TO_PIXEL_WIDTH (f, new_text_width),
+ min_inner_width
+ 2 * FRAME_INTERNAL_BORDER_WIDTH (f)));
- new_windows_height = (new_pixel_height
- - FRAME_TOP_MARGIN_HEIGHT (f)
- - 2 * FRAME_INTERNAL_BORDER_WIDTH (f));
- new_text_height = FRAME_PIXEL_TO_TEXT_HEIGHT (f, new_pixel_height);
- new_lines = new_text_height / unit_height;
+ new_inner_width = new_native_width - 2 * FRAME_INTERNAL_BORDER_WIDTH (f);
+ new_text_width = FRAME_PIXEL_TO_TEXT_WIDTH (f, new_native_width);
+ new_text_cols = new_text_width / unit_width;
+
+ new_native_height = ((inhibit_vertical && inhibit < 5)
+ ? old_native_height
+ : max (FRAME_TEXT_TO_PIXEL_HEIGHT (f, new_text_height),
+ min_inner_height
+ + FRAME_TOP_MARGIN_HEIGHT (f)
+ + 2 * FRAME_INTERNAL_BORDER_WIDTH (f)));
+ new_inner_height = (new_native_height
+ - FRAME_TOP_MARGIN_HEIGHT (f)
+ - 2 * FRAME_INTERNAL_BORDER_WIDTH (f));
+ new_text_height = FRAME_PIXEL_TO_TEXT_HEIGHT (f, new_native_height);
+ new_text_lines = new_text_height / unit_height;
-#ifdef HAVE_WINDOW_SYSTEM
if (FRAME_WINDOW_P (f)
&& f->can_set_window_size
&& ((!inhibit_horizontal
- && (new_pixel_width != old_pixel_width
+ && (new_native_width != old_native_width
|| inhibit == 0 || inhibit == 2))
|| (!inhibit_vertical
- && (new_pixel_height != old_pixel_height
+ && (new_native_height != old_native_height
|| inhibit == 0 || inhibit == 2))))
- /* We are either allowed to change the frame size or the minimum
- sizes request such a change. Do not care for fixing minimum
- sizes here, we do that eventually when we're called from
- change_frame_size. */
{
/* Make sure we respect fullheight and fullwidth. */
if (inhibit_horizontal)
- new_text_width = old_text_width;
+ new_native_width = old_native_width;
else if (inhibit_vertical)
- new_text_height = old_text_height;
+ new_native_height = old_native_height;
+
+ if (inhibit == 2 && f->new_width > 0 && f->new_height > 0)
+ /* For implied resizes with inhibit 2 (external menu and tool
+ bar) pick up any new sizes the display engine has not
+ processed yet. Otherwsie, we would request the old sizes
+ which will make this request appear as a request to set new
+ sizes and have the WM react accordingly which is not TRT. */
+ {
+ /* But don't that for the external menu bar on Motif.
+ Otherwise, switching off the menu bar will shrink the frame
+ and switching it on will not enlarge it. */
+#ifdef USE_MOTIF
+ if (!EQ (parameter, Qmenu_bar_lines))
+#endif
+ {
+ new_native_width = f->new_width;
+ new_native_height = f->new_height;
+ }
+ }
- frame_size_history_add
- (f, Qadjust_frame_size_2, new_text_width, new_text_height,
- list2 (inhibit_horizontal ? Qt : Qnil,
- inhibit_vertical ? Qt : Qnil));
+ if (CONSP (frame_size_history))
+ frame_size_history_adjust (f, inhibit, parameter,
+ old_text_width, old_text_height,
+ new_text_width, new_text_height,
+ old_text_cols, old_text_lines,
+ new_text_cols, new_text_lines,
+ old_native_width, old_native_height,
+ new_native_width, new_native_height,
+ old_inner_width, old_inner_height,
+ new_inner_width, new_inner_height,
+ min_inner_width, min_inner_height,
+ inhibit_horizontal, inhibit_vertical);
if (FRAME_TERMINAL (f)->set_window_size_hook)
FRAME_TERMINAL (f)->set_window_size_hook
- (f, 0, new_text_width, new_text_height, 1);
+ (f, 0, new_native_width, new_native_height);
f->resized_p = true;
return;
}
-#endif
+
+ if (CONSP (frame_size_history))
+ frame_size_history_adjust (f, inhibit, parameter,
+ old_text_width, old_text_height,
+ new_text_width, new_text_height,
+ old_text_cols, old_text_lines,
+ new_text_cols, new_text_lines,
+ old_native_width, old_native_height,
+ new_native_width, new_native_height,
+ old_inner_width, old_inner_height,
+ new_inner_width, new_inner_height,
+ min_inner_width, min_inner_height,
+ inhibit_horizontal, inhibit_vertical);
if ((XWINDOW (FRAME_ROOT_WINDOW (f))->pixel_top
== FRAME_TOP_MARGIN_HEIGHT (f))
&& new_text_width == old_text_width
&& new_text_height == old_text_height
- && new_windows_width == old_windows_width
- && new_windows_height == old_windows_height
- && new_pixel_width == old_pixel_width
- && new_pixel_height == old_pixel_height
- && new_cols == old_cols
- && new_lines == old_lines)
- /* No change. Sanitize window sizes and return. */
- {
- sanitize_window_sizes (Qt);
- sanitize_window_sizes (Qnil);
-
- return;
- }
+ && new_inner_width == old_inner_width
+ && new_inner_height == old_inner_height
+ /* We might be able to drop these but some doubts remain. */
+ && new_native_width == old_native_width
+ && new_native_height == old_native_height
+ && new_text_cols == old_text_cols
+ && new_text_lines == old_text_lines)
+ /* No change. */
+ return;
block_input ();
@@ -736,69 +803,67 @@ adjust_frame_size (struct frame *f, int new_width, int
new_height, int inhibit,
our video hardware. Try to find the smallest size greater or
equal to the requested dimensions, while accounting for the fact
that the menu-bar lines are not counted in the frame height. */
- int dos_new_lines = new_lines + FRAME_TOP_MARGIN (f);
- dos_set_window_size (&dos_new_lines, &new_cols);
- new_lines = dos_new_lines - FRAME_TOP_MARGIN (f);
+ int dos_new_text_lines = new_text_lines + FRAME_TOP_MARGIN (f);
+
+ dos_set_window_size (&dos_new_text_lines, &new_text_cols);
+ new_text_lines = dos_new_text_lines - FRAME_TOP_MARGIN (f);
#endif
- if (new_windows_width != old_windows_width)
+ if (new_inner_width != old_inner_width)
{
- resize_frame_windows (f, new_windows_width, true);
+ resize_frame_windows (f, new_inner_width, true);
/* MSDOS frames cannot PRETEND, as they change frame size by
manipulating video hardware. */
if ((FRAME_TERMCAP_P (f) && !pretend) || FRAME_MSDOS_P (f))
- FrameCols (FRAME_TTY (f)) = new_cols;
+ FrameCols (FRAME_TTY (f)) = new_text_cols;
#if defined (HAVE_WINDOW_SYSTEM)
if (WINDOWP (f->tab_bar_window))
{
- XWINDOW (f->tab_bar_window)->pixel_width = new_windows_width;
+ XWINDOW (f->tab_bar_window)->pixel_width = new_inner_width;
XWINDOW (f->tab_bar_window)->total_cols
- = new_windows_width / unit_width;
+ = new_inner_width / unit_width;
}
#endif
#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_TOOL_BAR)
if (WINDOWP (f->tool_bar_window))
{
- XWINDOW (f->tool_bar_window)->pixel_width = new_windows_width;
+ XWINDOW (f->tool_bar_window)->pixel_width = new_inner_width;
XWINDOW (f->tool_bar_window)->total_cols
- = new_windows_width / unit_width;
+ = new_inner_width / unit_width;
}
#endif
}
- else if (new_cols != old_cols)
+ else if (new_text_cols != old_text_cols)
call2 (Qwindow__pixel_to_total, frame, Qt);
- if (new_windows_height != old_windows_height
+ if (new_inner_height != old_inner_height
/* When the top margin has changed we have to recalculate the top
edges of all windows. No such calculation is necessary for the
left edges. */
|| WINDOW_TOP_PIXEL_EDGE (r) != FRAME_TOP_MARGIN_HEIGHT (f))
{
- resize_frame_windows (f, new_windows_height, false);
+ resize_frame_windows (f, new_inner_height, false);
/* MSDOS frames cannot PRETEND, as they change frame size by
manipulating video hardware. */
if ((FRAME_TERMCAP_P (f) && !pretend) || FRAME_MSDOS_P (f))
- FrameRows (FRAME_TTY (f)) = new_lines + FRAME_TOP_MARGIN (f);
+ FrameRows (FRAME_TTY (f)) = new_text_lines + FRAME_TOP_MARGIN (f);
}
- else if (new_lines != old_lines)
+ else if (new_text_lines != old_text_lines)
call2 (Qwindow__pixel_to_total, frame, Qnil);
- frame_size_history_add
- (f, Qadjust_frame_size_3, new_text_width, new_text_height,
- list4i (old_pixel_width, old_pixel_height,
- new_pixel_width, new_pixel_height));
-
/* Assign new sizes. */
+ FRAME_COLS (f) = new_text_cols;
+ FRAME_LINES (f) = new_text_lines;
FRAME_TEXT_WIDTH (f) = new_text_width;
FRAME_TEXT_HEIGHT (f) = new_text_height;
- FRAME_PIXEL_WIDTH (f) = new_pixel_width;
- FRAME_PIXEL_HEIGHT (f) = new_pixel_height;
- SET_FRAME_COLS (f, new_cols);
- SET_FRAME_LINES (f, new_lines);
+ FRAME_PIXEL_WIDTH (f) = new_native_width;
+ FRAME_PIXEL_HEIGHT (f) = new_native_height;
+ FRAME_TOTAL_COLS (f) = FRAME_PIXEL_WIDTH (f) / FRAME_COLUMN_WIDTH (f);
+ FRAME_TOTAL_LINES (f) = FRAME_PIXEL_HEIGHT (f) / FRAME_LINE_HEIGHT (f);
{
struct window *w = XWINDOW (FRAME_SELECTED_WINDOW (f));
@@ -812,18 +877,18 @@ adjust_frame_size (struct frame *f, int new_width, int
new_height, int inhibit,
w->cursor.vpos = w->cursor.y = 0;
}
- /* Sanitize window sizes. */
- sanitize_window_sizes (Qt);
- sanitize_window_sizes (Qnil);
-
adjust_frame_glyphs (f);
calculate_costs (f);
SET_FRAME_GARBAGED (f);
+ /* We now say here that F was resized instead of using the old
+ condition below. Some resizing must have taken place and if it was
+ only shifting the root window's position (paranoia?). */
+ f->resized_p = true;
- /* A frame was "resized" if one of its pixelsizes changed, even if its
- X window wasn't resized at all. */
- f->resized_p = (new_pixel_width != old_pixel_width
- || new_pixel_height != old_pixel_height);
+/** /\* A frame was "resized" if its native size changed, even if its X **/
+/** window wasn't resized at all. *\/ **/
+/** f->resized_p = (new_native_width != old_native_width **/
+/** || new_native_height != old_native_height); **/
unblock_input ();
@@ -834,8 +899,8 @@ adjust_frame_size (struct frame *f, int new_width, int
new_height, int inhibit,
FOR_EACH_FRAME (frames, frame1)
if (FRAME_PARENT_FRAME (XFRAME (frame1)) == f)
- keep_ratio (XFRAME (frame1), f, old_pixel_width, old_pixel_height,
- new_pixel_width, new_pixel_height);
+ keep_ratio (XFRAME (frame1), f, old_native_width, old_native_height,
+ new_native_width, new_native_height);
}
#endif
}
@@ -884,6 +949,8 @@ make_frame (bool mini_p)
f->tool_bar_resized = false;
f->column_width = 1; /* !FRAME_WINDOW_P value. */
f->line_height = 1; /* !FRAME_WINDOW_P value. */
+ f->new_width = -1;
+ f->new_height = -1;
#ifdef HAVE_WINDOW_SYSTEM
f->vertical_scroll_bar_type = vertical_scroll_bar_none;
f->horizontal_scroll_bars = false;
@@ -932,17 +999,14 @@ make_frame (bool mini_p)
wset_frame (rw, frame);
- /* 80/25 is arbitrary,
- just so that there is "something there."
+ /* 80/25 is arbitrary, just so that there is "something there."
Correct size will be set up later with adjust_frame_size. */
+ FRAME_COLS (f) = FRAME_TOTAL_COLS (f) = rw->total_cols = 80;
+ FRAME_TEXT_WIDTH (f) = FRAME_PIXEL_WIDTH (f) = rw->pixel_width
+ = 80 * FRAME_COLUMN_WIDTH (f);
+ FRAME_LINES (f) = FRAME_TOTAL_LINES (f) = 25;
+ FRAME_TEXT_HEIGHT (f) = FRAME_PIXEL_HEIGHT (f) = 25 * FRAME_LINE_HEIGHT (f);
- SET_FRAME_COLS (f, 80);
- SET_FRAME_LINES (f, 25);
- SET_FRAME_WIDTH (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f));
- SET_FRAME_HEIGHT (f, FRAME_LINES (f) * FRAME_LINE_HEIGHT (f));
-
- rw->total_cols = FRAME_COLS (f);
- rw->pixel_width = rw->total_cols * FRAME_COLUMN_WIDTH (f);
rw->total_lines = FRAME_LINES (f) - (mini_p ? 1 : 0);
rw->pixel_height = rw->total_lines * FRAME_LINE_HEIGHT (f);
@@ -1316,8 +1380,8 @@ affects all frames on the same terminal device. */)
{
int width, height;
get_tty_size (fileno (FRAME_TTY (f)->input), &width, &height);
- adjust_frame_size (f, width, height - FRAME_MENU_BAR_LINES (f)
- - FRAME_TAB_BAR_LINES (f),
+ /* With INHIBIT 5 pass correct text height to adjust_frame_size. */
+ adjust_frame_size (f, width, height - FRAME_TOP_MARGIN (f),
5, 0, Qterminal_frame);
}
@@ -1384,7 +1448,8 @@ do_switch_frame (Lisp_Object frame, int track, int
for_deletion, Lisp_Object nor
especially when deleting the initial frame during startup. */
CHECK_FRAME (frame);
f = XFRAME (frame);
- if (!FRAME_LIVE_P (f))
+ /* Silently ignore dead and tooltip frames (Bug#47207). */
+ if (!FRAME_LIVE_P (f) || FRAME_TOOLTIP_P (f))
return Qnil;
else if (f == sf)
return frame;
@@ -1508,7 +1573,16 @@ redisplay will display FRAME.
This function returns FRAME, or nil if FRAME has been deleted. */)
(Lisp_Object frame, Lisp_Object norecord)
{
- return do_switch_frame (frame, 1, 0, norecord);
+ struct frame *f;
+
+ CHECK_LIVE_FRAME (frame);
+ f = XFRAME (frame);
+
+ if (FRAME_TOOLTIP_P (f))
+ /* Do not select a tooltip frame (Bug#47207). */
+ error ("Cannot select a tooltip frame");
+ else
+ return do_switch_frame (frame, 1, 0, norecord);
}
DEFUN ("handle-switch-frame", Fhandle_switch_frame,
@@ -1523,6 +1597,7 @@ necessarily represent user-visible input focus. */)
/* Preserve prefix arg that the command loop just cleared. */
kset_prefix_arg (current_kboard, Vcurrent_prefix_arg);
run_hook (Qmouse_leave_buffer_hook);
+
return do_switch_frame (event, 0, 0, Qnil);
}
@@ -3209,21 +3284,23 @@ If FRAME is omitted or nil, return information on the
currently selected frame.
: FRAME_W32_P (f) ? "w32term"
:"tty"));
}
+
store_in_alist (&alist, Qname, f->name);
- height = (f->new_height
- ? (f->new_pixelwise
- ? (f->new_height / FRAME_LINE_HEIGHT (f))
- : f->new_height)
+ /* It's questionable whether here we should report the value of
+ f->new_height (and f->new_width below) but we've done that in the
+ past, so let's keep it. Note that a value of -1 for either of
+ these means that no new size was requested. */
+ height = (f->new_height >= 0
+ ? f->new_height / FRAME_LINE_HEIGHT (f)
: FRAME_LINES (f));
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));
+ width = (f->new_width >= 0
+ ? f->new_width / FRAME_COLUMN_WIDTH (f)
+ : FRAME_COLS(f));
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, 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);
store_in_alist (&alist, Qburied_buffer_list, f->buried_buffer_list);
@@ -3236,6 +3313,7 @@ If FRAME is omitted or nil, return information on the
currently selected frame.
{
/* This ought to be correct in f->param_alist for an X frame. */
Lisp_Object lines;
+
XSETFASTINT (lines, FRAME_MENU_BAR_LINES (f));
store_in_alist (&alist, Qmenu_bar_lines, lines);
XSETFASTINT (lines, FRAME_TAB_BAR_LINES (f));
@@ -3582,15 +3660,18 @@ DEFUN ("frame-bottom-divider-width",
Fbottom_divider_width, Sbottom_divider_widt
static int
check_frame_pixels (Lisp_Object size, Lisp_Object pixelwise, int item_size)
{
+ intmax_t sz;
+ int pixel_size; /* size * item_size */
+
CHECK_INTEGER (size);
if (!NILP (pixelwise))
item_size = 1;
- intmax_t sz;
- int pixel_size; /* size * item_size */
- if (! integer_to_intmax (size, &sz)
+
+ if (!integer_to_intmax (size, &sz)
|| INT_MULTIPLY_WRAPV (sz, item_size, &pixel_size))
args_out_of_range_3 (size, make_int (INT_MIN / item_size),
make_int (INT_MAX / item_size));
+
return pixel_size;
}
@@ -3613,9 +3694,13 @@ If FRAME is nil, it defaults to the selected frame. */)
(Lisp_Object frame, Lisp_Object height, Lisp_Object pretend, Lisp_Object
pixelwise)
{
struct frame *f = decode_live_frame (frame);
- int pixel_height = check_frame_pixels (height, pixelwise,
- FRAME_LINE_HEIGHT (f));
- adjust_frame_size (f, -1, pixel_height, 1, !NILP (pretend), Qheight);
+ int text_height
+ = check_frame_pixels (height, pixelwise, FRAME_LINE_HEIGHT (f));
+
+ /* With INHIBIT 1 pass correct text width to adjust_frame_size. */
+ adjust_frame_size
+ (f, FRAME_TEXT_WIDTH (f), text_height, 1, !NILP (pretend), Qheight);
+
return Qnil;
}
@@ -3638,9 +3723,13 @@ If FRAME is nil, it defaults to the selected frame. */)
(Lisp_Object frame, Lisp_Object width, Lisp_Object pretend, Lisp_Object
pixelwise)
{
struct frame *f = decode_live_frame (frame);
- int pixel_width = check_frame_pixels (width, pixelwise,
- FRAME_COLUMN_WIDTH (f));
- adjust_frame_size (f, pixel_width, -1, 1, !NILP (pretend), Qwidth);
+ int text_width
+ = check_frame_pixels (width, pixelwise, FRAME_COLUMN_WIDTH (f));
+
+ /* With INHIBIT 1 pass correct text height to adjust_frame_size. */
+ adjust_frame_size
+ (f, text_width, FRAME_TEXT_HEIGHT (f), 1, !NILP (pretend), Qwidth);
+
return Qnil;
}
@@ -3656,11 +3745,14 @@ If FRAME is nil, it defaults to the selected frame. */)
(Lisp_Object frame, Lisp_Object width, Lisp_Object height, Lisp_Object
pixelwise)
{
struct frame *f = decode_live_frame (frame);
- int pixel_width = check_frame_pixels (width, pixelwise,
- FRAME_COLUMN_WIDTH (f));
- int pixel_height = check_frame_pixels (height, pixelwise,
- FRAME_LINE_HEIGHT (f));
- adjust_frame_size (f, pixel_width, pixel_height, 1, 0, Qsize);
+ int text_width
+ = check_frame_pixels (width, pixelwise, FRAME_COLUMN_WIDTH (f));
+ int text_height
+ = check_frame_pixels (height, pixelwise, FRAME_LINE_HEIGHT (f));
+
+ /* PRETEND is always false here. */
+ adjust_frame_size (f, text_width, text_height, 1, false, Qsize);
+
return Qnil;
}
@@ -3744,6 +3836,18 @@ window state change flag is reset. */)
return (FRAME_WINDOW_STATE_CHANGE (f) = !NILP (arg)) ? Qt : Qnil;
}
+DEFUN ("frame-scale-factor", Fframe_scale_factor, Sframe_scale_factor,
+ 0, 1, 0,
+ doc: /* Return FRAMEs scale factor.
+If FRAME is omitted or nil, the selected frame is used.
+The scale factor is the amount by which a logical pixel size must be
+multiplied to find the real number of pixels. */)
+ (Lisp_Object frame)
+{
+ struct frame *f = decode_live_frame (frame);
+
+ return (make_float (f ? FRAME_SCALE_FACTOR (f) : 1));
+}
/***********************************************************************
Frame Parameters
@@ -4012,11 +4116,9 @@ gui_set_frame_parameters (struct frame *f, Lisp_Object
alist)
{
Lisp_Object tail, frame;
-
- /* If both of these parameters are present, it's more efficient to
- set them both at once. So we wait until we've looked at the
- entire list before we set them. */
- int width = -1, height = -1; /* -1 denotes they were not changed. */
+ /* Neither of these values should be used. */
+ int width = -1, height = -1;
+ bool width_change = false, height_change = false;
/* Same here. */
Lisp_Object left, top;
@@ -4094,6 +4196,8 @@ gui_set_frame_parameters (struct frame *f, Lisp_Object
alist)
if (EQ (prop, Qwidth))
{
+ width_change = true;
+
if (RANGED_FIXNUMP (0, val, INT_MAX))
width = XFIXNAT (val) * FRAME_COLUMN_WIDTH (f) ;
else if (CONSP (val) && EQ (XCAR (val), Qtext_pixels)
@@ -4102,9 +4206,13 @@ gui_set_frame_parameters (struct frame *f, Lisp_Object
alist)
else if (FLOATP (val))
width = frame_float (f, val, FRAME_FLOAT_WIDTH, &parent_done,
&outer_done, -1);
+ else
+ width_change = false;
}
else if (EQ (prop, Qheight))
{
+ height_change = true;
+
if (RANGED_FIXNUMP (0, val, INT_MAX))
height = XFIXNAT (val) * FRAME_LINE_HEIGHT (f);
else if (CONSP (val) && EQ (XCAR (val), Qtext_pixels)
@@ -4113,6 +4221,8 @@ gui_set_frame_parameters (struct frame *f, Lisp_Object
alist)
else if (FLOATP (val))
height = frame_float (f, val, FRAME_FLOAT_HEIGHT, &parent_done,
&outer_done, -1);
+ else
+ height_change = false;
}
else if (EQ (prop, Qtop))
top = val;
@@ -4181,23 +4291,28 @@ gui_set_frame_parameters (struct frame *f, Lisp_Object
alist)
XSETINT (icon_top, 0);
}
- /* Don't set these parameters unless they've been explicitly
- specified. The window might be mapped or resized while we're in
- this function, and we don't want to override that unless the lisp
- code has asked for it.
-
- Don't set these parameters unless they actually differ from the
- window's current parameters; the window may not actually exist
- yet. */
- if ((width != -1 && width != FRAME_TEXT_WIDTH (f))
- || (height != -1 && height != FRAME_TEXT_HEIGHT (f)))
- /* We could consider checking f->after_make_frame here, but I
- don't have the faintest idea why the following is needed at
- all. With the old setting it can get a Heisenbug when
- EmacsFrameResize intermittently provokes a delayed
- change_frame_size in the middle of adjust_frame_size. */
- /** || (f->can_set_window_size && (f->new_height || f->new_width)))
**/
- adjust_frame_size (f, width, height, 1, 0, Qx_set_frame_parameters);
+ if (width_change || height_change)
+ {
+ Lisp_Object parameter;
+
+ if (width_change)
+ {
+ if (height_change)
+ parameter = Qsize;
+ else
+ {
+ height = FRAME_TEXT_HEIGHT (f);
+ parameter = Qwidth;
+ }
+ }
+ else
+ {
+ width = FRAME_TEXT_WIDTH (f);
+ parameter = Qheight;
+ }
+
+ adjust_frame_size (f, width, height, 1, 0, parameter);
+ }
if ((!NILP (left) || !NILP (top))
&& ! (left_no_change && top_no_change)
@@ -4270,9 +4385,6 @@ gui_set_frame_parameters (struct frame *f, Lisp_Object
alist)
{
Lisp_Object old_value = get_frame_param (f, Qfullscreen);
- frame_size_history_add
- (f, Qx_set_fullscreen, 0, 0, list2 (old_value, fullscreen));
-
store_frame_param (f, Qfullscreen, fullscreen);
if (!EQ (fullscreen, old_value))
gui_set_fullscreen (f, fullscreen, old_value);
@@ -5481,25 +5593,16 @@ On Nextstep, this just calls `ns-parse-geometry'. */)
This function does not make the coordinates positive. */
-#define DEFAULT_ROWS 36
-#define DEFAULT_COLS 80
-
long
gui_figure_window_size (struct frame *f, Lisp_Object parms, bool tabbar_p,
- bool toolbar_p, int *x_width, int *x_height)
+ bool toolbar_p)
{
Lisp_Object height, width, user_size, top, left, user_position;
long window_prompting = 0;
Display_Info *dpyinfo = FRAME_DISPLAY_INFO (f);
int parent_done = -1, outer_done = -1;
-
- /* Default values if we fall through.
- Actually, if that happens we should get
- window manager prompting. */
- SET_FRAME_WIDTH (f, DEFAULT_COLS * FRAME_COLUMN_WIDTH (f));
- SET_FRAME_COLS (f, DEFAULT_COLS);
- SET_FRAME_HEIGHT (f, DEFAULT_ROWS * FRAME_LINE_HEIGHT (f));
- SET_FRAME_LINES (f, DEFAULT_ROWS);
+ int text_width = 80 * FRAME_COLUMN_WIDTH (f);
+ int text_height = 36 * FRAME_LINE_HEIGHT (f);
/* Window managers expect that if program-specified
positions are not (0,0), they're intentional, not defaults. */
@@ -5514,8 +5617,12 @@ gui_figure_window_size (struct frame *f, Lisp_Object
parms, bool tabbar_p,
if (tabbar_p && FRAME_TAB_BAR_LINES (f))
{
if (frame_default_tab_bar_height)
+ /* A default tab bar height was already set by the display code
+ for some other frame, use that. */
FRAME_TAB_BAR_HEIGHT (f) = frame_default_tab_bar_height;
else
+ /* Calculate the height from various other settings. For some
+ reason, these are usually off by 2 hence of no use. */
{
int margin, relief;
@@ -5568,7 +5675,7 @@ gui_figure_window_size (struct frame *f, Lisp_Object
parms, bool tabbar_p,
/* Ensure that earlier new_width and new_height settings won't
override what we specify below. */
- f->new_width = f->new_height = 0;
+ f->new_width = f->new_height = -1;
height = gui_display_get_arg (dpyinfo, parms, Qheight, 0, 0,
RES_TYPE_NUMBER);
width = gui_display_get_arg (dpyinfo, parms, Qwidth, 0, 0, RES_TYPE_NUMBER);
@@ -5582,9 +5689,8 @@ gui_figure_window_size (struct frame *f, Lisp_Object
parms, bool tabbar_p,
if ((XFIXNUM (XCDR (width)) < 0 || XFIXNUM (XCDR (width)) >
INT_MAX))
xsignal1 (Qargs_out_of_range, XCDR (width));
- SET_FRAME_WIDTH (f, XFIXNUM (XCDR (width)));
+ text_width = XFIXNUM (XCDR (width));
f->inhibit_horizontal_resize = true;
- *x_width = XFIXNUM (XCDR (width));
}
else if (FLOATP (width))
{
@@ -5598,7 +5704,7 @@ gui_figure_window_size (struct frame *f, Lisp_Object
parms, bool tabbar_p,
&parent_done, &outer_done, -1);
if (new_width > -1)
- SET_FRAME_WIDTH (f, new_width);
+ text_width = new_width;
}
}
else
@@ -5607,7 +5713,7 @@ gui_figure_window_size (struct frame *f, Lisp_Object
parms, bool tabbar_p,
if ((XFIXNUM (width) < 0 || XFIXNUM (width) > INT_MAX))
xsignal1 (Qargs_out_of_range, width);
- SET_FRAME_WIDTH (f, XFIXNUM (width) * FRAME_COLUMN_WIDTH (f));
+ text_width = XFIXNUM (width) * FRAME_COLUMN_WIDTH (f);
}
}
@@ -5619,9 +5725,8 @@ gui_figure_window_size (struct frame *f, Lisp_Object
parms, bool tabbar_p,
if ((XFIXNUM (XCDR (height)) < 0 || XFIXNUM (XCDR (height)) >
INT_MAX))
xsignal1 (Qargs_out_of_range, XCDR (height));
- SET_FRAME_HEIGHT (f, XFIXNUM (XCDR (height)));
+ text_height = XFIXNUM (XCDR (height));
f->inhibit_vertical_resize = true;
- *x_height = XFIXNUM (XCDR (height));
}
else if (FLOATP (height))
{
@@ -5635,7 +5740,7 @@ gui_figure_window_size (struct frame *f, Lisp_Object
parms, bool tabbar_p,
&parent_done, &outer_done, -1);
if (new_height > -1)
- SET_FRAME_HEIGHT (f, new_height);
+ text_height = new_height;
}
}
else
@@ -5644,7 +5749,7 @@ gui_figure_window_size (struct frame *f, Lisp_Object
parms, bool tabbar_p,
if ((XFIXNUM (height) < 0) || (XFIXNUM (height) > INT_MAX))
xsignal1 (Qargs_out_of_range, height);
- SET_FRAME_HEIGHT (f, XFIXNUM (height) * FRAME_LINE_HEIGHT (f));
+ text_height = XFIXNUM (height) * FRAME_LINE_HEIGHT (f);
}
}
@@ -5656,6 +5761,9 @@ gui_figure_window_size (struct frame *f, Lisp_Object
parms, bool tabbar_p,
window_prompting |= PSize;
}
+ adjust_frame_size (f, text_width, text_height, 5, false,
+ Qgui_figure_window_size);
+
top = gui_display_get_arg (dpyinfo, parms, Qtop, 0, 0, RES_TYPE_NUMBER);
left = gui_display_get_arg (dpyinfo, parms, Qleft, 0, 0, RES_TYPE_NUMBER);
user_position = gui_display_get_arg (dpyinfo, parms, Quser_position, 0, 0,
@@ -5963,39 +6071,17 @@ syms_of_frame (void)
DEFSYM (Qtab_bar_size, "tab-bar-size");
DEFSYM (Qtool_bar_external, "tool-bar-external");
DEFSYM (Qtool_bar_size, "tool-bar-size");
- /* The following are used for frame_size_history. */
- DEFSYM (Qadjust_frame_size_1, "adjust-frame-size-1");
- DEFSYM (Qadjust_frame_size_2, "adjust-frame-size-2");
- DEFSYM (Qadjust_frame_size_3, "adjust-frame-size-3");
- DEFSYM (Qx_set_frame_parameters, "x-set-frame-parameters");
- DEFSYM (QEmacsFrameResize, "EmacsFrameResize");
- DEFSYM (Qset_frame_size, "set-frame-size");
- DEFSYM (Qframe_inhibit_resize, "frame-inhibit-resize");
- DEFSYM (Qx_set_fullscreen, "x-set-fullscreen");
- DEFSYM (Qx_check_fullscreen, "x-check-fullscreen");
- DEFSYM (Qxg_frame_resized, "xg-frame-resized");
- DEFSYM (Qxg_frame_set_char_size_1, "xg-frame-set-char-size-1");
- DEFSYM (Qxg_frame_set_char_size_2, "xg-frame-set-char-size-2");
- DEFSYM (Qxg_frame_set_char_size_3, "xg-frame-set-char-size-3");
- DEFSYM (Qxg_frame_set_char_size_4, "xg-frame-set-char-size-4");
- DEFSYM (Qx_set_window_size_1, "x-set-window-size-1");
- DEFSYM (Qx_set_window_size_2, "x-set-window-size-2");
- DEFSYM (Qx_set_window_size_3, "x-set-window-size-3");
- DEFSYM (Qxg_change_toolbar_position, "xg-change-toolbar-position");
- DEFSYM (Qx_net_wm_state, "x-net-wm-state");
- DEFSYM (Qx_handle_net_wm_state, "x-handle-net-wm-state");
- DEFSYM (Qtb_size_cb, "tb-size-cb");
- DEFSYM (Qupdate_frame_tab_bar, "update-frame-tab-bar");
- DEFSYM (Qupdate_frame_tool_bar, "update-frame-tool-bar");
- DEFSYM (Qfree_frame_tab_bar, "free-frame-tab-bar");
- DEFSYM (Qfree_frame_tool_bar, "free-frame-tool-bar");
- DEFSYM (Qx_set_menu_bar_lines, "x-set-menu-bar-lines");
- DEFSYM (Qchange_frame_size, "change-frame-size");
- DEFSYM (Qxg_frame_set_char_size, "xg-frame-set-char-size");
- DEFSYM (Qset_window_configuration, "set-window-configuration");
- DEFSYM (Qx_create_frame_1, "x-create-frame-1");
- DEFSYM (Qx_create_frame_2, "x-create-frame-2");
- DEFSYM (Qterminal_frame, "terminal-frame");
+ /* The following are passed to adjust_frame_size. */
+ DEFSYM (Qx_set_menu_bar_lines, "x_set_menu_bar_lines");
+ DEFSYM (Qchange_frame_size, "change_frame_size");
+ DEFSYM (Qxg_frame_set_char_size, "xg_frame_set_char_size");
+ DEFSYM (Qx_set_window_size_1, "x_set_window_size_1");
+ DEFSYM (Qset_window_configuration, "set_window_configuration");
+ DEFSYM (Qx_create_frame_1, "x_create_frame_1");
+ DEFSYM (Qx_create_frame_2, "x_create_frame_2");
+ DEFSYM (Qgui_figure_window_size, "gui_figure_window_size");
+ DEFSYM (Qtip_frame, "tip_frame");
+ DEFSYM (Qterminal_frame, "terminal_frame");
#ifdef HAVE_NS
DEFSYM (Qns_parse_geometry, "ns-parse-geometry");
@@ -6024,9 +6110,7 @@ syms_of_frame (void)
DEFSYM (Qleft_fringe, "left-fringe");
DEFSYM (Qline_spacing, "line-spacing");
DEFSYM (Qmenu_bar_lines, "menu-bar-lines");
- DEFSYM (Qupdate_frame_menubar, "update-frame-menubar");
- DEFSYM (Qfree_frame_menubar_1, "free-frame-menubar-1");
- DEFSYM (Qfree_frame_menubar_2, "free-frame-menubar-2");
+ DEFSYM (Qtab_bar_lines, "tab-bar-lines");
DEFSYM (Qmouse_color, "mouse-color");
DEFSYM (Qname, "name");
DEFSYM (Qright_divider_width, "right-divider-width");
@@ -6038,7 +6122,6 @@ syms_of_frame (void)
DEFSYM (Qscroll_bar_width, "scroll-bar-width");
DEFSYM (Qsticky, "sticky");
DEFSYM (Qtitle, "title");
- DEFSYM (Qtab_bar_lines, "tab-bar-lines");
DEFSYM (Qtool_bar_lines, "tool-bar-lines");
DEFSYM (Qtool_bar_position, "tool-bar-position");
DEFSYM (Qunsplittable, "unsplittable");
@@ -6457,6 +6540,7 @@ iconify the top level frame instead. */);
defsubr (&Sframe_pointer_visible_p);
defsubr (&Sframe_window_state_change);
defsubr (&Sset_frame_window_state_change);
+ defsubr (&Sframe_scale_factor);
#ifdef HAVE_WINDOW_SYSTEM
defsubr (&Sx_get_resource);
diff --git a/src/frame.h b/src/frame.h
index 9ddcb4c..19ee6ac 100644
--- a/src/frame.h
+++ b/src/frame.h
@@ -256,8 +256,8 @@ struct frame
be used for output. */
bool_bf glyphs_initialized_p : 1;
- /* Set to true in change_frame_size when size of frame changed
- Clear the frame in clear_garbaged_frames if set. */
+ /* Set to true in adjust_frame_size when one of the frame's sizes
+ changed. Clear the frame in clear_garbaged_frames if set. */
bool_bf resized_p : 1;
/* Set to true if the default face for the frame has been
@@ -415,10 +415,6 @@ struct frame
bool_bf no_special_glyphs : 1;
#endif /* HAVE_WINDOW_SYSTEM */
- /* Whether new_height and new_width shall be interpreted
- in pixels. */
- bool_bf new_pixelwise : 1;
-
/* True means set_window_size_hook requests can be processed for
this frame. */
bool_bf can_set_window_size : 1;
@@ -426,11 +422,23 @@ struct frame
/* Set to true after this frame was made by `make-frame'. */
bool_bf after_make_frame : 1;
- /* Whether the tab bar height change should be taken into account. */
+ /* Two sticky flags, that are both false when a frame is created.
+ 'display_tab_bar' sets the former to true the first time it
+ displays the tab bar. When the former is true, the next call of
+ 'x_change_tab_bar_height' and associates sets the latter true and
+ tries to adjust the frame height in a way that the now valid pixel
+ height of the tab bar is taken into account by the frame's native
+ height. */
bool_bf tab_bar_redisplayed : 1;
bool_bf tab_bar_resized : 1;
- /* Whether the tool bar height change should be taken into account. */
+ /* Two sticky flags, that are both false when a frame is created.
+ 'redisplay_tool_bar' sets the former to true the first time it
+ displays the tool bar. When the former is true, the next call of
+ 'x_change_tool_bar_height' and associates sets the latter true and
+ tries to adjust the frame height in a way that the now valid pixel
+ height of the tool bar is taken into account by the frame's native
+ height. */
bool_bf tool_bar_redisplayed : 1;
bool_bf tool_bar_resized : 1;
@@ -461,7 +469,7 @@ struct frame
last time run_window_change_functions was called on it. */
ptrdiff_t number_of_windows;
- /* Number of lines (rounded up) of tab bar. REMOVE THIS */
+ /* Number of frame lines (rounded up) of tab bar. */
int tab_bar_lines;
/* Height of frame internal tab bar in pixels. */
@@ -470,7 +478,7 @@ struct frame
int n_tab_bar_rows;
int n_tab_bar_items;
- /* Number of lines (rounded up) of tool bar. REMOVE THIS */
+ /* Number of frame lines (rounded up) of tool bar. */
int tool_bar_lines;
/* Height of frame internal tool bar in pixels. */
@@ -492,39 +500,24 @@ struct frame
/* Cost of deleting n lines on this frame. */
int *delete_n_lines_cost;
- /* Text width of this frame (excluding fringes, vertical scroll bar
- and internal border widths) and text height (excluding menu bar,
- tool bar, horizontal scroll bar and internal border widths) in
- units of canonical characters. */
+ /* Text width and height of this frame in (and maybe rounded to) frame
+ columns and lines. */
int text_cols, text_lines;
-
- /* Total width of this frame (including fringes, vertical scroll bar
- and internal border widths) and total height (including menu bar,
- tool bar, horizontal scroll bar and internal border widths) in
- units of canonical characters. */
- int total_cols, total_lines;
-
- /* Text width of this frame (excluding fringes, vertical scroll bar
- and internal border widths) and text height (excluding menu bar,
- tool bar, horizontal scroll bar and internal border widths) in
- pixels. */
+ /* Text width and height of this frame in pixels. */
int text_width, text_height;
- /* New text height and width for pending size change. 0 if no change
- pending. These values represent pixels or canonical character units
- according to the value of new_pixelwise and correlate to the
- text width/height of the frame. */
+ /* Native width of this frame in (and maybe rounded to) frame columns
+ and lines. */
+ int total_cols, total_lines;
+ /* Native width and height of this frame in pixels. */
+ int pixel_width, pixel_height;
+ /* New native width and height of this frame for pending size change,
+ in pixels. -1 if no change pending. */
int new_width, new_height;
/* Pixel position of the frame window (x and y offsets in root window). */
int left_pos, top_pos;
- /* Total width of this frame (including fringes, vertical scroll bar
- and internal border widths) and total height (including internal
- menu and tool bars, horizontal scroll bar and internal border
- widths) in pixels. */
- int pixel_width, pixel_height;
-
/* This is the gravity value for the specified window position. */
int win_gravity;
@@ -848,7 +841,6 @@ default_pixels_per_inch_y (void)
/* FRAME_WINDOW_P tests whether the frame is a graphical window system
frame. */
-
#ifdef HAVE_X_WINDOWS
#define FRAME_WINDOW_P(f) FRAME_X_P (f)
#endif
@@ -907,45 +899,43 @@ default_pixels_per_inch_y (void)
(WINDOWP (f->minibuffer_window) \
&& XFRAME (XWINDOW (f->minibuffer_window)->frame) == f)
-/* Pixel width of frame F. */
-#define FRAME_PIXEL_WIDTH(f) ((f)->pixel_width)
+/* Scale factor of frame F. */
+#if defined HAVE_NS
+# define FRAME_SCALE_FACTOR(f) (FRAME_NS_P (f) ? ns_frame_scale_factor (f) : 1)
+#else
+# define FRAME_SCALE_FACTOR(f) 1
+#endif
-/* Pixel height of frame F. */
+/* Native width and height of frame F, in pixels and frame
+ columns/lines. */
+#define FRAME_PIXEL_WIDTH(f) ((f)->pixel_width)
#define FRAME_PIXEL_HEIGHT(f) ((f)->pixel_height)
+#define FRAME_TOTAL_COLS(f) ((f)->total_cols)
+#define FRAME_TOTAL_LINES(f) ((f)->total_lines)
-/* Width of frame F, measured in canonical character columns,
- not including scroll bars if any. */
-#define FRAME_COLS(f) (f)->text_cols
-
-/* Height of frame F, measured in canonical lines, including
- non-toolkit menu bar and non-toolkit tool bar lines. */
-#define FRAME_LINES(f) (f)->text_lines
-
-/* Width of frame F, measured in pixels not including the width for
- fringes, scroll bar, and internal borders. */
+/* Text width and height of frame F, in pixels and frame
+ columns/lines. */
#define FRAME_TEXT_WIDTH(f) (f)->text_width
-
-/* Height of frame F, measured in pixels not including the height
- for scroll bar and internal borders. */
#define FRAME_TEXT_HEIGHT(f) (f)->text_height
+#define FRAME_COLS(f) ((f)->text_cols)
+#define FRAME_LINES(f) ((f)->text_lines)
-/* Number of lines of frame F used for menu bar.
- This is relevant on terminal frames and on
- X Windows when not using the X toolkit.
- These lines are counted in FRAME_LINES. */
-#define FRAME_MENU_BAR_LINES(f) (f)->menu_bar_lines
+/* True if this frame should display an external menu bar. */
+#ifdef HAVE_EXT_MENU_BAR
+#define FRAME_EXTERNAL_MENU_BAR(f) (f)->external_menu_bar
+#else
+#define FRAME_EXTERNAL_MENU_BAR(f) false
+#endif
-/* Pixel height of frame F's menu bar. */
+/* Size of frame F's internal menu bar in frame lines and pixels. */
+#define FRAME_MENU_BAR_LINES(f) (f)->menu_bar_lines
#define FRAME_MENU_BAR_HEIGHT(f) (f)->menu_bar_height
-/* Number of lines of frame F used for the tab-bar. */
+/* Size of frame F's tab bar in frame lines and pixels. */
#define FRAME_TAB_BAR_LINES(f) (f)->tab_bar_lines
-
-/* Pixel height of frame F's tab-bar. */
#define FRAME_TAB_BAR_HEIGHT(f) (f)->tab_bar_height
-/* True if this frame should display a tool bar
- in a way that does not use any text lines. */
+/* True if this frame should display an external tool bar. */
#ifdef HAVE_EXT_TOOL_BAR
#define FRAME_EXTERNAL_TOOL_BAR(f) (f)->external_tool_bar
#else
@@ -959,27 +949,21 @@ default_pixels_per_inch_y (void)
#define FRAME_TOOL_BAR_POSITION(f) ((void) (f), Qtop)
#endif
-/* Number of lines of frame F used for the tool-bar. */
+/* Size of frame F's internal tool bar in frame lines and pixels. */
#define FRAME_TOOL_BAR_LINES(f) (f)->tool_bar_lines
-
-/* Pixel height of frame F's tool-bar. */
#define FRAME_TOOL_BAR_HEIGHT(f) (f)->tool_bar_height
-/* Lines above the top-most window in frame F. */
-#define FRAME_TOP_MARGIN(F) \
- (FRAME_MENU_BAR_LINES (F) + FRAME_TAB_BAR_LINES (F) + FRAME_TOOL_BAR_LINES
(F))
+/* Height of frame F's top margin in frame lines. */
+#define FRAME_TOP_MARGIN(F) \
+ (FRAME_MENU_BAR_LINES (F) \
+ + FRAME_TAB_BAR_LINES (F) \
+ + FRAME_TOOL_BAR_LINES (F))
/* Pixel height of frame F's top margin. */
-#define FRAME_TOP_MARGIN_HEIGHT(F) \
- (FRAME_MENU_BAR_HEIGHT (F) + FRAME_TAB_BAR_HEIGHT (F) +
FRAME_TOOL_BAR_HEIGHT (F))
-
-/* True if this frame should display a menu bar
- in a way that does not use any text lines. */
-#ifdef HAVE_EXT_MENU_BAR
-#define FRAME_EXTERNAL_MENU_BAR(f) (f)->external_menu_bar
-#else
-#define FRAME_EXTERNAL_MENU_BAR(f) false
-#endif
+#define FRAME_TOP_MARGIN_HEIGHT(F) \
+ (FRAME_MENU_BAR_HEIGHT (F) \
+ + FRAME_TAB_BAR_HEIGHT (F) \
+ + FRAME_TOOL_BAR_HEIGHT (F))
/* True if frame F is currently visible. */
#define FRAME_VISIBLE_P(f) (f)->visible
@@ -1176,48 +1160,6 @@ default_pixels_per_inch_y (void)
? FRAME_CONFIG_SCROLL_BAR_LINES (f) \
: 0)
-/* Total width of frame F, in columns (characters),
- including the width used by scroll bars if any. */
-#define FRAME_TOTAL_COLS(f) ((f)->total_cols)
-
-/* Total height of frame F, in lines (characters),
- including the height used by scroll bars if any. */
-#define FRAME_TOTAL_LINES(f) ((f)->total_lines)
-
-/* Set the character widths of frame F. WIDTH specifies a nominal
- character text width. */
-#define SET_FRAME_COLS(f, width) \
- ((f)->text_cols = (width), \
- (f)->total_cols = ((width) \
- + FRAME_SCROLL_BAR_COLS (f) \
- + FRAME_FRINGE_COLS (f)))
-
-/* Set the character heights of frame F. HEIGHT specifies a nominal
- character text height. */
-#define SET_FRAME_LINES(f, height) \
- ((f)->text_lines = (height), \
- (f)->total_lines = ((height)
\
- + FRAME_TOP_MARGIN (f) \
- + FRAME_SCROLL_BAR_LINES (f)))
-
-/* Set the widths of frame F. WIDTH specifies a nominal pixel text
- width. */
-#define SET_FRAME_WIDTH(f, width) \
- ((f)->text_width = (width), \
- (f)->pixel_width = ((width) \
- + FRAME_SCROLL_BAR_AREA_WIDTH (f) \
- + FRAME_TOTAL_FRINGE_WIDTH (f) \
- + 2 * FRAME_INTERNAL_BORDER_WIDTH (f)))
-
-/* Set the heights of frame F. HEIGHT specifies a nominal pixel text
- height. */
-#define SET_FRAME_HEIGHT(f, height) \
- ((f)->text_height = (height),
\
- (f)->pixel_height = ((height) \
- + FRAME_TOP_MARGIN_HEIGHT (f) \
- + FRAME_SCROLL_BAR_AREA_HEIGHT (f) \
- + 2 * FRAME_INTERNAL_BORDER_WIDTH (f)))
-
/* Maximum + 1 legitimate value for FRAME_CURSOR_X. */
#define FRAME_CURSOR_X_LIMIT(f) \
(FRAME_COLS (f) + FRAME_LEFT_SCROLL_BAR_COLS (f))
@@ -1238,7 +1180,6 @@ default_pixels_per_inch_y (void)
#define FRAME_BACKGROUND_PIXEL(f) ((f)->background_pixel)
/* Return a pointer to the face cache of frame F. */
-
#define FRAME_FACE_CACHE(F) (F)->face_cache
/* Return the size of message_buf of the frame F. We multiply the
@@ -1264,15 +1205,13 @@ default_pixels_per_inch_y (void)
This macro is a holdover from a time when multiple frames weren't always
supported. An alternate definition of the macro would expand to
something which executes the statement once. */
-
-#define FOR_EACH_FRAME(list_var, frame_var) \
- for ((list_var) = Vframe_list; \
- (CONSP (list_var) \
+#define FOR_EACH_FRAME(list_var, frame_var) \
+ for ((list_var) = Vframe_list; \
+ (CONSP (list_var) \
&& (frame_var = XCAR (list_var), true)); \
list_var = XCDR (list_var))
/* Reflect mouse movement when a complete frame update is performed. */
-
#define FRAME_MOUSE_UPDATE(frame) \
do { \
Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (frame); \
@@ -1287,8 +1226,7 @@ default_pixels_per_inch_y (void)
} while (false)
/* Handy macro to construct an argument to Fmodify_frame_parameters. */
-
-#define AUTO_FRAME_ARG(name, parameter, value) \
+#define AUTO_FRAME_ARG(name, parameter, value) \
AUTO_LIST1 (name, AUTO_CONS_EXPR (parameter, value))
/* False means there are no visible garbaged frames. */
@@ -1298,7 +1236,6 @@ extern bool frame_garbaged;
We call redisplay_other_windows to make sure the frame gets redisplayed
if some changes were applied to it while it wasn't visible (and hence
wasn't redisplayed). */
-
INLINE void
SET_FRAME_VISIBLE (struct frame *f, int v)
{
@@ -1313,9 +1250,8 @@ SET_FRAME_VISIBLE (struct frame *f, int v)
f->visible = v;
}
-/* Set iconify of frame F. */
-
-#define SET_FRAME_ICONIFIED(f, i) \
+/* Set iconified status of frame F. */
+#define SET_FRAME_ICONIFIED(f, i) \
(f)->iconified = (eassert (0 <= (i) && (i) <= 1), (i))
extern Lisp_Object selected_frame;
@@ -1362,11 +1298,14 @@ extern void frame_make_pointer_invisible (struct frame
*);
extern void frame_make_pointer_visible (struct frame *);
extern Lisp_Object delete_frame (Lisp_Object, Lisp_Object);
extern bool frame_inhibit_resize (struct frame *, bool, Lisp_Object);
-extern void adjust_frame_size (struct frame *, int, int, int, bool,
Lisp_Object);
-extern void frame_size_history_add (struct frame *f, Lisp_Object fun_symbol,
- int width, int height, Lisp_Object rest);
+extern void adjust_frame_size (struct frame *, int, int, int, bool,
+ Lisp_Object);
extern Lisp_Object mouse_position (bool);
-
+extern int frame_windows_min_size (Lisp_Object, Lisp_Object, Lisp_Object,
+ Lisp_Object);
+extern void frame_size_history_plain (struct frame *, Lisp_Object);
+extern void frame_size_history_extra (struct frame *, Lisp_Object,
+ int, int, int, int, int, int);
extern Lisp_Object Vframe_list;
/* Value is a pointer to the selected frame. If the selected frame
@@ -1645,12 +1584,11 @@ IMAGE_OPT_FROM_ID (struct frame *f, int id)
- FRAME_SCROLL_BAR_AREA_HEIGHT (f) \
- 2 * FRAME_INTERNAL_BORDER_WIDTH (f))
-/* Return the width/height reserved for the windows of frame F. */
-#define FRAME_WINDOWS_WIDTH(f) \
+#define FRAME_INNER_WIDTH(f) \
(FRAME_PIXEL_WIDTH (f) \
- 2 * FRAME_INTERNAL_BORDER_WIDTH (f))
-#define FRAME_WINDOWS_HEIGHT(f) \
+#define FRAME_INNER_HEIGHT(f) \
(FRAME_PIXEL_HEIGHT (f) \
- FRAME_TOP_MARGIN_HEIGHT (f) \
- 2 * FRAME_INTERNAL_BORDER_WIDTH (f))
@@ -1694,7 +1632,7 @@ extern void gui_set_horizontal_scroll_bars (struct frame
*, Lisp_Object, Lisp_Ob
extern void gui_set_scroll_bar_width (struct frame *, Lisp_Object,
Lisp_Object);
extern void gui_set_scroll_bar_height (struct frame *, Lisp_Object,
Lisp_Object);
-extern long gui_figure_window_size (struct frame *, Lisp_Object, bool, bool,
int *, int *);
+extern long gui_figure_window_size (struct frame *, Lisp_Object, bool, bool);
extern void gui_set_alpha (struct frame *, Lisp_Object, Lisp_Object);
extern void gui_set_no_special_glyphs (struct frame *, Lisp_Object,
Lisp_Object);
diff --git a/src/gtkutil.c b/src/gtkutil.c
index 4634c35..4ad172b 100644
--- a/src/gtkutil.c
+++ b/src/gtkutil.c
@@ -910,70 +910,58 @@ xg_set_geometry (struct frame *f)
}
}
-/* Function to handle resize of our frame. As we have a Gtk+ tool bar
- and a Gtk+ menu bar, we get resize events for the edit part of the
- frame only. We let Gtk+ deal with the Gtk+ parts.
- F is the frame to resize.
- PIXELWIDTH, PIXELHEIGHT is the new size in pixels. */
-
+/** Function to handle resize of native frame F to WIDTH and HEIGHT
+ pixels after we got a ConfigureNotify event. */
void
-xg_frame_resized (struct frame *f, int pixelwidth, int pixelheight)
+xg_frame_resized (struct frame *f, int width, int height)
{
- int width, height;
-
- if (pixelwidth == -1 && pixelheight == -1)
+ /* Ignore case where size of native rectangle didn't change. */
+ if (width != FRAME_PIXEL_WIDTH (f) || height != FRAME_PIXEL_HEIGHT (f)
+ || (delayed_size_change
+ && (width != f->new_width || height != f->new_height)))
{
- if (FRAME_GTK_WIDGET (f) && gtk_widget_get_mapped (FRAME_GTK_WIDGET (f)))
- gdk_window_get_geometry (gtk_widget_get_window (FRAME_GTK_WIDGET (f)),
- 0, 0, &pixelwidth, &pixelheight);
- else
- return;
- }
+ if (CONSP (frame_size_history))
+ frame_size_history_extra
+ (f, build_string ("xg_frame_resized, changed"),
+ FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f), width, height,
+ delayed_size_change ? f->new_width : -1,
+ delayed_size_change ? f->new_height : -1);
- width = FRAME_PIXEL_TO_TEXT_WIDTH (f, pixelwidth);
- height = FRAME_PIXEL_TO_TEXT_HEIGHT (f, pixelheight);
-
- frame_size_history_add
- (f, Qxg_frame_resized, width, height, Qnil);
-
- if (width != FRAME_TEXT_WIDTH (f)
- || height != FRAME_TEXT_HEIGHT (f)
- || pixelwidth != FRAME_PIXEL_WIDTH (f)
- || pixelheight != FRAME_PIXEL_HEIGHT (f))
- {
FRAME_RIF (f)->clear_under_internal_border (f);
- change_frame_size (f, width, height, 0, 1, 0, 1);
+ change_frame_size (f, width, height, false, true, false);
SET_FRAME_GARBAGED (f);
cancel_mouse_face (f);
}
+ else if (CONSP (frame_size_history))
+ frame_size_history_extra
+ (f, build_string ("xg_frame_resized, unchanged"),
+ FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f), width, height,
+ delayed_size_change ? f->new_width : -1,
+ delayed_size_change ? f->new_height : -1);
+
}
/** Resize the outer window of frame F. WIDTH and HEIGHT are the new
- pixel sizes of F's text area. */
+ native pixel sizes of F. */
void
xg_frame_set_char_size (struct frame *f, int width, int height)
{
- int pixelwidth = FRAME_TEXT_TO_PIXEL_WIDTH (f, width);
- int pixelheight = FRAME_TEXT_TO_PIXEL_HEIGHT (f, height);
Lisp_Object fullscreen = get_frame_param (f, Qfullscreen);
gint gwidth, gheight;
- int totalheight
- = pixelheight + FRAME_TOOLBAR_HEIGHT (f) + FRAME_MENUBAR_HEIGHT (f);
- int totalwidth = pixelwidth + FRAME_TOOLBAR_WIDTH (f);
+ int outer_height
+ = height + FRAME_TOOLBAR_HEIGHT (f) + FRAME_MENUBAR_HEIGHT (f);
+ int outer_width = width + FRAME_TOOLBAR_WIDTH (f);
bool was_visible = false;
bool hide_child_frame;
- if (FRAME_PIXEL_HEIGHT (f) == 0)
- return;
-
gtk_window_get_size (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
&gwidth, &gheight);
/* Do this before resize, as we don't know yet if we will be resized. */
FRAME_RIF (f)->clear_under_internal_border (f);
- totalheight /= xg_get_scale (f);
- totalwidth /= xg_get_scale (f);
+ outer_height /= xg_get_scale (f);
+ outer_width /= xg_get_scale (f);
x_wm_set_size_hint (f, 0, 0);
@@ -986,35 +974,19 @@ xg_frame_set_char_size (struct frame *f, int width, int
height)
manager will abolish it. At least the respective size should
remain unchanged but giving the frame back its normal size will
be broken ... */
- if (EQ (fullscreen, Qfullwidth) && width == FRAME_TEXT_WIDTH (f))
- {
- frame_size_history_add
- (f, Qxg_frame_set_char_size_1, width, height,
- list2i (gheight, totalheight));
-
- gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
- gwidth, totalheight);
- }
- else if (EQ (fullscreen, Qfullheight) && height == FRAME_TEXT_HEIGHT (f))
- {
- frame_size_history_add
- (f, Qxg_frame_set_char_size_2, width, height,
- list2i (gwidth, totalwidth));
-
- gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
- totalwidth, gheight);
- }
+ if (EQ (fullscreen, Qfullwidth) && width == FRAME_PIXEL_WIDTH (f))
+ gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ gwidth, outer_height);
+ else if (EQ (fullscreen, Qfullheight) && height == FRAME_PIXEL_HEIGHT (f))
+ gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
+ outer_width, gheight);
else if (FRAME_PARENT_FRAME (f) && FRAME_VISIBLE_P (f))
{
was_visible = true;
hide_child_frame = EQ (x_gtk_resize_child_frames, Qhide);
- if (totalwidth != gwidth || totalheight != gheight)
+ if (outer_width != gwidth || outer_height != gheight)
{
- frame_size_history_add
- (f, Qxg_frame_set_char_size_4, width, height,
- list2i (totalwidth, totalheight));
-
if (hide_child_frame)
{
block_input ();
@@ -1023,7 +995,7 @@ xg_frame_set_char_size (struct frame *f, int width, int
height)
}
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
- totalwidth, totalheight);
+ outer_width, outer_height);
if (hide_child_frame)
{
@@ -1037,11 +1009,8 @@ xg_frame_set_char_size (struct frame *f, int width, int
height)
}
else
{
- frame_size_history_add
- (f, Qxg_frame_set_char_size_3, width, height,
- list2i (totalwidth, totalheight));
gtk_window_resize (GTK_WINDOW (FRAME_GTK_OUTER_WIDGET (f)),
- totalwidth, totalheight);
+ outer_width, outer_height);
fullscreen = Qnil;
}
@@ -1062,6 +1031,12 @@ xg_frame_set_char_size (struct frame *f, int width, int
height)
gdk_flush ();
x_wait_for_event (f, ConfigureNotify);
+ if (CONSP (frame_size_history))
+ frame_size_history_extra
+ (f, build_string ("xg_frame_set_char_size, visible"),
+ FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f), width, height,
+ f->new_width, f->new_height);
+
if (!NILP (fullscreen))
/* Try to restore fullscreen state. */
{
@@ -1070,8 +1045,17 @@ xg_frame_set_char_size (struct frame *f, int width, int
height)
}
}
else
- adjust_frame_size (f, width, height, 5, 0, Qxg_frame_set_char_size);
-
+ {
+ if (CONSP (frame_size_history))
+ frame_size_history_extra
+ (f, build_string ("xg_frame_set_char_size, invisible"),
+ FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f), width, height,
+ f->new_width, f->new_height);
+
+ adjust_frame_size (f, FRAME_PIXEL_TO_TEXT_WIDTH (f, width),
+ FRAME_PIXEL_TO_TEXT_HEIGHT (f, height),
+ 5, 0, Qxg_frame_set_char_size);
+ }
}
/* Handle height/width changes (i.e. add/remove/move menu/toolbar).
@@ -1186,7 +1170,8 @@ style_changed_cb (GObject *go,
{
FRAME_TERMINAL (f)->set_scroll_bar_default_width_hook (f);
FRAME_TERMINAL (f)->set_scroll_bar_default_height_hook (f);
- xg_frame_set_char_size (f, FRAME_TEXT_WIDTH (f),
FRAME_TEXT_HEIGHT (f));
+ xg_frame_set_char_size (f, FRAME_PIXEL_WIDTH (f),
+ FRAME_PIXEL_HEIGHT (f));
}
}
}
@@ -4589,10 +4574,7 @@ tb_size_cb (GtkWidget *widget,
struct frame *f = user_data;
if (xg_update_tool_bar_sizes (f))
- {
- frame_size_history_add (f, Qtb_size_cb, 0, 0, Qnil);
- adjust_frame_size (f, -1, -1, 5, 0, Qtool_bar_lines);
- }
+ adjust_frame_size (f, -1, -1, 2, false, Qtool_bar_lines);
}
/* Create a tool bar for frame F. */
@@ -5219,23 +5201,10 @@ update_frame_tool_bar (struct frame *f)
xg_pack_tool_bar (f, FRAME_TOOL_BAR_POSITION (f));
gtk_widget_show_all (x->toolbar_widget);
if (xg_update_tool_bar_sizes (f))
- {
- int inhibit
- = ((f->after_make_frame
- && !f->tool_bar_resized
- && (EQ (frame_inhibit_implied_resize, Qt)
- || (CONSP (frame_inhibit_implied_resize)
- && !NILP (Fmemq (Qtool_bar_lines,
- frame_inhibit_implied_resize))))
- /* This will probably fail to DTRT in the
- fullheight/-width cases. */
- && NILP (get_frame_param (f, Qfullscreen)))
- ? 0
- : 2);
-
- frame_size_history_add (f, Qupdate_frame_tool_bar, 0, 0, Qnil);
- adjust_frame_size (f, -1, -1, inhibit, 0, Qtool_bar_lines);
- }
+ /* It's not entirely clear whether here we want a treatment
+ similar to that for frames with internal tool bar. */
+ adjust_frame_size (f, -1, -1, 2, 0, Qtool_bar_lines);
+
f->tool_bar_resized = f->tool_bar_redisplayed;
}
@@ -5284,7 +5253,6 @@ free_frame_tool_bar (struct frame *f)
NULL);
}
- frame_size_history_add (f, Qfree_frame_tool_bar, 0, 0, Qnil);
adjust_frame_size (f, -1, -1, 2, 0, Qtool_bar_lines);
unblock_input ();
@@ -5316,11 +5284,7 @@ xg_change_toolbar_position (struct frame *f, Lisp_Object
pos)
g_object_unref (top_widget);
if (xg_update_tool_bar_sizes (f))
- {
- frame_size_history_add (f, Qxg_change_toolbar_position, 0, 0, Qnil);
- adjust_frame_size (f, -1, -1, 2, 0, Qtool_bar_lines);
- }
-
+ adjust_frame_size (f, -1, -1, 2, 0, Qtool_bar_lines);
unblock_input ();
}
diff --git a/src/image.c b/src/image.c
index b85418c..f2fb69a 100644
--- a/src/image.c
+++ b/src/image.c
@@ -135,14 +135,6 @@ typedef struct ns_bitmap_record Bitmap_Record;
# define COLOR_TABLE_SUPPORT 1
#endif
-#ifdef HAVE_RSVG
-#if defined HAVE_NS
-# define FRAME_SCALE_FACTOR(f) ns_frame_scale_factor (f)
-#else
-# define FRAME_SCALE_FACTOR(f) 1;
-#endif
-#endif
-
static void image_disable_image (struct frame *, struct image *);
static void image_edge_detection (struct frame *, struct image *, Lisp_Object,
Lisp_Object);
@@ -519,7 +511,7 @@ image_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_fixnum (R_OK), false)
+ make_fixnum (R_OK), false, false)
< 0)
return -1;
@@ -1207,6 +1199,7 @@ free_image (struct frame *f, struct image *img)
/* Free resources, then free IMG. */
img->type->free_img (f, img);
+ xfree (img->face_font_family);
xfree (img);
}
}
@@ -1605,7 +1598,7 @@ make_image_cache (void)
static struct image *
search_image_cache (struct frame *f, Lisp_Object spec, EMACS_UINT hash,
unsigned long foreground, unsigned long background,
- bool ignore_colors)
+ int font_size, char *font_family, bool ignore_colors)
{
struct image *img;
struct image_cache *c = FRAME_IMAGE_CACHE (f);
@@ -1629,7 +1622,10 @@ search_image_cache (struct frame *f, Lisp_Object spec,
EMACS_UINT hash,
if (img->hash == hash
&& !NILP (Fequal (img->spec, spec))
&& (ignore_colors || (img->face_foreground == foreground
- && img->face_background == background)))
+ && img->face_background == background
+ && img->face_font_size == font_size
+ && (font_family
+ &&!strcmp (font_family,
img->face_font_family)))))
break;
return img;
}
@@ -1647,7 +1643,7 @@ uncache_image (struct frame *f, Lisp_Object spec)
can have multiple copies of an image with the same spec. We want
to remove them all to ensure the user doesn't see an old version
of the image when the face changes. */
- while ((img = search_image_cache (f, spec, hash, 0, 0, true)))
+ while ((img = search_image_cache (f, spec, hash, 0, 0, 0, NULL, true)))
{
free_image (f, img);
/* As display glyphs may still be referring to the image ID, we
@@ -1991,46 +1987,68 @@ scale_image_size (int size, size_t divisor, size_t
multiplier)
return INT_MAX;
}
+/* Return a size, in pixels, from the value specified by SYMBOL, which
+ may be an integer or a pair of the form (VALUE . 'em) where VALUE
+ is a float that is multiplied by the font size to get the final
+ dimension.
+
+ If the value doesn't exist in the image spec, or is invalid, return
+ -1.
+*/
+static int
+image_get_dimension (struct image *img, Lisp_Object symbol)
+{
+ Lisp_Object value = image_spec_value (img->spec, symbol, NULL);
+
+ if (FIXNATP (value))
+ return min (XFIXNAT (value), INT_MAX);
+ if (CONSP (value) && NUMBERP (CAR (value)) && EQ (Qem, CDR (value)))
+ return min (img->face_font_size * XFLOATINT (CAR (value)), INT_MAX);
+
+ return -1;
+}
+
/* Compute the desired size of an image with native size WIDTH x HEIGHT.
Use SPEC to deduce the size. Store the desired size into
*D_WIDTH x *D_HEIGHT. Store -1 x -1 if the native size is OK. */
static void
compute_image_size (size_t width, size_t height,
- Lisp_Object spec,
+ struct image *img,
int *d_width, int *d_height)
{
Lisp_Object value;
+ int int_value;
int desired_width = -1, desired_height = -1, max_width = -1, max_height = -1;
double scale = 1;
- value = image_spec_value (spec, QCscale, NULL);
+ value = image_spec_value (img->spec, QCscale, NULL);
if (NUMBERP (value))
scale = XFLOATINT (value);
- value = image_spec_value (spec, QCmax_width, NULL);
- if (FIXNATP (value))
- max_width = min (XFIXNAT (value), INT_MAX);
+ int_value = image_get_dimension (img, QCmax_width);
+ if (int_value >= 0)
+ max_width = int_value;
- value = image_spec_value (spec, QCmax_height, NULL);
- if (FIXNATP (value))
- max_height = min (XFIXNAT (value), INT_MAX);
+ int_value = image_get_dimension (img, QCmax_height);
+ if (int_value >= 0)
+ max_height = int_value;
/* If width and/or height is set in the display spec assume we want
to scale to those values. If either h or w is unspecified, the
unspecified should be calculated from the specified to preserve
aspect ratio. */
- value = image_spec_value (spec, QCwidth, NULL);
- if (FIXNATP (value))
+ int_value = image_get_dimension (img, QCwidth);
+ if (int_value >= 0)
{
- desired_width = min (XFIXNAT (value) * scale, INT_MAX);
+ desired_width = int_value * scale;
/* :width overrides :max-width. */
max_width = -1;
}
- value = image_spec_value (spec, QCheight, NULL);
- if (FIXNATP (value))
+ int_value = image_get_dimension (img, QCheight);
+ if (int_value >= 0)
{
- desired_height = min (XFIXNAT (value) * scale, INT_MAX);
+ desired_height = int_value * scale;
/* :height overrides :max-height. */
max_height = -1;
}
@@ -2220,7 +2238,7 @@ image_set_transform (struct frame *f, struct image *img)
}
else
#endif
- compute_image_size (img->width, img->height, img->spec, &width, &height);
+ compute_image_size (img->width, img->height, img, &width, &height);
/* Determine rotation. */
double rotation = 0.0;
@@ -2419,6 +2437,8 @@ lookup_image (struct frame *f, Lisp_Object spec, int
face_id)
struct face *face = FACE_FROM_ID (f, face_id);
unsigned long foreground = FACE_COLOR_TO_PIXEL (face->foreground, f);
unsigned long background = FACE_COLOR_TO_PIXEL (face->background, f);
+ int font_size = face->font->pixel_size;
+ char *font_family = SSDATA (face->lface[LFACE_FAMILY_INDEX]);
/* F must be a window-system frame, and SPEC must be a valid image
specification. */
@@ -2427,7 +2447,8 @@ lookup_image (struct frame *f, Lisp_Object spec, int
face_id)
/* Look up SPEC in the hash table of the image cache. */
hash = sxhash (spec);
- img = search_image_cache (f, spec, hash, foreground, background, false);
+ img = search_image_cache (f, spec, hash, foreground, background,
+ font_size, font_family, false);
if (img && img->load_failed_p)
{
free_image (f, img);
@@ -2442,6 +2463,9 @@ lookup_image (struct frame *f, Lisp_Object spec, int
face_id)
cache_image (f, img);
img->face_foreground = foreground;
img->face_background = background;
+ img->face_font_size = font_size;
+ img->face_font_family = xmalloc (strlen (font_family) + 1);
+ strcpy (img->face_font_family, font_family);
img->load_failed_p = ! img->type->load_img (f, img);
/* If we can't load the image, and we don't have a width and
@@ -3128,7 +3152,7 @@ image_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_fixnum (R_OK), false);
+ pfd ? Qt : make_fixnum (R_OK), false, false);
if (fd >= 0 || fd == -2)
{
file_found = ENCODE_FILE (file_found);
@@ -9208,7 +9232,7 @@ imagemagick_load_image (struct frame *f, struct image
*img,
compute_image_size (MagickGetImageWidth (image_wand),
MagickGetImageHeight (image_wand),
- img->spec, &desired_width, &desired_height);
+ img, &desired_width, &desired_height);
if (desired_width != -1 && desired_height != -1)
{
@@ -9540,6 +9564,7 @@ enum svg_keyword_index
SVG_DATA,
SVG_FILE,
SVG_BASE_URI,
+ SVG_CSS,
SVG_ASCENT,
SVG_MARGIN,
SVG_RELIEF,
@@ -9560,6 +9585,7 @@ static const struct image_keyword svg_format[SVG_LAST] =
{":data", IMAGE_STRING_VALUE, 0},
{":file", IMAGE_STRING_VALUE, 0},
{":base-uri", IMAGE_STRING_VALUE, 0},
+ {":css", IMAGE_STRING_VALUE, 0},
{":ascent", IMAGE_ASCENT_VALUE, 0},
{":margin", IMAGE_NON_NEGATIVE_INTEGER_VALUE_OR_PAIR, 0},
{":relief", IMAGE_INTEGER_VALUE, 0},
@@ -9643,6 +9669,11 @@ DEF_DLL_FN (gboolean, rsvg_handle_get_geometry_for_layer,
(RsvgHandle *, const char *, const RsvgRectangle *,
RsvgRectangle *, RsvgRectangle *, GError **));
# endif
+
+# if LIBRSVG_CHECK_VERSION (2, 48, 0)
+DEF_DLL_FN (gboolean, rsvg_handle_set_stylesheet,
+ (RsvgHandle *, const guint8 *, gsize, GError **));
+# endif
DEF_DLL_FN (void, rsvg_handle_get_dimensions,
(RsvgHandle *, RsvgDimensionData *));
DEF_DLL_FN (GdkPixbuf *, rsvg_handle_get_pixbuf, (RsvgHandle *));
@@ -9696,6 +9727,9 @@ init_svg_functions (void)
LOAD_DLL_FN (library, rsvg_handle_get_intrinsic_dimensions);
LOAD_DLL_FN (library, rsvg_handle_get_geometry_for_layer);
#endif
+#if LIBRSVG_CHECK_VERSION (2, 48, 0)
+ LOAD_DLL_FN (library, rsvg_handle_set_stylesheet);
+#endif
LOAD_DLL_FN (library, rsvg_handle_get_dimensions);
LOAD_DLL_FN (library, rsvg_handle_get_pixbuf);
@@ -9736,6 +9770,9 @@ init_svg_functions (void)
# undef rsvg_handle_get_geometry_for_layer
# endif
# undef rsvg_handle_get_dimensions
+# if LIBRSVG_CHECK_VERSION (2, 48, 0)
+# undef rsvg_handle_set_stylesheet
+# endif
# undef rsvg_handle_get_pixbuf
# if LIBRSVG_CHECK_VERSION (2, 32, 0)
# undef g_file_new_for_path
@@ -9769,6 +9806,9 @@ init_svg_functions (void)
fn_rsvg_handle_get_geometry_for_layer
# endif
# define rsvg_handle_get_dimensions fn_rsvg_handle_get_dimensions
+# if LIBRSVG_CHECK_VERSION (2, 48, 0)
+# define rsvg_handle_set_stylesheet fn_rsvg_handle_set_stylesheet
+# endif
# define rsvg_handle_get_pixbuf fn_rsvg_handle_get_pixbuf
# if LIBRSVG_CHECK_VERSION (2, 32, 0)
# define g_file_new_for_path fn_g_file_new_for_path
@@ -9846,7 +9886,7 @@ svg_load (struct frame *f, struct image *img)
#if LIBRSVG_CHECK_VERSION (2, 46, 0)
static double
-svg_css_length_to_pixels (RsvgLength length, double dpi)
+svg_css_length_to_pixels (RsvgLength length, double dpi, int font_size)
{
double value = length.length;
@@ -9874,9 +9914,16 @@ svg_css_length_to_pixels (RsvgLength length, double dpi)
case RSVG_UNIT_IN:
value *= dpi;
break;
+#if LIBRSVG_CHECK_VERSION (2, 48, 0)
+ /* We don't know exactly what font size is used on older librsvg
+ versions. */
+ case RSVG_UNIT_EM:
+ value *= font_size;
+ break;
+#endif
default:
- /* Probably one of em, ex, or %. We can't know what the pixel
- value is without more information. */
+ /* Probably ex or %. We can't know what the pixel value is
+ without more information. */
value = 0;
}
@@ -9906,6 +9953,10 @@ svg_load_image (struct frame *f, struct image *img, char
*contents,
char *wrapped_contents = NULL;
ptrdiff_t wrapped_size;
+#if LIBRSVG_CHECK_VERSION (2, 48, 0)
+ char *css = NULL;
+#endif
+
#if ! GLIB_CHECK_VERSION (2, 36, 0)
/* g_type_init is a glib function that must be called prior to
using gnome type library functions (obsolete since 2.36.0). */
@@ -9931,6 +9982,26 @@ svg_load_image (struct frame *f, struct image *img, char
*contents,
rsvg_handle_set_dpi_x_y (rsvg_handle, FRAME_DISPLAY_INFO (f)->resx,
FRAME_DISPLAY_INFO (f)->resy);
+
+#if LIBRSVG_CHECK_VERSION (2, 48, 0)
+ Lisp_Object lcss = image_spec_value (img->spec, QCcss, NULL);
+ if (!STRINGP (lcss))
+ {
+ /* Generate the CSS for the SVG image. */
+ const char *css_spec = "svg{font-family:\"%s\";font-size:%4dpx}";
+ int css_len = strlen (css_spec) + strlen (img->face_font_family);
+ css = xmalloc (css_len);
+ snprintf (css, css_len, css_spec, img->face_font_family,
img->face_font_size);
+ rsvg_handle_set_stylesheet (rsvg_handle, (guint8 *)css, strlen (css),
NULL);
+ }
+ else
+ {
+ css = xmalloc (SBYTES (lcss) + 1);
+ strncpy (css, SSDATA (lcss), SBYTES (lcss));
+ *(css + SBYTES (lcss) + 1) = 0;
+ }
+#endif
+
#else
/* Make a handle to a new rsvg object. */
rsvg_handle = rsvg_handle_new ();
@@ -9973,20 +10044,20 @@ svg_load_image (struct frame *f, struct image *img,
char *contents,
if (has_width && has_height)
{
/* Success! We can use these values directly. */
- viewbox_width = svg_css_length_to_pixels (iwidth, dpi);
- viewbox_height = svg_css_length_to_pixels (iheight, dpi);
+ viewbox_width = svg_css_length_to_pixels (iwidth, dpi,
img->face_font_size);
+ viewbox_height = svg_css_length_to_pixels (iheight, dpi,
img->face_font_size);
}
else if (has_width && has_viewbox)
{
- viewbox_width = svg_css_length_to_pixels (iwidth, dpi);
- viewbox_height = svg_css_length_to_pixels (iwidth, dpi)
- * viewbox.width / viewbox.height;
+ viewbox_width = svg_css_length_to_pixels (iwidth, dpi,
img->face_font_size);
+ viewbox_height = svg_css_length_to_pixels (iwidth, dpi,
img->face_font_size)
+ * viewbox.height / viewbox.width;
}
else if (has_height && has_viewbox)
{
- viewbox_height = svg_css_length_to_pixels (iheight, dpi);
- viewbox_width = svg_css_length_to_pixels (iheight, dpi)
- * viewbox.height / viewbox.width;
+ viewbox_height = svg_css_length_to_pixels (iheight, dpi,
img->face_font_size);
+ viewbox_width = svg_css_length_to_pixels (iheight, dpi,
img->face_font_size)
+ * viewbox.width / viewbox.height;
}
else if (has_viewbox)
{
@@ -10019,7 +10090,7 @@ svg_load_image (struct frame *f, struct image *img,
char *contents,
viewbox_height = dimension_data.height;
}
- compute_image_size (viewbox_width, viewbox_height, img->spec,
+ compute_image_size (viewbox_width, viewbox_height, img,
&width, &height);
width *= FRAME_SCALE_FACTOR (f);
@@ -10107,6 +10178,10 @@ svg_load_image (struct frame *f, struct image *img,
char *contents,
rsvg_handle_set_dpi_x_y (rsvg_handle, FRAME_DISPLAY_INFO (f)->resx,
FRAME_DISPLAY_INFO (f)->resy);
+
+#if LIBRSVG_CHECK_VERSION (2, 48, 0)
+ rsvg_handle_set_stylesheet (rsvg_handle, (guint8 *)css, strlen (css), NULL);
+#endif
#else
/* Make a handle to a new rsvg object. */
rsvg_handle = rsvg_handle_new ();
@@ -10140,6 +10215,11 @@ svg_load_image (struct frame *f, struct image *img,
char *contents,
g_object_unref (rsvg_handle);
xfree (wrapped_contents);
+#if LIBRSVG_CHECK_VERSION (2, 48, 0)
+ if (!STRINGP (lcss))
+ xfree (css);
+#endif
+
/* Extract some meta data from the svg handle. */
width = gdk_pixbuf_get_width (pixbuf);
height = gdk_pixbuf_get_height (pixbuf);
@@ -10210,6 +10290,10 @@ svg_load_image (struct frame *f, struct image *img,
char *contents,
g_object_unref (rsvg_handle);
if (wrapped_contents)
xfree (wrapped_contents);
+#if LIBRSVG_CHECK_VERSION (2, 48, 0)
+ if (css && !STRINGP (lcss))
+ xfree (css);
+#endif
/* FIXME: Use error->message so the user knows what is the actual
problem with the image. */
image_error ("Error parsing SVG image `%s'", img->spec);
@@ -10715,6 +10799,8 @@ non-numeric, there is no explicit limit on the size of
images. */);
DEFSYM (QCmax_width, ":max-width");
DEFSYM (QCmax_height, ":max-height");
+ DEFSYM (Qem, "em");
+
#ifdef HAVE_NATIVE_TRANSFORMS
DEFSYM (Qscale, "scale");
DEFSYM (Qrotate, "rotate");
@@ -10801,6 +10887,7 @@ non-numeric, there is no explicit limit on the size of
images. */);
#if defined (HAVE_RSVG)
DEFSYM (Qsvg, "svg");
DEFSYM (QCbase_uri, ":base-uri");
+ DEFSYM (QCcss, ":css");
add_image_type (Qsvg);
#ifdef HAVE_NTGUI
/* Other libraries used directly by svg code. */
diff --git a/src/keyboard.c b/src/keyboard.c
index 266ebaa..47b5e59 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -2121,7 +2121,7 @@ read_char_help_form_unwind (void)
Lisp_Object window_config = XCAR (help_form_saved_window_configs);
help_form_saved_window_configs = XCDR (help_form_saved_window_configs);
if (!NILP (window_config))
- Fset_window_configuration (window_config, Qnil);
+ Fset_window_configuration (window_config, Qnil, Qnil);
}
#define STOP_POLLING \
@@ -10379,7 +10379,7 @@ update_recent_keys (int new_size, int kept_keys)
}
DEFUN ("lossage-size", Flossage_size, Slossage_size, 0, 1,
- "(list (read-number \"new-size: \" (lossage-size)))",
+ "(list (read-number \"Set maximum keystrokes to: \" (lossage-size)))",
doc: /* Return or set the maximum number of keystrokes to save.
If called with a non-nil ARG, set the limit to ARG and return it.
Otherwise, return the current limit.
@@ -10665,10 +10665,7 @@ On such systems, Emacs starts a subshell instead of
suspending. */)
with a window system; but suspend should be disabled in that case. */
get_tty_size (fileno (CURTTY ()->input), &width, &height);
if (width != old_width || height != old_height)
- change_frame_size (SELECTED_FRAME (), width,
- height - FRAME_MENU_BAR_LINES (SELECTED_FRAME ())
- - FRAME_TAB_BAR_LINES (SELECTED_FRAME ()),
- 0, 0, 0, 0);
+ change_frame_size (SELECTED_FRAME (), width, height, false, false, false);
run_hook (intern ("suspend-resume-hook"));
diff --git a/src/keymap.c b/src/keymap.c
index bb26b63..fb8ecea 100644
--- a/src/keymap.c
+++ b/src/keymap.c
@@ -3148,12 +3148,6 @@ syms_of_keymap (void)
doc: /* Default keymap to use when reading from the minibuffer.
*/);
Vminibuffer_local_map = Fmake_sparse_keymap (Qnil);
- DEFVAR_LISP ("minibuffer-local-ns-map", Vminibuffer_local_ns_map,
- doc: /* Local keymap for the minibuffer when spaces are not
allowed. */);
- Vminibuffer_local_ns_map = Fmake_sparse_keymap (Qnil);
- Fset_keymap_parent (Vminibuffer_local_ns_map, Vminibuffer_local_map);
-
-
DEFVAR_LISP ("minor-mode-map-alist", Vminor_mode_map_alist,
doc: /* Alist of keymaps to use for minor modes.
Each element looks like (VARIABLE . KEYMAP); KEYMAP is used to read
diff --git a/src/lisp.h b/src/lisp.h
index c67c8b0..f83c55f 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -294,12 +294,12 @@ DEFINE_GDB_SYMBOL_END (VALMASK)
/* 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
+ 'struct 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;
+typedef struct Lisp_X *Lisp_Word;
#else
typedef EMACS_INT Lisp_Word;
#endif
@@ -563,6 +563,7 @@ enum Lisp_Fwd_Type
#ifdef CHECK_LISP_OBJECT_TYPE
typedef struct Lisp_Object { Lisp_Word i; } Lisp_Object;
+# define LISP_OBJECT_IS_STRUCT
# define LISP_INITIALLY(w) {w}
# undef CHECK_LISP_OBJECT_TYPE
enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = true };
@@ -1068,6 +1069,7 @@ enum pvec_type
PVEC_MUTEX,
PVEC_CONDVAR,
PVEC_MODULE_FUNCTION,
+ PVEC_NATIVE_COMP_UNIT,
/* These should be last, for internal_equal and sxhash_obj. */
PVEC_COMPILED,
@@ -1313,6 +1315,7 @@ dead_object (void)
#define XSETTHREAD(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_THREAD))
#define XSETMUTEX(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_MUTEX))
#define XSETCONDVAR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CONDVAR))
+#define XSETNATIVE_COMP_UNIT(a, b) (XSETPSEUDOVECTOR (a, b,
PVEC_NATIVE_COMP_UNIT))
/* Efficiently convert a pointer to a Lisp object and back. The
pointer is represented as a fixnum, so the garbage collector
@@ -2036,6 +2039,8 @@ CHAR_TABLE_SET (Lisp_Object ct, int idx, Lisp_Object val)
char_table_set (ct, idx, val);
}
+#include "comp.h"
+
/* This structure describes a built-in function.
It is generated by the DEFUN macro only.
defsubr makes it into a Lisp object. */
@@ -2058,8 +2063,15 @@ struct Lisp_Subr
} function;
short min_args, max_args;
const char *symbol_name;
- const char *intspec;
+ union {
+ const char *intspec;
+ Lisp_Object native_intspec;
+ };
EMACS_INT doc;
+ Lisp_Object native_comp_u[NATIVE_COMP_FLAG];
+ char *native_c_name[NATIVE_COMP_FLAG];
+ Lisp_Object lambda_list[NATIVE_COMP_FLAG];
+ Lisp_Object type[NATIVE_COMP_FLAG];
} GCALIGNED_STRUCT;
union Aligned_Lisp_Subr
{
@@ -2972,6 +2984,12 @@ CHECK_INTEGER (Lisp_Object x)
{
CHECK_TYPE (INTEGERP (x), Qnumberp, x);
}
+
+INLINE void
+CHECK_SUBR (Lisp_Object x)
+{
+ CHECK_TYPE (SUBRP (x), Qsubrp, x);
+}
/* If we're not dumping using the legacy dumper and we might be using
@@ -3019,7 +3037,7 @@ CHECK_INTEGER (Lisp_Object x)
static union Aligned_Lisp_Subr sname = \
{{{ PVEC_SUBR << PSEUDOVECTOR_AREA_BITS },
\
{ .a ## maxargs = fnname }, \
- minargs, maxargs, lname, intspec, 0}}; \
+ minargs, maxargs, lname, {intspec}, 0}};
\
Lisp_Object fnname
/* defsubr (Sname);
@@ -4066,10 +4084,11 @@ LOADHIST_ATTACH (Lisp_Object x)
if (initialized)
Vcurrent_load_list = Fcons (x, Vcurrent_load_list);
}
+extern bool suffix_p (Lisp_Object, const char *);
extern Lisp_Object save_match_data_load (Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object, Lisp_Object);
extern int openp (Lisp_Object, Lisp_Object, Lisp_Object,
- Lisp_Object *, Lisp_Object, bool);
+ Lisp_Object *, Lisp_Object, bool, bool);
enum { S2N_IGNORE_TRAILING = 1 };
extern Lisp_Object string_to_number (char const *, int, ptrdiff_t *);
extern void map_obarray (Lisp_Object, void (*) (Lisp_Object, Lisp_Object),
@@ -4140,6 +4159,9 @@ extern Lisp_Object internal_lisp_condition_case
(Lisp_Object, Lisp_Object, Lisp_
extern Lisp_Object internal_condition_case (Lisp_Object (*) (void),
Lisp_Object, Lisp_Object (*) (Lisp_Object));
extern Lisp_Object internal_condition_case_1 (Lisp_Object (*) (Lisp_Object),
Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object));
extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object,
Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*)
(Lisp_Object));
+extern Lisp_Object internal_condition_case_3 (Lisp_Object (*) (Lisp_Object,
Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object (*) (Lisp_Object));
+extern Lisp_Object internal_condition_case_4 (Lisp_Object (*) (Lisp_Object,
Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object));
+extern Lisp_Object internal_condition_case_5 (Lisp_Object (*) (Lisp_Object,
Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object,
Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*)
(Lisp_Object));
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 *));
@@ -4705,7 +4727,11 @@ extern void syms_of_lcms2 (void);
#endif
#ifdef HAVE_ZLIB
+
+#include <stdio.h>
+
/* Defined in decompress.c. */
+extern int md5_gz_stream (FILE *, void *);
extern void syms_of_decompress (void);
#endif
@@ -4727,6 +4753,46 @@ extern void syms_of_profiler (void);
extern char *emacs_root_dir (void);
#endif /* DOS_NT */
+#ifdef HAVE_NATIVE_COMP
+INLINE bool
+SUBR_NATIVE_COMPILEDP (Lisp_Object a)
+{
+ return SUBRP (a) && !NILP (XSUBR (a)->native_comp_u[0]);
+}
+
+INLINE bool
+SUBR_NATIVE_COMPILED_DYNP (Lisp_Object a)
+{
+ return SUBR_NATIVE_COMPILEDP (a) && !NILP (XSUBR (a)->lambda_list[0]);
+}
+
+INLINE Lisp_Object
+SUBR_TYPE (Lisp_Object a)
+{
+ return XSUBR (a)->type[0];
+}
+
+INLINE struct Lisp_Native_Comp_Unit *
+allocate_native_comp_unit (void)
+{
+ return ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Native_Comp_Unit,
+ data_impure_vec, PVEC_NATIVE_COMP_UNIT);
+}
+#else
+INLINE bool
+SUBR_NATIVE_COMPILEDP (Lisp_Object a)
+{
+ return false;
+}
+
+INLINE bool
+SUBR_NATIVE_COMPILED_DYNP (Lisp_Object a)
+{
+ return false;
+}
+
+#endif
+
/* Defined in lastfile.c. */
extern char my_edata[];
extern char my_endbss[];
diff --git a/src/lread.c b/src/lread.c
index dea1b23..e53e1f6 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -1119,7 +1119,7 @@ This uses the variables `load-suffixes' and
`load-file-rep-suffixes'. */)
}
/* Return true if STRING ends with SUFFIX. */
-static bool
+bool
suffix_p (Lisp_Object string, const char *suffix)
{
ptrdiff_t suffix_len = strlen (suffix);
@@ -1138,6 +1138,24 @@ close_infile_unwind (void *arg)
infile = prev_infile;
}
+/* Compute the filename we want in `load-history' and `load-file-name'. */
+
+static Lisp_Object
+compute_found_effective (Lisp_Object found)
+{
+ /* Reconstruct the .elc filename. */
+ Lisp_Object src_name =
+ Fgethash (Ffile_name_nondirectory (found), Vcomp_eln_to_el_h, Qnil);
+
+ if (NILP (src_name))
+ /* Manual eln load. */
+ return found;
+
+ if (suffix_p (src_name, "el.gz"))
+ src_name = Fsubstring (src_name, make_fixnum (0), make_fixnum (-3));
+ return concat2 (src_name, build_string ("c"));
+}
+
DEFUN ("load", Fload, Sload, 1, 5, 0,
doc: /* Execute a file of Lisp code named FILE.
First try FILE with `.elc' appended, then try with `.el', then try
@@ -1222,6 +1240,8 @@ Return t if the file exists and loads successfully. */)
else
file = Fsubstitute_in_file_name (file);
+ bool no_native = suffix_p (file, ".elc");
+
/* Avoid weird lossage with null string as arg,
since it would try to load a directory as a Lisp file. */
if (SCHARS (file) == 0)
@@ -1245,7 +1265,7 @@ Return t if the file exists and loads successfully. */)
|| suffix_p (file, MODULES_SECONDARY_SUFFIX)
#endif
#endif
- )
+ || (NATIVE_COMP_FLAG && suffix_p (file, NATIVE_ELISP_SUFFIX)))
must_suffix = Qnil;
/* Don't insist on adding a suffix
if the argument includes a directory name. */
@@ -1262,7 +1282,9 @@ Return t if the file exists and loads successfully. */)
suffixes = CALLN (Fappend, suffixes, Vload_file_rep_suffixes);
}
- fd = openp (Vload_path, file, suffixes, &found, Qnil, load_prefer_newer);
+ fd =
+ openp (Vload_path, file, suffixes, &found, Qnil, load_prefer_newer,
+ no_native);
}
if (fd == -1)
@@ -1323,6 +1345,9 @@ Return t if the file exists and loads successfully. */)
bool is_module = false;
#endif
+ bool is_native_elisp =
+ NATIVE_COMP_FLAG && suffix_p (found, NATIVE_ELISP_SUFFIX) ? true : false;
+
/* Check if we're stuck in a recursive load cycle.
2000-09-21: It's not possible to just check for the file loaded
@@ -1349,11 +1374,15 @@ Return t if the file exists and loads successfully. */)
Vload_source_file_function. */
specbind (Qlexical_binding, Qnil);
- /* Get the name for load-history. */
+ Lisp_Object found_eff =
+ is_native_elisp
+ ? compute_found_effective (found)
+ : found;
+
hist_file_name = (! NILP (Vpurify_flag)
? concat2 (Ffile_name_directory (file),
- Ffile_name_nondirectory (found))
- : found) ;
+ Ffile_name_nondirectory (found_eff))
+ : found_eff);
version = -1;
@@ -1417,7 +1446,7 @@ Return t if the file exists and loads successfully. */)
} /* !load_prefer_newer */
}
}
- else if (!is_module)
+ else if (!is_module && !is_native_elisp)
{
/* We are loading a source file (*.el). */
if (!NILP (Vload_source_file_function))
@@ -1444,7 +1473,7 @@ Return t if the file exists and loads successfully. */)
stream = NULL;
errno = EINVAL;
}
- else if (!is_module)
+ else if (!is_module && !is_native_elisp)
{
#ifdef WINDOWSNT
emacs_close (fd);
@@ -1460,7 +1489,7 @@ Return t if the file exists and loads successfully. */)
might be accessed by the unbind_to call below. */
struct infile input;
- if (is_module)
+ if (is_module || is_native_elisp)
{
/* `module-load' uses the file name, so we can close the stream
now. */
@@ -1487,6 +1516,8 @@ Return t if the file exists and loads successfully. */)
{
if (is_module)
message_with_string ("Loading %s (module)...", file, 1);
+ else if (is_native_elisp)
+ message_with_string ("Loading %s (native compiled elisp)...", file, 1);
else if (!compiled)
message_with_string ("Loading %s (source)...", file, 1);
else if (newer)
@@ -1496,7 +1527,8 @@ Return t if the file exists and loads successfully. */)
message_with_string ("Loading %s...", file, 1);
}
- specbind (Qload_file_name, found);
+ specbind (Qload_file_name, found_eff);
+ specbind (Qload_true_file_name, found);
specbind (Qinhibit_file_name_operation, Qnil);
specbind (Qload_in_progress, Qt);
@@ -1512,6 +1544,19 @@ Return t if the file exists and loads successfully. */)
emacs_abort ();
#endif
}
+ else if (is_native_elisp)
+ {
+#ifdef HAVE_NATIVE_COMP
+ specbind (Qcurrent_load_list, Qnil);
+ LOADHIST_ATTACH (hist_file_name);
+ Fnative_elisp_load (found, Qnil);
+ build_load_history (hist_file_name, true);
+#else
+ /* This cannot happen. */
+ emacs_abort ();
+#endif
+
+ }
else
{
if (lisp_file_lexically_bound_p (Qget_file_char))
@@ -1547,6 +1592,8 @@ Return t if the file exists and loads successfully. */)
{
if (is_module)
message_with_string ("Loading %s (module)...done", file, 1);
+ else if (is_native_elisp)
+ message_with_string ("Loading %s (native compiled elisp)...done", file,
1);
else if (!compiled)
message_with_string ("Loading %s (source)...done", file, 1);
else if (newer)
@@ -1592,12 +1639,108 @@ directories, make sure the PREDICATE function returns
`dir-ok' for them. */)
(Lisp_Object filename, Lisp_Object path, Lisp_Object suffixes, Lisp_Object
predicate)
{
Lisp_Object file;
- int fd = openp (path, filename, suffixes, &file, predicate, false);
+ int fd = openp (path, filename, suffixes, &file, predicate, false, false);
if (NILP (predicate) && fd >= 0)
emacs_close (fd);
return file;
}
+#ifdef HAVE_NATIVE_COMP
+static bool
+maybe_swap_for_eln1 (Lisp_Object src_name, Lisp_Object eln_name,
+ Lisp_Object *filename, int *fd, struct timespec mtime)
+{
+ struct stat eln_st;
+ int eln_fd = emacs_open (SSDATA (ENCODE_FILE (eln_name)), O_RDONLY, 0);
+
+ if (eln_fd > 0)
+ {
+ if (fstat (eln_fd, &eln_st) || S_ISDIR (eln_st.st_mode))
+ emacs_close (eln_fd);
+ else
+ {
+ struct timespec eln_mtime = get_stat_mtime (&eln_st);
+ if (timespec_cmp (eln_mtime, mtime) >= 0)
+ {
+ emacs_close (*fd);
+ *fd = eln_fd;
+ *filename = eln_name;
+ /* Store the eln -> el relation. */
+ Fputhash (Ffile_name_nondirectory (eln_name),
+ src_name, Vcomp_eln_to_el_h);
+ return true;
+ }
+ else
+ emacs_close (eln_fd);
+ }
+ }
+
+ return false;
+}
+#endif
+
+/* Look for a suitable .eln file to be loaded in place of FILENAME.
+ If found replace the content of FILENAME and FD. */
+
+static void
+maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd,
+ struct timespec mtime)
+{
+#ifdef HAVE_NATIVE_COMP
+
+ if (no_native
+ || load_no_native)
+ Fputhash (*filename, Qt, V_comp_no_native_file_h);
+ else
+ Fremhash (*filename, V_comp_no_native_file_h);
+
+ if (no_native
+ || load_no_native
+ || !suffix_p (*filename, ".elc"))
+ return;
+
+ /* Search eln in the eln-cache directories. */
+ Lisp_Object eln_path_tail = Vcomp_eln_load_path;
+ Lisp_Object src_name =
+ Fsubstring (*filename, Qnil, make_fixnum (-1));
+ if (NILP (Ffile_exists_p (src_name)))
+ {
+ src_name = concat2 (src_name, build_string (".gz"));
+ if (NILP (Ffile_exists_p (src_name)))
+ {
+ if (!NILP (find_symbol_value (Qcomp_warning_on_missing_source)))
+ call2 (intern_c_string ("display-warning"),
+ Qcomp,
+ CALLN (Fformat,
+ build_string ("Cannot look-up eln file as no source "
+ "file was found for %s"),
+ *filename));
+ return;
+ }
+ }
+ Lisp_Object eln_rel_name = Fcomp_el_to_eln_rel_filename (src_name);
+
+ Lisp_Object dir = Qnil;
+ FOR_EACH_TAIL_SAFE (eln_path_tail)
+ {
+ dir = XCAR (eln_path_tail);
+ Lisp_Object eln_name =
+ Fexpand_file_name (eln_rel_name,
+ Fexpand_file_name (Vcomp_native_version_dir, dir));
+ if (maybe_swap_for_eln1 (src_name, eln_name, filename, fd, mtime))
+ return;
+ }
+
+ /* Look also in preloaded subfolder of the last entry in
+ `comp-eln-load-path'. */
+ dir = Fexpand_file_name (build_string ("preloaded"),
+ Fexpand_file_name (Vcomp_native_version_dir,
+ dir));
+ maybe_swap_for_eln1 (src_name, Fexpand_file_name (eln_rel_name, dir),
+ filename, fd, mtime);
+#endif
+}
+
/* Search for a file whose name is STR, looking in directories
in the Lisp list PATH, and trying suffixes from SUFFIX.
On success, return a file descriptor (or 1 or -2 as described below).
@@ -1622,11 +1765,14 @@ directories, make sure the PREDICATE function returns
`dir-ok' for them. */)
If NEWER is true, try all SUFFIXes and return the result for the
newest file that exists. Does not apply to remote files,
- or if a non-nil and non-t PREDICATE is specified. */
+ or if a non-nil and non-t PREDICATE is specified.
+
+ if NO_NATIVE is true do not try to load native code. */
int
openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes,
- Lisp_Object *storeptr, Lisp_Object predicate, bool newer)
+ Lisp_Object *storeptr, Lisp_Object predicate, bool newer,
+ bool no_native)
{
ptrdiff_t fn_size = 100;
char buf[100];
@@ -1836,6 +1982,8 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object
suffixes,
}
else
{
+ maybe_swap_for_eln (no_native, &string, &fd,
+ get_stat_mtime (&st));
/* We succeeded; return this descriptor and filename. */
if (storeptr)
*storeptr = string;
@@ -1847,6 +1995,8 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object
suffixes,
/* No more suffixes. Return the newest. */
if (0 <= save_fd && ! CONSP (XCDR (tail)))
{
+ maybe_swap_for_eln (no_native, &save_string, &save_fd,
+ save_mtime);
if (storeptr)
*storeptr = save_string;
SAFE_FREE ();
@@ -1942,8 +2092,8 @@ readevalloop_1 (int old)
static AVOID
end_of_file_error (void)
{
- if (STRINGP (Vload_file_name))
- xsignal1 (Qend_of_file, Vload_file_name);
+ if (STRINGP (Vload_true_file_name))
+ xsignal1 (Qend_of_file, Vload_true_file_name);
xsignal0 (Qend_of_file);
}
@@ -4204,10 +4354,14 @@ intern_c_string_1 (const char *str, ptrdiff_t len)
if (!SYMBOLP (tem))
{
- /* Creating a non-pure string from a string literal not implemented yet.
- We could just use make_string here and live with the extra copy. */
- eassert (!NILP (Vpurify_flag));
- tem = intern_driver (make_pure_c_string (str, len), obarray, tem);
+ Lisp_Object string;
+
+ if (NILP (Vpurify_flag))
+ string = make_string (str, len);
+ else
+ string = make_pure_c_string (str, len);
+
+ tem = intern_driver (string, obarray, tem);
}
return tem;
}
@@ -4467,6 +4621,10 @@ defsubr (union Aligned_Lisp_Subr *aname)
XSETPVECTYPE (sname, PVEC_SUBR);
XSETSUBR (tem, sname);
set_symbol_function (sym, tem);
+#ifdef HAVE_NATIVE_COMP
+ eassert (NILP (Vcomp_abi_hash));
+ Vcomp_subr_list = Fpurecopy (Fcons (tem, Vcomp_subr_list));
+#endif
}
#ifdef NOTDEF /* Use fset in subr.el now! */
@@ -4767,6 +4925,7 @@ init_lread (void)
load_in_progress = 0;
Vload_file_name = Qnil;
+ Vload_true_file_name = Qnil;
Vstandard_input = Qt;
Vloads_in_progress = Qnil;
}
@@ -4891,20 +5050,15 @@ This list includes suffixes for both compiled and
source Emacs Lisp files.
This list should not include the empty string.
`load' and related functions try to append these suffixes, in order,
to the specified file name if a suffix is allowed or required. */);
+ Vload_suffixes = list2 (build_pure_c_string (".elc"),
+ build_pure_c_string (".el"));
#ifdef HAVE_MODULES
+ Vload_suffixes = Fcons (build_pure_c_string (MODULES_SUFFIX),
Vload_suffixes);
#ifdef MODULES_SECONDARY_SUFFIX
- Vload_suffixes = list4 (build_pure_c_string (".elc"),
- build_pure_c_string (".el"),
- build_pure_c_string (MODULES_SUFFIX),
- build_pure_c_string (MODULES_SECONDARY_SUFFIX));
-#else
- Vload_suffixes = list3 (build_pure_c_string (".elc"),
- build_pure_c_string (".el"),
- build_pure_c_string (MODULES_SUFFIX));
+ Vload_suffixes =
+ Fcons (build_pure_c_string (MODULES_SECONDARY_SUFFIX), Vload_suffixes);
#endif
-#else
- Vload_suffixes = list2 (build_pure_c_string (".elc"),
- build_pure_c_string (".el"));
+
#endif
DEFVAR_LISP ("module-file-suffix", Vmodule_file_suffix,
doc: /* Suffix of loadable module file, or nil if modules are
not supported. */);
@@ -4971,9 +5125,17 @@ directory. These file names are converted to absolute
at startup. */);
Vload_history = Qnil;
DEFVAR_LISP ("load-file-name", Vload_file_name,
- doc: /* Full name of file being loaded by `load'. */);
+ doc: /* Full name of file being loaded by `load'.
+
+In case of native code being loaded this is indicating the
+corresponding bytecode filename. Use `load-true-file-name' to obtain
+the .eln filename. */);
Vload_file_name = Qnil;
+ DEFVAR_LISP ("load-true-file-name", Vload_true_file_name,
+ doc: /* Full name of file being loaded by `load'. */);
+ Vload_true_file_name = Qnil;
+
DEFVAR_LISP ("user-init-file", Vuser_init_file,
doc: /* File name, including directory, of user's initialization
file.
If the file loaded had extension `.elc', and the corresponding source file
@@ -5093,6 +5255,10 @@ 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 ("load-no-native", load_no_native,
+ doc: /* Non-nil means not to load a .eln file when a .elc was
requested. */);
+ load_no_native = false;
+
/* Vsource_directory was initialized in init_lread. */
DEFSYM (Qcurrent_load_list, "current-load-list");
@@ -5115,6 +5281,7 @@ that are loaded before your customizations are read! */);
DEFSYM (Qfunction, "function");
DEFSYM (Qload, "load");
DEFSYM (Qload_file_name, "load-file-name");
+ DEFSYM (Qload_true_file_name, "load-true-file-name");
DEFSYM (Qeval_buffer_list, "eval-buffer-list");
DEFSYM (Qdir_ok, "dir-ok");
DEFSYM (Qdo_after_load_evaluation, "do-after-load-evaluation");
diff --git a/src/minibuf.c b/src/minibuf.c
index c9831fd..c4482d7 100644
--- a/src/minibuf.c
+++ b/src/minibuf.c
@@ -112,13 +112,15 @@ choose_minibuf_frame (void)
{
if (FRAMEP (selected_frame)
&& FRAME_LIVE_P (XFRAME (selected_frame))
+ && WINDOW_LIVE_P (XFRAME (selected_frame)->minibuffer_window)
&& !EQ (minibuf_window, XFRAME (selected_frame)->minibuffer_window))
{
struct frame *sf = XFRAME (selected_frame);
- /* I don't think that any frames may validly have a null minibuffer
- window anymore. */
- if (NILP (sf->minibuffer_window))
- emacs_abort ();
+ /* I don't think that any frames may validly have a null
+ minibuffer window anymore. (2021-04-15): Tooltip frames have
+ a null MB. Comment out the following. */
+ /* if (NILP (sf->minibuffer_window)) */
+ /* emacs_abort (); */
minibuf_window = sf->minibuffer_window;
}
@@ -195,7 +197,9 @@ move_minibuffers_onto_frame (struct frame *of, bool
for_deletion)
&& (for_deletion || minibuf_follows_frame () || FRAME_INITIAL_P (of))))
return;
if (FRAME_LIVE_P (f)
- && !EQ (f->minibuffer_window, of->minibuffer_window))
+ && !EQ (f->minibuffer_window, of->minibuffer_window)
+ && WINDOW_LIVE_P (f->minibuffer_window) /* F not a tootip frame */
+ && WINDOW_LIVE_P (of->minibuffer_window))
{
zip_minibuffer_stacks (f->minibuffer_window, of->minibuffer_window);
if (for_deletion && XFRAME (MB_frame) != of)
@@ -563,7 +567,7 @@ read_minibuf (Lisp_Object map, Lisp_Object initial,
Lisp_Object prompt,
in previous recursive minibuffer, but was not set explicitly
to t for this invocation, so set it to nil in this minibuffer.
Save the old value now, before we change it. */
- specbind (intern ("minibuffer-completing-file-name"),
+ specbind (Qminibuffer_completing_file_name,
Vminibuffer_completing_file_name);
if (EQ (Vminibuffer_completing_file_name, Qlambda))
Vminibuffer_completing_file_name = Qnil;
@@ -636,6 +640,7 @@ read_minibuf (Lisp_Object map, Lisp_Object initial,
Lisp_Object prompt,
mini_frame = WINDOW_FRAME (XWINDOW (minibuf_window));
if (minibuf_level > 1
+ && WINDOW_LIVE_P (XFRAME (MB_frame)->minibuffer_window)
&& !EQ (XWINDOW (XFRAME (selected_frame)->minibuffer_window)->frame,
MB_frame)
&& minibuf_moves_frame_when_opened ()
@@ -655,17 +660,14 @@ read_minibuf (Lisp_Object map, Lisp_Object initial,
Lisp_Object prompt,
record_unwind_protect_void (minibuffer_unwind);
record_unwind_protect (restore_window_configuration,
- Fcons (Qt, Fcurrent_window_configuration (Qnil)));
+ list3 (Fcurrent_window_configuration (Qnil), Qt, Qt));
/* If the minibuffer window is on a different frame, save that
frame's configuration too. */
if (!EQ (mini_frame, selected_frame))
record_unwind_protect (restore_window_configuration,
- Fcons (/* Arrange for the frame later to be
- switched back to the calling
- frame. */
- Qnil,
- Fcurrent_window_configuration (mini_frame)));
+ list3 (Fcurrent_window_configuration (mini_frame),
+ Qnil, Qt));
/* If the minibuffer is on an iconified or invisible frame,
make it visible now. */
@@ -723,10 +725,10 @@ read_minibuf (Lisp_Object map, Lisp_Object initial,
Lisp_Object prompt,
Vminibuffer_completing_file_name = Qlambda;
/* If variable is unbound, make it nil. */
- histval = find_symbol_value (Vminibuffer_history_variable);
+ histval = find_symbol_value (histvar);
if (EQ (histval, Qunbound))
{
- Fset (Vminibuffer_history_variable, Qnil);
+ Fset (histvar, Qnil);
histval = Qnil;
}
@@ -748,10 +750,6 @@ read_minibuf (Lisp_Object map, Lisp_Object initial,
Lisp_Object prompt,
not work correctly in minibuffers. (Bug#5715, etc) */
bset_truncate_lines (current_buffer, Qnil);
- /* If appropriate, copy enable-multibyte-characters into the minibuffer. */
- if (inherit_input_method)
- bset_enable_multibyte_characters (current_buffer, enable_multibyte);
-
/* The current buffer's default directory is usually the right thing
for our minibuffer here. However, if you're typing a command at
a minibuffer-only frame when minibuf_level is zero, then buf IS
@@ -803,9 +801,11 @@ read_minibuf (Lisp_Object map, Lisp_Object initial,
Lisp_Object prompt,
specbind (Qinhibit_modification_hooks, Qt);
Ferase_buffer ();
- if (!NILP (BVAR (current_buffer, enable_multibyte_characters))
- && ! STRING_MULTIBYTE (minibuf_prompt))
- minibuf_prompt = Fstring_make_multibyte (minibuf_prompt);
+ /* If appropriate, copy enable-multibyte-characters into the minibuffer.
+ In any case don't blindly inherit the multibyteness used previously. */
+ bset_enable_multibyte_characters (current_buffer,
+ inherit_input_method ? enable_multibyte
+ : Qt);
/* Insert the prompt, record where it ends. */
Finsert (1, &minibuf_prompt);
@@ -908,18 +908,20 @@ read_minibuf (Lisp_Object map, Lisp_Object initial,
Lisp_Object prompt,
unbind_to (count, Qnil);
/* Switch the frame back to the calling frame. */
- if ((!EQ (selected_frame, calling_frame)
- || !EQ (XWINDOW (XFRAME (calling_frame)->minibuffer_window)->frame,
- calling_frame))
- && FRAMEP (calling_frame)
- && FRAME_LIVE_P (XFRAME (calling_frame)))
- call2 (intern ("select-frame-set-input-focus"), calling_frame, Qnil);
+ if (FRAMEP (calling_frame)
+ && FRAME_LIVE_P (XFRAME (calling_frame))
+ && (!EQ (selected_frame, calling_frame)
+ || (WINDOW_LIVE_P (XFRAME (calling_frame)->minibuffer_window)
+ && !EQ (XWINDOW (XFRAME (calling_frame)->minibuffer_window)
+ ->frame,
+ calling_frame))))
+ call2 (Qselect_frame_set_input_focus, calling_frame, Qnil);
/* Add the value to the appropriate history list, if any. This is
done after the previous buffer has been made current again, in
case the history variable is buffer-local. */
if (! (NILP (Vhistory_add_new_input) || NILP (histstring)))
- call2 (intern ("add-to-history"), histvar, histstring);
+ call2 (Qadd_to_history, histvar, histstring);
/* If Lisp form desired instead of string, parse it. */
if (expflag)
@@ -958,13 +960,13 @@ set_minibuffer_mode (Lisp_Object buf, EMACS_INT depth)
Fset_buffer (buf);
if (depth > 0)
{
- if (!NILP (Ffboundp (intern ("fundamental-mode"))))
- call0 (intern ("fundamental-mode"));
+ if (!NILP (Ffboundp (Qminibuffer_mode)))
+ call0 (Qminibuffer_mode);
}
else
{
- if (!NILP (Ffboundp (intern ("minibuffer-inactive-mode"))))
- call0 (intern ("minibuffer-inactive-mode"));
+ if (!NILP (Ffboundp (Qminibuffer_inactive_mode)))
+ call0 (Qminibuffer_inactive_mode);
else
Fkill_all_local_variables ();
}
@@ -1056,18 +1058,21 @@ read_minibuf_unwind (void)
{
f = XFRAME (exp_MB_frame);
window = f->minibuffer_window;
- w = XWINDOW (window);
- if (EQ (w->frame, exp_MB_frame)
- && EQ (w->contents, nth_minibuffer (minibuf_level)))
- goto found;
+ if (WINDOW_LIVE_P (window))
+ {
+ w = XWINDOW (window);
+ if (EQ (w->frame, exp_MB_frame)
+ && EQ (w->contents, nth_minibuffer (minibuf_level)))
+ goto found;
+ }
}
- return; /* expired minibuffer not found. Maybe we should output an
- error, here. */
+ exp_MB_frame = Qnil; /* "Can't happen." */
found:
- if (!EQ (exp_MB_frame, saved_selected_frame))
+ if (!EQ (exp_MB_frame, saved_selected_frame)
+ && !NILP (exp_MB_frame))
do_switch_frame (exp_MB_frame, 0, 0, Qt); /* This also sets
- minibuff_window */
+ minibuf_window */
/* To keep things predictable, in case it matters, let's be in the
minibuffer when we reset the relevant variables. Don't depend on
@@ -1153,7 +1158,7 @@ read_minibuf_unwind (void)
dead, we may keep displaying this buffer (tho it's inactive), so reset it,
to make sure we don't leave around bindings and stuff which only
made sense during the read_minibuf invocation. */
- call0 (intern ("minibuffer-inactive-mode"));
+ call0 (Qminibuffer_inactive_mode);
/* We've exited the recursive edit, so switch the current windows
away from the expired minibuffer window, both in the current
@@ -1177,7 +1182,8 @@ read_minibuf_unwind (void)
}
/* Restore the selected frame. */
- if (!EQ (exp_MB_frame, saved_selected_frame))
+ if (!EQ (exp_MB_frame, saved_selected_frame)
+ && !NILP (exp_MB_frame))
do_switch_frame (saved_selected_frame, 0, 0, Qt);
}
@@ -1192,6 +1198,7 @@ minibuffer_unwind (void)
Lisp_Object window;
Lisp_Object entry;
+ if (NILP (exp_MB_frame)) return; /* "Can't happen." */
f = XFRAME (exp_MB_frame);
window = f->minibuffer_window;
w = XWINDOW (window);
@@ -1352,30 +1359,6 @@ Fifth arg INHERIT-INPUT-METHOD, if non-nil, means the
minibuffer inherits
return unbind_to (count, val);
}
-DEFUN ("read-no-blanks-input", Fread_no_blanks_input, Sread_no_blanks_input,
1, 3, 0,
- doc: /* Read a string from the terminal, not allowing blanks.
-Prompt with PROMPT. Whitespace terminates the input. If INITIAL is
-non-nil, it should be a string, which is used as initial input, with
-point positioned at the end, so that SPACE will accept the input.
-\(Actually, INITIAL can also be a cons of a string and an integer.
-Such values are treated as in `read-from-minibuffer', but are normally
-not useful in this function.)
-
-Third arg INHERIT-INPUT-METHOD, if non-nil, means the minibuffer inherits
-the current input method and the setting of`enable-multibyte-characters'.
-
-If `inhibit-interaction' is non-nil, this function will signal an
-`inhibited-interaction' error. */)
- (Lisp_Object prompt, Lisp_Object initial, Lisp_Object inherit_input_method)
-{
- CHECK_STRING (prompt);
- barf_if_interaction_inhibited ();
-
- return read_minibuf (Vminibuffer_local_ns_map, initial, prompt,
- 0, Qminibuffer_history, make_fixnum (0), Qnil, 0,
- !NILP (inherit_input_method));
-}
-
DEFUN ("read-command", Fread_command, Sread_command, 1, 2, 0,
doc: /* Read the name of a command and return as a symbol.
Prompt with PROMPT. By default, return DEFAULT-VALUE or its first element
@@ -2013,7 +1996,8 @@ HIST, if non-nil, specifies a history list and optionally
the initial
(This is the only case in which you should use INITIAL-INPUT instead
of DEF.) Positions are counted starting from 1 at the beginning of
the list. The variable `history-length' controls the maximum length
- of a history list.
+ of a history list. If HIST is the symbol `t', history is not
+ recorded.
DEF, if non-nil, is the default value or the list of default values.
@@ -2322,6 +2306,12 @@ syms_of_minibuf (void)
/* A frame parameter. */
DEFSYM (Qminibuffer_exit, "minibuffer-exit");
+ DEFSYM (Qminibuffer_mode, "minibuffer-mode");
+ DEFSYM (Qminibuffer_inactive_mode, "minibuffer-inactive-mode");
+ DEFSYM (Qminibuffer_completing_file_name, "minibuffer-completing-file-name");
+ DEFSYM (Qselect_frame_set_input_focus, "select-frame-set-input-focus");
+ DEFSYM (Qadd_to_history, "add-to-history");
+
DEFVAR_LISP ("read-expression-history", Vread_expression_history,
doc: /* A history list for arguments that are Lisp expressions
to evaluate.
For example, `eval-expression' uses this. */);
@@ -2502,7 +2492,6 @@ instead. */);
defsubr (&Sread_variable);
defsubr (&Sinternal_complete_buffer);
defsubr (&Sread_buffer);
- defsubr (&Sread_no_blanks_input);
defsubr (&Sminibuffer_depth);
defsubr (&Sminibuffer_prompt);
diff --git a/src/nsfns.m b/src/nsfns.m
index 5c4cc91..054777a 100644
--- a/src/nsfns.m
+++ b/src/nsfns.m
@@ -669,21 +669,9 @@ ns_set_tool_bar_lines (struct frame *f, Lisp_Object value,
Lisp_Object oldval)
}
{
- int inhibit
- = ((f->after_make_frame
- && !f->tool_bar_resized
- && (EQ (frame_inhibit_implied_resize, Qt)
- || (CONSP (frame_inhibit_implied_resize)
- && !NILP (Fmemq (Qtool_bar_lines,
- frame_inhibit_implied_resize))))
- && NILP (get_frame_param (f, Qfullscreen)))
- ? 0
- : 2);
-
NSTRACE_MSG ("inhibit:%d", inhibit);
- frame_size_history_add (f, Qupdate_frame_tool_bar, 0, 0, Qnil);
- adjust_frame_size (f, -1, -1, inhibit, 0, Qtool_bar_lines);
+ adjust_frame_size (f, -1, -1, 2, false, Qtool_bar_lines);
}
}
@@ -1332,8 +1320,7 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame,
RES_TYPE_STRING);
parms = get_geometry_from_preferences (dpyinfo, parms);
- window_prompting = gui_figure_window_size (f, parms, false, true,
- &x_width, &x_height);
+ window_prompting = gui_figure_window_size (f, parms, false, true);
tem = gui_display_get_arg (dpyinfo, parms, Qunsplittable, 0, 0,
RES_TYPE_BOOLEAN);
@@ -1400,13 +1387,8 @@ DEFUN ("x-create-frame", Fx_create_frame,
Sx_create_frame,
/* Allow set_window_size_hook, now. */
f->can_set_window_size = true;
- if (x_width > 0)
- SET_FRAME_WIDTH (f, x_width);
- if (x_height > 0)
- SET_FRAME_HEIGHT (f, x_height);
-
- adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), 0, 1,
- Qx_create_frame_2);
+ adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f),
+ 0, true, Qx_create_frame_2);
if (! f->output_data.ns->explicit_parent)
{
diff --git a/src/nsterm.m b/src/nsterm.m
index bf175bb..b135e35 100644
--- a/src/nsterm.m
+++ b/src/nsterm.m
@@ -1876,10 +1876,9 @@ static void
ns_set_window_size (struct frame *f,
bool change_gravity,
int width,
- int height,
- bool pixelwise)
+ int height)
/* --------------------------------------------------------------------------
- Adjust window pixel size based on given character grid size
+ Adjust window pixel size based on native sizes WIDTH and HEIGHT.
Impl is a bit more complex than other terms, need to do some
internal clipping.
--------------------------------------------------------------------------
*/
@@ -1887,7 +1886,6 @@ ns_set_window_size (struct frame *f,
EmacsView *view = FRAME_NS_VIEW (f);
NSWindow *window = [view window];
NSRect wr = [window frame];
- int pixelwidth, pixelheight;
int orig_height = wr.size.height;
NSTRACE ("ns_set_window_size");
@@ -1896,24 +1894,13 @@ ns_set_window_size (struct frame *f,
return;
NSTRACE_RECT ("current", wr);
- NSTRACE_MSG ("Width:%d Height:%d Pixelwise:%d", width, height, pixelwise);
+ NSTRACE_MSG ("Width:%d Height:%d", width, height);
NSTRACE_MSG ("Font %d x %d", FRAME_COLUMN_WIDTH (f), FRAME_LINE_HEIGHT (f));
block_input ();
- if (pixelwise)
- {
- pixelwidth = FRAME_TEXT_TO_PIXEL_WIDTH (f, width);
- pixelheight = FRAME_TEXT_TO_PIXEL_HEIGHT (f, height);
- }
- else
- {
- pixelwidth = FRAME_TEXT_COLS_TO_PIXEL_WIDTH (f, width);
- pixelheight = FRAME_TEXT_LINES_TO_PIXEL_HEIGHT (f, height);
- }
-
- wr.size.width = pixelwidth + f->border_width;
- wr.size.height = pixelheight;
+ wr.size.width = width + f->border_width;
+ wr.size.height = height;
if (! [view isFullscreen])
wr.size.height += FRAME_NS_TITLEBAR_HEIGHT (f)
+ FRAME_TOOLBAR_HEIGHT (f);
@@ -1926,21 +1913,10 @@ ns_set_window_size (struct frame *f,
else
wr.origin.y += orig_height - wr.size.height;
- frame_size_history_add
- (f, Qx_set_window_size_1, width, height,
- 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))));
-
/* Usually it seems safe to delay changing the frame size, but when a
series of actions are taken with no redisplay between them then we
can end up using old values so don't delay here. */
- change_frame_size (f,
- FRAME_PIXEL_TO_TEXT_WIDTH (f, pixelwidth),
- FRAME_PIXEL_TO_TEXT_HEIGHT (f, pixelheight),
- 0, NO, 0, 1);
+ change_frame_size (f, width, height, false, NO, false);
[window setFrame:wr display:NO];
@@ -7359,10 +7335,7 @@ not_in_argv (NSString *arg)
changes size, as Emacs may already know about the change.
Unfortunately there doesn't seem to be a bullet-proof method of
determining whether we need to call it or not. */
- change_frame_size (emacsframe,
- FRAME_PIXEL_TO_TEXT_WIDTH (emacsframe, neww),
- FRAME_PIXEL_TO_TEXT_HEIGHT (emacsframe, newh),
- 0, YES, 0, 1);
+ change_frame_size (emacsframe, neww, newh, false, YES, false);
SET_FRAME_GARBAGED (emacsframe);
cancel_mouse_face (emacsframe);
@@ -9790,7 +9763,7 @@ nswindow_orderedIndex_sort (id w1, id w2, void *c)
IOSurfaceRef surface = NULL;
NSTRACE ("[EmacsSurface getContextWithSize:]");
- NSTRACE_MSG (@"IOSurface count: %lu", [cache count] + (lastSurface ? 1 : 0));
+ NSTRACE_MSG ("IOSurface count: %lu", [cache count] + (lastSurface ? 1 : 0));
for (id object in cache)
{
diff --git a/src/pdumper.c b/src/pdumper.c
index fdd9b3b..dfc7388 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -121,6 +121,9 @@ static const char dump_magic[16] = {
static pdumper_hook dump_hooks[24];
static int nr_dump_hooks = 0;
+static pdumper_hook dump_late_hooks[24];
+static int nr_dump_late_hooks = 0;
+
static struct
{
void *mem;
@@ -175,6 +178,8 @@ enum dump_reloc_type
/* dump_ptr = dump_ptr + dump_base */
RELOC_DUMP_TO_DUMP_PTR_RAW,
/* dump_mpz = [rebuild bignum] */
+ RELOC_NATIVE_COMP_UNIT,
+ RELOC_NATIVE_SUBR,
RELOC_BIGNUM,
/* dump_lv = make_lisp_ptr (dump_lv + dump_base,
type - RELOC_DUMP_TO_DUMP_LV)
@@ -317,6 +322,20 @@ dump_fingerprint (char const *label,
fprintf (stderr, "%s: %.*s\n", label, hexbuf_size, hexbuf);
}
+/* To be used if some order in the relocation process has to be enforced. */
+enum reloc_phase
+ {
+ /* First to run. Place every relocation with no dependency here. */
+ EARLY_RELOCS,
+ /* Late and very late relocs are relocated at the very last after
+ all hooks has been run. All lisp machinery is at disposal
+ (memory allocation allowed too). */
+ LATE_RELOCS,
+ VERY_LATE_RELOCS,
+ /* Fake, must be last. */
+ RELOC_NUM_PHASES
+ };
+
/* Format of an Emacs dump file. All offsets are relative to
the beginning of the file. An Emacs dump file is coupled
to exactly the Emacs binary that produced it, so details of
@@ -344,7 +363,7 @@ struct dump_header
/* Relocation table for the dump file; each entry is a
struct dump_reloc. */
- struct dump_table_locator dump_relocs;
+ struct dump_table_locator dump_relocs[RELOC_NUM_PHASES];
/* "Relocation" table we abuse to hold information about the
location and type of each lisp object in the dump. We need for
@@ -425,6 +444,7 @@ enum cold_op
COLD_OP_CHARSET,
COLD_OP_BUFFER,
COLD_OP_BIGNUM,
+ COLD_OP_NATIVE_SUBR,
};
/* This structure controls what operations we perform inside
@@ -524,7 +544,7 @@ struct dump_context
Lisp_Object cold_queue;
/* Relocations in the dump. */
- Lisp_Object dump_relocs;
+ Lisp_Object dump_relocs[RELOC_NUM_PHASES];
/* Object starts. */
Lisp_Object object_starts;
@@ -919,7 +939,7 @@ dump_note_reachable (struct dump_context *ctx, Lisp_Object
object)
static void *
dump_object_emacs_ptr (Lisp_Object lv)
{
- if (SUBRP (lv))
+ if (SUBRP (lv) && !SUBR_NATIVE_COMPILEDP (lv))
return XSUBR (lv);
if (dump_builtin_symbol_p (lv))
return XSYMBOL (lv);
@@ -1405,7 +1425,7 @@ dump_reloc_dump_to_emacs_ptr_raw (struct dump_context
*ctx,
dump_off dump_offset)
{
if (ctx->flags.dump_object_contents)
- dump_push (&ctx->dump_relocs,
+ dump_push (&ctx->dump_relocs[EARLY_RELOCS],
list2 (make_fixnum (RELOC_DUMP_TO_EMACS_PTR_RAW),
dump_off_to_lisp (dump_offset)));
}
@@ -1438,7 +1458,7 @@ dump_reloc_dump_to_dump_lv (struct dump_context *ctx,
emacs_abort ();
}
- dump_push (&ctx->dump_relocs,
+ dump_push (&ctx->dump_relocs[EARLY_RELOCS],
list2 (make_fixnum (reloc_type),
dump_off_to_lisp (dump_offset)));
}
@@ -1454,7 +1474,7 @@ dump_reloc_dump_to_dump_ptr_raw (struct dump_context *ctx,
dump_off dump_offset)
{
if (ctx->flags.dump_object_contents)
- dump_push (&ctx->dump_relocs,
+ dump_push (&ctx->dump_relocs[EARLY_RELOCS],
list2 (make_fixnum (RELOC_DUMP_TO_DUMP_PTR_RAW),
dump_off_to_lisp (dump_offset)));
}
@@ -1487,7 +1507,7 @@ dump_reloc_dump_to_emacs_lv (struct dump_context *ctx,
emacs_abort ();
}
- dump_push (&ctx->dump_relocs,
+ dump_push (&ctx->dump_relocs[EARLY_RELOCS],
list2 (make_fixnum (reloc_type),
dump_off_to_lisp (dump_offset)));
}
@@ -2200,7 +2220,7 @@ dump_bignum (struct dump_context *ctx, Lisp_Object object)
Lisp_Bignum instead of the actual mpz field so that the
relocation offset is aligned. The relocation-application
code knows to actually advance past the header. */
- dump_push (&ctx->dump_relocs,
+ dump_push (&ctx->dump_relocs[EARLY_RELOCS],
list2 (make_fixnum (RELOC_BIGNUM),
dump_off_to_lisp (bignum_offset)));
}
@@ -2840,20 +2860,73 @@ dump_bool_vector (struct dump_context *ctx, const
struct Lisp_Vector *v)
static dump_off
dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr)
{
-#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_594AB72B54)
+#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_AA236F7759)
# error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h."
#endif
struct Lisp_Subr out;
dump_object_start (ctx, &out, sizeof (out));
DUMP_FIELD_COPY (&out, subr, header.size);
- dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0);
+ if (NATIVE_COMP_FLAG && !NILP (subr->native_comp_u[0]))
+ out.function.a0 = NULL;
+ else
+ dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0);
DUMP_FIELD_COPY (&out, subr, min_args);
DUMP_FIELD_COPY (&out, subr, max_args);
- dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name);
- dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec);
+ if (NATIVE_COMP_FLAG && !NILP (subr->native_comp_u[0]))
+ {
+ dump_field_fixup_later (ctx, &out, subr, &subr->symbol_name);
+ dump_remember_cold_op (ctx,
+ COLD_OP_NATIVE_SUBR,
+ make_lisp_ptr ((void *) subr, Lisp_Vectorlike));
+ dump_field_lv (ctx, &out, subr, &subr->native_intspec, WEIGHT_NORMAL);
+ }
+ else
+ {
+ dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name);
+ dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec);
+ }
DUMP_FIELD_COPY (&out, subr, doc);
- return dump_object_finish (ctx, &out, sizeof (out));
+ if (NATIVE_COMP_FLAG)
+ {
+ dump_field_lv (ctx, &out, subr, &subr->native_comp_u[0], WEIGHT_NORMAL);
+ if (!NILP (subr->native_comp_u[0]))
+ dump_field_fixup_later (ctx, &out, subr, &subr->native_c_name[0]);
+
+ dump_field_lv (ctx, &out, subr, &subr->lambda_list[0], WEIGHT_NORMAL);
+ dump_field_lv (ctx, &out, subr, &subr->type[0], WEIGHT_NORMAL);
+ }
+ dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out));
+ if (NATIVE_COMP_FLAG
+ && ctx->flags.dump_object_contents
+ && !NILP (subr->native_comp_u[0]))
+ /* We'll do the final addr relocation during VERY_LATE_RELOCS time
+ after the compilation units has been loaded. */
+ dump_push (&ctx->dump_relocs[VERY_LATE_RELOCS],
+ list2 (make_fixnum (RELOC_NATIVE_SUBR),
+ dump_off_to_lisp (subr_off)));
+ return subr_off;
+}
+
+#ifdef HAVE_NATIVE_COMP
+static dump_off
+dump_native_comp_unit (struct dump_context *ctx,
+ struct Lisp_Native_Comp_Unit *comp_u)
+{
+ /* Have function documentation always lazy loaded to optimize load-time. */
+ comp_u->data_fdoc_v = Qnil;
+ START_DUMP_PVEC (ctx, &comp_u->header, struct Lisp_Native_Comp_Unit, out);
+ dump_pseudovector_lisp_fields (ctx, &out->header, &comp_u->header);
+ out->handle = NULL;
+
+ dump_off comp_u_off = finish_dump_pvec (ctx, &out->header);
+ if (ctx->flags.dump_object_contents)
+ /* We'll do the real elf load during LATE_RELOCS relocation time. */
+ dump_push (&ctx->dump_relocs[LATE_RELOCS],
+ list2 (make_fixnum (RELOC_NATIVE_COMP_UNIT),
+ dump_off_to_lisp (comp_u_off)));
+ return comp_u_off;
}
+#endif
static void
fill_pseudovec (union vectorlike_header *header, Lisp_Object item)
@@ -2879,7 +2952,7 @@ dump_vectorlike (struct dump_context *ctx,
Lisp_Object lv,
dump_off offset)
{
-#if CHECK_STRUCTS && !defined HASH_pvec_type_A4A6E9984D
+#if CHECK_STRUCTS && !defined HASH_pvec_type_F5BA506141
# error "pvec_type changed. See CHECK_STRUCTS comment in config.h."
#endif
const struct Lisp_Vector *v = XVECTOR (lv);
@@ -2932,6 +3005,11 @@ dump_vectorlike (struct dump_context *ctx,
case PVEC_BIGNUM:
offset = dump_bignum (ctx, lv);
break;
+#ifdef HAVE_NATIVE_COMP
+ case PVEC_NATIVE_COMP_UNIT:
+ offset = dump_native_comp_unit (ctx, XNATIVE_COMP_UNIT (lv));
+ break;
+#endif
case PVEC_WINDOW_CONFIGURATION:
error_unsupported_dump_object (ctx, lv, "window configuration");
case PVEC_OTHER:
@@ -3167,6 +3245,12 @@ dump_metadata_for_pdumper (struct dump_context *ctx)
(void const *) dump_hooks[i]);
dump_emacs_reloc_immediate_int (ctx, &nr_dump_hooks, nr_dump_hooks);
+ for (int i = 0; i < nr_dump_late_hooks; ++i)
+ dump_emacs_reloc_to_emacs_ptr_raw (ctx, &dump_late_hooks[i],
+ (void const *) dump_late_hooks[i]);
+ dump_emacs_reloc_immediate_int (ctx, &nr_dump_late_hooks,
+ nr_dump_late_hooks);
+
for (int i = 0; i < nr_remembered_data; ++i)
{
dump_emacs_reloc_to_emacs_ptr_raw (ctx, &remembered_data[i].mem,
@@ -3328,6 +3412,29 @@ dump_cold_bignum (struct dump_context *ctx, Lisp_Object
object)
}
}
+#ifdef HAVE_NATIVE_COMP
+static void
+dump_cold_native_subr (struct dump_context *ctx, Lisp_Object subr)
+{
+ /* Dump subr contents. */
+ dump_off subr_offset = dump_recall_object (ctx, subr);
+ eassert (subr_offset > 0);
+ dump_remember_fixup_ptr_raw
+ (ctx,
+ subr_offset + dump_offsetof (struct Lisp_Subr, symbol_name),
+ ctx->offset);
+ const char *symbol_name = XSUBR (subr)->symbol_name;
+ dump_write (ctx, symbol_name, 1 + strlen (symbol_name));
+
+ dump_remember_fixup_ptr_raw
+ (ctx,
+ subr_offset + dump_offsetof (struct Lisp_Subr, native_c_name[0]),
+ ctx->offset);
+ const char *c_name = XSUBR (subr)->native_c_name[0];
+ dump_write (ctx, c_name, 1 + strlen (c_name));
+}
+#endif
+
static void
dump_drain_cold_data (struct dump_context *ctx)
{
@@ -3371,6 +3478,11 @@ dump_drain_cold_data (struct dump_context *ctx)
case COLD_OP_BIGNUM:
dump_cold_bignum (ctx, data);
break;
+#ifdef HAVE_NATIVE_COMP
+ case COLD_OP_NATIVE_SUBR:
+ dump_cold_native_subr (ctx, data);
+ break;
+#endif
default:
emacs_abort ();
}
@@ -3779,7 +3891,7 @@ dump_do_fixup (struct dump_context *ctx,
/* Dump wants a pointer to a Lisp object.
If DUMP_FIXUP_LISP_OBJECT_RAW, we should stick a C pointer in
the dump; otherwise, a Lisp_Object. */
- if (SUBRP (arg))
+ if (SUBRP (arg) && !SUBR_NATIVE_COMPILEDP (arg))
{
dump_value = emacs_offset (XSUBR (arg));
if (type == DUMP_FIXUP_LISP_OBJECT)
@@ -3960,7 +4072,8 @@ types. */)
ctx->symbol_aux = Qnil;
ctx->copied_queue = Qnil;
ctx->cold_queue = Qnil;
- ctx->dump_relocs = Qnil;
+ for (int i = 0; i < RELOC_NUM_PHASES; ++i)
+ ctx->dump_relocs[i] = Qnil;
ctx->object_starts = Qnil;
ctx->emacs_relocs = Qnil;
ctx->bignum_data = make_eq_hash_table ();
@@ -4128,8 +4241,9 @@ types. */)
/* Emit instructions for Emacs to execute when loading the dump.
Note that this relocation information ends up in the cold section
of the dump. */
- drain_reloc_list (ctx, dump_emit_dump_reloc, emacs_reloc_merger,
- &ctx->dump_relocs, &ctx->header.dump_relocs);
+ for (int i = 0; i < RELOC_NUM_PHASES; ++i)
+ drain_reloc_list (ctx, dump_emit_dump_reloc, emacs_reloc_merger,
+ &ctx->dump_relocs[i], &ctx->header.dump_relocs[i]);
dump_off number_hot_relocations = ctx->number_hot_relocations;
ctx->number_hot_relocations = 0;
dump_off number_discardable_relocations =
ctx->number_discardable_relocations;
@@ -4147,7 +4261,8 @@ types. */)
eassert (NILP (ctx->deferred_symbols));
eassert (NILP (ctx->deferred_hash_tables));
eassert (NILP (ctx->fixups));
- eassert (NILP (ctx->dump_relocs));
+ for (int i = 0; i < RELOC_NUM_PHASES; ++i)
+ eassert (NILP (ctx->dump_relocs[i]));
eassert (NILP (ctx->emacs_relocs));
/* Dump is complete. Go back to the header and write the magic
@@ -4207,6 +4322,15 @@ pdumper_do_now_and_after_load_impl (pdumper_hook hook)
hook ();
}
+void
+pdumper_do_now_and_after_late_load_impl (pdumper_hook hook)
+{
+ if (nr_dump_late_hooks == ARRAYELTS (dump_late_hooks))
+ fatal ("out of dump hooks: make dump_late_hooks[] bigger");
+ dump_late_hooks[nr_dump_late_hooks++] = hook;
+ hook ();
+}
+
static void
pdumper_remember_user_data_1 (void *mem, int nbytes)
{
@@ -4232,6 +4356,16 @@ pdumper_remember_lv_ptr_raw_impl (void *ptr, enum
Lisp_Type type)
}
+#ifdef HAVE_NATIVE_COMP
+/* This records the directory where the Emacs executable lives, to be
+ used for locating the native-lisp directory from which we need to
+ load the preloaded *.eln files. See pdumper_set_emacs_execdir
+ below. */
+static char *emacs_execdir;
+static ptrdiff_t execdir_size;
+static ptrdiff_t execdir_len;
+#endif
+
/* Dump runtime */
enum dump_memory_protection
{
@@ -5138,6 +5272,117 @@ dump_do_dump_relocation (const uintptr_t dump_base,
dump_write_word_to_dump (dump_base, reloc_offset, value);
break;
}
+#ifdef HAVE_NATIVE_COMP
+ case RELOC_NATIVE_COMP_UNIT:
+ {
+ static enum { UNKNOWN, LOCAL_BUILD, INSTALLED } installation_state;
+ struct Lisp_Native_Comp_Unit *comp_u =
+ dump_ptr (dump_base, reloc_offset);
+ comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq);
+ if (STRINGP (comp_u->file))
+ error ("Trying to load incoherent dumped eln file %s",
+ SSDATA (comp_u->file));
+
+ /* emacs_execdir is always unibyte, but the file names in
+ comp_u->file could be multibyte, so we need to encode
+ them. */
+ Lisp_Object cu_file1 = ENCODE_FILE (XCAR (comp_u->file));
+ Lisp_Object cu_file2 = ENCODE_FILE (XCDR (comp_u->file));
+ ptrdiff_t fn1_len = SBYTES (cu_file1), fn2_len = SBYTES (cu_file2);
+ Lisp_Object eln_fname;
+ char *fndata;
+
+ /* Check just once if this is a local build or Emacs was installed. */
+ /* Can't use expand-file-name here, because we are too early
+ in the startup, and we will crash at least on WINDOWSNT. */
+ if (installation_state == UNKNOWN)
+ {
+ eln_fname = make_uninit_string (execdir_len + fn1_len);
+ fndata = SSDATA (eln_fname);
+ memcpy (fndata, emacs_execdir, execdir_len);
+ memcpy (fndata + execdir_len, SSDATA (cu_file1), fn1_len);
+ if (file_access_p (fndata, F_OK))
+ installation_state = INSTALLED;
+ else
+ {
+ eln_fname = make_uninit_string (execdir_len + fn2_len);
+ fndata = SSDATA (eln_fname);
+ memcpy (fndata, emacs_execdir, execdir_len);
+ memcpy (fndata + execdir_len, SSDATA (cu_file2), fn2_len);
+ installation_state = LOCAL_BUILD;
+ }
+ fixup_eln_load_path (eln_fname);
+ }
+ else
+ {
+ ptrdiff_t fn_len =
+ installation_state == INSTALLED ? fn1_len : fn2_len;
+ Lisp_Object cu_file =
+ installation_state == INSTALLED ? cu_file1 : cu_file2;
+ eln_fname = make_uninit_string (execdir_len + fn_len);
+ fndata = SSDATA (eln_fname);
+ memcpy (fndata, emacs_execdir, execdir_len);
+ memcpy (fndata + execdir_len, SSDATA (cu_file), fn_len);
+ }
+
+ /* FIXME: This records the names of the *.eln files in an
+ unexpanded form, with one or more ".." elements (and on
+ Windows with the first part using backslashes). The file
+ names are also unibyte. If we care about this, we need to
+ loop in startup.el over all the preloaded modules and run
+ their file names through expand-file-name and
+ decode-coding-string. */
+ comp_u->file = eln_fname;
+ comp_u->handle = dynlib_open (SSDATA (eln_fname));
+ if (!comp_u->handle)
+ {
+ fprintf (stderr, "Error using execdir %s:\n",
+ emacs_execdir);
+ error ("%s", dynlib_error ());
+ }
+ load_comp_unit (comp_u, true, false);
+ break;
+ }
+ case RELOC_NATIVE_SUBR:
+ {
+ if (!NATIVE_COMP_FLAG)
+ /* This cannot happen. */
+ emacs_abort ();
+
+ /* When resurrecting from a dump given non all the original
+ native compiled subrs may be still around we can't rely on
+ a 'top_level_run' mechanism, we revive them one-by-one
+ here. */
+ struct Lisp_Subr *subr = dump_ptr (dump_base, reloc_offset);
+ struct Lisp_Native_Comp_Unit *comp_u =
+ XNATIVE_COMP_UNIT (subr->native_comp_u[0]);
+ if (!comp_u->handle)
+ error ("NULL handle in compilation unit %s", SSDATA (comp_u->file));
+ const char *c_name = subr->native_c_name[0];
+ eassert (c_name);
+ void *func = dynlib_sym (comp_u->handle, c_name);
+ if (!func)
+ error ("can't find function \"%s\" in compilation unit %s", c_name,
+ SSDATA (comp_u->file));
+ subr->function.a0 = func;
+ Lisp_Object lambda_data_idx =
+ Fgethash (build_string (c_name), comp_u->lambda_c_name_idx_h, Qnil);
+ if (!NILP (lambda_data_idx))
+ {
+ /* This is an anonymous lambda.
+ We must fixup d_reloc_imp so the lambda can be referenced
+ by code. */
+ Lisp_Object tem;
+ XSETSUBR (tem, subr);
+ Lisp_Object *fixup =
+ &(comp_u->data_imp_relocs[XFIXNUM (lambda_data_idx)]);
+ eassert (EQ (*fixup, Qlambda_fixup));
+ *fixup = tem;
+ Fputhash (tem, Qt, comp_u->lambda_gc_guard_h);
+ }
+ break;
+ }
+#endif
case RELOC_BIGNUM:
{
struct Lisp_Bignum *bignum = dump_ptr (dump_base, reloc_offset);
@@ -5160,11 +5405,12 @@ dump_do_dump_relocation (const uintptr_t dump_base,
}
static void
-dump_do_all_dump_relocations (const struct dump_header *const header,
- const uintptr_t dump_base)
+dump_do_all_dump_reloc_for_phase (const struct dump_header *const header,
+ const uintptr_t dump_base,
+ const enum reloc_phase phase)
{
- struct dump_reloc *r = dump_ptr (dump_base, header->dump_relocs.offset);
- dump_off nr_entries = header->dump_relocs.nr_entries;
+ struct dump_reloc *r = dump_ptr (dump_base,
header->dump_relocs[phase].offset);
+ dump_off nr_entries = header->dump_relocs[phase].nr_entries;
for (dump_off i = 0; i < nr_entries; ++i)
dump_do_dump_relocation (dump_base, r[i]);
}
@@ -5229,6 +5475,26 @@ dump_do_all_emacs_relocations (const struct dump_header
*const header,
dump_do_emacs_relocation (dump_base, r[i]);
}
+#ifdef HAVE_NATIVE_COMP
+/* Compute and record the directory of the Emacs executable given the
+ file name of that executable. */
+static void
+pdumper_set_emacs_execdir (char *emacs_executable)
+{
+ char *p = emacs_executable + strlen (emacs_executable);
+
+ while (p > emacs_executable
+ && !IS_DIRECTORY_SEP (p[-1]))
+ --p;
+ eassert (p > emacs_executable);
+ emacs_execdir = xpalloc (emacs_execdir, &execdir_size,
+ p - emacs_executable + 1 - execdir_size, -1, 1);
+ memcpy (emacs_execdir, emacs_executable, p - emacs_executable);
+ execdir_len = p - emacs_executable;
+ emacs_execdir[execdir_len] = '\0';
+}
+#endif
+
enum dump_section
{
DS_HOT,
@@ -5245,7 +5511,7 @@ static Lisp_Object *pdumper_hashes = &zero_vector;
N.B. We run very early in initialization, so we can't use lisp,
unwinding, xmalloc, and so on. */
int
-pdumper_load (const char *dump_filename)
+pdumper_load (const char *dump_filename, char *argv0)
{
intptr_t dump_size;
struct stat stat;
@@ -5380,7 +5646,7 @@ pdumper_load (const char *dump_filename)
dump_public.start = dump_base;
dump_public.end = dump_public.start + dump_size;
- dump_do_all_dump_relocations (header, dump_base);
+ dump_do_all_dump_reloc_for_phase (header, dump_base, EARLY_RELOCS);
dump_do_all_emacs_relocations (header, dump_base);
dump_mmap_discard_contents (§ions[DS_DISCARDABLE]);
@@ -5400,6 +5666,21 @@ pdumper_load (const char *dump_filename)
initialization. */
for (int i = 0; i < nr_dump_hooks; ++i)
dump_hooks[i] ();
+
+#ifdef HAVE_NATIVE_COMP
+ pdumper_set_emacs_execdir (argv0);
+#else
+ (void) argv0;
+#endif
+
+ dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS);
+ dump_do_all_dump_reloc_for_phase (header, dump_base, VERY_LATE_RELOCS);
+
+ /* Run the functions Emacs registered for doing post-dump-load
+ initialization. */
+ for (int i = 0; i < nr_dump_late_hooks; ++i)
+ dump_late_hooks[i] ();
+
initialized = true;
struct timespec load_timespec =
@@ -5463,9 +5744,6 @@ Value is nil if this session was not started using a dump
file.*/)
Fcons (Qdump_file_name, dump_fn));
}
-#endif /* HAVE_PDUMPER */
-
-
static void
thaw_hash_tables (void)
{
@@ -5474,10 +5752,15 @@ thaw_hash_tables (void)
hash_table_thaw (AREF (hash_tables, i));
}
+#endif /* HAVE_PDUMPER */
+
+
void
init_pdumper_once (void)
{
+#ifdef HAVE_PDUMPER
pdumper_do_now_and_after_load (thaw_hash_tables);
+#endif
}
void
diff --git a/src/pdumper.h b/src/pdumper.h
index ed665ac..deec9af 100644
--- a/src/pdumper.h
+++ b/src/pdumper.h
@@ -81,6 +81,7 @@ pdumper_remember_lv_ptr_raw (void *ptr, enum Lisp_Type type)
typedef void (*pdumper_hook)(void);
extern void pdumper_do_now_and_after_load_impl (pdumper_hook hook);
+extern void pdumper_do_now_and_after_late_load_impl (pdumper_hook hook);
INLINE void
pdumper_do_now_and_after_load (pdumper_hook hook)
@@ -92,6 +93,18 @@ pdumper_do_now_and_after_load (pdumper_hook hook)
#endif
}
+/* Same as 'pdumper_do_now_and_after_load' but for hooks running code
+ that can call into Lisp. */
+INLINE void
+pdumper_do_now_and_after_late_load (pdumper_hook hook)
+{
+#ifdef HAVE_PDUMPER
+ pdumper_do_now_and_after_late_load_impl (hook);
+#else
+ hook ();
+#endif
+}
+
/* Macros useful in pdumper callback functions. Assign a value if
we're loading a dump and the value needs to be reset to its
original value, and if we're initializing for the first time,
@@ -127,7 +140,7 @@ enum pdumper_load_result
PDUMPER_LOAD_ERROR /* Must be last, as errno may be added. */
};
-int pdumper_load (const char *dump_filename);
+int pdumper_load (const char *dump_filename, char *argv0);
struct pdumper_loaded_dump
{
diff --git a/src/print.c b/src/print.c
index 14af919..d4301fd 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1841,7 +1841,18 @@ print_vectorlike (Lisp_Object obj, Lisp_Object
printcharfun, bool escapeflag,
}
break;
#endif
-
+#ifdef HAVE_NATIVE_COMP
+ case PVEC_NATIVE_COMP_UNIT:
+ {
+ struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (obj);
+ print_c_string ("#<native compilation unit: ", printcharfun);
+ print_string (cu->file, printcharfun);
+ printchar (' ', printcharfun);
+ print_object (cu->optimize_qualities, printcharfun, escapeflag);
+ printchar ('>', printcharfun);
+ }
+ break;
+#endif
default:
emacs_abort ();
}
diff --git a/src/process.c b/src/process.c
index b98bc29..84e301a 100644
--- a/src/process.c
+++ b/src/process.c
@@ -1936,7 +1936,7 @@ usage: (make-process &rest ARGS) */)
{
tem = Qnil;
openp (Vexec_path, program, Vexec_suffixes, &tem,
- make_fixnum (X_OK), false);
+ make_fixnum (X_OK), false, false);
if (NILP (tem))
report_file_error ("Searching for program", program);
tem = Fexpand_file_name (tem, Qnil);
diff --git a/src/sound.c b/src/sound.c
index e5f66f8..9041076 100644
--- a/src/sound.c
+++ b/src/sound.c
@@ -1370,8 +1370,9 @@ Internal use only, use `play-sound' instead. */)
if (STRINGP (attrs[SOUND_FILE]))
{
/* Open the sound file. */
- current_sound->fd = openp (list1 (Vdata_directory),
- attrs[SOUND_FILE], Qnil, &file, Qnil, false);
+ current_sound->fd =
+ openp (list1 (Vdata_directory), attrs[SOUND_FILE], Qnil, &file, Qnil,
+ false, false);
if (current_sound->fd < 0)
sound_perror ("Could not open sound file");
diff --git a/src/term.c b/src/term.c
index 1059b06..c995a44 100644
--- a/src/term.c
+++ b/src/term.c
@@ -2356,9 +2356,7 @@ frame's terminal). */)
was suspended. */
get_tty_size (fileno (t->display_info.tty->input), &width, &height);
if (width != old_width || height != old_height)
- change_frame_size (f, width, height - FRAME_MENU_BAR_LINES (f)
- - FRAME_TAB_BAR_LINES (f),
- 0, 0, 0, 0);
+ change_frame_size (f, width, height, false, false, false);
SET_FRAME_VISIBLE (XFRAME (t->display_info.tty->top_frame), 1);
}
diff --git a/src/termhooks.h b/src/termhooks.h
index 3800679..1d3cdc8 100644
--- a/src/termhooks.h
+++ b/src/termhooks.h
@@ -583,7 +583,7 @@ struct terminal
window gravity for this size change and subsequent size changes.
Otherwise we leave the window gravity unchanged. */
void (*set_window_size_hook) (struct frame *f, bool change_gravity,
- int width, int height, bool pixelwise);
+ int width, int height);
/* CHANGE_GRAVITY is 1 when calling from Fset_frame_position,
to really change the position, and 0 when calling from
diff --git a/src/verbose.mk.in b/src/verbose.mk.in
index e55fd63..085a05a 100644
--- a/src/verbose.mk.in
+++ b/src/verbose.mk.in
@@ -34,7 +34,15 @@ AM_V_AR = @echo " AR " $@;
AM_V_at = @
AM_V_CC = @echo " CC " $@;
AM_V_CCLD = @echo " CCLD " $@;
+ifeq ($(HAVE_NATIVE_COMP),yes)
+ifeq ($(NATIVE_DISABLED),1)
AM_V_ELC = @echo " ELC " $@;
+else
+AM_V_ELC = @echo " ELC+ELN " $@;
+endif
+else
+AM_V_ELC = @echo " ELC " $@;
+endif
AM_V_GEN = @echo " GEN " $@;
AM_V_GLOBALS = @echo " GEN " globals.h;
AM_V_NO_PD = --no-print-directory
diff --git a/src/w32.c b/src/w32.c
index aade802..467e6cb 100644
--- a/src/w32.c
+++ b/src/w32.c
@@ -1941,11 +1941,10 @@ buf_prev (int from)
return prev_idx;
}
-static void
-sample_system_load (ULONGLONG *idle, ULONGLONG *kernel, ULONGLONG *user)
+unsigned
+w32_get_nproc (void)
{
SYSTEM_INFO sysinfo;
- FILETIME ft_idle, ft_user, ft_kernel;
/* Initialize the number of processors on this machine. */
if (num_of_processors <= 0)
@@ -1960,6 +1959,15 @@ sample_system_load (ULONGLONG *idle, ULONGLONG *kernel,
ULONGLONG *user)
if (num_of_processors <= 0)
num_of_processors = 1;
}
+ return num_of_processors;
+}
+
+static void
+sample_system_load (ULONGLONG *idle, ULONGLONG *kernel, ULONGLONG *user)
+{
+ FILETIME ft_idle, ft_user, ft_kernel;
+
+ (void) w32_get_nproc ();
/* TODO: Take into account threads that are ready to run, by
sampling the "\System\Processor Queue Length" performance
@@ -10247,7 +10255,8 @@ check_windows_init_file (void)
need to ENCODE_FILE here, but we do need to convert the file
names from UTF-8 to ANSI. */
init_file = build_string ("term/w32-win");
- fd = openp (Vload_path, init_file, Fget_load_suffixes (), NULL, Qnil, 0);
+ fd =
+ openp (Vload_path, init_file, Fget_load_suffixes (), NULL, Qnil, 0, 0);
if (fd < 0)
{
Lisp_Object load_path_print = Fprin1_to_string (Vload_path, Qnil);
@@ -10439,6 +10448,13 @@ shutdown_handler (DWORD type)
|| type == CTRL_LOGOFF_EVENT /* User logs off. */
|| type == CTRL_SHUTDOWN_EVENT) /* User shutsdown. */
{
+ /* If we are being shut down in noninteractive mode, we don't
+ care about the message stack, so clear it to avoid abort in
+ shut_down_emacs. This happens when an noninteractive Emacs
+ is invoked as a subprocess of Emacs, and the parent wants to
+ kill us, e.g. because it's about to exit. */
+ if (noninteractive)
+ clear_message_stack ();
/* Shut down cleanly, making sure autosave files are up to date. */
shut_down_emacs (0, Qnil);
}
@@ -10657,6 +10673,10 @@ globals_of_w32 (void)
#endif
w32_crypto_hprov = (HCRYPTPROV)0;
+
+ /* We need to forget about libraries that were loaded during the
+ dumping process (e.g. libgccjit) */
+ Vlibrary_cache = Qnil;
}
/* For make-serial-process */
diff --git a/src/w32.h b/src/w32.h
index 3f8eb25..a382dbe 100644
--- a/src/w32.h
+++ b/src/w32.h
@@ -233,6 +233,9 @@ extern int w32_memory_info (unsigned long long *, unsigned
long long *,
/* Compare 2 UTF-8 strings in locale-dependent fashion. */
extern int w32_compare_strings (const char *, const char *, char *, int);
+/* Return the number of processor execution units on this system. */
+extern unsigned w32_get_nproc (void);
+
/* Return a cryptographically secure seed for PRNG. */
extern int w32_init_random (void *, ptrdiff_t);
diff --git a/src/w32common.h b/src/w32common.h
index 714a238..cbe05c5 100644
--- a/src/w32common.h
+++ b/src/w32common.h
@@ -86,6 +86,14 @@ get_proc_addr (HINSTANCE handle, LPCSTR fname)
} \
while (false)
+/* Load a function from the DLL, and don't fail if it does not exist. */
+#define LOAD_DLL_FN_OPT(lib, func) \
+ do \
+ { \
+ fn_##func = (W32_PFN_##func) get_proc_addr (lib, #func); \
+ } \
+ while (false)
+
#ifdef HAVE_HARFBUZZ
extern bool hbfont_init_w32_funcs (HMODULE);
#endif
diff --git a/src/w32fns.c b/src/w32fns.c
index 9db367b..66baeae 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -1701,7 +1701,7 @@ w32_change_tab_bar_height (struct frame *f, int height)
int unit = FRAME_LINE_HEIGHT (f);
int old_height = FRAME_TAB_BAR_HEIGHT (f);
int lines = (height + unit - 1) / unit;
- Lisp_Object fullscreen;
+ Lisp_Object fullscreen = get_frame_param (f, Qfullscreen);
/* Make sure we redisplay all windows in this frame. */
fset_redisplay (f);
@@ -1728,25 +1728,21 @@ w32_change_tab_bar_height (struct frame *f, int height)
if ((height < old_height) && WINDOWP (f->tab_bar_window))
clear_glyph_matrix (XWINDOW (f->tab_bar_window)->current_matrix);
- /* Recalculate tabbar height. */
- f->n_tab_bar_rows = 0;
- if (old_height == 0
- && (!f->after_make_frame
- || NILP (frame_inhibit_implied_resize)
- || (CONSP (frame_inhibit_implied_resize)
- && NILP (Fmemq (Qtab_bar_lines, frame_inhibit_implied_resize)))))
- f->tab_bar_redisplayed = f->tab_bar_resized = false;
-
- adjust_frame_size (f, -1, -1,
- ((!f->tab_bar_resized
- && (NILP (fullscreen =
- get_frame_param (f, Qfullscreen))
- || EQ (fullscreen, Qfullwidth))) ? 1
- : (old_height == 0 || height == 0) ? 2
- : 4),
- false, Qtab_bar_lines);
-
- f->tab_bar_resized = f->tab_bar_redisplayed;
+ if (!f->tab_bar_resized)
+ {
+ /* As long as tab_bar_resized is false, effectively try to change
+ F's native height. */
+ if (NILP (fullscreen) || EQ (fullscreen, Qfullwidth))
+ adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f),
+ 1, false, Qtab_bar_lines);
+ else
+ adjust_frame_size (f, -1, -1, 4, false, Qtab_bar_lines);
+
+ f->tab_bar_resized = f->tab_bar_redisplayed;
+ }
+ else
+ /* Any other change may leave the native size of F alone. */
+ adjust_frame_size (f, -1, -1, 3, false, Qtab_bar_lines);
/* adjust_frame_size might not have done anything, garbage frame
here. */
@@ -1790,7 +1786,7 @@ w32_change_tool_bar_height (struct frame *f, int height)
int unit = FRAME_LINE_HEIGHT (f);
int old_height = FRAME_TOOL_BAR_HEIGHT (f);
int lines = (height + unit - 1) / unit;
- Lisp_Object fullscreen;
+ Lisp_Object fullscreen = get_frame_param (f, Qfullscreen);
/* Make sure we redisplay all windows in this frame. */
windows_or_buffers_changed = 23;
@@ -1811,25 +1807,21 @@ w32_change_tool_bar_height (struct frame *f, int height)
if ((height < old_height) && WINDOWP (f->tool_bar_window))
clear_glyph_matrix (XWINDOW (f->tool_bar_window)->current_matrix);
- /* Recalculate toolbar height. */
- f->n_tool_bar_rows = 0;
- if (old_height == 0
- && (!f->after_make_frame
- || NILP (frame_inhibit_implied_resize)
- || (CONSP (frame_inhibit_implied_resize)
- && NILP (Fmemq (Qtool_bar_lines, frame_inhibit_implied_resize)))))
- f->tool_bar_redisplayed = f->tool_bar_resized = false;
-
- adjust_frame_size (f, -1, -1,
- ((!f->tool_bar_resized
- && (NILP (fullscreen =
- get_frame_param (f, Qfullscreen))
- || EQ (fullscreen, Qfullwidth))) ? 1
- : (old_height == 0 || height == 0) ? 2
- : 4),
- false, Qtool_bar_lines);
-
- f->tool_bar_resized = f->tool_bar_redisplayed;
+ if (!f->tool_bar_resized)
+ {
+ /* As long as tool_bar_resized is false, effectively try to change
+ F's native height. */
+ if (NILP (fullscreen) || EQ (fullscreen, Qfullwidth))
+ adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f),
+ 1, false, Qtool_bar_lines);
+ else
+ adjust_frame_size (f, -1, -1, 4, false, Qtool_bar_lines);
+
+ f->tool_bar_resized = f->tool_bar_redisplayed;
+ }
+ else
+ /* Any other change may leave the native size of F alone. */
+ adjust_frame_size (f, -1, -1, 3, false, Qtool_bar_lines);
/* adjust_frame_size might not have done anything, garbage frame
here. */
@@ -5718,7 +5710,6 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame,
struct w32_display_info *dpyinfo = NULL;
Lisp_Object parent, parent_frame;
struct kboard *kb;
- int x_width = 0, x_height = 0;
if (!FRAME_W32_P (SELECTED_FRAME ())
&& !FRAME_INITIAL_P (SELECTED_FRAME ()))
@@ -6045,8 +6036,7 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame,
f->output_data.w32->current_cursor = f->output_data.w32->nontext_cursor;
- window_prompting = gui_figure_window_size (f, parameters, true, true,
- &x_width, &x_height);
+ window_prompting = gui_figure_window_size (f, parameters, true, true);
tem = gui_display_get_arg (dpyinfo, parameters, Qunsplittable, 0, 0,
RES_TYPE_BOOLEAN);
@@ -6081,11 +6071,6 @@ DEFUN ("x-create-frame", Fx_create_frame,
Sx_create_frame,
/* Allow set_window_size_hook, now. */
f->can_set_window_size = true;
- if (x_width > 0)
- SET_FRAME_WIDTH (f, x_width);
- if (x_height > 0)
- SET_FRAME_HEIGHT (f, x_height);
-
/* Tell the server what size and position, etc, we want, and how
badly we want them. This should be done after we have the menu
bar so that its size can be taken into account. */
@@ -6093,8 +6078,8 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame,
w32_wm_set_size_hint (f, window_prompting, false);
unblock_input ();
- adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), 0, true,
- Qx_create_frame_2);
+ adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f),
+ 0, true, Qx_create_frame_2);
/* Process fullscreen parameter here in the hope that normalizing a
fullheight/fullwidth frame will produce the size set by the last
@@ -6888,11 +6873,9 @@ w32_create_tip_frame (struct w32_display_info *dpyinfo,
Lisp_Object parms)
struct frame *f;
Lisp_Object frame;
Lisp_Object name;
- int width, height;
ptrdiff_t count = SPECPDL_INDEX ();
struct kboard *kb;
bool face_change_before = face_change;
- int x_width = 0, x_height = 0;
/* Use this general default value to start with until we know if
this frame has a specified name. */
@@ -7013,7 +6996,7 @@ w32_create_tip_frame (struct w32_display_info *dpyinfo,
Lisp_Object parms)
f->output_data.w32->parent_desc = FRAME_DISPLAY_INFO (f)->root_window;
f->output_data.w32->explicit_parent = false;
- gui_figure_window_size (f, parms, true, true, &x_width, &x_height);
+ gui_figure_window_size (f, parms, true, true);
/* No fringes on tip frame. */
f->fringe_cols = 0;
@@ -7039,15 +7022,6 @@ w32_create_tip_frame (struct w32_display_info *dpyinfo,
Lisp_Object parms)
gui_default_parameter (f, parms, Qalpha, Qnil,
"alpha", "Alpha", RES_TYPE_NUMBER);
- /* Dimensions, especially FRAME_LINES (f), must be done via
- change_frame_size. Change will not be effected unless different
- from the current FRAME_LINES (f). */
- width = FRAME_COLS (f);
- height = FRAME_LINES (f);
- SET_FRAME_COLS (f, 0);
- SET_FRAME_LINES (f, 0);
- adjust_frame_size (f, width * FRAME_COLUMN_WIDTH (f),
- height * FRAME_LINE_HEIGHT (f), 0, true, Qtip_frame);
/* Add `tooltip' frame parameter's default value. */
if (NILP (Fframe_parameter (frame, Qtooltip)))
Fmodify_frame_parameters (frame, Fcons (Fcons (Qtooltip, Qt), Qnil));
@@ -7088,6 +7062,8 @@ w32_create_tip_frame (struct w32_display_info *dpyinfo,
Lisp_Object parms)
visible won't work. */
Vframe_list = Fcons (frame, Vframe_list);
f->can_set_window_size = true;
+ adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f),
+ 0, true, Qtip_frame);
/* Setting attributes of faces of the tooltip frame from resources
and similar will set face_change, which leads to the
@@ -7434,6 +7410,8 @@ DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0,
set_window_buffer (window, tip_buf, false, false);
w = XWINDOW (window);
w->pseudo_window_p = true;
+ /* Try to avoid that `other-window' select us (Bug#47207). */
+ Fset_window_parameter (window, Qno_other_window, Qt);
/* Set up the frame's root window. Note: The following code does not
try to size the window or its frame correctly. Its only purpose is
diff --git a/src/w32inevt.c b/src/w32inevt.c
index 1a80a00..1255072 100644
--- a/src/w32inevt.c
+++ b/src/w32inevt.c
@@ -608,9 +608,7 @@ resize_event (WINDOW_BUFFER_SIZE_RECORD *event)
{
struct frame *f = get_frame ();
- change_frame_size (f, event->dwSize.X, event->dwSize.Y
- - FRAME_MENU_BAR_LINES (f)
- - FRAME_TAB_BAR_LINES (f), 0, 1, 0, 0);
+ change_frame_size (f, event->dwSize.X, event->dwSize.Y, false, true, false);
SET_FRAME_GARBAGED (f);
}
@@ -624,11 +622,9 @@ maybe_generate_resize_event (void)
/* It is okay to call this unconditionally, since it will do nothing
if the size hasn't actually changed. */
- change_frame_size (f,
- 1 + info.srWindow.Right - info.srWindow.Left,
- 1 + info.srWindow.Bottom - info.srWindow.Top
- - FRAME_MENU_BAR_LINES (f)
- - FRAME_TAB_BAR_LINES (f), 0, 1, 0, 0);
+ change_frame_size (f, 1 + info.srWindow.Right - info.srWindow.Left,
+ 1 + info.srWindow.Bottom - info.srWindow.Top,
+ false, true, false);
}
#if HAVE_W32NOTIFY
diff --git a/src/w32proc.c b/src/w32proc.c
index 2b6cb9c..ffa56e1 100644
--- a/src/w32proc.c
+++ b/src/w32proc.c
@@ -1918,7 +1918,8 @@ sys_spawnve (int mode, char *cmdname, char **argv, char
**envp)
{
program = build_string (cmdname);
full = Qnil;
- openp (Vexec_path, program, Vexec_suffixes, &full, make_fixnum (X_OK),
0);
+ openp (Vexec_path, program, Vexec_suffixes, &full, make_fixnum (X_OK),
+ 0, 0);
if (NILP (full))
{
errno = EINVAL;
@@ -3877,6 +3878,14 @@ w32_compare_strings (const char *s1, const char *s2,
char *locname,
return val - 2;
}
+DEFUN ("w32-get-nproc", Fw32_get_nproc,
+ Sw32_get_nproc, 0, 0, 0,
+ doc: /* Return the number of system's processor execution units. */)
+ (void)
+{
+ return make_fixnum (w32_get_nproc ());
+}
+
void
syms_of_ntproc (void)
@@ -3911,6 +3920,8 @@ syms_of_ntproc (void)
defsubr (&Sw32_get_keyboard_layout);
defsubr (&Sw32_set_keyboard_layout);
+ defsubr (&Sw32_get_nproc);
+
DEFVAR_LISP ("w32-quote-process-args", Vw32_quote_process_args,
doc: /* Non-nil enables quoting of process arguments to ensure
correct parsing.
Because Windows does not directly pass argv arrays to child processes,
diff --git a/src/w32term.c b/src/w32term.c
index 0ee805a..4f91029 100644
--- a/src/w32term.c
+++ b/src/w32term.c
@@ -2031,8 +2031,11 @@ w32_draw_image_relief (struct glyph_string *s)
if (s->hl == DRAW_IMAGE_SUNKEN
|| s->hl == DRAW_IMAGE_RAISED)
{
- thick = tool_bar_button_relief >= 0 ? tool_bar_button_relief
- : DEFAULT_TOOL_BAR_BUTTON_RELIEF;
+ thick = (tab_bar_button_relief < 0
+ ? DEFAULT_TAB_BAR_BUTTON_RELIEF
+ : (tool_bar_button_relief < 0
+ ? DEFAULT_TOOL_BAR_BUTTON_RELIEF
+ : min (tool_bar_button_relief, 1000000)));
raised_p = s->hl == DRAW_IMAGE_RAISED;
}
else
@@ -2045,6 +2048,19 @@ w32_draw_image_relief (struct glyph_string *s)
y1 = y + s->slice.height - 1;
extra_x = extra_y = 0;
+ if (s->face->id == TAB_BAR_FACE_ID)
+ {
+ if (CONSP (Vtab_bar_button_margin)
+ && FIXNUMP (XCAR (Vtab_bar_button_margin))
+ && FIXNUMP (XCDR (Vtab_bar_button_margin)))
+ {
+ extra_x = XFIXNUM (XCAR (Vtab_bar_button_margin));
+ extra_y = XFIXNUM (XCDR (Vtab_bar_button_margin));
+ }
+ else if (FIXNUMP (Vtab_bar_button_margin))
+ extra_x = extra_y = XFIXNUM (Vtab_bar_button_margin);
+ }
+
if (s->face->id == TOOL_BAR_FACE_ID)
{
if (CONSP (Vtool_bar_button_margin)
@@ -5336,7 +5352,7 @@ w32_read_socket (struct terminal *terminal,
if (f)
{
RECT rect;
- int /* rows, columns, */ width, height, text_width, text_height;
+ int /* rows, columns, */ width, height;
if (GetClientRect (msg.msg.hwnd, &rect)
/* GetClientRect evidently returns (0, 0, 0, 0) if
@@ -5349,23 +5365,11 @@ w32_read_socket (struct terminal *terminal,
{
height = rect.bottom - rect.top;
width = rect.right - rect.left;
- text_width = FRAME_PIXEL_TO_TEXT_WIDTH (f, width);
- text_height = FRAME_PIXEL_TO_TEXT_HEIGHT (f, height);
- /* rows = FRAME_PIXEL_HEIGHT_TO_TEXT_LINES (f, height); */
- /* columns = FRAME_PIXEL_WIDTH_TO_TEXT_COLS (f, width); */
-
- /* TODO: Clip size to the screen dimensions. */
-
- /* Even if the number of character rows and columns
- has not changed, the font size may have changed,
- so we need to check the pixel dimensions as well. */
-
if (width != FRAME_PIXEL_WIDTH (f)
- || height != FRAME_PIXEL_HEIGHT (f)
- || text_width != FRAME_TEXT_WIDTH (f)
- || text_height != FRAME_TEXT_HEIGHT (f))
+ || height != FRAME_PIXEL_HEIGHT (f))
{
- change_frame_size (f, text_width, text_height, 0, 1, 0,
1);
+ change_frame_size
+ (f, width, height, false, true, false);
SET_FRAME_GARBAGED (f);
cancel_mouse_face (f);
f->win_gravity = NorthWestGravity;
@@ -5549,7 +5553,7 @@ w32_read_socket (struct terminal *terminal,
if (f && !FRAME_ICONIFIED_P (f) && msg.msg.wParam != SIZE_MINIMIZED)
{
RECT rect;
- int /* rows, columns, */ width, height, text_width, text_height;
+ int /* rows, columns, */ width, height;
if (GetClientRect (msg.msg.hwnd, &rect)
/* GetClientRect evidently returns (0, 0, 0, 0) if
@@ -5562,23 +5566,12 @@ w32_read_socket (struct terminal *terminal,
{
height = rect.bottom - rect.top;
width = rect.right - rect.left;
- text_width = FRAME_PIXEL_TO_TEXT_WIDTH (f, width);
- text_height = FRAME_PIXEL_TO_TEXT_HEIGHT (f, height);
- /* rows = FRAME_PIXEL_HEIGHT_TO_TEXT_LINES (f, height); */
- /* columns = FRAME_PIXEL_WIDTH_TO_TEXT_COLS (f, width); */
-
- /* TODO: Clip size to the screen dimensions. */
-
- /* Even if the number of character rows and columns
- has not changed, the font size may have changed,
- so we need to check the pixel dimensions as well. */
if (width != FRAME_PIXEL_WIDTH (f)
- || height != FRAME_PIXEL_HEIGHT (f)
- || text_width != FRAME_TEXT_WIDTH (f)
- || text_height != FRAME_TEXT_HEIGHT (f))
+ || height != FRAME_PIXEL_HEIGHT (f))
{
- change_frame_size (f, text_width, text_height, 0, 1, 0,
1);
+ change_frame_size
+ (f, width, height, false, true, false);
SET_FRAME_GARBAGED (f);
cancel_mouse_face (f);
f->win_gravity = NorthWestGravity;
@@ -6251,17 +6244,15 @@ w32_new_font (struct frame *f, Lisp_Object font_object,
int fontset)
FRAME_CONFIG_SCROLL_BAR_COLS (f) * unit;
}
- /* Now make the frame display the given font. */
- if (FRAME_NATIVE_WINDOW (f) != 0)
- {
- /* 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 (!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);
- }
+ FRAME_TAB_BAR_HEIGHT (f) = FRAME_TAB_BAR_LINES (f) * FRAME_LINE_HEIGHT (f);
+
+/* 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 (FRAME_NATIVE_WINDOW (f) != 0 && !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);
/* X version sets font of input methods here also. */
@@ -6474,7 +6465,8 @@ w32fullscreen_hook (struct frame *f)
ShowWindow (hwnd, SW_SHOWNORMAL);
else if (f->want_fullscreen == FULLSCREEN_MAXIMIZED)
{
- if (prev_fsmode == FULLSCREEN_BOTH || prev_fsmode == FULLSCREEN_WIDTH
+ if (prev_fsmode == FULLSCREEN_BOTH
+ || prev_fsmode == FULLSCREEN_WIDTH
|| prev_fsmode == FULLSCREEN_HEIGHT)
/* Make window normal since otherwise the subsequent
maximization might fail in some cases. */
@@ -6483,52 +6475,31 @@ w32fullscreen_hook (struct frame *f)
}
else if (f->want_fullscreen == FULLSCREEN_BOTH)
{
- int menu_bar_height = GetSystemMetrics (SM_CYMENU);
-
- w32_fullscreen_rect (hwnd, f->want_fullscreen,
- FRAME_NORMAL_PLACEMENT (f).rcNormalPosition,
&rect);
+ w32_fullscreen_rect
+ (hwnd, f->want_fullscreen,
+ FRAME_NORMAL_PLACEMENT (f).rcNormalPosition, &rect);
if (!FRAME_UNDECORATED (f))
SetWindowLong (hwnd, GWL_STYLE, dwStyle & ~WS_OVERLAPPEDWINDOW);
SetWindowPos (hwnd, HWND_TOP, rect.left, rect.top,
rect.right - rect.left, rect.bottom - rect.top,
SWP_NOOWNERZORDER | SWP_FRAMECHANGED);
change_frame_size
- (f, FRAME_PIXEL_TO_TEXT_WIDTH (f, rect.right - rect.left),
- FRAME_PIXEL_TO_TEXT_HEIGHT (f, (rect.bottom - rect.top
- - menu_bar_height)),
- 0, 1, 0, 1);
+ (f, rect.right - rect.left, rect.bottom - rect.top,
+ false, true, false);
}
else
{
ShowWindow (hwnd, SW_SHOWNORMAL);
- w32_fullscreen_rect (hwnd, f->want_fullscreen,
- FRAME_NORMAL_PLACEMENT (f).rcNormalPosition,
&rect);
+ w32_fullscreen_rect
+ (hwnd, f->want_fullscreen,
+ FRAME_NORMAL_PLACEMENT (f).rcNormalPosition, &rect);
SetWindowPos (hwnd, HWND_TOP, rect.left, rect.top,
rect.right - rect.left, rect.bottom - rect.top, 0);
- if (f->want_fullscreen == FULLSCREEN_WIDTH)
- {
- int border_width = GetSystemMetrics (SM_CXFRAME);
-
- change_frame_size
- (f, (FRAME_PIXEL_TO_TEXT_WIDTH
- (f, rect.right - rect.left - 2 * border_width)),
- 0, 0, 1, 0, 1);
- }
- else
- {
- int border_height = GetSystemMetrics (SM_CYFRAME);
- /* Won't work for wrapped menu bar. */
- int menu_bar_height = GetSystemMetrics (SM_CYMENU);
- int title_height = GetSystemMetrics (SM_CYCAPTION);
-
- change_frame_size
- (f, 0, (FRAME_PIXEL_TO_TEXT_HEIGHT
- (f, rect.bottom - rect.top - 2 * border_height
- - title_height - menu_bar_height)),
- 0, 1, 0, 1);
- }
- }
+ change_frame_size
+ (f, rect.right - rect.left, rect.bottom - rect.top,
+ false, true, false);
+ }
f->want_fullscreen = FULLSCREEN_NONE;
unblock_input ();
@@ -6543,16 +6514,14 @@ w32fullscreen_hook (struct frame *f)
f->want_fullscreen |= FULLSCREEN_WAIT;
}
-/* Call this to change the size of frame F's native window.
- If CHANGE_GRAVITY, change to top-left-corner window gravity
- for this size change and subsequent size changes.
- Otherwise we leave the window gravity unchanged. */
-
+/* Change the size of frame F's Windows window to WIDTH and HEIGHT
+ pixels. If CHANGE_GRAVITY, change to top-left-corner window gravity
+ for this size change and subsequent size changes. Otherwise leave
+ the window gravity unchanged. */
static void
w32_set_window_size (struct frame *f, bool change_gravity,
- int width, int height, bool pixelwise)
+ int width, int height)
{
- int pixelwidth, pixelheight;
Lisp_Object fullscreen = get_frame_param (f, Qfullscreen);
RECT rect;
MENUBARINFO info;
@@ -6568,17 +6537,6 @@ w32_set_window_size (struct frame *f, bool
change_gravity,
GetMenuBarInfo (FRAME_W32_WINDOW (f), 0xFFFFFFFD, 0, &info);
menu_bar_height = info.rcBar.bottom - info.rcBar.top;
- if (pixelwise)
- {
- pixelwidth = FRAME_TEXT_TO_PIXEL_WIDTH (f, width);
- pixelheight = FRAME_TEXT_TO_PIXEL_HEIGHT (f, height);
- }
- else
- {
- pixelwidth = FRAME_TEXT_COLS_TO_PIXEL_WIDTH (f, width);
- pixelheight = FRAME_TEXT_LINES_TO_PIXEL_HEIGHT (f, height);
- }
-
if (w32_add_wrapped_menu_bar_lines)
{
/* When the menu bar wraps sending a SetWindowPos shrinks the
@@ -6594,15 +6552,15 @@ w32_set_window_size (struct frame *f, bool
change_gravity,
if ((default_menu_bar_height > 0)
&& (menu_bar_height > default_menu_bar_height)
&& ((menu_bar_height % default_menu_bar_height) == 0))
- pixelheight = pixelheight + menu_bar_height - default_menu_bar_height;
+ height = height + menu_bar_height - default_menu_bar_height;
}
f->win_gravity = NorthWestGravity;
w32_wm_set_size_hint (f, (long) 0, false);
rect.left = rect.top = 0;
- rect.right = pixelwidth;
- rect.bottom = pixelheight;
+ rect.right = width;
+ rect.bottom = height;
AdjustWindowRect (&rect, f->output_data.w32->dwStyle, menu_bar_height > 0);
@@ -6620,7 +6578,7 @@ w32_set_window_size (struct frame *f, bool change_gravity,
{
rect.left = window_rect.left;
rect.right = window_rect.right;
- pixelwidth = 0;
+ width = -1;
}
if (EQ (fullscreen, Qmaximized)
|| EQ (fullscreen, Qfullboth)
@@ -6628,19 +6586,12 @@ w32_set_window_size (struct frame *f, bool
change_gravity,
{
rect.top = window_rect.top;
rect.bottom = window_rect.bottom;
- pixelheight = 0;
+ height = -1;
}
}
- if (pixelwidth > 0 || pixelheight > 0)
+ if (width > 0 || height > 0)
{
- frame_size_history_add
- (f, Qx_set_window_size_1, width, height,
- 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,
0, 0,
@@ -6654,12 +6605,7 @@ w32_set_window_size (struct frame *f, bool
change_gravity,
rect.bottom - rect.top,
SWP_NOMOVE | SWP_NOACTIVATE);
- change_frame_size (f,
- ((pixelwidth == 0)
- ? 0 : FRAME_PIXEL_TO_TEXT_WIDTH (f, pixelwidth)),
- ((pixelheight == 0)
- ? 0 : FRAME_PIXEL_TO_TEXT_HEIGHT (f, pixelheight)),
- 0, 1, 0, 1);
+ change_frame_size (f, width, height, false, true, false);
SET_FRAME_GARBAGED (f);
/* If cursor was outside the new size, mark it as off. */
diff --git a/src/widget.c b/src/widget.c
index 43f0307..dd43fd1 100644
--- a/src/widget.c
+++ b/src/widget.c
@@ -169,14 +169,6 @@ pixel_to_char_size (EmacsFrame ew, Dimension pixel_width,
Dimension pixel_height
}
static void
-pixel_to_text_size (EmacsFrame ew, Dimension pixel_width, Dimension
pixel_height, int *text_width, int *text_height)
-{
- struct frame *f = ew->emacs_frame.frame;
- *text_width = FRAME_PIXEL_TO_TEXT_WIDTH (f, (int) pixel_width);
- *text_height = FRAME_PIXEL_TO_TEXT_HEIGHT (f, (int) pixel_height);
-}
-
-static void
char_to_pixel_size (EmacsFrame ew, int char_width, int char_height, Dimension
*pixel_width, Dimension *pixel_height)
{
struct frame *f = ew->emacs_frame.frame;
@@ -257,27 +249,14 @@ set_frame_size (EmacsFrame ew)
*/
- /* Hairily merged geometry */
struct frame *f = ew->emacs_frame.frame;
- int w = FRAME_COLS (f);
- int h = FRAME_LINES (f);
- Widget wmshell = get_wm_shell ((Widget) ew);
- Dimension pixel_width, pixel_height;
- /* Each Emacs shell is now independent and top-level. */
-
- if (! XtIsSubclass (wmshell, shellWidgetClass)) emacs_abort ();
-
- char_to_pixel_size (ew, w, h, &pixel_width, &pixel_height);
- ew->core.width = (frame_resize_pixelwise
- ? FRAME_PIXEL_WIDTH (f)
- : pixel_width);
- ew->core.height = (frame_resize_pixelwise
- ? FRAME_PIXEL_HEIGHT (f)
- : pixel_height);
-
- frame_size_history_add
- (f, Qset_frame_size, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f),
- list2i (ew->core.width, ew->core.height));
+
+ ew->core.width = FRAME_PIXEL_WIDTH (f);
+ ew->core.height = FRAME_PIXEL_HEIGHT (f);
+
+ if (CONSP (frame_size_history))
+ frame_size_history_plain
+ (f, build_string ("set_frame_size"));
}
static void
@@ -350,6 +329,13 @@ update_from_various_frame_slots (EmacsFrame ew)
ew->emacs_frame.foreground_pixel = FRAME_FOREGROUND_PIXEL (f);
ew->emacs_frame.cursor_color = x->cursor_pixel;
ew->core.border_pixel = x->border_pixel;
+
+ if (CONSP (frame_size_history))
+ frame_size_history_extra
+ (f, build_string ("update_from_various_frame_slots"),
+ FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f),
+ ew->core.width, ew->core.height,
+ f->new_width, f->new_height);
}
static void
@@ -381,6 +367,7 @@ static void
EmacsFrameRealize (Widget widget, XtValueMask *mask, XSetWindowAttributes
*attrs)
{
EmacsFrame ew = (EmacsFrame) widget;
+ struct frame *f = ew->emacs_frame.frame;
/* This used to contain SubstructureRedirectMask, but this turns out
to be a problem with XIM on Solaris, and events from that mask
@@ -394,6 +381,11 @@ EmacsFrameRealize (Widget widget, XtValueMask *mask,
XSetWindowAttributes *attrs
/* Some ConfigureNotify events does not end up in EmacsFrameResize so
make sure we get them all. Seen with xfcwm4 for example. */
XtAddRawEventHandler (widget, StructureNotifyMask, False, resize_cb, NULL);
+
+ if (CONSP (frame_size_history))
+ frame_size_history_plain
+ (f, build_string ("EmacsFrameRealize"));
+
update_wm_hints (ew);
}
@@ -408,18 +400,15 @@ EmacsFrameResize (Widget widget)
{
EmacsFrame ew = (EmacsFrame) widget;
struct frame *f = ew->emacs_frame.frame;
- int width, height;
-
- pixel_to_text_size (ew, ew->core.width, ew->core.height, &width, &height);
- frame_size_history_add
- (f, QEmacsFrameResize, width, height,
- 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))));
+ if (CONSP (frame_size_history))
+ frame_size_history_extra
+ (f, build_string ("EmacsFrameResize"),
+ FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f),
+ ew->core.width, ew->core.height,
+ f->new_width, f->new_height);
- change_frame_size (f, width, height, 0, 1, 0, 1);
+ change_frame_size (f, ew->core.width, ew->core.height, false, true, false);
update_wm_hints (ew);
update_various_frame_slots (ew);
@@ -463,9 +452,17 @@ EmacsFrameSetCharSize (Widget widget, int columns, int
rows)
EmacsFrame ew = (EmacsFrame) widget;
struct frame *f = ew->emacs_frame.frame;
+ if (CONSP (frame_size_history))
+ frame_size_history_extra
+ (f, build_string ("EmacsFrameSetCharSize"),
+ FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f),
+ columns, rows,
+ f->new_width, f->new_height);
+
if (!frame_inhibit_resize (f, 0, Qfont)
&& !frame_inhibit_resize (f, 1, Qfont))
- x_set_window_size (f, 0, columns, rows, 0);
+ x_set_window_size (f, 0, columns * FRAME_COLUMN_WIDTH (f),
+ rows * FRAME_LINE_HEIGHT (f));
}
diff --git a/src/window.c b/src/window.c
index 4d5c7e7..0a14eca 100644
--- a/src/window.c
+++ b/src/window.c
@@ -215,20 +215,6 @@ wset_combination (struct window *w, bool horflag,
Lisp_Object val)
w->horizontal = horflag;
}
-static void
-wset_update_mode_line (struct window *w)
-{
- /* If this window is the selected window on its frame, set the
- global variable update_mode_lines, so that gui_consider_frame_title
- will consider this frame's title for redisplay. */
- Lisp_Object fselected_window = XFRAME (WINDOW_FRAME (w))->selected_window;
-
- if (WINDOWP (fselected_window) && XWINDOW (fselected_window) == w)
- update_mode_lines = 42;
- else
- w->update_mode_line = true;
-}
-
/* True if leaf window W doesn't reflect the actual state
of displayed buffer due to its text or overlays change. */
@@ -518,10 +504,18 @@ select_window (Lisp_Object window, Lisp_Object norecord,
{
struct window *w;
struct frame *sf;
+ Lisp_Object frame;
+ struct frame *f;
CHECK_LIVE_WINDOW (window);
w = XWINDOW (window);
+ frame = WINDOW_FRAME (w);
+ f = XFRAME (frame);
+
+ if (FRAME_TOOLTIP_P (f))
+ /* Do not select a tooltip window (Bug#47207). */
+ error ("Cannot select a tooltip window");
/* Make the selected window's buffer current. */
Fset_buffer (w->contents);
@@ -542,14 +536,14 @@ select_window (Lisp_Object window, Lisp_Object norecord,
redisplay_other_windows ();
sf = SELECTED_FRAME ();
- if (XFRAME (WINDOW_FRAME (w)) != sf)
+ if (f != sf)
{
- fset_selected_window (XFRAME (WINDOW_FRAME (w)), window);
+ fset_selected_window (f, window);
/* Use this rather than Fhandle_switch_frame
so that FRAME_FOCUS_FRAME is moved appropriately as we
move around in the state where a minibuffer in a separate
frame is active. */
- Fselect_frame (WINDOW_FRAME (w), norecord);
+ Fselect_frame (frame, norecord);
/* Fselect_frame called us back so we've done all the work already. */
eassert (EQ (window, selected_window));
return window;
@@ -2556,8 +2550,13 @@ window_list (void)
if (!CONSP (Vwindow_list))
{
Lisp_Object tail, frame;
+ ptrdiff_t count = SPECPDL_INDEX ();
Vwindow_list = Qnil;
+ /* Don't allow quitting in Fnconc. Otherwise we might end up
+ with a too short Vwindow_list and Fkill_buffer not being able
+ to replace a buffer in all windows showing it (Bug#47244). */
+ specbind (Qinhibit_quit, Qt);
FOR_EACH_FRAME (tail, frame)
{
Lisp_Object arglist = Qnil;
@@ -2569,6 +2568,8 @@ window_list (void)
arglist = Fnreverse (arglist);
Vwindow_list = nconc2 (Vwindow_list, arglist);
}
+
+ unbind_to (count, Qnil);
}
return Vwindow_list;
@@ -2603,7 +2604,7 @@ candidate_window_p (Lisp_Object window, Lisp_Object
owindow,
candidate_p = false;
else if (MINI_WINDOW_P (w)
&& (EQ (minibuf, Qlambda)
- || (WINDOWP (minibuf) && !EQ (minibuf, window))))
+ || (WINDOW_LIVE_P (minibuf) && !EQ (minibuf, window))))
{
/* If MINIBUF is `lambda' don't consider any mini-windows.
If it is a window, consider only that one. */
@@ -2647,7 +2648,8 @@ candidate_window_p (Lisp_Object window, Lisp_Object
owindow,
candidate_p = ((EQ (XWINDOW (all_frames)->frame, w->frame)
|| (EQ (f->minibuffer_window, all_frames)
&& EQ (XWINDOW (all_frames)->frame, FRAME_FOCUS_FRAME
(f))))
- && !is_minibuffer (0, XWINDOW (all_frames)->contents));
+ && (EQ (minibuf, Qt)
+ || !is_minibuffer (0, XWINDOW (all_frames)->contents)));
else if (FRAMEP (all_frames))
candidate_p = EQ (all_frames, w->frame);
@@ -2666,12 +2668,12 @@ decode_next_window_args (Lisp_Object *window,
Lisp_Object *minibuf, Lisp_Object
Lisp_Object miniwin = XFRAME (w->frame)->minibuffer_window;
XSETWINDOW (*window, w);
- /* MINIBUF nil may or may not include minibuffers. Decide if it
- does. */
- if (NILP (*minibuf))
- *minibuf = this_minibuffer_depth (XWINDOW (miniwin)->contents)
- ? miniwin
- : Qlambda;
+ /* MINIBUF nil may or may not include minibuffer windows. Decide if
+ it does. But first make sure that this frame's minibuffer window
+ is live (Bug#47207). */
+ if (WINDOW_LIVE_P (miniwin) && NILP (*minibuf))
+ *minibuf = (this_minibuffer_depth (XWINDOW (miniwin)->contents)
+ ? miniwin : Qlambda);
else if (!EQ (*minibuf, Qt))
*minibuf = Qlambda;
@@ -2682,9 +2684,10 @@ decode_next_window_args (Lisp_Object *window,
Lisp_Object *minibuf, Lisp_Object
/* ALL_FRAMES nil doesn't specify which frames to include. */
if (NILP (*all_frames))
*all_frames
- = (!EQ (*minibuf, Qlambda)
- ? FRAME_MINIBUF_WINDOW (XFRAME (w->frame))
- : Qnil);
+ /* Once more make sure that this frame's minibuffer window is live
+ before including it (Bug#47207). */
+ = ((WINDOW_LIVE_P (miniwin) && !EQ (*minibuf, Qlambda))
+ ? miniwin : Qnil);
else if (EQ (*all_frames, Qvisible))
;
else if (EQ (*all_frames, make_fixnum (0)))
@@ -2705,6 +2708,8 @@ static Lisp_Object
next_window (Lisp_Object window, Lisp_Object minibuf, Lisp_Object all_frames,
bool next_p)
{
+ ptrdiff_t count = SPECPDL_INDEX ();
+
decode_next_window_args (&window, &minibuf, &all_frames);
/* If ALL_FRAMES is a frame, and WINDOW isn't on that frame, just
@@ -2713,6 +2718,9 @@ next_window (Lisp_Object window, Lisp_Object minibuf,
Lisp_Object all_frames,
&& !EQ (all_frames, XWINDOW (window)->frame))
return Fframe_first_window (all_frames);
+ /* Don't allow quitting in Fmemq. */
+ specbind (Qinhibit_quit, Qt);
+
if (next_p)
{
Lisp_Object list;
@@ -2762,6 +2770,8 @@ next_window (Lisp_Object window, Lisp_Object minibuf,
Lisp_Object all_frames,
window = candidate;
}
+ unbind_to (count, Qnil);
+
return window;
}
@@ -2852,10 +2862,14 @@ static Lisp_Object
window_list_1 (Lisp_Object window, Lisp_Object minibuf, Lisp_Object all_frames)
{
Lisp_Object tail, list, rest;
+ ptrdiff_t count = SPECPDL_INDEX ();
decode_next_window_args (&window, &minibuf, &all_frames);
list = Qnil;
+ /* Don't allow quitting in Fmemq and Fnconc. */
+ specbind (Qinhibit_quit, Qt);
+
for (tail = window_list (); CONSP (tail); tail = XCDR (tail))
if (candidate_window_p (XCAR (tail), window, minibuf, all_frames))
list = Fcons (XCAR (tail), list);
@@ -2870,6 +2884,9 @@ window_list_1 (Lisp_Object window, Lisp_Object minibuf,
Lisp_Object all_frames)
XSETCDR (tail, Qnil);
list = nconc2 (rest, list);
}
+
+ unbind_to (count, Qnil);
+
return list;
}
@@ -6864,19 +6881,22 @@ DEFUN ("window-configuration-frame",
Fwindow_configuration_frame, Swindow_config
}
DEFUN ("set-window-configuration", Fset_window_configuration,
- Sset_window_configuration, 1, 2, 0,
+ Sset_window_configuration, 1, 3, 0,
doc: /* Set the configuration of windows and buffers as specified by
CONFIGURATION.
CONFIGURATION must be a value previously returned
by `current-window-configuration' (which see).
Normally, this function selects the frame of the CONFIGURATION, but if
DONT-SET-FRAME is non-nil, it leaves selected the frame which was
-current at the start of the function.
+current at the start of the function. If DONT-SET-MINIWINDOW is non-nil,
+the mini-window of the frame doesn't get set to the corresponding element
+of CONFIGURATION.
If CONFIGURATION was made from a frame that is now deleted,
only frame-independent values can be restored. In this case,
the return value is nil. Otherwise the value is t. */)
- (Lisp_Object configuration, Lisp_Object dont_set_frame)
+ (Lisp_Object configuration, Lisp_Object dont_set_frame,
+ Lisp_Object dont_set_miniwindow)
{
register struct save_window_data *data;
struct Lisp_Vector *saved_windows;
@@ -7087,8 +7107,10 @@ the return value is nil. Otherwise the value is t. */)
}
}
- if (BUFFERP (p->buffer) && BUFFER_LIVE_P (XBUFFER (p->buffer)))
- /* If saved buffer is alive, install it. */
+ if ((NILP (dont_set_miniwindow) || !MINI_WINDOW_P (w))
+ && BUFFERP (p->buffer) && BUFFER_LIVE_P (XBUFFER (p->buffer)))
+ /* If saved buffer is alive, install it, unless it's a
+ minibuffer we explicitly prohibit. */
{
wset_buffer (w, p->buffer);
w->start_at_line_beg = !NILP (p->start_at_line_beg);
@@ -7241,9 +7263,11 @@ void
restore_window_configuration (Lisp_Object configuration)
{
if (CONSP (configuration))
- Fset_window_configuration (XCDR (configuration), XCAR (configuration));
+ Fset_window_configuration (XCAR (configuration),
+ XCAR (XCDR (configuration)),
+ XCAR (XCDR (XCDR (configuration))));
else
- Fset_window_configuration (configuration, Qnil);
+ Fset_window_configuration (configuration, Qnil, Qnil);
}
@@ -8135,7 +8159,7 @@ init_window_once (void)
minibuf_selected_window = Qnil;
staticpro (&minibuf_selected_window);
- pdumper_do_now_and_after_load (init_window_once_for_pdumper);
+ pdumper_do_now_and_after_late_load (init_window_once_for_pdumper);
}
static void init_window_once_for_pdumper (void)
@@ -8225,6 +8249,7 @@ syms_of_window (void)
DEFSYM (Qmode_line_format, "mode-line-format");
DEFSYM (Qheader_line_format, "header-line-format");
DEFSYM (Qtab_line_format, "tab-line-format");
+ DEFSYM (Qno_other_window, "no-other-window");
DEFVAR_LISP ("temp-buffer-show-function", Vtemp_buffer_show_function,
doc: /* Non-nil means call as function to display a help buffer.
diff --git a/src/window.h b/src/window.h
index b6f88e8..2400c42 100644
--- a/src/window.h
+++ b/src/window.h
@@ -1141,6 +1141,7 @@ extern void wset_redisplay (struct window *w);
extern void fset_redisplay (struct frame *f);
extern void bset_redisplay (struct buffer *b);
extern void bset_update_mode_line (struct buffer *b);
+extern void wset_update_mode_line (struct window *w);
/* Call this to tell redisplay to look for other windows than selected-window
that need to be redisplayed. Calling one of the *set_redisplay functions
above already does it, so it's only needed in unusual cases. */
diff --git a/src/xdisp.c b/src/xdisp.c
index a405d51..23b4ba5 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -869,6 +869,19 @@ bset_update_mode_line (struct buffer *b)
b->text->redisplay = true;
}
+void
+wset_update_mode_line (struct window *w)
+{
+ w->update_mode_line = true;
+ /* When a window's mode line needs to be updated, the window's frame's
+ title may also need to be updated, but we don't need to worry about it
+ here. Instead, `gui_consider_frame_title' is automatically called
+ whenever w->update_mode_line is set for that frame's selected window.
+ But for this to work reliably, we have to make sure the window
+ is considered, so we have to mark it for redisplay. */
+ wset_redisplay (w);
+}
+
DEFUN ("set-buffer-redisplay", Fset_buffer_redisplay,
Sset_buffer_redisplay, 4, 4, 0,
doc: /* Mark the current buffer for redisplay.
@@ -10051,8 +10064,20 @@ move_it_to (struct it *it, ptrdiff_t to_charpos, int
to_x, int to_y, int to_vpos
if ((op & MOVE_TO_POS) != 0
&& (IT_CHARPOS (*it) > to_charpos
|| (IT_CHARPOS (*it) == to_charpos
+ /* Consider TO_CHARPOS as REACHED if we are at
+ EOB that ends in something other than a newline. */
&& to_charpos == ZV
- && (ZV_BYTE <= 1 || FETCH_BYTE (ZV_BYTE - 1) != '\n'))))
+ && (ZV_BYTE <= 1 || FETCH_BYTE (ZV_BYTE - 1) != '\n')
+ /* But if we have a display or an overlay string
+ at EOB, keep going until we exhaust all the
+ characters of the string(s). */
+ && (it->sp == 0
+ || (STRINGP (it->string)
+ && (it->current.overlay_string_index < 0
+ || (it->current.overlay_string_index >= 0
+ && it->current.overlay_string_index
+ >= it->n_overlay_strings - 1))
+ && IT_STRING_CHARPOS (*it) >= it->end_charpos)))))
{
reached = 9;
goto out;
@@ -11835,7 +11860,7 @@ resize_mini_window (struct window *w, bool exact_p)
int height, max_height;
struct text_pos start;
struct buffer *old_current_buffer = NULL;
- int windows_height = FRAME_WINDOWS_HEIGHT (f);
+ int windows_height = FRAME_INNER_HEIGHT (f);
if (current_buffer != XBUFFER (w->contents))
{
@@ -13452,8 +13477,6 @@ PIXELWISE non-nil means return the height of the tab
bar in pixels. */)
static bool
redisplay_tab_bar (struct frame *f)
{
- f->tab_bar_redisplayed = true;
-
struct window *w;
struct it it;
struct glyph_row *row;
@@ -13467,6 +13490,8 @@ redisplay_tab_bar (struct frame *f)
WINDOW_TOTAL_LINES (w) == 0))
return false;
+ f->tab_bar_redisplayed = true;
+
/* Set up an iterator for the tab-bar window. */
init_iterator (&it, w, -1, -1, w->desired_matrix->rows, TAB_BAR_FACE_ID);
it.first_visible_x = 0;
@@ -13607,8 +13632,9 @@ redisplay_tab_bar (struct frame *f)
/* Get information about the tab-bar item which is displayed in GLYPH
on frame F. Return in *PROP_IDX the index where tab-bar item
- properties start in F->tab_bar_items. Value is false if
- GLYPH doesn't display a tab-bar item. */
+ properties start in F->tab_bar_items. Return in CLOSE_P an
+ indication whether the click was on the close-tab icon of the tab.
+ Value is false if GLYPH doesn't display a tab-bar item. */
static bool
tab_bar_item_info (struct frame *f, struct glyph *glyph,
@@ -13654,7 +13680,6 @@ static int
get_tab_bar_item (struct frame *f, int x, int y, struct glyph **glyph,
int *hpos, int *vpos, int *prop_idx, bool *close_p)
{
- Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f);
struct window *w = XWINDOW (f->tab_bar_window);
int area;
@@ -13668,18 +13693,7 @@ get_tab_bar_item (struct frame *f, int x, int y,
struct glyph **glyph,
if (!tab_bar_item_info (f, *glyph, prop_idx, close_p))
return -1;
- /* Is mouse on the highlighted item? */
- if (EQ (f->tab_bar_window, hlinfo->mouse_face_window)
- && *vpos >= hlinfo->mouse_face_beg_row
- && *vpos <= hlinfo->mouse_face_end_row
- && (*vpos > hlinfo->mouse_face_beg_row
- || *hpos >= hlinfo->mouse_face_beg_col)
- && (*vpos < hlinfo->mouse_face_end_row
- || *hpos < hlinfo->mouse_face_end_col
- || hlinfo->mouse_face_past_end))
- return 0;
-
- return 1;
+ return *prop_idx == f->last_tab_bar_item ? 0 : 1;
}
@@ -13701,25 +13715,14 @@ handle_tab_bar_click (struct frame *f, int x, int y,
bool down_p,
Lisp_Object enabled_p;
int ts;
- /* If not on the highlighted tab-bar item, and mouse-highlight is
- non-nil, return. This is so we generate the tab-bar button
- click only when the mouse button is released on the same item as
- where it was pressed. However, when mouse-highlight is disabled,
- generate the click when the button is released regardless of the
- highlight, since tab-bar items are not highlighted in that
- case. */
frame_to_window_pixel_xy (w, &x, &y);
ts = get_tab_bar_item (f, x, y, &glyph, &hpos, &vpos, &prop_idx, &close_p);
if (ts == -1
- || (ts != 0 && !NILP (Vmouse_highlight)))
+ /* If the button is released on a tab other than the one where
+ it was pressed, don't generate the tab-bar button click event. */
+ || (ts != 0 && !down_p))
return;
- /* When mouse-highlight is off, generate the click for the item
- where the button was pressed, disregarding where it was
- released. */
- if (NILP (Vmouse_highlight) && !down_p)
- prop_idx = f->last_tab_bar_item;
-
/* If item is disabled, do nothing. */
enabled_p = AREF (f->tab_bar_items, prop_idx + TAB_BAR_ITEM_ENABLED_P);
if (NILP (enabled_p))
@@ -13727,10 +13730,10 @@ handle_tab_bar_click (struct frame *f, int x, int y,
bool down_p,
if (down_p)
{
- /* Show item in pressed state. */
+ /* Show the clicked button in pressed state. */
if (!NILP (Vmouse_highlight))
show_mouse_face (hlinfo, DRAW_IMAGE_SUNKEN);
- f->last_tab_bar_item = prop_idx;
+ f->last_tab_bar_item = prop_idx; /* record the pressed tab */
}
else
{
@@ -14399,21 +14402,13 @@ PIXELWISE non-nil means return the height of the tool
bar in pixels. */)
return make_fixnum (height);
}
+#ifndef HAVE_EXT_TOOL_BAR
-/* Display the tool-bar of frame F. Value is true if tool-bar's
- height should be changed. */
+/* Display the internal tool-bar of frame F. Value is true if
+ tool-bar's height should be changed. */
static bool
redisplay_tool_bar (struct frame *f)
{
- f->tool_bar_redisplayed = true;
-#ifdef HAVE_EXT_TOOL_BAR
-
- if (FRAME_EXTERNAL_TOOL_BAR (f))
- update_frame_tool_bar (f);
- return false;
-
-#else /* ! (HAVE_EXT_TOOL_BAR) */
-
struct window *w;
struct it it;
struct glyph_row *row;
@@ -14427,6 +14422,8 @@ redisplay_tool_bar (struct frame *f)
WINDOW_TOTAL_LINES (w) == 0))
return false;
+ f->tool_bar_redisplayed = true;
+
/* Set up an iterator for the tool-bar window. */
init_iterator (&it, w, -1, -1, w->desired_matrix->rows, TOOL_BAR_FACE_ID);
it.first_visible_x = 0;
@@ -14562,13 +14559,10 @@ redisplay_tool_bar (struct frame *f)
}
f->minimize_tool_bar_window_p = false;
- return false;
-#endif /* HAVE_EXT_TOOL_BAR */
+ return false;
}
-#ifndef HAVE_EXT_TOOL_BAR
-
/* Get information about the tool-bar item which is displayed in GLYPH
on frame F. Return in *PROP_IDX the index where tool-bar item
properties start in F->tool_bar_items. Value is false if
@@ -19331,7 +19325,7 @@ redisplay_window (Lisp_Object window, bool
just_this_one_p)
#ifdef HAVE_EXT_TOOL_BAR
if (FRAME_EXTERNAL_TOOL_BAR (f))
- redisplay_tool_bar (f);
+ update_frame_tool_bar (f);
#else
if (WINDOWP (f->tool_bar_window)
&& (FRAME_TOOL_BAR_LINES (f) > 0
@@ -31983,6 +31977,11 @@ draw_row_with_mouse_face (struct window *w, int
start_x, struct glyph_row *row,
static void
show_mouse_face (Mouse_HLInfo *hlinfo, enum draw_glyphs_face draw)
{
+ /* Don't bother doing anything if the mouse-face window is not set
+ up. */
+ if (!WINDOWP (hlinfo->mouse_face_window))
+ return;
+
struct window *w = XWINDOW (hlinfo->mouse_face_window);
struct frame *f = XFRAME (WINDOW_FRAME (w));
diff --git a/src/xfns.c b/src/xfns.c
index 0507dc8..2c95065 100644
--- a/src/xfns.c
+++ b/src/xfns.c
@@ -1563,7 +1563,6 @@ x_set_menu_bar_lines (struct frame *f, Lisp_Object value,
Lisp_Object oldval)
#else /* not USE_X_TOOLKIT && not USE_GTK */
FRAME_MENU_BAR_LINES (f) = nlines;
FRAME_MENU_BAR_HEIGHT (f) = nlines * FRAME_LINE_HEIGHT (f);
- adjust_frame_size (f, -1, -1, 2, true, Qx_set_menu_bar_lines);
if (FRAME_X_WINDOW (f))
x_clear_under_internal_border (f);
@@ -1577,6 +1576,8 @@ x_set_menu_bar_lines (struct frame *f, Lisp_Object value,
Lisp_Object oldval)
int width = FRAME_PIXEL_WIDTH (f);
int y;
+ adjust_frame_size (f, -1, -1, 3, true, Qmenu_bar_lines);
+
/* height can be zero here. */
if (FRAME_X_WINDOW (f) && height > 0 && width > 0)
{
@@ -1637,7 +1638,7 @@ x_change_tab_bar_height (struct frame *f, int height)
int unit = FRAME_LINE_HEIGHT (f);
int old_height = FRAME_TAB_BAR_HEIGHT (f);
int lines = (height + unit - 1) / unit;
- Lisp_Object fullscreen;
+ Lisp_Object fullscreen = get_frame_param (f, Qfullscreen);
/* Make sure we redisplay all windows in this frame. */
fset_redisplay (f);
@@ -1645,16 +1646,8 @@ x_change_tab_bar_height (struct frame *f, int height)
/* Recalculate tab bar and frame text sizes. */
FRAME_TAB_BAR_HEIGHT (f) = height;
FRAME_TAB_BAR_LINES (f) = lines;
- /* Store the `tab-bar-lines' and `height' frame parameters. */
store_frame_param (f, Qtab_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 tab bar, is redrawn when the
- tab bar disappears. This is so because the internal border is
- below the tab bar if one is displayed, but is below the menu bar
- if there isn't a tab bar. The tab bar draws into the area
- below the menu bar. */
+
if (FRAME_X_WINDOW (f) && FRAME_TAB_BAR_HEIGHT (f) == 0)
{
clear_frame (f);
@@ -1664,25 +1657,21 @@ x_change_tab_bar_height (struct frame *f, int height)
if ((height < old_height) && WINDOWP (f->tab_bar_window))
clear_glyph_matrix (XWINDOW (f->tab_bar_window)->current_matrix);
- /* Recalculate tabbar height. */
- f->n_tab_bar_rows = 0;
- if (old_height == 0
- && (!f->after_make_frame
- || NILP (frame_inhibit_implied_resize)
- || (CONSP (frame_inhibit_implied_resize)
- && NILP (Fmemq (Qtab_bar_lines, frame_inhibit_implied_resize)))))
- f->tab_bar_redisplayed = f->tab_bar_resized = false;
-
- adjust_frame_size (f, -1, -1,
- ((!f->tab_bar_resized
- && (NILP (fullscreen =
- get_frame_param (f, Qfullscreen))
- || EQ (fullscreen, Qfullwidth))) ? 1
- : (old_height == 0 || height == 0) ? 2
- : 4),
- false, Qtab_bar_lines);
-
- f->tab_bar_resized = f->tab_bar_redisplayed;
+ if (!f->tab_bar_resized)
+ {
+ /* As long as tab_bar_resized is false, effectively try to change
+ F's native height. */
+ if (NILP (fullscreen) || EQ (fullscreen, Qfullwidth))
+ adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f),
+ 1, false, Qtab_bar_lines);
+ else
+ adjust_frame_size (f, -1, -1, 4, false, Qtab_bar_lines);
+
+ f->tab_bar_resized = f->tab_bar_redisplayed;
+ }
+ else
+ /* Any other change may leave the native size of F alone. */
+ adjust_frame_size (f, -1, -1, 3, false, Qtab_bar_lines);
/* adjust_frame_size might not have done anything, garbage frame
here. */
@@ -1743,24 +1732,15 @@ x_change_tool_bar_height (struct frame *f, int height)
int unit = FRAME_LINE_HEIGHT (f);
int old_height = FRAME_TOOL_BAR_HEIGHT (f);
int lines = (height + unit - 1) / unit;
- Lisp_Object fullscreen;
+ Lisp_Object fullscreen = get_frame_param (f, Qfullscreen);
/* Make sure we redisplay all windows in this frame. */
fset_redisplay (f);
- /* Recalculate tool bar and frame text sizes. */
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_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
- tool bar disappears. This is so because the internal border is
- below the tool bar if one is displayed, but is below the menu bar
- if there isn't a tool bar. The tool bar draws into the area
- below the menu bar. */
+
if (FRAME_X_WINDOW (f) && FRAME_TOOL_BAR_HEIGHT (f) == 0)
{
clear_frame (f);
@@ -1770,25 +1750,21 @@ x_change_tool_bar_height (struct frame *f, int height)
if ((height < old_height) && WINDOWP (f->tool_bar_window))
clear_glyph_matrix (XWINDOW (f->tool_bar_window)->current_matrix);
- /* Recalculate toolbar height. */
- f->n_tool_bar_rows = 0;
- if (old_height == 0
- && (!f->after_make_frame
- || NILP (frame_inhibit_implied_resize)
- || (CONSP (frame_inhibit_implied_resize)
- && NILP (Fmemq (Qtool_bar_lines, frame_inhibit_implied_resize)))))
- f->tool_bar_redisplayed = f->tool_bar_resized = false;
-
- adjust_frame_size (f, -1, -1,
- ((!f->tool_bar_resized
- && (NILP (fullscreen =
- get_frame_param (f, Qfullscreen))
- || EQ (fullscreen, Qfullwidth))) ? 1
- : (old_height == 0 || height == 0) ? 2
- : 4),
- false, Qtool_bar_lines);
-
- f->tool_bar_resized = f->tool_bar_redisplayed;
+ if (!f->tool_bar_resized)
+ {
+ /* As long as tool_bar_resized is false, effectively try to change
+ F's native height. */
+ if (NILP (fullscreen) || EQ (fullscreen, Qfullwidth))
+ adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f),
+ 1, false, Qtool_bar_lines);
+ else
+ adjust_frame_size (f, -1, -1, 4, false, Qtool_bar_lines);
+
+ f->tool_bar_resized = f->tool_bar_redisplayed;
+ }
+ else
+ /* Any other change may leave the native size of F alone. */
+ adjust_frame_size (f, -1, -1, 3, false, Qtool_bar_lines);
/* adjust_frame_size might not have done anything, garbage frame
here. */
@@ -3687,7 +3663,6 @@ This function is an internal primitive--use `make-frame'
instead. */)
struct x_display_info *dpyinfo = NULL;
Lisp_Object parent, parent_frame;
struct kboard *kb;
- int x_width = 0, x_height = 0;
parms = Fcopy_alist (parms);
@@ -3999,18 +3974,6 @@ This function is an internal primitive--use `make-frame'
instead. */)
init_iterator with a null face cache, which should not happen. */
init_frame_faces (f);
- /* We have to call adjust_frame_size here since otherwise
- x_set_tool_bar_lines will already work with the character sizes
- installed by init_frame_faces while the frame's pixel size is still
- calculated from a character size of 1 and we subsequently hit the
- (height >= 0) assertion in window_box_height.
-
- The non-pixelwise code apparently worked around this because it
- had one frame line vs one toolbar line which left us with a zero
- root window height which was obviously wrong as well ...
-
- Also process `min-width' and `min-height' parameters right here
- because `frame-windows-min-size' needs them. */
tem = gui_display_get_arg (dpyinfo, parms, Qmin_width, NULL, NULL,
RES_TYPE_NUMBER);
if (FIXNUMP (tem))
@@ -4019,6 +3982,7 @@ This function is an internal primitive--use `make-frame'
instead. */)
RES_TYPE_NUMBER);
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,
Qx_create_frame_1);
@@ -4055,8 +4019,7 @@ This function is an internal primitive--use `make-frame'
instead. */)
RES_TYPE_BOOLEAN);
/* Compute the size of the X window. */
- window_prompting = gui_figure_window_size (f, parms, true, true,
- &x_width, &x_height);
+ window_prompting = gui_figure_window_size (f, parms, true, true);
tem = gui_display_get_arg (dpyinfo, parms, Qunsplittable, 0, 0,
RES_TYPE_BOOLEAN);
@@ -4140,11 +4103,6 @@ This function is an internal primitive--use `make-frame'
instead. */)
/* Consider frame official, now. */
f->can_set_window_size = true;
- if (x_width > 0)
- SET_FRAME_WIDTH (f, x_width);
- if (x_height > 0)
- SET_FRAME_HEIGHT (f, x_height);
-
/* Tell the server what size and position, etc, we want, and how
badly we want them. This should be done after we have the menu
bar so that its size can be taken into account. */
@@ -6291,10 +6249,8 @@ x_create_tip_frame (struct x_display_info *dpyinfo,
Lisp_Object parms)
struct frame *f;
Lisp_Object frame;
Lisp_Object name;
- int width, height;
ptrdiff_t count = SPECPDL_INDEX ();
bool face_change_before = face_change;
- int x_width = 0, x_height = 0;
if (!dpyinfo->terminal->name)
error ("Terminal is not live, can't create new frames on it");
@@ -6418,7 +6374,7 @@ x_create_tip_frame (struct x_display_info *dpyinfo,
Lisp_Object parms)
gui_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
+ /* This defaults to 1 in order to match xterm. We recognize either
internalBorderWidth or internalBorder (which is what xterm calls
it). */
if (NILP (Fassq (Qinternal_border_width, parms)))
@@ -6466,7 +6422,7 @@ x_create_tip_frame (struct x_display_info *dpyinfo,
Lisp_Object parms)
"inhibitDoubleBuffering", "InhibitDoubleBuffering",
RES_TYPE_BOOLEAN);
- gui_figure_window_size (f, parms, false, false, &x_width, &x_height);
+ gui_figure_window_size (f, parms, false, false);
{
XSetWindowAttributes attrs;
@@ -6518,15 +6474,6 @@ x_create_tip_frame (struct x_display_info *dpyinfo,
Lisp_Object parms)
gui_default_parameter (f, parms, Qalpha, Qnil,
"alpha", "Alpha", RES_TYPE_NUMBER);
- /* Dimensions, especially FRAME_LINES (f), must be done via
change_frame_size.
- Change will not be effected unless different from the current
- FRAME_LINES (f). */
- width = FRAME_COLS (f);
- height = FRAME_LINES (f);
- SET_FRAME_COLS (f, 0);
- SET_FRAME_LINES (f, 0);
- change_frame_size (f, width, height, true, false, false, false);
-
/* Add `tooltip' frame parameter's default value. */
if (NILP (Fframe_parameter (frame, Qtooltip)))
{
@@ -6588,6 +6535,8 @@ x_create_tip_frame (struct x_display_info *dpyinfo,
Lisp_Object parms)
visible won't work. */
Vframe_list = Fcons (frame, Vframe_list);
f->can_set_window_size = true;
+ adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f),
+ 0, true, Qtip_frame);
/* Setting attributes of faces of the tooltip frame from resources
and similar will set face_change, which leads to the clearing of
@@ -7076,6 +7025,8 @@ Text larger than the specified size is clipped. */)
set_window_buffer (window, tip_buf, false, false);
w = XWINDOW (window);
w->pseudo_window_p = true;
+ /* Try to avoid that `other-window' select us (Bug#47207). */
+ Fset_window_parameter (window, Qno_other_window, Qt);
/* Set up the frame's root window. Note: The following code does not
try to size the window or its frame correctly. Its only purpose is
diff --git a/src/xmenu.c b/src/xmenu.c
index a83fffb..a6762236 100644
--- a/src/xmenu.c
+++ b/src/xmenu.c
@@ -641,7 +641,7 @@ update_frame_menubar (struct frame *f)
lw_refigure_widget (x->column_widget, True);
/* Force the pane widget to resize itself. */
- adjust_frame_size (f, -1, -1, 2, false, Qupdate_frame_menubar);
+ adjust_frame_size (f, -1, -1, 2, false, Qmenu_bar_lines);
unblock_input ();
#endif /* USE_GTK */
}
@@ -1044,6 +1044,7 @@ free_frame_menubar (struct frame *f)
/* Motif automatically shrinks the frame in lw_destroy_all_widgets.
If we want to preserve the old height, calculate it now so we can
restore it below. */
+ int old_width = FRAME_TEXT_WIDTH (f);
int old_height = FRAME_TEXT_HEIGHT (f) + FRAME_MENUBAR_HEIGHT (f);
#endif
@@ -1077,26 +1078,43 @@ free_frame_menubar (struct frame *f)
lw_destroy_all_widgets ((LWLIB_ID) f->output_data.x->id);
f->output_data.x->menubar_widget = NULL;
+ /* When double-buffering is enabled and the frame shall not be
+ resized either because resizing is inhibited or the frame is
+ fullheight, some (usually harmless) display artifacts like a
+ doubled mode line may show up. Sometimes the configuration
+ gets messed up in a more serious fashion though and you may
+ have to resize the frame to get it back in a normal state. */
if (f->output_data.x->widget)
{
#ifdef USE_MOTIF
XtVaGetValues (f->output_data.x->widget, XtNx, &x1, XtNy, &y1, NULL);
if (x1 == 0 && y1 == 0)
XtVaSetValues (f->output_data.x->widget, XtNx, x0, XtNy, y0, NULL);
- if (frame_inhibit_resize (f, false, Qmenu_bar_lines))
- adjust_frame_size (f, -1, old_height, 1, false,
Qfree_frame_menubar_1);
+ /* When resizing is inhibited and a normal Motif frame is not
+ fullheight, we have to explicitly request its old sizes
+ here since otherwise turning off the menu bar will shrink
+ the frame but turning them on again will not resize it
+ back. For a fullheight frame we let the window manager
+ deal with this problem. */
+ if (frame_inhibit_resize (f, false, Qmenu_bar_lines)
+ && !EQ (get_frame_param (f, Qfullscreen), Qfullheight))
+ adjust_frame_size (f, old_width, old_height, 1, false,
+ Qmenu_bar_lines);
else
- adjust_frame_size (f, -1, -1, 2, false, Qfree_frame_menubar_1);
+ adjust_frame_size (f, -1, -1, 2, false, Qmenu_bar_lines);
#else
- adjust_frame_size (f, -1, -1, 2, false, Qfree_frame_menubar_1);
+ adjust_frame_size (f, -1, -1, 2, false, Qmenu_bar_lines);
#endif /* USE_MOTIF */
}
else
{
#ifdef USE_MOTIF
if (WINDOWP (FRAME_ROOT_WINDOW (f))
- && frame_inhibit_resize (f, false, Qmenu_bar_lines))
- adjust_frame_size (f, -1, old_height, 1, false,
Qfree_frame_menubar_2);
+ /* See comment above. */
+ && frame_inhibit_resize (f, false, Qmenu_bar_lines)
+ && !EQ (get_frame_param (f, Qfullscreen), Qfullheight))
+ adjust_frame_size (f, old_width, old_height, 1, false,
+ Qmenu_bar_lines);
#endif
}
diff --git a/src/xselect.c b/src/xselect.c
index 030f624..cd6d86b 100644
--- a/src/xselect.c
+++ b/src/xselect.c
@@ -1482,14 +1482,21 @@ x_get_window_property_as_lisp_data (struct
x_display_info *dpyinfo,
= XGetSelectionOwner (display, selection_atom) != 0;
unblock_input ();
if (there_is_a_selection_owner)
- signal_error ("Selection owner couldn't convert",
- actual_type
- ? list2 (target_type,
- x_atom_to_symbol (dpyinfo, actual_type))
- : target_type);
+ {
+ AUTO_STRING (format, "Selection owner couldn't convert: %s");
+ CALLN (Fmessage, format,
+ actual_type
+ ? list2 (target_type,
+ x_atom_to_symbol (dpyinfo, actual_type))
+ : target_type);
+ return Qnil;
+ }
else
- signal_error ("No selection",
- x_atom_to_symbol (dpyinfo, selection_atom));
+ {
+ AUTO_STRING (format, "No selection: %s");
+ CALLN (Fmessage, format, x_atom_to_symbol (dpyinfo, selection_atom));
+ return Qnil;
+ }
}
if (actual_type == dpyinfo->Xatom_INCR)
diff --git a/src/xterm.c b/src/xterm.c
index 744b80c..5049f72 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -6223,7 +6223,7 @@ x_create_toolkit_scroll_bar (struct frame *f, struct
scroll_bar *bar)
/* But only if we have a small colormap. Xaw3d can allocate nice
colors itself. */
{
- XtSetArg (av[ac], XtNbeNiceToColormap,
+ XtSetArg (av[ac], (String) XtNbeNiceToColormap,
DefaultDepthOfScreen (FRAME_X_SCREEN (f)) < 16);
++ac;
}
@@ -6234,20 +6234,20 @@ x_create_toolkit_scroll_bar (struct frame *f, struct
scroll_bar *bar)
{
/* This tells Xaw3d to use real colors instead of dithering for
the shadows. */
- XtSetArg (av[ac], XtNbeNiceToColormap, False);
+ XtSetArg (av[ac], (String) XtNbeNiceToColormap, False);
++ac;
/* Specify the colors. */
pixel = f->output_data.x->scroll_bar_top_shadow_pixel;
if (pixel != -1)
{
- XtSetArg (av[ac], XtNtopShadowPixel, pixel);
+ XtSetArg (av[ac], (String) XtNtopShadowPixel, pixel);
++ac;
}
pixel = f->output_data.x->scroll_bar_bottom_shadow_pixel;
if (pixel != -1)
{
- XtSetArg (av[ac], XtNbottomShadowPixel, pixel);
+ XtSetArg (av[ac], (String) XtNbottomShadowPixel, pixel);
++ac;
}
}
@@ -6424,7 +6424,7 @@ x_create_horizontal_toolkit_scroll_bar (struct frame *f,
struct scroll_bar *bar)
/* But only if we have a small colormap. Xaw3d can allocate nice
colors itself. */
{
- XtSetArg (av[ac], XtNbeNiceToColormap,
+ XtSetArg (av[ac], (String) XtNbeNiceToColormap,
DefaultDepthOfScreen (FRAME_X_SCREEN (f)) < 16);
++ac;
}
@@ -6435,20 +6435,20 @@ x_create_horizontal_toolkit_scroll_bar (struct frame
*f, struct scroll_bar *bar)
{
/* This tells Xaw3d to use real colors instead of dithering for
the shadows. */
- XtSetArg (av[ac], XtNbeNiceToColormap, False);
+ XtSetArg (av[ac], (String) XtNbeNiceToColormap, False);
++ac;
/* Specify the colors. */
pixel = f->output_data.x->scroll_bar_top_shadow_pixel;
if (pixel != -1)
{
- XtSetArg (av[ac], XtNtopShadowPixel, pixel);
+ XtSetArg (av[ac], (String) XtNtopShadowPixel, pixel);
++ac;
}
pixel = f->output_data.x->scroll_bar_bottom_shadow_pixel;
if (pixel != -1)
{
- XtSetArg (av[ac], XtNbottomShadowPixel, pixel);
+ XtSetArg (av[ac], (String) XtNbottomShadowPixel, pixel);
++ac;
}
}
@@ -7833,10 +7833,6 @@ x_net_wm_state (struct frame *f, Window window)
break;
}
- frame_size_history_add
- (f, Qx_net_wm_state, 0, 0,
- list2 (get_frame_param (f, Qfullscreen), lval));
-
store_frame_param (f, Qfullscreen, lval);
/** store_frame_param (f, Qsticky, sticky ? Qt : Qnil); **/
}
@@ -8167,19 +8163,29 @@ handle_one_xevent (struct x_display_info *dpyinfo,
if (f && event->xproperty.atom == dpyinfo->Xatom_net_wm_state)
{
bool not_hidden = x_handle_net_wm_state (f, &event->xproperty);
+
if (not_hidden && FRAME_ICONIFIED_P (f))
{
+ if (CONSP (frame_size_history))
+ frame_size_history_plain
+ (f, build_string ("PropertyNotify, not hidden & iconified"));
+
/* Gnome shell does not iconify us when C-z is pressed.
It hides the frame. So if our state says we aren't
hidden anymore, treat it as deiconified. */
SET_FRAME_VISIBLE (f, 1);
SET_FRAME_ICONIFIED (f, false);
+
f->output_data.x->has_been_visible = true;
inev.ie.kind = DEICONIFY_EVENT;
XSETFRAME (inev.ie.frame_or_window, f);
}
- else if (! not_hidden && ! FRAME_ICONIFIED_P (f))
+ else if (!not_hidden && !FRAME_ICONIFIED_P (f))
{
+ if (CONSP (frame_size_history))
+ frame_size_history_plain
+ (f, build_string ("PropertyNotify, hidden & not iconified"));
+
SET_FRAME_VISIBLE (f, 0);
SET_FRAME_ICONIFIED (f, true);
inev.ie.kind = ICONIFY_EVENT;
@@ -8357,10 +8363,17 @@ handle_one_xevent (struct x_display_info *dpyinfo,
and that way, we know the window is not iconified now. */
if (visible || FRAME_ICONIFIED_P (f))
{
+ if (CONSP (frame_size_history))
+ frame_size_history_plain
+ (f, build_string ("UnmapNotify, visible | iconified"));
+
SET_FRAME_ICONIFIED (f, true);
- inev.ie.kind = ICONIFY_EVENT;
+ inev.ie.kind = ICONIFY_EVENT;
XSETFRAME (inev.ie.frame_or_window, f);
}
+ else if (CONSP (frame_size_history))
+ frame_size_history_plain
+ (f, build_string ("UnmapNotify, not visible & not iconified"));
}
goto OTHER;
@@ -8372,8 +8385,24 @@ handle_one_xevent (struct x_display_info *dpyinfo,
if (f)
{
bool iconified = FRAME_ICONIFIED_P (f);
-
- /* Check if fullscreen was specified before we where mapped the
+ int value;
+ bool sticky;
+ bool not_hidden = x_get_current_wm_state (f, event->xmap.window,
&value, &sticky);
+
+ if (CONSP (frame_size_history))
+ frame_size_history_extra
+ (f,
+ iconified
+ ? (not_hidden
+ ? build_string ("MapNotify, not hidden & iconified")
+ : build_string ("MapNotify, hidden & iconified"))
+ : (not_hidden
+ ? build_string ("MapNotify, not hidden & not iconified")
+ : build_string ("MapNotify, hidden & not iconified")),
+ FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f),
+ -1, -1, f->new_width, f->new_height);
+
+ /* Check if fullscreen was specified before we where mapped the
first time, i.e. from the command line. */
if (!f->output_data.x->has_been_visible)
{
@@ -8974,7 +9003,16 @@ handle_one_xevent (struct x_display_info *dpyinfo,
|| !(configureEvent.xconfigure.width <= 1
&& configureEvent.xconfigure.height <= 1)))
{
- block_input ();
+
+ if (CONSP (frame_size_history))
+ frame_size_history_extra
+ (f, build_string ("ConfigureNotify"),
+ FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f),
+ configureEvent.xconfigure.width,
+ configureEvent.xconfigure.height,
+ f->new_width, f->new_height);
+
+ block_input ();
if (FRAME_X_DOUBLE_BUFFERED_P (f))
font_drop_xrender_surfaces (f);
unblock_input ();
@@ -9015,24 +9053,28 @@ handle_one_xevent (struct x_display_info *dpyinfo,
#ifndef USE_X_TOOLKIT
#ifndef USE_GTK
- int width =
- FRAME_PIXEL_TO_TEXT_WIDTH (f, configureEvent.xconfigure.width);
- int height =
- FRAME_PIXEL_TO_TEXT_HEIGHT (f, configureEvent.xconfigure.height);
+ int width = configureEvent.xconfigure.width;
+ int height = configureEvent.xconfigure.height;
+
+ if (CONSP (frame_size_history))
+ frame_size_history_extra
+ (f, build_string ("ConfigureNotify"),
+ FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f),
+ width, height, f->new_width, f->new_height);
- /* In the toolkit version, change_frame_size
+ /* In the toolkit version, change_frame_size
is called by the code that handles resizing
of the EmacsFrame widget. */
/* Even if the number of character rows and columns has
not changed, the font size may have changed, so we need
to check the pixel dimensions as well. */
- if (width != FRAME_TEXT_WIDTH (f)
- || height != FRAME_TEXT_HEIGHT (f)
- || configureEvent.xconfigure.width != FRAME_PIXEL_WIDTH (f)
- || configureEvent.xconfigure.height != FRAME_PIXEL_HEIGHT (f))
+ if (width != FRAME_PIXEL_WIDTH (f)
+ || height != FRAME_PIXEL_HEIGHT (f)
+ || (delayed_size_change
+ && (width != f->new_width || height != f->new_height)))
{
- change_frame_size (f, width, height, false, true, false, true);
+ change_frame_size (f, width, height, false, true, false);
x_clear_under_internal_border (f);
SET_FRAME_GARBAGED (f);
cancel_mouse_face (f);
@@ -10217,11 +10259,6 @@ x_new_font (struct frame *f, Lisp_Object font_object,
int fontset)
{
struct font *font = XFONT_OBJECT (font_object);
int unit, font_ascent, font_descent;
-#ifndef USE_X_TOOLKIT
- int old_menu_bar_height = FRAME_MENU_BAR_HEIGHT (f);
- int old_tab_bar_height = FRAME_TAB_BAR_HEIGHT (f);
- Lisp_Object fullscreen;
-#endif
if (fontset < 0)
fontset = fontset_from_font (font_object);
@@ -10239,8 +10276,9 @@ x_new_font (struct frame *f, Lisp_Object font_object,
int fontset)
#ifndef USE_X_TOOLKIT
FRAME_MENU_BAR_HEIGHT (f) = FRAME_MENU_BAR_LINES (f) * FRAME_LINE_HEIGHT (f);
- FRAME_TAB_BAR_HEIGHT (f) = FRAME_TAB_BAR_LINES (f) * FRAME_LINE_HEIGHT (f);
#endif
+ /* We could use a more elaborate calculation here. */
+ FRAME_TAB_BAR_HEIGHT (f) = FRAME_TAB_BAR_LINES (f) * FRAME_LINE_HEIGHT (f);
/* Compute character columns occupied by scrollbar.
@@ -10253,34 +10291,14 @@ x_new_font (struct frame *f, Lisp_Object font_object,
int fontset)
else
FRAME_CONFIG_SCROLL_BAR_COLS (f) = (14 + unit - 1) / unit;
- if (FRAME_X_WINDOW (f) != 0)
- {
- /* 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 (!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);
-#ifndef USE_X_TOOLKIT
- if ((FRAME_MENU_BAR_HEIGHT (f) != old_menu_bar_height
- || FRAME_TAB_BAR_HEIGHT (f) != old_tab_bar_height)
- && !f->after_make_frame
- && (EQ (frame_inhibit_implied_resize, Qt)
- || (CONSP (frame_inhibit_implied_resize)
- && NILP (Fmemq (Qfont, frame_inhibit_implied_resize))))
- && (NILP (fullscreen = get_frame_param (f, Qfullscreen))
- || EQ (fullscreen, Qfullwidth)))
- /* If the menu/tab bar height changes, try to keep text height
- constant. */
- adjust_frame_size
- (f, -1, FRAME_TEXT_HEIGHT (f) + FRAME_MENU_BAR_HEIGHT (f)
- + FRAME_TAB_BAR_HEIGHT (f)
- - old_menu_bar_height - old_tab_bar_height, 1, false, Qfont);
-#endif /* USE_X_TOOLKIT */
- }
- }
+
+ /* 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 (FRAME_X_WINDOW (f) != 0 && !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);
#ifdef HAVE_X_I18N
if (FRAME_XIC (f)
@@ -11164,10 +11182,6 @@ x_handle_net_wm_state (struct frame *f, const
XPropertyEvent *event)
break;
}
- frame_size_history_add
- (f, Qx_handle_net_wm_state, 0, 0,
- list2 (get_frame_param (f, Qfullscreen), lval));
-
store_frame_param (f, Qfullscreen, lval);
store_frame_param (f, Qsticky, sticky ? Qt : Qnil);
@@ -11222,9 +11236,6 @@ x_check_fullscreen (struct frame *f)
emacs_abort ();
}
- frame_size_history_add
- (f, Qx_check_fullscreen, width, height, Qnil);
-
x_wm_set_size_hint (f, 0, false);
XResizeWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
@@ -11234,8 +11245,7 @@ x_check_fullscreen (struct frame *f)
x_wait_for_event (f, ConfigureNotify);
else
{
- change_frame_size (f, width, height - FRAME_MENUBAR_HEIGHT (f),
- false, true, false, true);
+ change_frame_size (f, width, height, false, true, false);
x_sync (f);
}
}
@@ -11389,57 +11399,12 @@ static void
x_set_window_size_1 (struct frame *f, bool change_gravity,
int width, int height)
{
- int pixelwidth = FRAME_TEXT_TO_PIXEL_WIDTH (f, width);
- int pixelheight = FRAME_TEXT_TO_PIXEL_HEIGHT (f, height);
- int old_width = FRAME_PIXEL_WIDTH (f);
- int old_height = FRAME_PIXEL_HEIGHT (f);
- Lisp_Object fullscreen = get_frame_param (f, Qfullscreen);
-
if (change_gravity)
f->win_gravity = NorthWestGravity;
x_wm_set_size_hint (f, 0, false);
- /* When the frame is fullheight and we only want to change the width
- or it is fullwidth and we only want to change the height we should
- be able to preserve the fullscreen property. However, due to the
- fact that we have to send a resize request anyway, the window
- manager will abolish it. At least the respective size should
- remain unchanged but giving the frame back its normal size will
- be broken ... */
- if (EQ (fullscreen, Qfullwidth) && width == FRAME_TEXT_WIDTH (f))
- {
- frame_size_history_add
- (f, Qx_set_window_size_1, width, height,
- list2i (old_height, pixelheight + FRAME_MENUBAR_HEIGHT (f)));
-
- XResizeWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
- old_width, pixelheight + FRAME_MENUBAR_HEIGHT (f));
- }
- else if (EQ (fullscreen, Qfullheight) && height == FRAME_TEXT_HEIGHT (f))
- {
- frame_size_history_add
- (f, Qx_set_window_size_2, width, height,
- list2i (old_width, pixelwidth));
-
- XResizeWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
- pixelwidth, old_height);
- }
-
- else
- {
- frame_size_history_add
- (f, Qx_set_window_size_3, width, height,
- list3i (pixelwidth + FRAME_TOOLBAR_WIDTH (f),
- (pixelheight + FRAME_TOOLBAR_HEIGHT (f)
- + FRAME_MENUBAR_HEIGHT (f)),
- FRAME_MENUBAR_HEIGHT (f)));
-
- XResizeWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
- pixelwidth, pixelheight + FRAME_MENUBAR_HEIGHT (f));
- fullscreen = Qnil;
- }
-
-
+ XResizeWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
+ width, height + FRAME_MENUBAR_HEIGHT (f));
/* We've set {FRAME,PIXEL}_{WIDTH,HEIGHT} to the values we hope to
receive in the ConfigureNotify event; if we get what we asked
@@ -11468,66 +11433,42 @@ x_set_window_size_1 (struct frame *f, bool
change_gravity,
{
x_wait_for_event (f, ConfigureNotify);
- if (!NILP (fullscreen))
- /* Try to restore fullscreen state. */
- {
- store_frame_param (f, Qfullscreen, fullscreen);
- gui_set_fullscreen (f, fullscreen, fullscreen);
- }
+ if (CONSP (frame_size_history))
+ frame_size_history_extra
+ (f, build_string ("x_set_window_size_1, visible"),
+ FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f), width, height,
+ f->new_width, f->new_height);
}
else
{
- change_frame_size (f, width, height, false, true, false, true);
+ if (CONSP (frame_size_history))
+ frame_size_history_extra
+ (f, build_string ("x_set_window_size_1, invisible"),
+ FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f), width, height,
+ f->new_width, f->new_height);
+
+ /* Call adjust_frame_size right away as with GTK. It might be
+ tempting to clear out f->new_width and f->new_height here. */
+ adjust_frame_size (f, FRAME_PIXEL_TO_TEXT_WIDTH (f, width),
+ FRAME_PIXEL_TO_TEXT_HEIGHT (f, height),
+ 5, 0, Qx_set_window_size_1);
+
x_sync (f);
}
}
-/* Call this to change the size of frame F's x-window.
- If CHANGE_GRAVITY, change to top-left-corner window gravity
- for this size change and subsequent size changes.
- Otherwise we leave the window gravity unchanged. */
+/* Change the size of frame F's X window to WIDTH and HEIGHT pixels. If
+ CHANGE_GRAVITY, change to top-left-corner window gravity for this
+ size change and subsequent size changes. Otherwise we leave the
+ window gravity unchanged. */
void
x_set_window_size (struct frame *f, bool change_gravity,
- int width, int height, bool pixelwise)
+ int width, int height)
{
block_input ();
- /* The following breaks our calculations. If it's really needed,
- think of something else. */
-#if false
- if (!FRAME_TOOLTIP_P (f))
- {
- int text_width, text_height;
-
- /* When the frame is maximized/fullscreen or running under for
- example Xmonad, x_set_window_size_1 will be a no-op.
- In that case, the right thing to do is extend rows/width to
- the current frame size. We do that first if x_set_window_size_1
- turns out to not be a no-op (there is no way to know).
- The size will be adjusted again if the frame gets a
- ConfigureNotify event as a result of x_set_window_size. */
- int pixelh = FRAME_PIXEL_HEIGHT (f);
-#ifdef USE_X_TOOLKIT
- /* The menu bar is not part of text lines. The tool bar
- is however. */
- pixelh -= FRAME_MENUBAR_HEIGHT (f);
-#endif
- text_width = FRAME_PIXEL_TO_TEXT_WIDTH (f, FRAME_PIXEL_WIDTH (f));
- text_height = FRAME_PIXEL_TO_TEXT_HEIGHT (f, pixelh);
-
- change_frame_size (f, text_width, text_height, false, true, false, true);
- }
-#endif
-
- /* Pixelize width and height, if necessary. */
- if (! pixelwise)
- {
- width = width * FRAME_COLUMN_WIDTH (f);
- height = height * FRAME_LINE_HEIGHT (f);
- }
-
#ifdef USE_GTK
if (FRAME_GTK_WIDGET (f))
xg_frame_set_char_size (f, width, height);
@@ -11880,6 +11821,11 @@ x_make_frame_visible (struct frame *f)
poll_for_input_1 ();
poll_suppress_count = old_poll_suppress_count;
#endif
+
+ if (CONSP (frame_size_history))
+ frame_size_history_plain
+ (f, build_string ("x_make_frame_visible"));
+
if (! FRAME_VISIBLE_P (f))
x_wait_for_event (f, MapNotify);
}
@@ -11937,6 +11883,10 @@ x_make_frame_invisible (struct frame *f)
SET_FRAME_VISIBLE (f, 0);
SET_FRAME_ICONIFIED (f, false);
+ if (CONSP (frame_size_history))
+ frame_size_history_plain
+ (f, build_string ("x_make_frame_invisible"));
+
unblock_input ();
}
diff --git a/src/xterm.h b/src/xterm.h
index ebc42b7..de6ea50 100644
--- a/src/xterm.h
+++ b/src/xterm.h
@@ -1079,7 +1079,7 @@ extern bool x_had_errors_p (Display *);
extern void x_uncatch_errors (void);
extern void x_uncatch_errors_after_check (void);
extern void x_clear_errors (Display *);
-extern void x_set_window_size (struct frame *f, bool, int, int, bool);
+extern void x_set_window_size (struct frame *f, bool, int, int);
extern void x_make_frame_visible (struct frame *f);
extern void x_make_frame_invisible (struct frame *f);
extern void x_iconify_frame (struct frame *f);
diff --git a/test/Makefile.in b/test/Makefile.in
index ba35428..84ab4e7 100644
--- a/test/Makefile.in
+++ b/test/Makefile.in
@@ -47,6 +47,8 @@ SO = @MODULES_SUFFIX@
SEPCHAR = @SEPCHAR@
+HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@
+
-include ${top_builddir}/src/verbose.mk
# Load any GNU ELPA dependencies that are present, for optional tests.
@@ -118,6 +120,8 @@ emacs = LANG=C EMACSLOADPATH= \
# Set HOME to a nonexistent directory to prevent tests from accessing
# it accidentally (e.g., popping up a gnupg dialog if ~/.authinfo.gpg
# exists, or writing to ~/.bzr.log when running bzr commands).
+# NOTE if the '/nonexistent' name is changed `normal-top-level' in
+# startup.el must be updated too.
TEST_HOME = /nonexistent
test_module_dir := src/emacs-module-resources
@@ -126,9 +130,15 @@ test_module_dir := src/emacs-module-resources
all: check
+ifeq ($(HAVE_NATIVE_COMP),yes)
SELECTOR_DEFAULT = (not (or (tag :expensive-test) (tag :unstable)))
SELECTOR_EXPENSIVE = (not (tag :unstable))
SELECTOR_ALL = t
+else
+SELECTOR_DEFAULT = (not (or (tag :expensive-test) (tag :unstable) (tag
:nativecomp)))
+SELECTOR_EXPENSIVE = (not (or (tag :unstable) (tag :nativecomp)))
+SELECTOR_ALL = (not (tag :nativecomp))
+endif
ifdef SELECTOR
SELECTOR_ACTUAL=$(SELECTOR)
else ifndef MAKECMDGOALS
@@ -276,6 +286,8 @@ $(test_module): $(test_module:${SO}=.c)
../src/emacs-module.h
$(srcdir)/../lib/timespec.c $(srcdir)/../lib/gettime.c
endif
+src/emacs-tests.log: ../lib-src/seccomp-filter.c
+
## Check that there is no 'automated' subdirectory, which would
## indicate an incomplete merge from an older version of Emacs where
## the tests were arranged differently.
diff --git a/test/infra/Dockerfile.emba b/test/infra/Dockerfile.emba
index 30a5897..19c83a8 100644
--- a/test/infra/Dockerfile.emba
+++ b/test/infra/Dockerfile.emba
@@ -68,5 +68,5 @@ COPY . /checkout
WORKDIR /checkout
RUN ./autogen.sh autoconf
RUN ./configure --with-ns
-RUN make -j4 bootstrap
+RUN make bootstrap
RUN make -j4
diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml
index 6355513..4023437 100644
--- a/test/infra/gitlab-ci.yml
+++ b/test/infra/gitlab-ci.yml
@@ -238,14 +238,48 @@ test-lisp-net-inotify:
test-filenotify-gio:
# This tests file monitor libraries gfilemonitor and gio.
stage: platforms
+ needs: [build-image-filenotify-gio]
extends: [.job-template, .test-template, .filenotify-gio-template]
variables:
target: emacs-filenotify-gio
make_params: "-k -C test autorevert-tests.log filenotify-tests.log"
+build-native-bootstrap-speed0:
+ # Test a full native bootstrap
+ # Run for now only speed 0 to limit memory usage and compilation time.
+ stage: slow
+ # Uncomment the following to run it only when scheduled.
+ # only:
+ # - schedules
+ script:
+ - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y
-qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev
+ - ./autogen.sh autoconf
+ - ./configure --with-nativecomp
+ - make bootstrap NATIVE_FULL_AOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq
comp-speed 0)"' -j2
+ timeout: 8 hours
+
+build-native-bootstrap-speed1:
+ stage: slow
+ script:
+ - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y
-qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev
+ - ./autogen.sh autoconf
+ - ./configure --with-nativecomp
+ - make bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"'
+ timeout: 8 hours
+
+build-native-bootstrap-speed2:
+ stage: slow
+ script:
+ - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y
-qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev
+ - ./autogen.sh autoconf
+ - ./configure --with-nativecomp
+ - make bootstrap
+ timeout: 8 hours
+
test-gnustep:
# This tests the GNUstep build process
stage: platforms
+ needs: [build-image-gnustep]
extends: [.job-template, .gnustep-template]
variables:
target: emacs-gnustep
@@ -262,3 +296,7 @@ test-all-inotify:
variables:
target: emacs-inotify
make_params: check-expensive
+
+# Local Variables:
+# add-log-current-defun-header-regexp: "^\\([-_.[:alnum:]]+\\)[ \t]*:"
+# End:
diff --git a/test/lisp/auth-source-tests.el b/test/lisp/auth-source-tests.el
index 4f0d994..1c4bd8d 100644
--- a/test/lisp/auth-source-tests.el
+++ b/test/lisp/auth-source-tests.el
@@ -320,7 +320,9 @@
;; 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)))
+ (lambda (_prompt &optional _initial _history default
+ _inherit-input-method)
+ default)))
(setq auth-info
(car (auth-source-search
:max 1 :host host :require '(:user :secret) :create t))))
diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el
index 5f27c2e..3e97e9c 100644
--- a/test/lisp/autorevert-tests.el
+++ b/test/lisp/autorevert-tests.el
@@ -1,4 +1,4 @@
-;;; auto-revert-tests.el --- Tests of auto-revert -*- lexical-binding: t -*-
+;;; autorevert-tests.el --- Tests of auto-revert -*- lexical-binding: t -*-
;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el
index c5aa5a3..13dd228 100644
--- a/test/lisp/calc/calc-tests.el
+++ b/test/lisp/calc/calc-tests.el
@@ -191,6 +191,33 @@ An existing calc stack is reused, otherwise a new one is
created."
(let ((calc-number-radix 36))
(should (equal (math-format-number 12345678901) "36#5,O6A,QT1")))))
+(ert-deftest calc-digit-after-point ()
+ "Test display of trailing 0 after decimal point (bug#47302)."
+ (let ((calc-digit-after-point nil))
+ ;; Integral floats have no digits after the decimal point (default).
+ (should (equal (math-format-number '(float 0 0)) "0."))
+ (should (equal (math-format-number '(float 5 0)) "5."))
+ (should (equal (math-format-number '(float 3 1)) "30."))
+ (should (equal (math-format-number '(float 23 0)) "23."))
+ (should (equal (math-format-number '(float 123 0)) "123."))
+ (should (equal (math-format-number '(float 1 -1)) "0.1"))
+ (should (equal (math-format-number '(float 54 -1)) "5.4"))
+ (should (equal (math-format-number '(float 1 -4)) "1e-4"))
+ (should (equal (math-format-number '(float 1 14)) "1e14"))
+ (should (equal (math-format-number 12) "12")))
+ (let ((calc-digit-after-point t))
+ ;; Integral floats have at least one digit after the decimal point.
+ (should (equal (math-format-number '(float 0 0)) "0.0"))
+ (should (equal (math-format-number '(float 5 0)) "5.0"))
+ (should (equal (math-format-number '(float 3 1)) "30.0"))
+ (should (equal (math-format-number '(float 23 0)) "23.0"))
+ (should (equal (math-format-number '(float 123 0)) "123.0"))
+ (should (equal (math-format-number '(float 1 -1)) "0.1"))
+ (should (equal (math-format-number '(float 54 -1)) "5.4"))
+ (should (equal (math-format-number '(float 1 -4)) "1e-4"))
+ (should (equal (math-format-number '(float 1 14)) "1e14"))
+ (should (equal (math-format-number 12) "12"))))
+
(ert-deftest calc-calendar ()
"Test calendar conversions (bug#36822)."
(should (equal (calcFunc-julian (math-parse-date "2019-07-27")) 2458692))
diff --git a/test/lisp/calculator-tests.el b/test/lisp/calculator-tests.el
new file mode 100644
index 0000000..9551b1a
--- /dev/null
+++ b/test/lisp/calculator-tests.el
@@ -0,0 +1,51 @@
+;;; calculator-tests.el --- Test suite for calculator. -*- lexical-binding: t
-*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+(require 'ert)
+(require 'calculator)
+
+(ert-deftest calculator-test-calculator-string-to-number ()
+ (dolist (x '(("" 0.0)
+ ("+" 0.0)
+ ("-" 0.0)
+ ("." 0.0)
+ ("+." 0.0)
+ ("-." -0.0)
+ (".-" 0.0)
+ ("--." 0.0)
+ ("-0.0e" -0.0)
+ ("1e1" 10.0)
+ ("1e+1" 10.0)
+ ("1e-1" 0.1)
+ ("+1e1" 10.0)
+ ("-1e1" -10.0)
+ ("+1e-1" 0.1)
+ ("-1e-1" -0.1)
+ (".1.e1" 0.1)
+ (".1..e1" 0.1)
+ ("1e+1.1" 10.0)
+ ("-2e-1.1" -0.2)))
+ (pcase x
+ (`(,str ,expected)
+ (let ((calculator-input-radix nil))
+ (should (equal (calculator-string-to-number str) expected)))))))
+
+(provide 'calculator-tests)
+;; calculator-tests.el ends here
diff --git a/test/lisp/calendar/icalendar-tests.el
b/test/lisp/calendar/icalendar-tests.el
index 61d3c11..6973f7e 100644
--- a/test/lisp/calendar/icalendar-tests.el
+++ b/test/lisp/calendar/icalendar-tests.el
@@ -1,4 +1,4 @@
-;; icalendar-tests.el --- Test suite for icalendar.el -*- lexical-binding:t
-*-
+;;; icalendar-tests.el --- Test suite for icalendar.el -*- lexical-binding:t
-*-
;; Copyright (C) 2005, 2008-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/calendar/parse-time-tests.el
b/test/lisp/calendar/parse-time-tests.el
index b90fe0b..b706b73 100644
--- a/test/lisp/calendar/parse-time-tests.el
+++ b/test/lisp/calendar/parse-time-tests.el
@@ -1,4 +1,4 @@
-;; parse-time-tests.el --- Test suite for parse-time.el -*- lexical-binding:t
-*-
+;;; parse-time-tests.el --- Test suite for parse-time.el -*-
lexical-binding:t -*-
;; Copyright (C) 2016-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/cedet/srecode-utest-template.el
b/test/lisp/cedet/srecode-utest-template.el
index f97ff18..087dcfd 100644
--- a/test/lisp/cedet/srecode-utest-template.el
+++ b/test/lisp/cedet/srecode-utest-template.el
@@ -1,4 +1,4 @@
-;;; srecode/test.el --- SRecode Core Template tests. -*- lexical-binding:t -*-
+;;; srecode-utest-template.el --- SRecode Core Template tests. -*-
lexical-binding:t -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/custom-resources/custom--test-theme.el
b/test/lisp/custom-resources/custom--test-theme.el
index 4ced98a..122bd79 100644
--- a/test/lisp/custom-resources/custom--test-theme.el
+++ b/test/lisp/custom-resources/custom--test-theme.el
@@ -1,4 +1,4 @@
-;;; custom--test-theme.el -- A test theme. -*- lexical-binding:t -*-
+;;; custom--test-theme.el --- A test theme. -*- lexical-binding:t -*-
(deftheme custom--test
"A test theme.")
diff --git a/test/lisp/descr-text-tests.el b/test/lisp/descr-text-tests.el
index 6ba455b..2052dc0 100644
--- a/test/lisp/descr-text-tests.el
+++ b/test/lisp/descr-text-tests.el
@@ -1,4 +1,4 @@
-;;; descr-text-test.el --- ERT tests for descr-text.el -*- lexical-binding: t
-*-
+;;; descr-text-tests.el --- ERT tests for descr-text.el -*- lexical-binding: t
-*-
;; Copyright (C) 2014, 2016-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el
index 44b3d8b..235c02f 100644
--- a/test/lisp/electric-tests.el
+++ b/test/lisp/electric-tests.el
@@ -47,7 +47,7 @@
(defmacro save-electric-modes (&rest body)
(declare (indent defun) (debug t))
- `(call-with-saved-electric-modes #'(lambda () ,@body)))
+ `(call-with-saved-electric-modes (lambda () ,@body)))
(defun electric-pair-test-for (fixture where char expected-string
expected-point mode bindings
@@ -359,7 +359,7 @@ baz\"\""
# \"
#
baz\"\""
- :fixture-fn #'(lambda () (goto-char (point-min)) (search-forward "bar")))
+ :fixture-fn (lambda () (goto-char (point-min)) (search-forward "bar")))
(define-electric-pair-test inhibit-in-mismatched-string-inside-c-comments
"foo\"\"/*
@@ -378,7 +378,7 @@ baz\"\""
\" \"
\"
*/baz\"\""
- :fixture-fn #'(lambda () (goto-char (point-min)) (search-forward "bar")))
+ :fixture-fn (lambda () (goto-char (point-min)) (search-forward "bar")))
;;; More quotes, but now don't bind `electric-pair-text-syntax-table'
@@ -520,8 +520,8 @@ baz\"\""
(define-electric-pair-test js-mode-braces
"" "{" :expected-string "{}" :expected-point 2
:modes '(js-mode)
- :fixture-fn #'(lambda ()
- (electric-pair-mode 1)))
+ :fixture-fn (lambda ()
+ (electric-pair-mode 1)))
(define-electric-pair-test js-mode-braces-with-layout
@@ -529,29 +529,29 @@ baz\"\""
:modes '(js-mode)
:test-in-comments nil
:test-in-strings nil
- :fixture-fn #'(lambda ()
- (electric-layout-mode 1)
- (electric-pair-mode 1)))
+ :fixture-fn (lambda ()
+ (electric-layout-mode 1)
+ (electric-pair-mode 1)))
(define-electric-pair-test js-mode-braces-with-layout-and-indent
"" "{" :expected-string "{\n \n}" :expected-point 7
:modes '(js-mode)
:test-in-comments nil
:test-in-strings nil
- :fixture-fn #'(lambda ()
- (electric-pair-mode 1)
- (electric-indent-mode 1)
- (electric-layout-mode 1)))
+ :fixture-fn (lambda ()
+ (electric-pair-mode 1)
+ (electric-indent-mode 1)
+ (electric-layout-mode 1)))
(define-electric-pair-test js-mode-braces-with-layout-and-indent
"" "{" :expected-string "{\n \n}" :expected-point 7
:modes '(js-mode)
:test-in-comments nil
:test-in-strings nil
- :fixture-fn #'(lambda ()
- (electric-pair-mode 1)
- (electric-indent-mode 1)
- (electric-layout-mode 1)))
+ :fixture-fn (lambda ()
+ (electric-pair-mode 1)
+ (electric-indent-mode 1)
+ (electric-layout-mode 1)))
;;; Backspacing
@@ -606,55 +606,55 @@ baz\"\""
;;;
(define-electric-pair-test autowrapping-1
"foo" "(" :expected-string "(foo)" :expected-point 2
- :fixture-fn #'(lambda ()
- (electric-pair-mode 1)
- (mark-sexp 1)))
+ :fixture-fn (lambda ()
+ (electric-pair-mode 1)
+ (mark-sexp 1)))
(define-electric-pair-test autowrapping-2
"foo" ")" :expected-string "(foo)" :expected-point 6
- :fixture-fn #'(lambda ()
- (electric-pair-mode 1)
- (mark-sexp 1)))
+ :fixture-fn (lambda ()
+ (electric-pair-mode 1)
+ (mark-sexp 1)))
(define-electric-pair-test autowrapping-3
"foo" ")" :expected-string "(foo)" :expected-point 6
- :fixture-fn #'(lambda ()
- (electric-pair-mode 1)
- (goto-char (point-max))
- (skip-chars-backward "\"")
- (mark-sexp -1)))
+ :fixture-fn (lambda ()
+ (electric-pair-mode 1)
+ (goto-char (point-max))
+ (skip-chars-backward "\"")
+ (mark-sexp -1)))
(define-electric-pair-test autowrapping-4
"foo" "(" :expected-string "(foo)" :expected-point 2
- :fixture-fn #'(lambda ()
- (electric-pair-mode 1)
- (goto-char (point-max))
- (skip-chars-backward "\"")
- (mark-sexp -1)))
+ :fixture-fn (lambda ()
+ (electric-pair-mode 1)
+ (goto-char (point-max))
+ (skip-chars-backward "\"")
+ (mark-sexp -1)))
(define-electric-pair-test autowrapping-5
"foo" "\"" :expected-string "\"foo\"" :expected-point 2
- :fixture-fn #'(lambda ()
- (electric-pair-mode 1)
- (mark-sexp 1)))
+ :fixture-fn (lambda ()
+ (electric-pair-mode 1)
+ (mark-sexp 1)))
(define-electric-pair-test autowrapping-6
"foo" "\"" :expected-string "\"foo\"" :expected-point 6
- :fixture-fn #'(lambda ()
- (electric-pair-mode 1)
- (goto-char (point-max))
- (skip-chars-backward "\"")
- (mark-sexp -1)))
+ :fixture-fn (lambda ()
+ (electric-pair-mode 1)
+ (goto-char (point-max))
+ (skip-chars-backward "\"")
+ (mark-sexp -1)))
(define-electric-pair-test autowrapping-7
"foo" "\"" :expected-string "``foo''" :expected-point 8
:modes '(tex-mode)
:test-in-comments nil
- :fixture-fn #'(lambda ()
- (electric-pair-mode 1)
- (goto-char (point-max))
- (skip-chars-backward "\"")
- (mark-sexp -1)))
+ :fixture-fn (lambda ()
+ (electric-pair-mode 1)
+ (goto-char (point-max))
+ (skip-chars-backward "\"")
+ (mark-sexp -1)))
;;; Electric quotes
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el
b/test/lisp/emacs-lisp/bytecomp-tests.el
index 5147cd2..c9ab3ec 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -41,7 +41,7 @@
"Identity, but hidden from some optimisations."
x)
-(defconst byte-opt-testsuite-arith-data
+(defconst bytecomp-tests--test-cases
'(
;; some functional tests
(let ((a most-positive-fixnum) (b 1) (c 1.0)) (+ a b c))
@@ -364,17 +364,17 @@
'((a c) (b c) (7 c) (-3 c) (nil nil) (t c) (q c) (r c) (s c)
(t c) (x "a") (x "c") (x c) (x d) (x e)))
- (mapcar (lambda (x) (cond ((member '(a . b) x) 1)
- ((equal x '(c)) 2)))
+ (mapcar (lambda (x) (ignore-errors (cond ((member '(a . b) x) 1)
+ ((equal x '(c)) 2))))
'(((a . b)) a b (c) (d)))
- (mapcar (lambda (x) (cond ((memq '(a . b) x) 1)
- ((equal x '(c)) 2)))
+ (mapcar (lambda (x) (ignore-errors (cond ((memq '(a . b) x) 1)
+ ((equal x '(c)) 2))))
'(((a . b)) a b (c) (d)))
- (mapcar (lambda (x) (cond ((member '(a b) x) 1)
- ((equal x '(c)) 2)))
+ (mapcar (lambda (x) (ignore-errors (cond ((member '(a b) x) 1)
+ ((equal x '(c)) 2))))
'(((a b)) a b (c) (d)))
- (mapcar (lambda (x) (cond ((memq '(a b) x) 1)
- ((equal x '(c)) 2)))
+ (mapcar (lambda (x) (ignore-errors (cond ((memq '(a b) x) 1)
+ ((equal x '(c)) 2))))
'(((a b)) a b (c) (d)))
(assoc 'b '((a 1) (b 2) (c 3)))
@@ -396,7 +396,7 @@
x)
(let ((x 1) (bytecomp-test-var 2) (y 3))
- (list x bytecomp-test-var (bytecomp-get-test-var) y))
+ (list x bytecomp-test-var (bytecomp-test-get-var) y))
(progn
(defvar d)
@@ -430,69 +430,126 @@
(list s x i))
(let ((x 2))
- (list (or (bytecomp-identity 'a) (setq x 3)) x)))
- "List of expression for test.
-Each element will be executed by interpreter and with
-bytecompiled code, and their results compared.")
+ (list (or (bytecomp-test-identity 'a) (setq x 3)) x))
-(defun bytecomp-check-1 (pat)
- "Return non-nil if PAT is the same whether directly evalled or compiled."
- (let ((warning-minimum-log-level :emergency)
- (byte-compile-warnings nil)
- (v0 (condition-case err
- (eval pat)
- (error (list 'bytecomp-check-error (car err)))))
- (v1 (condition-case err
- (funcall (byte-compile (list 'lambda nil pat)))
- (error (list 'bytecomp-check-error (car err))))))
- (equal v0 v1)))
-
-(put 'bytecomp-check-1 'ert-explainer 'bytecomp-explain-1)
-
-(defun bytecomp-explain-1 (pat)
- (let ((v0 (condition-case err
- (eval pat)
- (error (list 'bytecomp-check-error (car err)))))
- (v1 (condition-case err
- (funcall (byte-compile (list 'lambda nil pat)))
- (error (list 'bytecomp-check-error (car err))))))
- (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled."
- pat v0 v1)))
-
-(ert-deftest bytecomp-tests ()
- "Test the Emacs byte compiler."
- (dolist (pat byte-opt-testsuite-arith-data)
- (should (bytecomp-check-1 pat))))
-
-(defun test-byte-opt-arithmetic (&optional arg)
- "Unit test for byte-opt arithmetic operations.
-Subtests signal errors if something goes wrong."
- (interactive "P")
- (switch-to-buffer (generate-new-buffer "*Font Pase Test*"))
+ (let* ((x 1)
+ (y (condition-case x
+ (/ 1 0)
+ (arith-error x))))
+ (list x y))
+
+ (funcall
+ (condition-case x
+ (/ 1 0)
+ (arith-error (prog1 (lambda (y) (+ y x))
+ (setq x 10))))
+ 4)
+
+ ;; No error, no success handler.
+ (condition-case x
+ (list 42)
+ (error (cons 'bad x)))
+ ;; Error, no success handler.
+ (condition-case x
+ (/ 1 0)
+ (error (cons 'bad x)))
+ ;; No error, success handler.
+ (condition-case x
+ (list 42)
+ (error (cons 'bad x))
+ (:success (cons 'good x)))
+ ;; Error, success handler.
+ (condition-case x
+ (/ 1 0)
+ (error (cons 'bad x))
+ (:success (cons 'good x)))
+ ;; Verify that the success code is not subject to the error handlers.
+ (condition-case x
+ (list 42)
+ (error (cons 'bad x))
+ (:success (/ (car x) 0)))
+ ;; Check variable scoping on success.
+ (let ((x 2))
+ (condition-case x
+ (list x)
+ (error (list 'bad x))
+ (:success (list 'good x))))
+ ;; Check variable scoping on failure.
+ (let ((x 2))
+ (condition-case x
+ (/ 1 0)
+ (error (list 'bad x))
+ (:success (list 'good x))))
+ ;; Check capture of mutated result variable.
+ (funcall
+ (condition-case x
+ 3
+ (:success (prog1 (lambda (y) (+ y x))
+ (setq x 10))))
+ 4)
+ ;; Check for-effect context, on error.
+ (let ((f (lambda (x)
+ (condition-case nil
+ (/ 1 0)
+ (error 'bad)
+ (:success 'good))
+ (1+ x))))
+ (funcall f 3))
+ ;; Check for-effect context, on success.
+ (let ((f (lambda (x)
+ (condition-case nil
+ nil
+ (error 'bad)
+ (:success 'good))
+ (1+ x))))
+ (funcall f 3))
+ )
+ "List of expressions for cross-testing interpreted and compiled code.")
+
+(defconst bytecomp-tests--test-cases-lexbind-only
+ `(
+ ;; This would infloop (and exhaust stack) with dynamic binding.
+ (let ((f #'car))
+ (let ((f (lambda (x) (cons (funcall f x) (cdr x)))))
+ (funcall f '(1 . 2))))
+ )
+ "List of expressions for cross-testing interpreted and compiled code.
+These are only tested with lexical binding.")
+
+(defun bytecomp-tests--eval-interpreted (form)
+ "Evaluate FORM using the Lisp interpreter, returning errors as a
+special value."
+ (condition-case err
+ (eval form lexical-binding)
+ (error (list 'bytecomp-check-error (car err)))))
+
+(defun bytecomp-tests--eval-compiled (form)
+ "Evaluate FORM using the Lisp byte-code compiler, returning errors as a
+special value."
(let ((warning-minimum-log-level :emergency)
- (byte-compile-warnings nil)
- (pass-face '((t :foreground "green")))
- (fail-face '((t :foreground "red")))
- (print-escape-nonascii t)
- (print-escape-newlines t)
- (print-quoted t)
- v0 v1)
- (dolist (pat byte-opt-testsuite-arith-data)
- (condition-case err
- (setq v0 (eval pat))
- (error (setq v0 (list 'bytecomp-check-error (car err)))))
- (condition-case err
- (setq v1 (funcall (byte-compile (list 'lambda nil pat))))
- (error (setq v1 (list 'bytecomp-check-error (car err)))))
- (insert (format "%s" pat))
- (indent-to-column 65)
- (if (equal v0 v1)
- (insert (propertize "OK" 'face pass-face))
- (insert (propertize "FAIL\n" 'face fail-face))
- (indent-to-column 55)
- (insert (propertize (format "[%s] vs [%s]" v0 v1)
- 'face fail-face)))
- (insert "\n"))))
+ (byte-compile-warnings nil))
+ (condition-case err
+ (funcall (byte-compile (list 'lambda nil form)))
+ (error (list 'bytecomp-check-error (car err))))))
+
+(ert-deftest bytecomp-tests-lexbind ()
+ "Check that various expressions behave the same when interpreted and
+byte-compiled. Run with lexical binding."
+ (let ((lexical-binding t))
+ (dolist (form (append bytecomp-tests--test-cases-lexbind-only
+ bytecomp-tests--test-cases))
+ (ert-info ((prin1-to-string form) :prefix "form: ")
+ (should (equal (bytecomp-tests--eval-interpreted form)
+ (bytecomp-tests--eval-compiled form)))))))
+
+(ert-deftest bytecomp-tests-dynbind ()
+ "Check that various expressions behave the same when interpreted and
+byte-compiled. Run with dynamic binding."
+ (let ((lexical-binding nil))
+ (dolist (form bytecomp-tests--test-cases)
+ (ert-info ((prin1-to-string form) :prefix "form: ")
+ (should (equal (bytecomp-tests--eval-interpreted form)
+ (bytecomp-tests--eval-compiled form)))))))
(defun test-byte-comp-compile-and-load (compile &rest forms)
(declare (indent 1))
@@ -584,8 +641,8 @@ Subtests signal errors if something goes wrong."
`(with-current-buffer (get-buffer-create "*Compile-Log*")
(let ((inhibit-read-only t)) (erase-buffer))
(byte-compile ,@form)
- (ert-info ((buffer-string) :prefix "buffer: ")
- (should (re-search-forward ,re-warning)))))
+ (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ")
+ (should (re-search-forward ,(string-replace " " "[ \n]+"
re-warning))))))
(ert-deftest bytecomp-warn-wrong-args ()
(bytecomp--with-warning-test "remq.*3.*2"
@@ -611,12 +668,13 @@ Subtests signal errors if something goes wrong."
(defmacro bytecomp--define-warning-file-test (file re-warning &optional
reverse)
`(ert-deftest ,(intern (format "bytecomp/%s" file)) ()
- :expected-result ,(if reverse :failed :passed)
(with-current-buffer (get-buffer-create "*Compile-Log*")
(let ((inhibit-read-only t)) (erase-buffer))
(byte-compile-file ,(ert-resource-file file))
(ert-info ((buffer-string) :prefix "buffer: ")
- (should (re-search-forward ,re-warning))))))
+ (,(if reverse 'should-not 'should)
+ (re-search-forward ,(string-replace " " "[ \n]+" re-warning)
+ nil t))))))
(bytecomp--define-warning-file-test "error-lexical-var-with-add-hook.el"
"add-hook.*lexical var")
@@ -658,10 +716,10 @@ Subtests signal errors if something goes wrong."
"free.*foo")
(bytecomp--define-warning-file-test "warn-free-variable-reference.el"
- "free.*bar")
+ "free variable .bar")
(bytecomp--define-warning-file-test "warn-make-variable-buffer-local.el"
- "make-variable-buffer-local.*not called at
toplevel")
+ "make-variable-buffer-local. not called at
toplevel")
(bytecomp--define-warning-file-test "warn-interactive-only.el"
"next-line.*interactive use only.*forward-line")
@@ -670,19 +728,19 @@ Subtests signal errors if something goes wrong."
"malformed interactive spec")
(bytecomp--define-warning-file-test "warn-obsolete-defun.el"
- "foo-obsolete.*obsolete function.*99.99")
+ "foo-obsolete. is an obsolete function (as of 99.99)")
(defvar bytecomp--tests-obsolete-var nil)
(make-obsolete-variable 'bytecomp--tests-obsolete-var nil "99.99")
(bytecomp--define-warning-file-test "warn-obsolete-hook.el"
- "bytecomp--tests-obs.*obsolete[^z-a]*99.99")
+ "bytecomp--tests-obsolete-var. is an obsolete variable (as of 99.99)")
(bytecomp--define-warning-file-test "warn-obsolete-variable-same-file.el"
"foo-obs.*obsolete.*99.99" t)
(bytecomp--define-warning-file-test "warn-obsolete-variable.el"
- "bytecomp--tests-obs.*obsolete[^z-a]*99.99")
+ "bytecomp--tests-obsolete-var. is an obsolete variable (as of 99.99)")
(bytecomp--define-warning-file-test "warn-obsolete-variable-bound.el"
"bytecomp--tests-obs.*obsolete.*99.99" t)
@@ -713,64 +771,64 @@ Subtests signal errors if something goes wrong."
(bytecomp--define-warning-file-test
"warn-wide-docstring-autoload.el"
- "autoload.*foox.*wider than.*characters")
+ "autoload .foox. docstring wider than .* characters")
(bytecomp--define-warning-file-test
"warn-wide-docstring-custom-declare-variable.el"
- "custom-declare-variable.*foo.*wider than.*characters")
+ "custom-declare-variable .foo. docstring wider than .* characters")
(bytecomp--define-warning-file-test
"warn-wide-docstring-defalias.el"
- "defalias.*foo.*wider than.*characters")
+ "defalias .foo. docstring wider than .* characters")
(bytecomp--define-warning-file-test
"warn-wide-docstring-defconst.el"
- "defconst.*foo.*wider than.*characters")
+ "defconst .foo-bar. docstring wider than .* characters")
(bytecomp--define-warning-file-test
"warn-wide-docstring-define-abbrev-table.el"
- "define-abbrev.*foo.*wider than.*characters")
+ "define-abbrev-table .foo. docstring wider than .* characters")
(bytecomp--define-warning-file-test
"warn-wide-docstring-define-obsolete-function-alias.el"
- "defalias.*foo.*wider than.*characters")
+ "defalias .foo. docstring wider than .* characters")
(bytecomp--define-warning-file-test
"warn-wide-docstring-define-obsolete-variable-alias.el"
- "defvaralias.*foo.*wider than.*characters")
+ "defvaralias .foo. docstring wider than .* characters")
;; TODO: We don't yet issue warnings for defuns.
(bytecomp--define-warning-file-test
"warn-wide-docstring-defun.el"
- "wider than.*characters" 'reverse)
+ "wider than .* characters" 'reverse)
(bytecomp--define-warning-file-test
"warn-wide-docstring-defvar.el"
- "defvar.*foo.*wider than.*characters")
+ "defvar .foo-bar. docstring wider than .* characters")
(bytecomp--define-warning-file-test
"warn-wide-docstring-defvaralias.el"
- "defvaralias.*foo.*wider than.*characters")
+ "defvaralias .foo-bar. docstring wider than .* characters")
(bytecomp--define-warning-file-test
"warn-wide-docstring-ignore-fill-column.el"
- "defvar.*foo.*wider than.*characters" 'reverse)
+ "defvar .foo-bar. docstring wider than .* characters" 'reverse)
(bytecomp--define-warning-file-test
"warn-wide-docstring-ignore-override.el"
- "defvar.*foo.*wider than.*characters" 'reverse)
+ "defvar .foo-bar. docstring wider than .* characters" 'reverse)
(bytecomp--define-warning-file-test
"warn-wide-docstring-ignore.el"
- "defvar.*foo.*wider than.*characters" 'reverse)
+ "defvar .foo-bar. docstring wider than .* characters" 'reverse)
(bytecomp--define-warning-file-test
"warn-wide-docstring-multiline-first.el"
- "defvar.*foo.*wider than.*characters")
+ "defvar .foo-bar. docstring wider than .* characters")
(bytecomp--define-warning-file-test
"warn-wide-docstring-multiline.el"
- "defvar.*foo.*wider than.*characters")
+ "defvar .foo-bar. docstring wider than .* characters")
(bytecomp--define-warning-file-test
"nowarn-inline-after-defvar.el"
@@ -813,47 +871,6 @@ Subtests signal errors if something goes wrong."
(defun def () (m))))
(should (equal (funcall 'def) 4)))
-(defconst bytecomp-lexbind-tests
- `(
- (let ((f #'car))
- (let ((f (lambda (x) (cons (funcall f x) (cdr x)))))
- (funcall f '(1 . 2))))
- )
- "List of expression for test.
-Each element will be executed by interpreter and with
-bytecompiled code, and their results compared.")
-
-(defun bytecomp-lexbind-check-1 (pat)
- "Return non-nil if PAT is the same whether directly evalled or compiled."
- (let ((warning-minimum-log-level :emergency)
- (byte-compile-warnings nil)
- (v0 (condition-case err
- (eval pat t)
- (error (list 'bytecomp-check-error (car err)))))
- (v1 (condition-case err
- (funcall (let ((lexical-binding t))
- (byte-compile `(lambda nil ,pat))))
- (error (list 'bytecomp-check-error (car err))))))
- (equal v0 v1)))
-
-(put 'bytecomp-lexbind-check-1 'ert-explainer 'bytecomp-lexbind-explain-1)
-
-(defun bytecomp-lexbind-explain-1 (pat)
- (let ((v0 (condition-case err
- (eval pat t)
- (error (list 'bytecomp-check-error (car err)))))
- (v1 (condition-case err
- (funcall (let ((lexical-binding t))
- (byte-compile (list 'lambda nil pat))))
- (error (list 'bytecomp-check-error (car err))))))
- (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled."
- pat v0 v1)))
-
-(ert-deftest bytecomp-lexbind-tests ()
- "Test the Emacs byte compiler lexbind handling."
- (dolist (pat bytecomp-lexbind-tests)
- (should (bytecomp-lexbind-check-1 pat))))
-
(defmacro bytecomp-tests--with-temp-file (file-name-var &rest body)
(declare (indent 1))
(cl-check-type file-name-var symbol)
@@ -1227,6 +1244,74 @@ compiled correctly."
(let ((lexical-binding t))
(should (equal (funcall (byte-compile '(lambda (x) "foo")) 'dummy)
"foo"))))
+(ert-deftest bytecomp-condition-case-success ()
+ ;; No error, no success handler.
+ (should (equal (condition-case x
+ (list 42)
+ (error (cons 'bad x)))
+ '(42)))
+ ;; Error, no success handler.
+ (should (equal (condition-case x
+ (/ 1 0)
+ (error (cons 'bad x)))
+ '(bad arith-error)))
+ ;; No error, success handler.
+ (should (equal (condition-case x
+ (list 42)
+ (error (cons 'bad x))
+ (:success (cons 'good x)))
+ '(good 42)))
+ ;; Error, success handler.
+ (should (equal (condition-case x
+ (/ 1 0)
+ (error (cons 'bad x))
+ (:success (cons 'good x)))
+ '(bad arith-error)))
+ ;; Verify that the success code is not subject to the error handlers.
+ (should-error (condition-case x
+ (list 42)
+ (error (cons 'bad x))
+ (:success (/ (car x) 0)))
+ :type 'arith-error)
+ ;; Check variable scoping.
+ (let ((x 2))
+ (should (equal (condition-case x
+ (list x)
+ (error (list 'bad x))
+ (:success (list 'good x)))
+ '(good (2))))
+ (should (equal (condition-case x
+ (/ 1 0)
+ (error (list 'bad x))
+ (:success (list 'good x)))
+ '(bad (arith-error)))))
+ ;; Check capture of mutated result variable.
+ (should (equal (funcall
+ (condition-case x
+ 3
+ (:success (prog1 (lambda (y) (+ y x))
+ (setq x 10))))
+ 4)
+ 14))
+ ;; Check for-effect context, on error.
+ (should (equal (let ((f (lambda (x)
+ (condition-case nil
+ (/ 1 0)
+ (error 'bad)
+ (:success 'good))
+ (1+ x))))
+ (funcall f 3))
+ 4))
+ ;; Check for-effect context, on success.
+ (should (equal (let ((f (lambda (x)
+ (condition-case nil
+ nil
+ (error 'bad)
+ (:success 'good))
+ (1+ x))))
+ (funcall f 3))
+ 4)))
+
;; Local Variables:
;; no-byte-compile: t
;; End:
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el
b/test/lisp/emacs-lisp/cl-macs-tests.el
index dd64876..f4e2e46 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -629,14 +629,25 @@ collection clause."
(let (n1)
(and xs
(progn (setq n1 (1+ n))
- (len2 (cdr xs) n1)))))))
+ (len2 (cdr xs) n1))))))
+ ;; Tail calls in error and success handlers.
+ (len3 (xs n)
+ (if xs
+ (condition-case k
+ (/ 1 (logand n 1))
+ (arith-error (len3 (cdr xs) (1+ n)))
+ (:success (len3 (cdr xs) (+ n k))))
+ n)))
(should (equal (len nil 0) 0))
(should (equal (len2 nil 0) 0))
+ (should (equal (len3 nil 0) 0))
(should (equal (len list-42 0) 42))
(should (equal (len2 list-42 0) 42))
+ (should (equal (len3 list-42 0) 42))
;; Should not bump into stack depth limits.
(should (equal (len list-42k 0) 42000))
- (should (equal (len2 list-42k 0) 42000))))
+ (should (equal (len2 list-42k 0) 42000))
+ (should (equal (len3 list-42k 0) 42000))))
;; Check that non-recursive functions are handled more efficiently.
(should (pcase (macroexpand '(cl-labels ((f (x) (+ x 1))) (f 5)))
diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el
b/test/lisp/emacs-lisp/comp-cstr-tests.el
new file mode 100644
index 0000000..59e1b69
--- /dev/null
+++ b/test/lisp/emacs-lisp/comp-cstr-tests.el
@@ -0,0 +1,233 @@
+;;; comp-cstr-tests.el --- unit tests for src/comp.c -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
+
+;; Author: Andrea Corallo <akrl@sdf.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:
+
+;; Unit tests for lisp/emacs-lisp/comp-cstr.el
+
+;;; Code:
+
+(require 'ert)
+(require 'cl-lib)
+(require 'comp-cstr)
+
+(cl-eval-when (compile eval load)
+
+ (defun comp-cstr-test-ts (type-spec)
+ "Create a constraint from TYPE-SPEC and convert it back to type specifier."
+ (let ((comp-ctxt (make-comp-cstr-ctxt)))
+ (comp-cstr-to-type-spec (comp-type-spec-to-cstr type-spec))))
+
+ (defun comp-cstr-typespec-test (number type-spec expected-type-spec)
+ `(ert-deftest ,(intern (concat "comp-cstr-test-" (int-to-string number)))
()
+ (should (equal (comp-cstr-test-ts ',type-spec)
+ ',expected-type-spec))))
+
+ (defconst comp-cstr-typespec-tests-alist
+ `(;; 1
+ (symbol . symbol)
+ ;; 2
+ ((or string array) . array)
+ ;; 3
+ ((or symbol number) . (or number symbol))
+ ;; 4
+ ((or cons atom) . (or atom cons)) ;; SBCL return T
+ ;; 5
+ ((or integer number) . number)
+ ;; 6
+ ((or (or integer symbol) number) . (or number symbol))
+ ;; 7
+ ((or (or integer symbol) (or number list)) . (or list number symbol))
+ ;; 8
+ ((or (or integer number) nil) . number)
+ ;; 9
+ ((member foo) . (member foo))
+ ;; 10
+ ((member foo bar) . (member bar foo))
+ ;; 11
+ ((or (member foo) (member bar)) . (member bar foo))
+ ;; 12
+ ((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER
FOO))
+ ;; 13
+ ((or (member foo) number) . (or (member foo) number))
+ ;; 14
+ ((or (integer 1 3) number) . number)
+ ;; 15
+ (integer . integer)
+ ;; 16
+ ((integer 1 2) . (integer 1 2))
+ ;; 17
+ ((or (integer -1 0) (integer 3 4)) . (or (integer -1 0) (integer 3
4)))
+ ;; 18
+ ((or (integer -1 2) (integer 3 4)) . (integer -1 4))
+ ;; 19
+ ((or (integer -1 3) (integer 3 4)) . (integer -1 4))
+ ;; 20
+ ((or (integer -1 4) (integer 3 4)) . (integer -1 4))
+ ;; 21
+ ((or (integer -1 5) (integer 3 4)) . (integer -1 5))
+ ;; 22
+ ((or (integer -1 *) (integer 3 4)) . (integer -1 *))
+ ;; 23
+ ((or (integer -1 2) (integer * 4)) . (integer * 4))
+ ;; 24
+ ((and string array) . string)
+ ;; 25
+ ((and cons atom) . nil)
+ ;; 26
+ ((and (member foo) (member foo bar baz)) . (member foo))
+ ;; 27
+ ((and (member foo) (member bar)) . nil)
+ ;; 28
+ ((and (member foo) symbol) . (member foo))
+ ;; 29
+ ((and (member foo) string) . nil)
+ ;; 30
+ ((and (member foo) (integer 1 2)) . nil)
+ ;; 31
+ ((and (member 1 2) (member 3 2)) . (integer 2 2))
+ ;; 32
+ ((and number (integer 1 2)) . (integer 1 2))
+ ;; 33
+ ((and integer (integer 1 2)) . (integer 1 2))
+ ;; 34
+ ((and (integer -1 0) (integer 3 5)) . nil)
+ ;; 35
+ ((and (integer -1 2) (integer 3 5)) . nil)
+ ;; 36
+ ((and (integer -1 3) (integer 3 5)) . (integer 3 3))
+ ;; 37
+ ((and (integer -1 4) (integer 3 5)) . (integer 3 4))
+ ;; 38
+ ((and (integer -1 5) nil) . nil)
+ ;; 39
+ ((not symbol) . (not symbol))
+ ;; 40
+ ((or (member foo) (not (member foo bar))) . (not (member bar)))
+ ;; 41
+ ((or (member foo bar) (not (member foo))) . t)
+ ;; 42
+ ((or symbol (not sequence)) . (not sequence))
+ ;; 43
+ ((or symbol (not symbol)) . t)
+ ;; 44
+ ((or symbol (not sequence)) . (not sequence))
+ ;; 45 Conservative.
+ ((or vector (not sequence)) . t)
+ ;; 46
+ ((or (integer 1 10) (not (integer * 5))) . (not (integer * 0)))
+ ;; 47
+ ((or symbol (integer 1 10) (not (integer * 5))) . (not (integer * 0)))
+ ;; 48
+ ((or (not symbol) (integer 1 10) (not (integer * 5))) . (not (or symbol
(integer * 0))))
+ ;; 49
+ ((or symbol (not (member foo))) . (not (member foo)))
+ ;; 50
+ ((or (not symbol) (not (member foo))) . (not symbol))
+ ;; 51 Conservative.
+ ((or (not (member foo)) string) . (not (member foo)))
+ ;; 52 Conservative.
+ ((or (member foo) (not string)) . (not string))
+ ;; 53
+ ((or (not (integer 1 2)) integer) . t)
+ ;; 54
+ ((or (not (integer 1 2)) (not integer)) . (not integer))
+ ;; 55
+ ((or (integer 1 2) (not integer)) . (not (or (integer * 0) (integer 3
*))))
+ ;; 56
+ ((or number (not (integer 1 2))) . t)
+ ;; 57
+ ((or atom (not (integer 1 2))) . t)
+ ;; 58
+ ((or atom (not (member foo))) . t)
+ ;; 59
+ ((and symbol (not cons)) . symbol)
+ ;; 60
+ ((and symbol (not symbol)) . nil)
+ ;; 61
+ ((and atom (not symbol)) . atom)
+ ;; 62
+ ((and atom (not string)) . (or array sequence atom))
+ ;; 63 Conservative
+ ((and symbol (not (member foo))) . symbol)
+ ;; 64 Conservative
+ ((and symbol (not (member 3))) . symbol)
+ ;; 65
+ ((and (not (member foo)) (integer 1 10)) . (integer 1 10))
+ ;; 66
+ ((and (member foo) (not (integer 1 10))) . (member foo))
+ ;; 67
+ ((and t (not (member foo))) . (not (member foo)))
+ ;; 68
+ ((and integer (not (integer 3 4))) . (or (integer * 2) (integer 5 *)))
+ ;; 69
+ ((and (integer 0 20) (not (integer 5 10))) . (or (integer 0 4) (integer
11 20)))
+ ;; 70
+ ((and (not (member a)) (not (member b))) . (not (member a b)))
+ ;; 71
+ ((and (not boolean) (not (member b))) . (not (or (member b) boolean)))
+ ;; 72
+ ((and t (integer 1 1)) . (integer 1 1))
+ ;; 73
+ ((not (integer -1 5)) . (not (integer -1 5)))
+ ;; 74
+ ((and boolean (or number marker)) . nil)
+ ;; 75
+ ((and atom (or number marker)) . (or marker number))
+ ;; 76
+ ((and symbol (or number marker)) . nil)
+ ;; 77
+ ((and (or symbol string) (or number marker)) . nil)
+ ;; 78
+ ((and t t) . t)
+ ;; 79
+ ((and (or marker number) (integer 0 0)) . (integer 0 0))
+ ;; 80
+ ((and t (not t)) . nil)
+ ;; 81
+ ((or (integer 1 1) (not (integer 1 1))) . t)
+ ;; 82
+ ((not t) . nil)
+ ;; 83
+ ((not nil) . t)
+ ;; 84
+ ((or (not string) t) . t)
+ ;; 85
+ ((or (not vector) sequence) . sequence)
+ ;; 86
+ ((or (not symbol) null) . t)
+ ;; 87
+ ((and (or null integer) (not (or null integer))) . nil)
+ ;; 88
+ ((and (or (member a b c)) (not (or (member a b)))) . (member c)))
+ "Alist type specifier -> expected type specifier."))
+
+(defmacro comp-cstr-synthesize-tests ()
+ "Generate all tests from `comp-cstr-typespec-tests-alist'."
+ `(progn
+ ,@(cl-loop
+ for i from 1
+ for (ts . exp-ts) in comp-cstr-typespec-tests-alist
+ append (list (comp-cstr-typespec-test i ts exp-ts)))))
+
+(comp-cstr-synthesize-tests)
+
+;;; comp-cstr-tests.el ends here
diff --git a/test/lisp/emacs-lisp/edebug-tests.el
b/test/lisp/emacs-lisp/edebug-tests.el
index dcb261c..7d45432 100644
--- a/test/lisp/emacs-lisp/edebug-tests.el
+++ b/test/lisp/emacs-lisp/edebug-tests.el
@@ -1061,5 +1061,30 @@ backtracking (Bug#42701)."
"edebug-anon10001"
"edebug-tests-duplicate-symbol-backtrack"))))))
+(defmacro edebug-tests--duplicate-&define (_arg)
+ "Helper macro for the ERT test `edebug-tests-duplicate-&define'.
+The Edebug specification is similar to the one used by `cl-flet'
+previously; see Bug#41988."
+ (declare (debug (&or (&define name function-form) (defun)))))
+
+(ert-deftest edebug-tests-duplicate-&define ()
+ "Check that Edebug doesn't backtrack out of `&define' forms.
+This avoids potential duplicate definitions (Bug#41988)."
+ (with-temp-buffer
+ (print '(defun edebug-tests-duplicate-&define ()
+ (edebug-tests--duplicate-&define
+ (edebug-tests-duplicate-&define-inner () nil)))
+ (current-buffer))
+ (let* ((edebug-all-defs t)
+ (edebug-initial-mode 'Go-nonstop)
+ (instrumented-names ())
+ (edebug-new-definition-function
+ (lambda (name)
+ (when (memq name instrumented-names)
+ (error "Duplicate definition of `%s'" name))
+ (push name instrumented-names)
+ (edebug-new-definition name))))
+ (should-error (eval-buffer) :type 'invalid-read-syntax))))
+
(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 285616a..9f9bb73 100644
--- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el
+++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el
@@ -1,4 +1,4 @@
-;;; eieio-testsinvoke.el -- eieio tests for method invocation -*-
lexical-binding:t -*-
+;;; eieio-test-methodinvoke.el --- eieio tests for method invocation -*-
lexical-binding:t -*-
;; Copyright (C) 2005, 2008, 2010, 2013-2021 Free Software Foundation,
;; Inc.
diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
index a47fb80..11ffc11 100644
--- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
+++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
@@ -1,4 +1,4 @@
-;;; eieio-tests.el -- eieio test routines -*- lexical-binding: t -*-
+;;; eieio-tests.el --- eieio test routines -*- lexical-binding: t -*-
;; Copyright (C) 1999-2003, 2005-2010, 2012-2021 Free Software
;; Foundation, Inc.
diff --git a/test/lisp/epg-config-tests.el b/test/lisp/epg-config-tests.el
new file mode 100644
index 0000000..fba61e5
--- /dev/null
+++ b/test/lisp/epg-config-tests.el
@@ -0,0 +1,47 @@
+;;; epg-config-tests.el --- Test suite for epg.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+(require 'epg-config)
+
+(ert-deftest epg-config-test-epg-find-configuration ()
+ (skip-unless (executable-find "gpg2"))
+ (should (assq 'version (epg-find-configuration 'OpenPGP))))
+
+(ert-deftest epg-config-test-epg-find-configuration/unknown-protocol ()
+ (should-error (epg-find-configuration 'does-not-exist)))
+
+(ert-deftest epg-config-test-epg-check-configuration ()
+ (should (epg-check-configuration '((version . "1.0")) "0.9"))
+ (should (epg-check-configuration '((version . "1.0")) "1.0"))
+ (should-error (epg-check-configuration '((version . "1.0")) "1.1"))
+ (should-error (epg-check-configuration '((version . "1.0")) 'foo))
+ (should-error (epg-check-configuration '((version . "1.0")) "foo")))
+
+(ert-deftest epg-config-test-epg-required-version-p ()
+ (skip-unless (executable-find "gpg2"))
+ (should (epg-required-version-p 'OpenPGP "1.0")))
+
+(provide 'epg-config-tests)
+
+;;; epg-config-tests.el ends here
diff --git a/test/lisp/eshell/em-hist-tests.el
b/test/lisp/eshell/em-hist-tests.el
index ec65397..31967a6 100644
--- a/test/lisp/eshell/em-hist-tests.el
+++ b/test/lisp/eshell/em-hist-tests.el
@@ -1,4 +1,4 @@
-;;; tests/em-hist-tests.el --- em-hist test suite -*- lexical-binding:t -*-
+;;; em-hist-tests.el --- em-hist test suite -*- lexical-binding:t -*-
;; Copyright (C) 2017-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/eshell/em-ls-tests.el b/test/lisp/eshell/em-ls-tests.el
index fc2cd9c..5d1742b 100644
--- a/test/lisp/eshell/em-ls-tests.el
+++ b/test/lisp/eshell/em-ls-tests.el
@@ -1,4 +1,4 @@
-;;; tests/em-ls-tests.el --- em-ls test suite -*- lexical-binding:t -*-
+;;; em-ls-tests.el --- em-ls test suite -*- lexical-binding:t -*-
;; Copyright (C) 2017-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/eshell/esh-opt-tests.el
b/test/lisp/eshell/esh-opt-tests.el
index 0c99da6..e2a0ea5 100644
--- a/test/lisp/eshell/esh-opt-tests.el
+++ b/test/lisp/eshell/esh-opt-tests.el
@@ -1,4 +1,4 @@
-;;; tests/esh-opt-tests.el --- esh-opt test suite -*- lexical-binding:t -*-
+;;; esh-opt-tests.el --- esh-opt test suite -*- lexical-binding:t -*-
;; Copyright (C) 2018-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/eshell/eshell-tests.el b/test/lisp/eshell/eshell-tests.el
index 4dac702..4f0cc9b 100644
--- a/test/lisp/eshell/eshell-tests.el
+++ b/test/lisp/eshell/eshell-tests.el
@@ -1,4 +1,4 @@
-;;; tests/eshell-tests.el --- Eshell test suite -*- lexical-binding:t -*-
+;;; eshell-tests.el --- Eshell test suite -*- lexical-binding:t -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el
index 4a2f1f9..13350b2 100644
--- a/test/lisp/filenotify-tests.el
+++ b/test/lisp/filenotify-tests.el
@@ -117,8 +117,9 @@ There are different timeouts for local and remote file
notification libraries."
(defun file-notify--test-timeout ()
"Timeout to wait for arriving a bunch of events, in seconds."
(cond
+ ((file-remote-p temporary-file-directory) 20)
((eq system-type 'cygwin) 10)
- ((file-remote-p temporary-file-directory) 6)
+ ((getenv "EMACS_EMBA_CI") 10)
((string-equal (file-notify--test-library) "w32notify") 4)
(t 3)))
diff --git a/test/lisp/gnus/message-tests.el b/test/lisp/gnus/message-tests.el
index 8650053..36ec8c5 100644
--- a/test/lisp/gnus/message-tests.el
+++ b/test/lisp/gnus/message-tests.el
@@ -1,4 +1,4 @@
-;;; message-mode-tests.el --- Tests for message-mode -*- lexical-binding: t;
-*-
+;;; message-tests.el --- Tests for message-mode -*- lexical-binding: t; -*-
;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el
index 80d90da..099d627 100644
--- a/test/lisp/help-fns-tests.el
+++ b/test/lisp/help-fns-tests.el
@@ -62,12 +62,16 @@ Return first line of the output of (describe-function-1
FUNC)."
(should (string-match regexp result))))
(ert-deftest help-fns-test-lisp-defun ()
- (let ((regexp "a compiled Lisp function in .+subr\\.el")
+ (let ((regexp (if (boundp 'comp-ctxt)
+ "a native compiled Lisp function in .+subr\\.el"
+ "a compiled Lisp function in .+subr\\.el"))
(result (help-fns-tests--describe-function 'last)))
(should (string-match regexp result))))
(ert-deftest help-fns-test-lisp-defsubst ()
- (let ((regexp "a compiled Lisp function in .+subr\\.el")
+ (let ((regexp (if (boundp 'comp-ctxt)
+ "a native compiled Lisp function in .+subr\\.el"
+ "a compiled Lisp function in .+subr\\.el"))
(result (help-fns-tests--describe-function 'posn-window)))
(should (string-match regexp result))))
diff --git a/test/lisp/info-xref-tests.el b/test/lisp/info-xref-tests.el
index 95af21f..ecba861 100644
--- a/test/lisp/info-xref-tests.el
+++ b/test/lisp/info-xref-tests.el
@@ -1,4 +1,4 @@
-;;; info-xref.el --- tests for info-xref.el -*- lexical-binding:t -*-
+;;; info-xref-tests.el --- tests for info-xref.el -*- lexical-binding:t -*-
;; Copyright (C) 2013-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/international/ucs-normalize-tests.el
b/test/lisp/international/ucs-normalize-tests.el
index a2da737..51f4ed3 100644
--- a/test/lisp/international/ucs-normalize-tests.el
+++ b/test/lisp/international/ucs-normalize-tests.el
@@ -1,4 +1,4 @@
-;;; ucs-normalize --- tests for international/ucs-normalize.el -*-
lexical-binding: t -*-
+;;; ucs-normalize-tests.el --- tests for international/ucs-normalize.el -*-
lexical-binding: t -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/loadhist-tests.el b/test/lisp/loadhist-tests.el
new file mode 100644
index 0000000..b29796d
--- /dev/null
+++ b/test/lisp/loadhist-tests.el
@@ -0,0 +1,57 @@
+;;; loadhist-tests.el --- Tests for loadhist.el -*- lexical-binding:t -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; Author: Stefan Kangas <stefankangas@gmail.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:
+
+;;; Code:
+
+(require 'ert)
+(require 'loadhist)
+
+(ert-deftest loadhist-tests-feature-symbols ()
+ (should (equal (file-name-base (car (feature-symbols 'loadhist)))
"loadhist"))
+ (should-not (feature-symbols 'non-existent-feature)))
+
+(ert-deftest loadhist-tests-feature-file ()
+ (should (equal (file-name-base (feature-file 'loadhist)) "loadhist"))
+ (should-error (feature-file 'non-existent-feature)))
+
+(ert-deftest loadhist-tests-file-loadhist-lookup ()
+ ;; This should probably be extended...
+ (should (listp (file-loadhist-lookup "loadhist"))))
+
+(ert-deftest loadhist-tests-file-provides ()
+ (should (eq (car (file-provides "loadhist")) 'loadhist)))
+
+(ert-deftest loadhist-tests-file-requires ()
+ (should-not (file-requires "loadhist")))
+
+(ert-deftest loadhist-tests-file-dependents ()
+ (require 'dired-x)
+ (let ((deps (file-dependents "dired")))
+ (should (member "dired-x" (mapcar #'file-name-base deps)))))
+
+(ert-deftest loadhist-tests-unload-feature ()
+ (require 'dired-x)
+ (should-error (unload-feature 'dired))
+ (unload-feature 'dired-x))
+
+;;; loadhist-tests.el ends here
diff --git a/test/lisp/play/cookie1-tests.el b/test/lisp/lpr-tests.el
similarity index 53%
copy from test/lisp/play/cookie1-tests.el
copy to test/lisp/lpr-tests.el
index d63ecb9..bc31982 100644
--- a/test/lisp/play/cookie1-tests.el
+++ b/test/lisp/lpr-tests.el
@@ -1,4 +1,4 @@
-;;; fortune-tests.el --- Tests for fortune.el -*- lexical-binding: t -*-
+;;; lpr-tests.el --- Tests for lpr.el -*- lexical-binding: t -*-
;; Copyright (C) 2021 Free Software Foundation, Inc.
@@ -22,19 +22,20 @@
;;; Code:
(require 'ert)
-(require 'ert-x)
-(require 'cookie1)
-
-(ert-deftest cookie1-tests-cookie ()
- (let ((fortune-file (ert-resource-file "cookies")))
- (should (string-match "\\`This fortune"
- (cookie fortune-file)))))
-
-(ert-deftest cookie1-testss-cookie-apropos ()
- (let ((fortune-file (ert-resource-file "cookies")))
- (should (string-match "\\`This fortune"
- (car (cookie-apropos "false" fortune-file))))
- (should (= (length (cookie-apropos "false" fortune-file)) 1))))
-
-(provide 'fortune-tests)
-;;; fortune-tests.el ends here
+(require 'lpr)
+
+(ert-deftest lpr-test-printify-region ()
+ (with-temp-buffer
+ (insert "foo\^@-\^h\^k\^n-\^_\177bar")
+ (printify-region (point-min) (point-max))
+ (should (equal (buffer-string) "foo\\^@-\\^H\\^K\\^N-\\^_\\7fbar"))))
+
+(ert-deftest lpr-test-lpr-eval-switch ()
+ (should (equal (lpr-eval-switch "foo") "foo"))
+ (should (equal (lpr-eval-switch (lambda () "foo")) "foo"))
+ (let ((v "foo"))
+ (should (equal (lpr-eval-switch v) "foo")))
+ (should (equal (lpr-eval-switch (list #'identity "foo")) "foo"))
+ (should (equal (lpr-eval-switch 1) nil)))
+
+;;; lpr-tests.el ends here
diff --git a/test/lisp/minibuffer-tests.el b/test/lisp/minibuffer-tests.el
index 791e51c..6ab5f57 100644
--- a/test/lisp/minibuffer-tests.el
+++ b/test/lisp/minibuffer-tests.el
@@ -83,7 +83,12 @@
(let* ((origtable '("A-hello" "A-there"))
(subvtable (completion-table-subvert origtable "B" "A")))
(should (equal (try-completion "B-hel" subvtable)
- "B-hello"))))
+ "B-hello"))
+ (should (equal (all-completions "B-hel" subvtable) '("-hello")))
+ (should (test-completion "B-hello" subvtable))
+ (should (equal (completion-boundaries "B-hel" subvtable
+ nil "suffix")
+ '(1 . 6)))))
(ert-deftest completion-table-test-quoting ()
(let ((process-environment
@@ -131,5 +136,57 @@
(should (equal (completion-pcm--optimize-pattern '(any "" any))
'(any))))
+(defun test-completion-all-sorted-completions (base def history-var
history-list)
+ (with-temp-buffer
+ (insert base)
+ (cl-letf (((symbol-function #'minibufferp) (lambda (&rest _) t)))
+ (let ((completion-styles '(basic))
+ (completion-category-defaults nil)
+ (completion-category-overrides nil)
+ (minibuffer-history-variable history-var)
+ (minibuffer-history history-list)
+ (minibuffer-default def)
+ (minibuffer-completion-table
+ (lambda (str pred action)
+ (pcase action
+ (`(boundaries . ,_) `(boundaries ,(length base) . 0))
+ (_ (complete-with-action
+ action
+ '("epsilon" "alpha" "gamma" "beta" "delta")
+ (substring str (length base)) pred))))))
+ (completion-all-sorted-completions)))))
+
+(ert-deftest completion-all-sorted-completions ()
+ ;; No base, disabled history, no default
+ (should (equal (test-completion-all-sorted-completions
+ "" nil t nil)
+ `("beta" "alpha" "delta" "gamma" "epsilon" . 0)))
+ ;; No base, disabled history, default string
+ (should (equal (test-completion-all-sorted-completions
+ "" "gamma" t nil)
+ `("gamma" "beta" "alpha" "delta" "epsilon" . 0)))
+ ;; No base, empty history, default string
+ (should (equal (test-completion-all-sorted-completions
+ "" "gamma" 'minibuffer-history nil)
+ `("gamma" "beta" "alpha" "delta" "epsilon" . 0)))
+ ;; No base, empty history, default list
+ (should (equal (test-completion-all-sorted-completions
+ "" '("gamma" "zeta") 'minibuffer-history nil)
+ `("gamma" "beta" "alpha" "delta" "epsilon" . 0)))
+ ;; No base, history, default string
+ (should (equal (test-completion-all-sorted-completions
+ "" "gamma" 'minibuffer-history '("other" "epsilon" "delta"))
+ `("gamma" "epsilon" "delta" "beta" "alpha" . 0)))
+ ;; Base, history, default string
+ (should (equal (test-completion-all-sorted-completions
+ "base/" "base/gamma" 'minibuffer-history
+ '("some/alpha" "base/epsilon" "base/delta"))
+ `("gamma" "epsilon" "delta" "beta" "alpha" . 5)))
+ ;; Base, history, default string
+ (should (equal (test-completion-all-sorted-completions
+ "base/" "gamma" 'minibuffer-history
+ '("some/alpha" "base/epsilon" "base/delta"))
+ `("epsilon" "delta" "beta" "alpha" "gamma" . 5))))
+
(provide 'minibuffer-tests)
;;; minibuffer-tests.el ends here
diff --git a/test/lisp/net/nsm-tests.el b/test/lisp/net/nsm-tests.el
index ff45331..1a35ec3 100644
--- a/test/lisp/net/nsm-tests.el
+++ b/test/lisp/net/nsm-tests.el
@@ -1,4 +1,4 @@
-;;; network-stream-tests.el --- tests for network security manager -*-
lexical-binding: t; -*-
+;;; nsm-tests.el --- tests for network security manager -*- lexical-binding:
t; -*-
;; Copyright (C) 2019-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/net/shr-tests.el b/test/lisp/net/shr-tests.el
index a06e31a..ed532af 100644
--- a/test/lisp/net/shr-tests.el
+++ b/test/lisp/net/shr-tests.el
@@ -1,4 +1,4 @@
-;;; network-stream-tests.el --- tests for network processes -*-
lexical-binding: t; -*-
+;;; shr-tests.el --- tests for shr.el -*- lexical-binding: t; -*-
;; Copyright (C) 2016-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index be428fc..1eb0d0e 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -59,6 +59,7 @@
(declare-function tramp-get-remote-perl "tramp-sh")
(declare-function tramp-get-remote-stat "tramp-sh")
(declare-function tramp-list-tramp-buffers "tramp-cmds")
+(declare-function tramp-method-out-of-band-p "tramp-sh")
(declare-function tramp-smb-get-localname "tramp-smb")
(defvar ange-ftp-make-backup-files)
(defvar auto-save-file-name-transforms)
@@ -3097,6 +3098,7 @@ This tests also `file-directory-p' and
`file-accessible-directory-p'."
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
(skip-unless (not (tramp--test-rsync-p)))
+ (skip-unless (not (tramp--test-windows-nt-and-scp-p)))
;; Wildcards are not supported in tramp-crypt.el.
(skip-unless (not (tramp--test-crypt-p)))
;; Since Emacs 26.1.
@@ -4369,7 +4371,7 @@ This tests also `make-symbolic-link', `file-truename' and
`add-name-to-file'."
(delete-file tmp-name))))))
(defun tramp--test-shell-file-name ()
- "Return default remote shell.."
+ "Return default remote shell."
(if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh"))
(ert-deftest tramp-test28-process-file ()
@@ -5838,18 +5840,18 @@ This requires restrictions of file name syntax."
"Check, whether the locale host runs MS Windows."
(eq system-type 'windows-nt))
-(defun tramp--test-windows-nt-and-batch-p ()
- "Check, whether the locale host runs MS Windows in batch mode.
-This does not support special characters."
- (and (eq system-type 'windows-nt) noninteractive))
+(defun tramp--test-windows-nt-and-out-of-band-p ()
+ "Check, whether the locale host runs MS Windows and an out-of-band method.
+This does not support utf8 based file transfer."
+ (and (eq system-type 'windows-nt)
+ (tramp-method-out-of-band-p tramp-test-vec 1)))
-(defun tramp--test-windows-nt-and-pscp-psftp-p ()
- "Check, whether the locale host runs MS Windows, and ps{cp,ftp} is used.
+(defun tramp--test-windows-nt-and-scp-p ()
+ "Check, whether the locale host runs MS Windows, and scpx? is used.
This does not support utf8 based file transfer."
(and (eq system-type 'windows-nt)
(string-match-p
- (regexp-opt '("pscp" "psftp"))
- (file-remote-p tramp-test-temporary-file-directory 'method))))
+ "^scpx?" (file-remote-p tramp-test-temporary-file-directory 'method))))
(defun tramp--test-windows-nt-or-smb-p ()
"Check, whether the locale or remote host runs MS Windows.
@@ -6112,7 +6114,7 @@ This requires restrictions of file name syntax."
"Check special characters in file names."
(skip-unless (tramp--test-enabled))
(skip-unless (not (tramp--test-rsync-p)))
- (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
+ (skip-unless (not (tramp--test-windows-nt-and-scp-p)))
(skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p))))
(tramp--test-special-characters))
@@ -6124,7 +6126,7 @@ Use the `stat' command."
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
(skip-unless (not (tramp--test-rsync-p)))
- (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
+ (skip-unless (not (tramp--test-windows-nt-and-scp-p)))
;; We cannot use `tramp-test-vec', because this fails during compilation.
(with-parsed-tramp-file-name tramp-test-temporary-file-directory nil
(skip-unless (tramp-get-remote-stat v)))
@@ -6143,7 +6145,7 @@ Use the `perl' command."
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
(skip-unless (not (tramp--test-rsync-p)))
- (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
+ (skip-unless (not (tramp--test-windows-nt-and-scp-p)))
;; We cannot use `tramp-test-vec', because this fails during compilation.
(with-parsed-tramp-file-name tramp-test-temporary-file-directory nil
(skip-unless (tramp-get-remote-perl v)))
@@ -6165,7 +6167,7 @@ Use the `ls' command."
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
(skip-unless (not (tramp--test-rsync-p)))
- (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
+ (skip-unless (not (tramp--test-windows-nt-and-scp-p)))
(let ((tramp-connection-properties
(append
@@ -6230,8 +6232,7 @@ Use the `ls' command."
(skip-unless (tramp--test-enabled))
(skip-unless (not (tramp--test-docker-p)))
(skip-unless (not (tramp--test-rsync-p)))
- (skip-unless (not (tramp--test-windows-nt-and-batch-p)))
- (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
+ (skip-unless (not (tramp--test-windows-nt-and-out-of-band-p)))
(skip-unless (not (tramp--test-ksh-p)))
(skip-unless (not (tramp--test-gdrive-p)))
(skip-unless (not (tramp--test-crypt-p)))
@@ -6247,8 +6248,7 @@ Use the `stat' command."
(skip-unless (tramp--test-sh-p))
(skip-unless (not (tramp--test-docker-p)))
(skip-unless (not (tramp--test-rsync-p)))
- (skip-unless (not (tramp--test-windows-nt-and-batch-p)))
- (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
+ (skip-unless (not (tramp--test-windows-nt-and-out-of-band-p)))
(skip-unless (not (tramp--test-ksh-p)))
(skip-unless (not (tramp--test-crypt-p)))
;; We cannot use `tramp-test-vec', because this fails during compilation.
@@ -6270,8 +6270,7 @@ Use the `perl' command."
(skip-unless (tramp--test-sh-p))
(skip-unless (not (tramp--test-docker-p)))
(skip-unless (not (tramp--test-rsync-p)))
- (skip-unless (not (tramp--test-windows-nt-and-batch-p)))
- (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
+ (skip-unless (not (tramp--test-windows-nt-and-out-of-band-p)))
(skip-unless (not (tramp--test-ksh-p)))
(skip-unless (not (tramp--test-crypt-p)))
;; We cannot use `tramp-test-vec', because this fails during compilation.
@@ -6296,8 +6295,7 @@ Use the `ls' command."
(skip-unless (tramp--test-sh-p))
(skip-unless (not (tramp--test-docker-p)))
(skip-unless (not (tramp--test-rsync-p)))
- (skip-unless (not (tramp--test-windows-nt-and-batch-p)))
- (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
+ (skip-unless (not (tramp--test-windows-nt-and-out-of-band-p)))
(skip-unless (not (tramp--test-ksh-p)))
(skip-unless (not (tramp--test-crypt-p)))
diff --git a/test/lisp/play/cookie1-tests.el b/test/lisp/play/cookie1-tests.el
index d63ecb9..75dea4e 100644
--- a/test/lisp/play/cookie1-tests.el
+++ b/test/lisp/play/cookie1-tests.el
@@ -1,4 +1,4 @@
-;;; fortune-tests.el --- Tests for fortune.el -*- lexical-binding: t -*-
+;;; cookie1-tests.el --- Tests for cookie1.el -*- lexical-binding: t -*-
;; Copyright (C) 2021 Free Software Foundation, Inc.
diff --git a/test/lisp/progmodes/cperl-mode-tests.el
b/test/lisp/progmodes/cperl-mode-tests.el
index 14bc48b..9867aa8 100644
--- a/test/lisp/progmodes/cperl-mode-tests.el
+++ b/test/lisp/progmodes/cperl-mode-tests.el
@@ -1,4 +1,4 @@
-;;; cperl-mode-tests --- Test for cperl-mode -*- lexical-binding: t -*-
+;;; cperl-mode-tests.el --- Test for cperl-mode -*- lexical-binding: t -*-
;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
@@ -495,4 +495,33 @@ as that quote like operator."
'font-lock-constant-face
font-lock-string-face))))))
+(ert-deftest cperl-test-hyperactive-electric-else ()
+ "Demonstrate cperl-electric-else behavior.
+If `cperl-electric-keywords' is true, keywords like \"else\" and
+\"continue\" are expanded by a following empty block, with the
+cursor in the appropriate position to write that block. This,
+however, must not happen when the keyword occurs in a variable
+\"$else\" or \"$continue\"."
+ (skip-unless (eq cperl-test-mode #'cperl-mode))
+ ;; `self-insert-command' takes a second argument only since Emacs 27
+ (skip-unless (not (< emacs-major-version 27)))
+ (with-temp-buffer
+ (setq cperl-electric-keywords t)
+ (cperl-mode)
+ (insert "continue")
+ (self-insert-command 1 ?\ )
+ (indent-region (point-min) (point-max))
+ (goto-char (point-min))
+ ;; cperl-mode creates a block here
+ (should (search-forward-regexp "continue {\n[[:blank:]]+\n}")))
+ (with-temp-buffer
+ (setq cperl-electric-keywords t)
+ (cperl-mode)
+ (insert "$continue")
+ (self-insert-command 1 ?\ )
+ (indent-region (point-min) (point-max))
+ (goto-char (point-min))
+ ;; No block should have been created here
+ (should-not (search-forward-regexp "{" nil t))))
+
;;; cperl-mode-tests.el ends here
diff --git a/test/lisp/progmodes/executable-tests.el
b/test/lisp/progmodes/executable-tests.el
new file mode 100644
index 0000000..4f0fa69
--- /dev/null
+++ b/test/lisp/progmodes/executable-tests.el
@@ -0,0 +1,51 @@
+;;; executable-tests.el --- Tests for executable.el -*- lexical-binding:t -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+(require 'executable)
+
+(ert-deftest executable-tests-set-magic ()
+ (with-temp-buffer
+ (insert "#!/foo/bar")
+ (executable-set-magic "/bin/bash" nil t t)
+ (should (equal (buffer-string) "#!/bin/bash"))))
+
+(ert-deftest executable-tests-set-magic/with-argument ()
+ (with-temp-buffer
+ (insert "#!/foo/bar")
+ (executable-set-magic "/bin/bash" "--norc" t t)
+ (should (equal (buffer-string) "#!/bin/bash --norc"))))
+
+(ert-deftest executable-tests-set-magic/executable-insert-nil ()
+ (let ((executable-insert nil))
+ (with-temp-buffer
+ (insert "#!/foo/bar")
+ (executable-set-magic "/bin/bash" nil t nil)
+ (should (equal (buffer-string) "#!/foo/bar"))))
+ (let ((executable-insert nil))
+ (with-temp-buffer
+ (insert "#!/foo/bar")
+ (executable-set-magic "/bin/bash" nil t t)
+ (should (equal (buffer-string) "#!/bin/bash")))))
+
+;;; executable-tests.el ends here
diff --git a/test/lisp/progmodes/perl-mode-tests.el
b/test/lisp/progmodes/perl-mode-tests.el
index 9f6800c..f63f8ad 100644
--- a/test/lisp/progmodes/perl-mode-tests.el
+++ b/test/lisp/progmodes/perl-mode-tests.el
@@ -1,4 +1,4 @@
-;;; perl-mode-tests --- Test for perl-mode -*- lexical-binding: t -*-
+;;; perl-mode-tests.el --- Test for perl-mode -*- lexical-binding: t -*-
;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/progmodes/project-tests.el
b/test/lisp/progmodes/project-tests.el
new file mode 100644
index 0000000..c8c03aa
--- /dev/null
+++ b/test/lisp/progmodes/project-tests.el
@@ -0,0 +1,85 @@
+;;; project-tests.el --- tests for project.el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; Keywords:
+
+;; 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 progmodes/project.el.
+
+;;; Code:
+
+(require 'project)
+
+(require 'cl-lib)
+(require 'ert)
+(require 'grep)
+(require 'xref)
+
+(defmacro project-tests--with-temporary-directory (var &rest body)
+ "Create a new temporary directory.
+Bind VAR to the name of the directory, and evaluate BODY. Delete
+the directory after BODY exits."
+ (declare (debug (symbolp body)) (indent 1))
+ (cl-check-type var symbol)
+ (let ((directory (make-symbol "directory")))
+ `(let ((,directory (make-temp-file "project-tests-" :directory)))
+ (unwind-protect
+ (let ((,var ,directory))
+ ,@body)
+ (delete-directory ,directory :recursive)))))
+
+(ert-deftest project/quoted-directory ()
+ "Check that `project-files' and `project-find-regexp' deal with
+quoted directory names (Bug#47799)."
+ (skip-unless (executable-find find-program))
+ (skip-unless (executable-find "xargs"))
+ (skip-unless (executable-find "grep"))
+ (project-tests--with-temporary-directory directory
+ (let ((default-directory directory)
+ (project-current-inhibit-prompt t)
+ (project-find-functions nil)
+ (project-list-file
+ (expand-file-name "projects" directory))
+ (project (cons 'transient (file-name-quote directory)))
+ (file (expand-file-name "file" directory)))
+ (add-hook 'project-find-functions (lambda (_dir) project))
+ (should (eq (project-current) project))
+ (write-region "contents" nil file nil nil nil 'excl)
+ (should (equal (project-files project)
+ (list (file-name-quote file))))
+ (let* ((references nil)
+ (xref-search-program 'grep)
+ (xref-show-xrefs-function
+ (lambda (fetcher _display)
+ (push (funcall fetcher) references))))
+ (project-find-regexp "tent")
+ (pcase references
+ (`((,item))
+ ;; FIXME: Shouldn't `xref-match-item' be a subclass of
+ ;; `xref-item'?
+ (should (cl-typep item '(or xref-item xref-match-item)))
+ (should (file-equal-p
+ (xref-location-group (xref-item-location item))
+ file)))
+ (otherwise
+ (ert-fail (format-message "Unexpected references: %S"
+ otherwise))))))))
+
+;;; project-tests.el ends here
diff --git a/test/lisp/progmodes/ruby-mode-tests.el
b/test/lisp/progmodes/ruby-mode-tests.el
index 42a011c..e2ea0d9 100644
--- a/test/lisp/progmodes/ruby-mode-tests.el
+++ b/test/lisp/progmodes/ruby-mode-tests.el
@@ -32,6 +32,13 @@
(ruby-mode)
,@body))
+(defmacro ruby-with-temp-file (contents &rest body)
+ `(ruby-with-temp-buffer ,contents
+ (set-visited-file-name "ruby-mode-tests")
+ ,@body
+ (set-buffer-modified-p nil)
+ (delete-file buffer-file-name)))
+
(defun ruby-should-indent (content column)
"Assert indentation COLUMN on the last line of CONTENT."
(ruby-with-temp-buffer content
@@ -844,6 +851,30 @@ VALUES-PLIST is a list with alternating index and value
elements."
(ruby--insert-coding-comment "utf-8")
(should (string= "# encoding: utf-8\n\n" (buffer-string))))))
+(ert-deftest ruby--set-encoding-when-ascii ()
+ (ruby-with-temp-file "ascii"
+ (let ((ruby-encoding-magic-comment-style 'ruby)
+ (ruby-insert-encoding-magic-comment t))
+ (setq save-buffer-coding-system 'us-ascii)
+ (ruby-mode-set-encoding)
+ (should (string= "ascii" (buffer-string))))))
+
+(ert-deftest ruby--set-encoding-when-utf8 ()
+ (ruby-with-temp-file "💎"
+ (let ((ruby-encoding-magic-comment-style 'ruby)
+ (ruby-insert-encoding-magic-comment t))
+ (setq save-buffer-coding-system 'utf-8)
+ (ruby-mode-set-encoding)
+ (should (string= "💎" (buffer-string))))))
+
+(ert-deftest ruby--set-encoding-when-latin-15 ()
+ (ruby-with-temp-file "Ⓡ"
+ (let ((ruby-encoding-magic-comment-style 'ruby)
+ (ruby-insert-encoding-magic-comment t))
+ (setq save-buffer-coding-system 'iso-8859-15)
+ (ruby-mode-set-encoding)
+ (should (string= "# coding: iso-8859-15\nⓇ" (buffer-string))))))
+
(ert-deftest ruby--indent/converted-from-manual-test ()
:tags '(:expensive-test)
;; Converted from manual test.
diff --git a/test/lisp/progmodes/xref-tests.el
b/test/lisp/progmodes/xref-tests.el
index 9982c32..66099dc 100644
--- a/test/lisp/progmodes/xref-tests.el
+++ b/test/lisp/progmodes/xref-tests.el
@@ -143,7 +143,7 @@
(let* ((data-parent-dir
(file-name-directory (directory-file-name xref-tests--data-dir)))
(project-find-functions
- #'(lambda (_) (cons 'transient data-parent-dir)))
+ (lambda (_) (cons 'transient data-parent-dir)))
(xref-file-name-display 'project-relative)
;; Some older BSD find versions can produce '//' in the output.
(expected (list
@@ -156,3 +156,5 @@
(cl-every (lambda (e1 e2)
(string-match-p e1 e2))
expected actual)))))
+
+;;; xref-tests.el ends here
diff --git a/test/lisp/shadowfile-tests.el b/test/lisp/shadowfile-tests.el
index 0c2d712..7b9c2ff 100644
--- a/test/lisp/shadowfile-tests.el
+++ b/test/lisp/shadowfile-tests.el
@@ -117,8 +117,8 @@
(ignore-errors (delete-file shadow-info-file))
(ignore-errors (delete-file shadow-todo-file))
;; Reset variables.
+ (shadow-invalidate-hashtable)
(setq shadow-info-buffer nil
- shadow-hashtable nil
shadow-todo-buffer nil
shadow-files-to-copy nil))
diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el
index 601eca6..4b153d1 100644
--- a/test/lisp/simple-tests.el
+++ b/test/lisp/simple-tests.el
@@ -1,4 +1,4 @@
-;;; simple-test.el --- Tests for simple.el -*- lexical-binding: t;
-*-
+;;; simple-tests.el --- Tests for simple.el -*- lexical-binding: t;
-*-
;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index 7a116aa..1e14673 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -382,7 +382,7 @@ cf. Bug#25477."
"Test for https://debbugs.gnu.org/22027 ."
(let ((default "foo") res)
(cl-letf (((symbol-function 'read-string)
- (lambda (_prompt _init _hist def) def)))
+ (lambda (_prompt &optional _init _hist def _inher-input) def)))
(setq res (read-passwd "pass: " 'confirm (mapconcat #'string default
"")))
(should (string= default res)))))
diff --git a/test/lisp/textmodes/fill-tests.el
b/test/lisp/textmodes/fill-tests.el
index 21efe62..a4c7f44 100644
--- a/test/lisp/textmodes/fill-tests.el
+++ b/test/lisp/textmodes/fill-tests.el
@@ -1,4 +1,4 @@
-;;; fill-test.el --- ERT tests for fill.el -*- lexical-binding: t -*-
+;;; fill-tests.el --- ERT tests for fill.el -*- lexical-binding: t -*-
;; Copyright (C) 2017-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/textmodes/tildify-tests.el
b/test/lisp/textmodes/tildify-tests.el
index 59c2394..3ee3cd6 100644
--- a/test/lisp/textmodes/tildify-tests.el
+++ b/test/lisp/textmodes/tildify-tests.el
@@ -1,4 +1,4 @@
-;;; tildify-test.el --- ERT tests for tildify.el -*- lexical-binding: t -*-
+;;; tildify-tests.el --- ERT tests for tildify.el -*- lexical-binding: t -*-
;; Copyright (C) 2014-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el
index 62a27f0..07eb8bb 100644
--- a/test/lisp/thingatpt-tests.el
+++ b/test/lisp/thingatpt-tests.el
@@ -1,4 +1,4 @@
-;;; thingatpt.el --- tests for thing-at-point. -*- lexical-binding:t -*-
+;;; thingatpt-tests.el --- tests for thing-at-point. -*- lexical-binding:t -*-
;; Copyright (C) 2013-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/vc/vc-bzr-tests.el b/test/lisp/vc/vc-bzr-tests.el
index aeab51e..b02dce8 100644
--- a/test/lisp/vc/vc-bzr-tests.el
+++ b/test/lisp/vc/vc-bzr-tests.el
@@ -1,4 +1,4 @@
-;;; vc-bzr.el --- tests for vc/vc-bzr.el -*- lexical-binding: t -*-
+;;; vc-bzr-tests.el --- tests for vc/vc-bzr.el -*- lexical-binding: t -*-
;; Copyright (C) 2011-2021 Free Software Foundation, Inc.
diff --git a/test/lisp/xml-tests.el b/test/lisp/xml-tests.el
index cd3e113..b00b58a 100644
--- a/test/lisp/xml-tests.el
+++ b/test/lisp/xml-tests.el
@@ -1,4 +1,4 @@
-;;; xml-parse-tests.el --- Test suite for XML parsing. -*- lexical-binding:t
-*-
+;;; xml-tests.el --- Test suite for XML parsing. -*- lexical-binding:t -*-
;; Copyright (C) 2012-2021 Free Software Foundation, Inc.
diff --git a/test/manual/cedet/semantic-tests.el
b/test/manual/cedet/semantic-tests.el
index 7169c78..1561c18 100644
--- a/test/manual/cedet/semantic-tests.el
+++ b/test/manual/cedet/semantic-tests.el
@@ -1,4 +1,4 @@
-;;; semantic-utest.el --- Miscellaneous Semantic tests. -*- lexical-binding:
t; -*-
+;;; semantic-tests.el --- Miscellaneous Semantic tests. -*- lexical-binding:
t; -*-
;; Copyright (C) 2003-2021 Free Software Foundation, Inc.
diff --git a/test/manual/cedet/tests/test.el b/test/manual/cedet/tests/test.el
index a54c253..d1d0d16 100644
--- a/test/manual/cedet/tests/test.el
+++ b/test/manual/cedet/tests/test.el
@@ -153,7 +153,4 @@
(defvar-mode-local emacs-lisp-mode a-mode-local-def
"some value")
-
-;;; Provide
-;;
(provide 'test)
diff --git a/test/manual/image-size-tests.el b/test/manual/image-size-tests.el
index f7c2bf7..44846a7 100644
--- a/test/manual/image-size-tests.el
+++ b/test/manual/image-size-tests.el
@@ -1,4 +1,4 @@
-;;; image-size-tests.el -- tests for image scaling -*- lexical-binding: t; -*-
+;;; image-size-tests.el --- tests for image scaling -*- lexical-binding: t;
-*-
;; Copyright (C) 2017-2021 Free Software Foundation, Inc.
diff --git a/test/manual/image-transforms-tests.el
b/test/manual/image-transforms-tests.el
index 5342b5e..debb74f 100644
--- a/test/manual/image-transforms-tests.el
+++ b/test/manual/image-transforms-tests.el
@@ -1,4 +1,4 @@
-;;; image-transform-tests.el --- Test suite for image transforms. -*-
lexical-binding: t -*-
+;;; image-transforms-tests.el --- Test suite for image transforms. -*-
lexical-binding: t -*-
;; Copyright (C) 2019-2021 Free Software Foundation, Inc.
diff --git a/test/manual/indent/scheme.scm b/test/manual/indent/scheme.scm
new file mode 100644
index 0000000..9053a87
--- /dev/null
+++ b/test/manual/indent/scheme.scm
@@ -0,0 +1,23 @@
+;; Testing sexp-comments
+
+(define a #;(hello) there)
+
+(define a #;1 there)
+
+(define a #;"asdf" there)
+
+(define a ;; #;(hello
+ there)
+
+(define a #;(hello
+ there) 2)
+
+(define a #;(hello
+ #;(world))
+ and)
+ there) 2)
+
+(define a #;(hello
+ #;"asdf" (world
+ and)
+ there) 2)
diff --git a/test/manual/scroll-tests.el b/test/manual/scroll-tests.el
index 2f40b2b..dd15d54 100644
--- a/test/manual/scroll-tests.el
+++ b/test/manual/scroll-tests.el
@@ -1,4 +1,4 @@
-;;; scroll-tests.el -- tests for scrolling -*- lexical-binding: t -*-
+;;; scroll-tests.el --- tests for scrolling -*- lexical-binding: t -*-
;; Copyright (C) 2017-2021 Free Software Foundation, Inc.
diff --git a/test/misc/test-custom-noloads.el b/test/misc/test-custom-noloads.el
index 6fa6a6c..5e95e7d 100644
--- a/test/misc/test-custom-noloads.el
+++ b/test/misc/test-custom-noloads.el
@@ -1,4 +1,4 @@
-;;; test-custom-deps.el --- Test custom noloads -*- lexical-binding:t -*-
+;;; test-custom-noloads.el --- Test custom noloads -*- lexical-binding:t -*-
;; Copyright (C) 2021 Free Software Foundation, Inc.
@@ -42,4 +42,4 @@
(cus-test-noloads)
(should-not cus-test-vars-not-cus-loaded))
-;;; test-custom-deps.el ends here
+;;; test-custom-noloads.el ends here
diff --git a/test/src/character-tests.el b/test/src/character-tests.el
new file mode 100644
index 0000000..f630b32
--- /dev/null
+++ b/test/src/character-tests.el
@@ -0,0 +1,45 @@
+;;; character-tests.el --- tests for character.c -*- lexical-binding:t -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+
+(ert-deftest character-test-string-width ()
+ "Test `string-width' with and without compositions."
+ (should (= (string-width "1234") 4))
+ (should (= (string-width "12\t34") (+ 4 tab-width)))
+ (should (= (string-width "áëòç") 4))
+ (should (= (string-width "áëòç") 4))
+ (should (= (string-width "הַרְבֵּה אַהֲבָה") 9))
+ (should (= (string-width "1234" 1 3) 2))
+ (should (= (string-width "1234" nil -1) 3))
+ (should (= (string-width "1234" 2) 2))
+ (should-error (string-width "1234" nil 5))
+ (should-error (string-width "1234" -5))
+ (should (= (string-width "12\t34") (+ 4 tab-width)))
+ (should (= (string-width "1234\t56") (+ 6 tab-width)))
+ (should (= (string-width "áëòç") 4))
+ (should (= (string-width "áëòç" nil 3) 3))
+ (should (= (string-width "áëòç" 1 3) 2))
+ (should (= (string-width "áëòç" nil 2) 1))
+ (should (= (string-width "áëòç" nil 3) 2))
+ (should (= (string-width "áëòç" nil 4) 2))
+ (should (= (string-width "הַרְבֵּה אַהֲבָה") 9))
+ (should (= (string-width "הַרְבֵּה אַהֲבָה" nil 8) 4)))
diff --git a/test/src/coding-tests.el b/test/src/coding-tests.el
index 0bdcff2..0309b2b 100644
--- a/test/src/coding-tests.el
+++ b/test/src/coding-tests.el
@@ -359,7 +359,7 @@
(delete-region (point-min) (point))))))
(defun benchmark-decoder ()
- (let ((gc-cons-threshold 4000000))
+ (let ((gc-cons-threshold (max gc-cons-threshold 4000000)))
(insert "Without optimization:\n")
(dolist (files test-file-list)
(dolist (file (cdr files))
diff --git a/test/src/comp-resources/comp-test-45603.el
b/test/src/comp-resources/comp-test-45603.el
new file mode 100644
index 0000000..f1c0daf
--- /dev/null
+++ b/test/src/comp-resources/comp-test-45603.el
@@ -0,0 +1,28 @@
+;;; -*- lexical-binding: t; -*-
+
+;; Reduced from ivy.el.
+
+(defvar comp-test-45603-last)
+(defvar comp-test-45603-mark-prefix)
+(defvar comp-test-45603-directory)
+(defvar comp-test-45603-marked-candidates)
+
+(defun comp-test-45603--call-marked (action)
+ (let* ((prefix-len (length comp-test-45603-mark-prefix))
+ (marked-candidates
+ (mapcar
+ (lambda (s)
+ (let ((cand (substring s prefix-len)))
+ (if comp-test-45603-directory
+ (expand-file-name cand comp-test-45603-directory)
+ cand)))
+ comp-test-45603-marked-candidates))
+ (multi-action (comp-test-45603--get-multi-action
comp-test-45603-last)))))
+
+(defalias 'comp-test-45603--file-local-name
+ (if (fboundp 'file-local-name)
+ #'file-local-name
+ (lambda (file)
+ (or (file-remote-p file 'localname) file))))
+
+(provide 'comp-test-45603)
diff --git a/test/lisp/progmodes/perl-mode-tests.el
b/test/src/comp-resources/comp-test-funcs-dyn.el
similarity index 50%
copy from test/lisp/progmodes/perl-mode-tests.el
copy to test/src/comp-resources/comp-test-funcs-dyn.el
index 9f6800c..3118455 100644
--- a/test/lisp/progmodes/perl-mode-tests.el
+++ b/test/src/comp-resources/comp-test-funcs-dyn.el
@@ -1,7 +1,9 @@
-;;; perl-mode-tests --- Test for perl-mode -*- lexical-binding: t -*-
+;;; comp-test-funcs-dyn.el --- compilation unit tested by comp-tests.el -*-
lexical-binding: nil; -*-
;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
+;; Author: Andrea Corallo <akrl@sdf.org>
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
@@ -17,17 +19,32 @@
;; 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 'perl-mode)
+(require 'cl-lib)
+
+(defun comp-tests-ffuncall-callee-dyn-f (a b)
+ (list a b))
+
+(defun comp-tests-ffuncall-callee-opt-dyn-f (a b &optional c d)
+ (list a b c d))
+
+(defun comp-tests-ffuncall-callee-rest-dyn-f (a b &rest c)
+ (list a b c))
+
+(defun comp-tests-ffuncall-callee-opt-rest-dyn-f (a b &optional c &rest d)
+ (list a b c d))
+
+(defun comp-tests-cl-macro-exp-f ()
+ (cl-loop for xxx in '(a b)
+ for yyy = xxx
+ collect xxx))
-;;;; Re-use cperl-mode tests
+(cl-defun comp-tests-cl-uninterned-arg-parse-f (a &optional b &aux)
+ (list a b))
-(defvar cperl-test-mode)
-(setq cperl-test-mode #'perl-mode)
-(load-file (expand-file-name "cperl-mode-tests.el"
- (file-truename
- (file-name-directory (or load-file-name
- buffer-file-name)))))
+(provide 'comp-test-dyn-funcs)
-;;; perl-mode-tests.el ends here
+;;; comp-test-funcs-dyn.el ends here
diff --git a/test/src/comp-resources/comp-test-funcs.el
b/test/src/comp-resources/comp-test-funcs.el
new file mode 100644
index 0000000..f2a2463
--- /dev/null
+++ b/test/src/comp-resources/comp-test-funcs.el
@@ -0,0 +1,710 @@
+;;; comp-test-funcs.el --- compilation unit tested by comp-tests.el -*-
lexical-binding: t; -*-
+
+;; Copyright (C) 2019-2021 Free Software Foundation, Inc.
+
+;; Author: Andrea Corallo <akrl@sdf.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:
+
+;;; Code:
+
+(defvar comp-tests-var1 3)
+
+(defun comp-tests-varref-f ()
+ comp-tests-var1)
+
+(defun comp-tests-list-f ()
+ (list 1 2 3))
+(defun comp-tests-list2-f (a b c)
+ (list a b c))
+(defun comp-tests-car-f (x)
+ ;; Bcar
+ (car x))
+(defun comp-tests-cdr-f (x)
+ ;; Bcdr
+ (cdr x))
+(defun comp-tests-car-safe-f (x)
+ ;; Bcar_safe
+ (car-safe x))
+(defun comp-tests-cdr-safe-f (x)
+ ;; Bcdr_safe
+ (cdr-safe x))
+
+(defun comp-tests-cons-car-f ()
+ (car (cons 1 2)))
+(defun comp-tests-cons-cdr-f (x)
+ (cdr (cons 'foo x)))
+
+(defun comp-tests-hint-fixnum-f (n)
+ (1+ (comp-hint-fixnum n)))
+
+(defun comp-tests-hint-cons-f (c)
+ (car (comp-hint-cons c)))
+
+(defun comp-tests-varset0-f ()
+ (setq comp-tests-var1 55))
+(defun comp-tests-varset1-f ()
+ (setq comp-tests-var1 66)
+ 4)
+
+(defun comp-tests-length-f ()
+ (length '(1 2 3)))
+
+(defun comp-tests-aref-aset-f ()
+ (let ((vec (make-vector 3 0)))
+ (aset vec 2 100)
+ (aref vec 2)))
+
+(defvar comp-tests-var2 3)
+(defun comp-tests-symbol-value-f ()
+ (symbol-value 'comp-tests-var2))
+
+(defun comp-tests-concat-f (x)
+ (concat "a" "b" "c" "d"
+ (concat "a" "b" "c" (concat "a" "b" (concat "foo" x)))))
+
+(defun comp-tests-ffuncall-callee-f (x y z)
+ (list x y z))
+
+(defun comp-tests-ffuncall-callee-optional-f (a b &optional c d)
+ (list a b c d))
+
+(defun comp-tests-ffuncall-callee-rest-f (a b &rest c)
+ (list a b c))
+
+(defun comp-tests-ffuncall-callee-more8-f (p1 p2 p3 p4 p5 p6 p7 p8 p9 p10)
+ ;; More then 8 args.
+ (list p1 p2 p3 p4 p5 p6 p7 p8 p9 p10))
+
+(defun comp-tests-ffuncall-callee-more8-rest-f (p1 p2 p3 p4 p5 p6 p7 p8 p9
&rest p10)
+ ;; More then 8 args.
+ (list p1 p2 p3 p4 p5 p6 p7 p8 p9 p10))
+
+(defun comp-tests-ffuncall-native-f ()
+ "Call a primitive with no dedicate op."
+ (make-vector 1 nil))
+
+(defun comp-tests-ffuncall-native-rest-f ()
+ "Call a primitive with no dedicate op with &rest."
+ (vector 1 2 3))
+
+(defun comp-tests-ffuncall-apply-many-f (x)
+ (apply #'list x))
+
+(defun comp-tests-ffuncall-lambda-f (x)
+ (let ((fun (lambda (x)
+ (1+ x))))
+ (funcall fun x)))
+
+(defun comp-tests-jump-table-1-f (x)
+ (pcase x
+ ('x 'a)
+ ('y 'b)
+ (_ 'c)))
+
+(defun comp-tests-jump-table-2-f (x)
+ (pcase x
+ ("aaa" 'a)
+ ("bbb" 'b)))
+
+(defun comp-tests-conditionals-1-f (x)
+ ;; Generate goto-if-nil
+ (if x 1 2))
+(defun comp-tests-conditionals-2-f (x)
+ ;; Generate goto-if-nil-else-pop
+ (when x
+ 1340))
+
+(defun comp-tests-fixnum-1-minus-f (x)
+ ;; Bsub1
+ (1- x))
+(defun comp-tests-fixnum-1-plus-f (x)
+ ;; Badd1
+ (1+ x))
+(defun comp-tests-fixnum-minus-f (x)
+ ;; Bnegate
+ (- x))
+
+(defun comp-tests-eqlsign-f (x y)
+ ;; Beqlsign
+ (= x y))
+(defun comp-tests-gtr-f (x y)
+ ;; Bgtr
+ (> x y))
+(defun comp-tests-lss-f (x y)
+ ;; Blss
+ (< x y))
+(defun comp-tests-les-f (x y)
+ ;; Bleq
+ (<= x y))
+(defun comp-tests-geq-f (x y)
+ ;; Bgeq
+ (>= x y))
+
+(defun comp-tests-setcar-f (x y)
+ (setcar x y)
+ x)
+(defun comp-tests-setcdr-f (x y)
+ (setcdr x y)
+ x)
+
+(defun comp-bubble-sort-f (list)
+ (let ((i (length list)))
+ (while (> i 1)
+ (let ((b list))
+ (while (cdr b)
+ (when (< (cadr b) (car b))
+ (setcar b (prog1 (cadr b)
+ (setcdr b (cons (car b) (cddr b))))))
+ (setq b (cdr b))))
+ (setq i (1- i)))
+ list))
+
+(defun comp-tests-consp-f (x)
+ ;; Bconsp
+ (consp x))
+(defun comp-tests-setcar2-f (x)
+ ;; Bsetcar
+ (setcar x 3))
+
+(defun comp-tests-integerp-f (x)
+ ;; Bintegerp
+ (integerp x))
+(defun comp-tests-numberp-f (x)
+ ;; Bnumberp
+ (numberp x))
+
+(defun comp-tests-discardn-f (x)
+ ;; BdiscardN
+ (1+ (let ((a 1)
+ (_b)
+ (_c))
+ a)))
+(defun comp-tests-insertn-f (a b c d)
+ ;; Binsert
+ (insert a b c d))
+
+(defun comp-tests-err-arith-f ()
+ (/ 1 0))
+(defun comp-tests-err-foo-f ()
+ (error "foo"))
+
+(defun comp-tests-condition-case-0-f ()
+ ;; Bpushhandler Bpophandler
+ (condition-case
+ err
+ (comp-tests-err-arith-f)
+ (arith-error (concat "arith-error "
+ (error-message-string err)
+ " catched"))
+ (error (concat "error "
+ (error-message-string err)
+ " catched"))))
+(defun comp-tests-condition-case-1-f ()
+ ;; Bpushhandler Bpophandler
+ (condition-case
+ err
+ (comp-tests-err-foo-f)
+ (arith-error (concat "arith-error "
+ (error-message-string err)
+ " catched"))
+ (error (concat "error "
+ (error-message-string err)
+ " catched"))))
+(defun comp-tests-catch-f (f)
+ (catch 'foo
+ (funcall f)))
+(defun comp-tests-throw-f (x)
+ (throw 'foo x))
+
+(defun comp-tests-buff0-f ()
+ (with-temp-buffer
+ (insert "foo")
+ (buffer-string)))
+
+(defun comp-tests-lambda-return-f ()
+ (lambda (x) (1+ x)))
+
+(defun comp-tests-fib-f (n)
+ (cond ((= n 0) 0)
+ ((= n 1) 1)
+ (t (+ (comp-tests-fib-f (- n 1))
+ (comp-tests-fib-f (- n 2))))))
+
+(defmacro comp-tests-macro-m (x)
+ x)
+
+(defun comp-tests-string-trim-f (url)
+ (string-trim url))
+
+(defun comp-tests-trampoline-removal-f ()
+ (make-hash-table))
+
+(defun comp-tests-signal-f ()
+ (signal 'foo t))
+
+(defun comp-tests-func-call-removal-f ()
+ (let ((a 10)
+ (b 3))
+ (% a b)))
+
+(defun comp-tests-doc-f ()
+ "A nice docstring"
+ t)
+
+(defun comp-test-interactive-form0-f (dir)
+ (interactive "D")
+ dir)
+
+(defun comp-test-interactive-form1-f (x y)
+ (interactive '(1 2))
+ (+ x y))
+
+(defun comp-test-interactive-form2-f ()
+ (interactive))
+
+(defun comp-test-40187-2-f ()
+ 'foo)
+
+(defalias 'comp-test-40187-1-f (symbol-function 'comp-test-40187-2-f))
+
+(defun comp-test-40187-2-f ()
+ 'bar)
+
+(defun comp-test-speed--1-f ()
+ (declare (speed -1))
+ 3)
+
+(defun comp-test-42360-f (str end-column
+ &optional start-column padding ellipsis
+ ellipsis-text-property)
+ ;; From `truncate-string-to-width'. A large enough function to
+ ;; potentially use all registers and that is modifying local
+ ;; variables inside condition-case.
+ (let ((str-len (length str))
+ (str-width 14)
+ (ellipsis-width 3)
+ (idx 0)
+ (column 0)
+ (head-padding "") (tail-padding "")
+ ch last-column last-idx from-idx)
+ (condition-case nil
+ (while (< column start-column)
+ (setq ch (aref str idx)
+ column (+ column (char-width ch))
+ idx (1+ idx)))
+ (args-out-of-range (setq idx str-len)))
+ (if (< column start-column)
+ (if padding (make-string end-column padding) "")
+ (when (and padding (> column start-column))
+ (setq head-padding (make-string (- column start-column) padding)))
+ (setq from-idx idx)
+ (when (>= end-column column)
+ (condition-case nil
+ (while (< column end-column)
+ (setq last-column column
+ last-idx idx
+ ch (aref str idx)
+ column (+ column (char-width ch))
+ idx (1+ idx)))
+ (args-out-of-range (setq idx str-len)))
+ (when (> column end-column)
+ (setq column last-column
+ idx last-idx))
+ (when (and padding (< column end-column))
+ (setq tail-padding (make-string (- end-column column) padding))))
+ (if (and ellipsis-text-property
+ (not (equal ellipsis ""))
+ idx)
+ (concat head-padding
+ (substring str from-idx idx)
+ (propertize (substring str idx) 'display (or ellipsis "")))
+ (concat head-padding (substring str from-idx idx)
+ tail-padding ellipsis)))))
+
+(defun comp-test-primitive-advice-f (x y)
+ (declare (speed 2))
+ (+ x y))
+
+(defun comp-test-primitive-redefine-f (x y)
+ (declare (speed 2))
+ (- x y))
+
+(defsubst comp-test-defsubst-f ()
+ t)
+
+(defvar comp-test-and-3-var 1)
+(defun comp-test-and-3-f (x)
+ (and (atom x)
+ comp-test-and-3-var
+ 2))
+
+(defun comp-test-copy-insn-f (insn)
+ ;; From `comp-copy-insn'.
+ (if (consp insn)
+ (let (result)
+ (while (consp insn)
+ (let ((newcar (car insn)))
+ (if (or (consp (car insn)) (comp-mvar-p (car insn)))
+ (setf newcar (comp-copy-insn (car insn))))
+ (push newcar result))
+ (setf insn (cdr insn)))
+ (nconc (nreverse result)
+ (if (comp-mvar-p insn) (comp-copy-insn insn) insn)))
+ (if (comp-mvar-p insn)
+ (copy-comp-mvar insn)
+ insn)))
+
+(defun comp-test-cond-rw-1-1-f ())
+
+(defun comp-test-cond-rw-1-2-f ()
+ (let ((it (comp-test-cond-rw-1-1-f))
+ (key 't))
+ (if (or (equal it key)
+ (eq key t))
+ it
+ nil)))
+
+(defun comp-test-44968-f (start end)
+ (let ((dirlist)
+ (dir (expand-file-name start))
+ (end (expand-file-name end)))
+ (while (not (or (equal dir (car dirlist))
+ (file-equal-p dir end)))
+ (push dir dirlist)
+ (setq dir (directory-file-name (file-name-directory dir))))
+ (nreverse dirlist)))
+
+(defun comp-test-45342-f (n)
+ (pcase n
+ (1 " ➊") (2 " ➋") (3 " ➌") (4 " ➍") (5 " ➎") (6 " ➏")
+ (7 " ➐") (8 " ➑") (9 " ➒") (10 " ➓") (_ "")))
+
+(defun comp-test-assume-double-neg-f (collection value)
+ ;; Reduced from `auth-source-search-collection'.
+ (when (atom collection)
+ (setq collection (list collection)))
+ (or (eq value t)
+ ;; value is (not (member t))
+ (eq collection value)
+ ;; collection is t, not (member t)!
+ (member value collection)))
+
+(defun comp-test-assume-in-loop-1-f (arg)
+ ;; Reduced from `comint-delim-arg'.
+ (let ((args nil)
+ (pos 0)
+ (len (length arg)))
+ (while (< pos len)
+ (let ((start pos))
+ (while (< pos len)
+ (setq pos (1+ pos)))
+ (setq args (cons (substring arg start pos) args))))
+ args))
+
+(defun comp-test-45376-1-f ()
+ ;; Reduced from `eshell-ls-find-column-lengths'.
+ (let* (res
+ (len 2)
+ (i 0)
+ (j 0))
+ (while (< j len)
+ (if (= i len)
+ (setq i 0))
+ (setq res (cons i res)
+ j (1+ j)
+ i (1+ i)))
+ res))
+
+(defun comp-test-45376-2-f ()
+ ;; Also reduced from `eshell-ls-find-column-lengths'.
+ (let* ((x 1)
+ res)
+ (while x
+ (let* ((y 4)
+ (i 0))
+ (while (> y 0)
+ (when (= i x)
+ (setq i 0))
+ (setf res (cons i res))
+ (setq y (1- y)
+ i (1+ i)))
+ (if (>= x 3)
+ (setq x nil)
+ (setq x (1+ x)))))
+ res))
+
+(defun comp-test-not-cons-f (x)
+ ;; Reduced from `cl-copy-list'.
+ (if (consp x)
+ (print x)
+ (car x)))
+
+(defun comp-test-45576-f ()
+ ;; Reduced from `eshell-find-alias-function'.
+ (let ((sym (intern-soft "eval")))
+ (if (and (functionp sym)
+ '(eshell-ls eshell-pred eshell-prompt eshell-script
+ eshell-term eshell-unix))
+ sym)))
+
+(defun comp-test-45635-f (&rest args)
+ ;; Reduced from `set-face-attribute'.
+ (let ((spec args)
+ family)
+ (while spec
+ (cond ((eq (car spec) :family)
+ (setq family (cadr spec))))
+ (setq spec (cddr spec)))
+ (when (and (stringp family)
+ (string-match "\\([^-]*\\)-\\([^-]*\\)" family))
+ (setq family (match-string 2 family)))
+ (when (or (stringp family)
+ (eq family 'unspecified))
+ family)))
+
+(defun comp-test-46670-1-f (_)
+ "foo")
+
+(defun comp-test-46670-2-f (s)
+ (and (equal (comp-test-46670-1-f (length s)) s)
+ s))
+
+(cl-defun comp-test-46824-1-f ()
+ (let ((next-repos '(1)))
+ (while t
+ (let ((recipe (car next-repos)))
+ (cl-block loop
+ (while t
+ (let ((err
+ (condition-case e
+ (progn
+ (setq next-repos
+ (cdr next-repos))
+ (cl-return-from loop))
+ (error e))))
+ (format "%S"
+ (error-message-string err))))))
+ (cl-return-from comp-test-46824-1-f))))
+
+(defun comp-test-47868-1-f ()
+ " ")
+
+(defun comp-test-47868-2-f ()
+ #(" " 0 1 (face font-lock-keyword-face)))
+
+(defun comp-test-47868-3-f ()
+ " ")
+
+(defun comp-test-47868-4-f ()
+ #(" " 0 1 (face font-lock-keyword-face)))
+
+
+
+;;;;;;;;;;;;;;;;;;;;
+;; Tromey's tests ;;
+;;;;;;;;;;;;;;;;;;;;
+
+;; Test Bconsp.
+(defun comp-test-consp (x) (consp x))
+
+;; Test Blistp.
+(defun comp-test-listp (x) (listp x))
+
+;; Test Bstringp.
+(defun comp-test-stringp (x) (stringp x))
+
+;; Test Bsymbolp.
+(defun comp-test-symbolp (x) (symbolp x))
+
+;; Test Bintegerp.
+(defun comp-test-integerp (x) (integerp x))
+
+;; Test Bnumberp.
+(defun comp-test-numberp (x) (numberp x))
+
+;; Test Badd1.
+(defun comp-test-add1 (x) (1+ x))
+
+;; Test Bsub1.
+(defun comp-test-sub1 (x) (1- x))
+
+;; Test Bneg.
+(defun comp-test-negate (x) (- x))
+
+;; Test Bnot.
+(defun comp-test-not (x) (not x))
+
+;; Test Bbobp, Beobp, Bpoint, Bpoint_min, Bpoint_max.
+(defun comp-test-bobp () (bobp))
+(defun comp-test-eobp () (eobp))
+(defun comp-test-point () (point))
+(defun comp-test-point-min () (point-min))
+(defun comp-test-point-max () (point-max))
+
+;; Test Bcar and Bcdr.
+(defun comp-test-car (x) (car x))
+(defun comp-test-cdr (x) (cdr x))
+
+;; Test Bcar_safe and Bcdr_safe.
+(defun comp-test-car-safe (x) (car-safe x))
+(defun comp-test-cdr-safe (x) (cdr-safe x))
+
+;; Test Beq.
+(defun comp-test-eq (x y) (eq x y))
+
+;; Test Bgotoifnil.
+(defun comp-test-if (x y) (if x x y))
+
+;; Test Bgotoifnilelsepop.
+(defun comp-test-and (x y) (and x y))
+
+;; Test Bgotoifnonnilelsepop.
+(defun comp-test-or (x y) (or x y))
+
+;; Test Bsave_excursion.
+(defun comp-test-save-excursion ()
+ (save-excursion
+ (insert "XYZ")))
+
+;; Test Bcurrent_buffer.
+(defun comp-test-current-buffer () (current-buffer))
+
+;; Test Bgtr.
+(defun comp-test-> (a b)
+ (> a b))
+
+;; Test Bpushcatch.
+(defun comp-test-catch (&rest l)
+ (catch 'done
+ (dolist (v l)
+ (when (> v 23)
+ (throw 'done v)))))
+
+;; Test Bmemq.
+(defun comp-test-memq (val list)
+ (memq val list))
+
+;; Test BlistN.
+(defun comp-test-listN (x)
+ (list x x x x x x x x x x x x x x x x))
+
+;; Test BconcatN.
+(defun comp-test-concatN (x)
+ (concat x x x x x x))
+
+;; Test optional and rest arguments.
+(defun comp-test-opt-rest (a &optional b &rest c)
+ (list a b c))
+
+;; Test for too many arguments.
+(defun comp-test-opt (a &optional b)
+ (cons a b))
+
+;; Test for unwind-protect.
+(defvar comp-test-up-val nil)
+(defun comp-test-unwind-protect (fun)
+ (setq comp-test-up-val nil)
+ (unwind-protect
+ (progn
+ (setq comp-test-up-val 23)
+ (funcall fun)
+ (setq comp-test-up-val 24))
+ (setq comp-test-up-val 999)))
+
+;; Non tested functions that proved just to be difficult to compile.
+
+(defun comp-test-callee (_ __) t)
+(defun comp-test-silly-frame1 (x)
+ ;; Check robustness against dead code.
+ (cl-case x
+ (0 (comp-test-callee
+ (pcase comp-tests-var1
+ (1 1)
+ (2 2))
+ 3))))
+
+(defun comp-test-silly-frame2 (token)
+ ;; Check robustness against dead code.
+ (while c
+ (cl-case c
+ (?< 1)
+ (?> 2))))
+
+(defun comp-test-big-interactive (filename &optional force arg load)
+ ;; Check non trivial interactive form using `byte-recompile-file'.
+ (interactive
+ (let ((file buffer-file-name)
+ (file-name nil)
+ (file-dir nil))
+ (and file
+ (derived-mode-p 'emacs-lisp-mode)
+ (setq file-name (file-name-nondirectory file)
+ file-dir (file-name-directory file)))
+ (list (read-file-name (if current-prefix-arg
+ "Byte compile file: "
+ "Byte recompile file: ")
+ file-dir file-name nil)
+ current-prefix-arg)))
+ (let ((dest (byte-compile-dest-file filename))
+ ;; Expand now so we get the current buffer's defaults
+ (filename (expand-file-name filename)))
+ (if (if (file-exists-p dest)
+ ;; File was already compiled
+ ;; Compile if forced to, or filename newer
+ (or force
+ (file-newer-than-file-p filename dest))
+ (and arg
+ (or (eq 0 arg)
+ (y-or-n-p (concat "Compile "
+ filename "? ")))))
+ (progn
+ (if (and noninteractive (not byte-compile-verbose))
+ (message "Compiling %s..." filename))
+ (byte-compile-file filename load))
+ (when load
+ (load (if (file-exists-p dest) dest filename)))
+ 'no-byte-compile)))
+
+(defun comp-test-no-return-1 (x)
+ (while x
+ (error "foo")))
+
+(defun comp-test-no-return-2 (x)
+ (cond
+ ((eql x '2) t)
+ ((error "bar") nil)))
+
+(defun comp-test-no-return-3 ())
+(defun comp-test-no-return-4 (x)
+ (when x
+ (error "foo")
+ (while (comp-test-no-return-3)
+ (comp-test-no-return-3))))
+
+(defun comp-test-=-nan (x)
+ (when (= x 0.0e+NaN)
+ x))
+
+(defun comp-test-=-infinity (x)
+ (when (= x 1.0e+INF)
+ x))
+
+(provide 'comp-test-funcs)
+
+;;; comp-test-funcs.el ends here
diff --git a/test/lisp/progmodes/perl-mode-tests.el
b/test/src/comp-resources/comp-test-pure.el
similarity index 60%
copy from test/lisp/progmodes/perl-mode-tests.el
copy to test/src/comp-resources/comp-test-pure.el
index 9f6800c..5c1d2d1 100644
--- a/test/lisp/progmodes/perl-mode-tests.el
+++ b/test/src/comp-resources/comp-test-pure.el
@@ -1,7 +1,9 @@
-;;; perl-mode-tests --- Test for perl-mode -*- lexical-binding: t -*-
+;;; comp-test-pure.el --- compilation unit tested by comp-tests.el -*-
lexical-binding: t; -*-
;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
+;; Author: Andrea Corallo <akrl@sdf.org>
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
@@ -17,17 +19,22 @@
;; 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 'perl-mode)
+(defun comp-tests-pure-callee-f (x)
+ (1+ x))
+
+(defun comp-tests-pure-caller-f ()
+ (comp-tests-pure-callee-f 3))
-;;;; Re-use cperl-mode tests
+(defun comp-tests-pure-fibn-f (a b count)
+ (if (= count 0)
+ b
+ (comp-tests-pure-fibn-f (+ a b) a (- count 1))))
-(defvar cperl-test-mode)
-(setq cperl-test-mode #'perl-mode)
-(load-file (expand-file-name "cperl-mode-tests.el"
- (file-truename
- (file-name-directory (or load-file-name
- buffer-file-name)))))
+(defun comp-tests-pure-fibn-entry-f ()
+ (comp-tests-pure-fibn-f 1 0 20))
-;;; perl-mode-tests.el ends here
+;;; comp-test-pure.el ends here
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
new file mode 100644
index 0000000..ba8b8b0
--- /dev/null
+++ b/test/src/comp-tests.el
@@ -0,0 +1,1443 @@
+;;; comp-tests.el --- unit tests for src/comp.c -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2019-2021 Free Software Foundation, Inc.
+
+;; Author: Andrea Corallo <akrl@sdf.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:
+
+;; Unit tests for src/comp.c.
+
+;;; Code:
+
+(require 'ert)
+(require 'ert-x)
+(require 'cl-lib)
+
+(defconst comp-test-src (ert-resource-file "comp-test-funcs.el"))
+
+(defconst comp-test-dyn-src (ert-resource-file "comp-test-funcs-dyn.el"))
+
+(when (featurep 'nativecomp)
+ (require 'comp)
+ (message "Compiling tests...")
+ (load (native-compile comp-test-src))
+ (load (native-compile comp-test-dyn-src)))
+
+(defmacro comp-deftest (name args &rest docstring-and-body)
+ "Define a test for the native compiler tagging it as :nativecomp."
+ (declare (indent defun)
+ (doc-string 3))
+ `(ert-deftest ,(intern (concat "comp-tests-" (symbol-name name))) ,args
+ :tags '(:nativecomp)
+ ,@docstring-and-body))
+
+
+
+(ert-deftest comp-tests-bootstrap ()
+ "Compile the compiler and load it to compile it-self.
+Check that the resulting binaries do not differ."
+ :tags '(:expensive-test :nativecomp)
+ (let* ((byte-native-for-bootstrap t) ; FIXME HACK
+ (comp-src (expand-file-name "../../../lisp/emacs-lisp/comp.el"
+ (ert-resource-directory)))
+ (comp1-src (make-temp-file "stage1-" nil ".el"))
+ (comp2-src (make-temp-file "stage2-" nil ".el"))
+ ;; Can't use debug symbols.
+ (comp-debug 0))
+ (copy-file comp-src comp1-src t)
+ (copy-file comp-src comp2-src t)
+ (let ((load-no-native t))
+ (load (concat comp-src "c") nil nil t t))
+ (should-not (subr-native-elisp-p (symbol-function #'native-compile)))
+ (message "Compiling stage1...")
+ (let* ((t0 (current-time))
+ (comp1-eln (native-compile comp1-src)))
+ (message "Done in %d secs" (float-time (time-since t0)))
+ (load comp1-eln nil nil t t)
+ (should (subr-native-elisp-p (symbol-function 'native-compile)))
+ (message "Compiling stage2...")
+ (let ((t0 (current-time))
+ (comp2-eln (native-compile comp2-src)))
+ (message "Done in %d secs" (float-time (time-since t0)))
+ (message "Comparing %s %s" comp1-eln comp2-eln)
+ (should (= (call-process "cmp" nil nil nil comp1-eln comp2-eln) 0))))))
+
+(comp-deftest provide ()
+ "Testing top level provide."
+ (should (featurep 'comp-test-funcs)))
+
+(comp-deftest varref ()
+ "Testing varref."
+ (should (= (comp-tests-varref-f) 3)))
+
+(comp-deftest list ()
+ "Testing cons car cdr."
+ (should (equal (comp-tests-list-f) '(1 2 3)))
+ (should (equal (comp-tests-list2-f 1 2 3) '(1 2 3)))
+ (should (= (comp-tests-car-f '(1 . 2)) 1))
+ (should (null (comp-tests-car-f nil)))
+ (should-error (comp-tests-car-f 3)
+ :type 'wrong-type-argument)
+ (should (= (comp-tests-cdr-f '(1 . 2)) 2))
+ (should (null (comp-tests-cdr-f nil)))
+ (should-error (comp-tests-cdr-f 3)
+ :type 'wrong-type-argument)
+ (should (= (comp-tests-car-safe-f '(1 . 2)) 1))
+ (should (null (comp-tests-car-safe-f 'a)))
+ (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2))
+ (should (null (comp-tests-cdr-safe-f 'a))))
+
+(comp-deftest comp-tests-cons-car-cdr ()
+ "Testing cons car cdr."
+ (should (= (comp-tests-cons-car-f) 1))
+ (should (= (comp-tests-cons-cdr-f 3) 3)))
+
+(comp-deftest varset ()
+ "Testing varset."
+ (comp-tests-varset0-f)
+ (should (= comp-tests-var1 55))
+
+ (should (= (comp-tests-varset1-f) 4))
+ (should (= comp-tests-var1 66)))
+
+(comp-deftest length ()
+ "Testing length."
+ (should (= (comp-tests-length-f) 3)))
+
+(comp-deftest aref-aset ()
+ "Testing aref and aset."
+ (should (= (comp-tests-aref-aset-f) 100)))
+
+(comp-deftest symbol-value ()
+ "Testing aref and aset."
+ (should (= (comp-tests-symbol-value-f) 3)))
+
+(comp-deftest concat ()
+ "Testing concatX opcodes."
+ (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar")))
+
+(comp-deftest ffuncall ()
+ "Test calling conventions."
+
+ ;; (defun comp-tests-ffuncall-caller-f ()
+ ;; (comp-tests-ffuncall-callee-f 1 2 3))
+
+ ;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3)))
+
+ ;; ;; After it gets compiled
+ ;; (native-compile #'comp-tests-ffuncall-callee-f)
+ ;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3)))
+
+ ;; ;; Recompiling the caller once with callee already compiled
+ ;; (defun comp-tests-ffuncall-caller-f ()
+ ;; (comp-tests-ffuncall-callee-f 1 2 3))
+ ;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3)))
+
+ (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4)
+ '(1 2 3 4)))
+ (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3)
+ '(1 2 3 nil)))
+ (should (equal (comp-tests-ffuncall-callee-optional-f 1 2)
+ '(1 2 nil nil)))
+
+ (should (equal (comp-tests-ffuncall-callee-rest-f 1 2)
+ '(1 2 nil)))
+ (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3)
+ '(1 2 (3))))
+ (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4)
+ '(1 2 (3 4))))
+
+ (should (equal (comp-tests-ffuncall-callee-more8-f 1 2 3 4 5 6 7 8 9 10)
+ '(1 2 3 4 5 6 7 8 9 10)))
+
+ (should (equal (comp-tests-ffuncall-callee-more8-rest-f 1 2 3 4 5 6 7 8 9 10
11)
+ '(1 2 3 4 5 6 7 8 9 (10 11))))
+
+ (should (equal (comp-tests-ffuncall-native-f) [nil]))
+
+ (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3]))
+
+ (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3))
+ '(1 2 3)))
+
+ (should (= (comp-tests-ffuncall-lambda-f 1) 2)))
+
+(comp-deftest jump-table ()
+ "Testing jump tables"
+ (should (eq (comp-tests-jump-table-1-f 'x) 'a))
+ (should (eq (comp-tests-jump-table-1-f 'y) 'b))
+ (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))
+
+ ;; Jump table not with eq as test
+ (should (eq (comp-tests-jump-table-2-f "aaa") 'a))
+ (should (eq (comp-tests-jump-table-2-f "bbb") 'b)))
+
+(comp-deftest conditionals ()
+ "Testing conditionals."
+ (should (= (comp-tests-conditionals-1-f t) 1))
+ (should (= (comp-tests-conditionals-1-f nil) 2))
+ (should (= (comp-tests-conditionals-2-f t) 1340))
+ (should (eq (comp-tests-conditionals-2-f nil) nil)))
+
+(comp-deftest fixnum ()
+ "Testing some fixnum inline operation."
+ (should (= (comp-tests-fixnum-1-minus-f 10) 9))
+ (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum)
+ (1- most-negative-fixnum)))
+ (should-error (comp-tests-fixnum-1-minus-f 'a)
+ :type 'wrong-type-argument)
+ (should (= (comp-tests-fixnum-1-plus-f 10) 11))
+ (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum)
+ (1+ most-positive-fixnum)))
+ (should-error (comp-tests-fixnum-1-plus-f 'a)
+ :type 'wrong-type-argument)
+ (should (= (comp-tests-fixnum-minus-f 10) -10))
+ (should (= (comp-tests-fixnum-minus-f most-negative-fixnum)
+ (- most-negative-fixnum)))
+ (should-error (comp-tests-fixnum-minus-f 'a)
+ :type 'wrong-type-argument))
+
+(comp-deftest type-hints ()
+ "Just test compiler hints are transparent in this case."
+ ;; FIXME we should really check they are also effective.
+ (should (= (comp-tests-hint-fixnum-f 3) 4))
+ (should (= (comp-tests-hint-cons-f (cons 1 2)) 1)))
+
+(comp-deftest arith-comp ()
+ "Testing arithmetic comparisons."
+ (should (eq (comp-tests-eqlsign-f 4 3) nil))
+ (should (eq (comp-tests-eqlsign-f 3 3) t))
+ (should (eq (comp-tests-eqlsign-f 2 3) nil))
+ (should (eq (comp-tests-gtr-f 4 3) t))
+ (should (eq (comp-tests-gtr-f 3 3) nil))
+ (should (eq (comp-tests-gtr-f 2 3) nil))
+ (should (eq (comp-tests-lss-f 4 3) nil))
+ (should (eq (comp-tests-lss-f 3 3) nil))
+ (should (eq (comp-tests-lss-f 2 3) t))
+ (should (eq (comp-tests-les-f 4 3) nil))
+ (should (eq (comp-tests-les-f 3 3) t))
+ (should (eq (comp-tests-les-f 2 3) t))
+ (should (eq (comp-tests-geq-f 4 3) t))
+ (should (eq (comp-tests-geq-f 3 3) t))
+ (should (eq (comp-tests-geq-f 2 3) nil)))
+
+(comp-deftest setcarcdr ()
+ "Testing setcar setcdr."
+ (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10)))
+ (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3)))
+ (should-error (comp-tests-setcar-f 3 10)
+ :type 'wrong-type-argument)
+ (should-error (comp-tests-setcdr-f 3 10)
+ :type 'wrong-type-argument))
+
+(comp-deftest bubble-sort ()
+ "Run bubble sort."
+ (let* ((list1 (mapcar #'random (make-list 1000 most-positive-fixnum)))
+ (list2 (copy-sequence list1)))
+ (should (equal (comp-bubble-sort-f list1)
+ (sort list2 #'<)))))
+
+(comp-deftest apply ()
+ "Test some inlined list functions."
+ (should (eq (comp-tests-consp-f '(1)) t))
+ (should (eq (comp-tests-consp-f 1) nil))
+ (let ((x (cons 1 2)))
+ (should (= (comp-tests-setcar2-f x) 3))
+ (should (equal x '(3 . 2)))))
+
+(comp-deftest num-inline ()
+ "Test some inlined number functions."
+ (should (eq (comp-tests-integerp-f 1) t))
+ (should (eq (comp-tests-integerp-f '(1)) nil))
+ (should (eq (comp-tests-integerp-f 3.5) nil))
+ (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t))
+
+ (should (eq (comp-tests-numberp-f 1) t))
+ (should (eq (comp-tests-numberp-f 'a) nil))
+ (should (eq (comp-tests-numberp-f 3.5) t)))
+
+(comp-deftest stack ()
+ "Test some stack operation."
+ (should (= (comp-tests-discardn-f 10) 2))
+ (should (string= (with-temp-buffer
+ (comp-tests-insertn-f "a" "b" "c" "d")
+ (buffer-string))
+ "abcd")))
+
+(comp-deftest non-locals ()
+ "Test non locals."
+ (should (string= (comp-tests-condition-case-0-f)
+ "arith-error Arithmetic error catched"))
+ (should (string= (comp-tests-condition-case-1-f)
+ "error foo catched"))
+ (should (= (comp-tests-catch-f
+ (lambda () (throw 'foo 3)))
+ 3))
+ (should (= (catch 'foo
+ (comp-tests-throw-f 3)))))
+
+(comp-deftest gc ()
+ "Try to do some longer computation to let the GC kick in."
+ (dotimes (_ 100000)
+ (comp-tests-cons-cdr-f 3))
+ (should (= (comp-tests-cons-cdr-f 3) 3)))
+
+(comp-deftest buffer ()
+ (should (string= (comp-tests-buff0-f) "foo")))
+
+(comp-deftest lambda-return ()
+ (let ((f (comp-tests-lambda-return-f)))
+ (should (subr-native-elisp-p f))
+ (should (= (funcall f 3) 4))))
+
+(comp-deftest recursive ()
+ (should (= (comp-tests-fib-f 10) 55)))
+
+(comp-deftest macro ()
+ "Just check we can define macros"
+ (should (macrop (symbol-function 'comp-tests-macro-m))))
+
+(comp-deftest string-trim ()
+ (should (string= (comp-tests-string-trim-f "dsaf ") "dsaf")))
+
+(comp-deftest trampoline-removal ()
+ ;; This tests that we can call primitives with no dedicated bytecode.
+ ;; At speed >= 2 the trampoline will not be used.
+ (should (hash-table-p (comp-tests-trampoline-removal-f))))
+
+(comp-deftest signal ()
+ (should (equal (condition-case err
+ (comp-tests-signal-f)
+ (t err))
+ '(foo . t))))
+
+(comp-deftest func-call-removal ()
+ ;; See `comp-propagate-insn' `comp-function-call-remove'.
+ (should (= (comp-tests-func-call-removal-f) 1)))
+
+(comp-deftest doc ()
+ (should (string= (documentation #'comp-tests-doc-f)
+ "A nice docstring"))
+ ;; Check a preloaded function, we can't use `comp-tests-doc-f' now
+ ;; as this is loaded manually with no .elc.
+ (should (string-match "\\.*.elc\\'" (symbol-file #'error))))
+
+(comp-deftest interactive-form ()
+ (should (equal (interactive-form #'comp-test-interactive-form0-f)
+ '(interactive "D")))
+ (should (equal (interactive-form #'comp-test-interactive-form1-f)
+ '(interactive '(1 2))))
+ (should (equal (interactive-form #'comp-test-interactive-form2-f)
+ '(interactive nil)))
+ (should (cl-every #'commandp '(comp-test-interactive-form0-f
+ comp-test-interactive-form1-f
+ comp-test-interactive-form2-f)))
+ (should-not (commandp #'comp-tests-doc-f)))
+
+(comp-deftest free-fun ()
+ "Check we are able to compile a single function."
+ (eval '(defun comp-tests-free-fun-f ()
+ "Some doc."
+ (interactive)
+ 3)
+ t)
+ (native-compile #'comp-tests-free-fun-f)
+
+ (should (subr-native-elisp-p (symbol-function #'comp-tests-free-fun-f)))
+ (should (= (comp-tests-free-fun-f) 3))
+ (should (string= (documentation #'comp-tests-free-fun-f)
+ "Some doc."))
+ (should (commandp #'comp-tests-free-fun-f))
+ (should (equal (interactive-form #'comp-tests-free-fun-f)
+ '(interactive))))
+
+(comp-deftest free-fun-silly-name ()
+ "Check we are able to compile a single function."
+ (eval '(defun comp-tests/free\fun-f ()) t)
+ (native-compile #'comp-tests/free\fun-f)
+ (should (subr-native-elisp-p (symbol-function #'comp-tests/free\fun-f))))
+
+(comp-deftest bug-40187 ()
+ "Check function name shadowing.
+https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html.";
+ (should (eq (comp-test-40187-1-f) 'foo))
+ (should (eq (comp-test-40187-2-f) 'bar)))
+
+(comp-deftest speed--1 ()
+ "Check that at speed -1 we do not native compile."
+ (should (= (comp-test-speed--1-f) 3))
+ (should-not (subr-native-elisp-p (symbol-function #'comp-test-speed--1-f))))
+
+(comp-deftest bug-42360 ()
+ "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-07/msg00418.html>."
+ (should (string= (comp-test-42360-f "Nel mezzo del " 18 0 32 "yyy" nil)
+ "Nel mezzo del yyy")))
+
+(comp-deftest bug-44968 ()
+ "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-11/msg02357.html>"
+ (comp-test-44968-f "/tmp/test/foo" "/tmp"))
+
+(comp-deftest bug-45342 ()
+ "Preserve multibyte immediate strings.
+<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-12/msg01771.html>"
+ (should (string= " ➊" (comp-test-45342-f 1))))
+
+(comp-deftest assume-double-neg ()
+ "In fwprop assumptions (not (not (member x))) /= (member x)."
+ (should-not (comp-test-assume-double-neg-f "bar" "foo")))
+
+(comp-deftest assume-in-loop-1 ()
+ "Broken call args assumptions lead to infinite loop."
+ (should (equal (comp-test-assume-in-loop-1-f "cd") '("cd"))))
+
+(comp-deftest bug-45376-1 ()
+ "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-12/msg01883.html>"
+ (should (equal (comp-test-45376-1-f) '(1 0))))
+
+(comp-deftest bug-45376-2 ()
+ "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-12/msg01883.html>"
+ (should (equal (comp-test-45376-2-f) '(0 2 1 0 1 0 1 0 0 0 0 0))))
+
+(defvar comp-test-primitive-advice)
+(comp-deftest primitive-advice ()
+ "Test effectiveness of primitive advising."
+ (let (comp-test-primitive-advice
+ (f (lambda (&rest args)
+ (setq comp-test-primitive-advice args))))
+ (advice-add #'+ :before f)
+ (unwind-protect
+ (progn
+ (should (= (comp-test-primitive-advice-f 3 4) 7))
+ (should (equal comp-test-primitive-advice '(3 4))))
+ (advice-remove #'+ f))))
+
+(defvar comp-test-primitive-redefine-args)
+(comp-deftest primitive-redefine ()
+ "Test effectiveness of primitive redefinition."
+ (cl-letf ((comp-test-primitive-redefine-args nil)
+ ((symbol-function #'-)
+ (lambda (&rest args)
+ (setq comp-test-primitive-redefine-args args)
+ 'xxx)))
+ (should (eq (comp-test-primitive-redefine-f 10 2) 'xxx))
+ (should (equal comp-test-primitive-redefine-args '(10 2)))))
+
+(comp-deftest compile-forms ()
+ "Verify lambda form native compilation."
+ (should-error (native-compile '(+ 1 foo)))
+ (let ((lexical-binding t)
+ (f (native-compile '(lambda (x) (1+ x)))))
+ (should (subr-native-elisp-p f))
+ (should (= (funcall f 2) 3)))
+ (let* ((lexical-binding nil)
+ (f (native-compile '(lambda (x) (1+ x)))))
+ (should (subr-native-elisp-p f))
+ (should (= (funcall f 2) 3))))
+
+(comp-deftest comp-test-defsubst ()
+ ;; Bug#42664, Bug#43280, Bug#44209.
+ (should-not (subr-native-elisp-p (symbol-function #'comp-test-defsubst-f))))
+
+(comp-deftest primitive-redefine-compile-44221 ()
+ "Test the compiler still works while primitives are redefined (bug#44221)."
+ (cl-letf (((symbol-function #'delete-region)
+ (lambda (_ _))))
+ (should (subr-native-elisp-p
+ (native-compile
+ '(lambda ()
+ (delete-region (point-min) (point-max))))))))
+
+(comp-deftest and-3 ()
+ (should (= (comp-test-and-3-f t) 2))
+ (should (null (comp-test-and-3-f '(1 2)))))
+
+(comp-deftest copy-insn ()
+ (should (equal (comp-test-copy-insn-f '(1 2 3 (4 5 6)))
+ '(1 2 3 (4 5 6))))
+ (should (null (comp-test-copy-insn-f nil))))
+
+(comp-deftest cond-rw-1 ()
+ "Check cond-rw does not break target blocks with multiple predecessor."
+ (should (null (comp-test-cond-rw-1-2-f))))
+
+(comp-deftest not-cons-1 ()
+ (should-not (comp-test-not-cons-f nil)))
+
+(comp-deftest 45576-1 ()
+ "Functionp satisfies also symbols.
+<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-01/msg00029.html>."
+ (should (eq (comp-test-45576-f) 'eval)))
+
+(comp-deftest 45635-1 ()
+ "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-01/msg00158.html>."
+ (should (string= (comp-test-45635-f :height 180 :family "PragmataPro Liga")
+ "PragmataPro Liga")))
+
+(comp-deftest 45603-1 ()
+ "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-12/msg01994.html>"
+ (load (native-compile (ert-resource-file "comp-test-45603.el")))
+ (should (fboundp #'comp-test-45603--file-local-name)))
+
+(comp-deftest 46670-1 ()
+ "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-02/msg01413.html>"
+ (should (string= (comp-test-46670-2-f "foo") "foo"))
+ (should (equal (subr-type (symbol-function #'comp-test-46670-2-f))
+ '(function (t) t))))
+
+(comp-deftest 46824-1 ()
+ "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-02/msg01949.html>"
+ (should (equal (comp-test-46824-1-f) nil)))
+
+(comp-deftest comp-test-47868-1 ()
+ "Verify string hash consing strategy.
+
+<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-04/msg00921.html>"
+ (should-not (equal-including-properties (comp-test-47868-1-f)
+ (comp-test-47868-2-f)))
+ (should (eq (comp-test-47868-1-f) (comp-test-47868-3-f)))
+ (should (eq (comp-test-47868-2-f) (comp-test-47868-4-f))))
+
+
+;;;;;;;;;;;;;;;;;;;;;
+;; Tromey's tests. ;;
+;;;;;;;;;;;;;;;;;;;;;
+
+(comp-deftest consp ()
+ (should-not (comp-test-consp 23))
+ (should-not (comp-test-consp nil))
+ (should (comp-test-consp '(1 . 2))))
+
+(comp-deftest listp ()
+ (should-not (comp-test-listp 23))
+ (should (comp-test-listp nil))
+ (should (comp-test-listp '(1 . 2))))
+
+(comp-deftest stringp ()
+ (should-not (comp-test-stringp 23))
+ (should-not (comp-test-stringp nil))
+ (should (comp-test-stringp "hi")))
+
+(comp-deftest symbolp ()
+ (should-not (comp-test-symbolp 23))
+ (should-not (comp-test-symbolp "hi"))
+ (should (comp-test-symbolp 'whatever)))
+
+(comp-deftest integerp ()
+ (should (comp-test-integerp 23))
+ (should-not (comp-test-integerp 57.5))
+ (should-not (comp-test-integerp "hi"))
+ (should-not (comp-test-integerp 'whatever)))
+
+(comp-deftest numberp ()
+ (should (comp-test-numberp 23))
+ (should (comp-test-numberp 57.5))
+ (should-not (comp-test-numberp "hi"))
+ (should-not (comp-test-numberp 'whatever)))
+
+(comp-deftest add1 ()
+ (should (eq (comp-test-add1 23) 24))
+ (should (eq (comp-test-add1 -17) -16))
+ (should (eql (comp-test-add1 1.0) 2.0))
+ (should-error (comp-test-add1 nil)
+ :type 'wrong-type-argument))
+
+(comp-deftest sub1 ()
+ (should (eq (comp-test-sub1 23) 22))
+ (should (eq (comp-test-sub1 -17) -18))
+ (should (eql (comp-test-sub1 1.0) 0.0))
+ (should-error (comp-test-sub1 nil)
+ :type 'wrong-type-argument))
+
+(comp-deftest negate ()
+ (should (eq (comp-test-negate 23) -23))
+ (should (eq (comp-test-negate -17) 17))
+ (should (eql (comp-test-negate 1.0) -1.0))
+ (should-error (comp-test-negate nil)
+ :type 'wrong-type-argument))
+
+(comp-deftest not ()
+ (should (eq (comp-test-not 23) nil))
+ (should (eq (comp-test-not nil) t))
+ (should (eq (comp-test-not t) nil)))
+
+(comp-deftest bobp-and-eobp ()
+ (with-temp-buffer
+ (should (comp-test-bobp))
+ (should (comp-test-eobp))
+ (insert "hi")
+ (goto-char (point-min))
+ (should (eq (comp-test-point-min) (point-min)))
+ (should (eq (comp-test-point) (point-min)))
+ (should (comp-test-bobp))
+ (should-not (comp-test-eobp))
+ (goto-char (point-max))
+ (should (eq (comp-test-point-max) (point-max)))
+ (should (eq (comp-test-point) (point-max)))
+ (should-not (comp-test-bobp))
+ (should (comp-test-eobp))))
+
+(comp-deftest car-cdr ()
+ (let ((pair '(1 . b)))
+ (should (eq (comp-test-car pair) 1))
+ (should (eq (comp-test-car nil) nil))
+ (should-error (comp-test-car 23)
+ :type 'wrong-type-argument)
+ (should (eq (comp-test-cdr pair) 'b))
+ (should (eq (comp-test-cdr nil) nil))
+ (should-error (comp-test-cdr 23)
+ :type 'wrong-type-argument)))
+
+(comp-deftest car-cdr-safe ()
+ (let ((pair '(1 . b)))
+ (should (eq (comp-test-car-safe pair) 1))
+ (should (eq (comp-test-car-safe nil) nil))
+ (should (eq (comp-test-car-safe 23) nil))
+ (should (eq (comp-test-cdr-safe pair) 'b))
+ (should (eq (comp-test-cdr-safe nil) nil))
+ (should (eq (comp-test-cdr-safe 23) nil))))
+
+(comp-deftest eq ()
+ (should (comp-test-eq 'a 'a))
+ (should (comp-test-eq 5 5))
+ (should-not (comp-test-eq 'a 'b)))
+
+(comp-deftest if ()
+ (should (eq (comp-test-if 'a 'b) 'a))
+ (should (eq (comp-test-if 0 23) 0))
+ (should (eq (comp-test-if nil 'b) 'b)))
+
+(comp-deftest and ()
+ (should (eq (comp-test-and 'a 'b) 'b))
+ (should (eq (comp-test-and 0 23) 23))
+ (should (eq (comp-test-and nil 'b) nil)))
+
+(comp-deftest or ()
+ (should (eq (comp-test-or 'a 'b) 'a))
+ (should (eq (comp-test-or 0 23) 0))
+ (should (eq (comp-test-or nil 'b) 'b)))
+
+(comp-deftest save-excursion ()
+ (with-temp-buffer
+ (comp-test-save-excursion)
+ (should (eq (point) (point-min)))
+ (should (eq (comp-test-current-buffer) (current-buffer)))))
+
+(comp-deftest > ()
+ (should (eq (comp-test-> 0 23) nil))
+ (should (eq (comp-test-> 23 0) t)))
+
+(comp-deftest catch ()
+ (should (eq (comp-test-catch 0 1 2 3 4) nil))
+ (should (eq (comp-test-catch 20 21 22 23 24 25 26 27 28) 24)))
+
+(comp-deftest memq ()
+ (should (equal (comp-test-memq 0 '(5 4 3 2 1 0)) '(0)))
+ (should (eq (comp-test-memq 72 '(5 4 3 2 1 0)) nil)))
+
+(comp-deftest listN ()
+ (should (equal (comp-test-listN 57)
+ '(57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57))))
+
+(comp-deftest concatN ()
+ (should (equal (comp-test-concatN "x") "xxxxxx")))
+
+(comp-deftest opt-rest ()
+ (should (equal (comp-test-opt-rest 1) '(1 nil nil)))
+ (should (equal (comp-test-opt-rest 1 2) '(1 2 nil)))
+ (should (equal (comp-test-opt-rest 1 2 3) '(1 2 (3))))
+ (should (equal (comp-test-opt-rest 1 2 56 57 58)
+ '(1 2 (56 57 58)))))
+
+(comp-deftest opt ()
+ (should (equal (comp-test-opt 23) '(23)))
+ (should (equal (comp-test-opt 23 24) '(23 . 24)))
+ (should-error (comp-test-opt)
+ :type 'wrong-number-of-arguments)
+ (should-error (comp-test-opt nil 24 97)
+ :type 'wrong-number-of-arguments))
+
+(comp-deftest unwind-protect ()
+ (comp-test-unwind-protect 'ignore)
+ (should (eq comp-test-up-val 999))
+ (condition-case nil
+ (comp-test-unwind-protect (lambda () (error "HI")))
+ (error
+ nil))
+ (should (eq comp-test-up-val 999)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Tests for dynamic scope. ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(comp-deftest dynamic-ffuncall ()
+ "Test calling convention for dynamic binding."
+
+ (should (equal (comp-tests-ffuncall-callee-dyn-f 1 2)
+ '(1 2)))
+
+ (should (equal (comp-tests-ffuncall-callee-opt-dyn-f 1 2 3 4)
+ '(1 2 3 4)))
+ (should (equal (comp-tests-ffuncall-callee-opt-dyn-f 1 2 3)
+ '(1 2 3 nil)))
+ (should (equal (comp-tests-ffuncall-callee-opt-dyn-f 1 2)
+ '(1 2 nil nil)))
+
+ (should (equal (comp-tests-ffuncall-callee-rest-dyn-f 1 2)
+ '(1 2 nil)))
+ (should (equal (comp-tests-ffuncall-callee-rest-dyn-f 1 2 3)
+ '(1 2 (3))))
+ (should (equal (comp-tests-ffuncall-callee-rest-dyn-f 1 2 3 4)
+ '(1 2 (3 4))))
+
+ (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2)
+ '(1 2 nil nil)))
+ (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2 3)
+ '(1 2 3 nil)))
+ (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2 3 4)
+ '(1 2 3 (4)))))
+
+(comp-deftest dynamic-arity ()
+ "Test func-arity on dynamic scope functions."
+ (should (equal '(2 . 2)
+ (func-arity #'comp-tests-ffuncall-callee-dyn-f)))
+ (should (equal '(2 . 4)
+ (func-arity #'comp-tests-ffuncall-callee-opt-dyn-f)))
+ (should (equal '(2 . many)
+ (func-arity #'comp-tests-ffuncall-callee-rest-dyn-f)))
+ (should (equal '(2 . many)
+ (func-arity #'comp-tests-ffuncall-callee-opt-rest-dyn-f))))
+
+(comp-deftest dynamic-help-arglist ()
+ "Test `help-function-arglist' works on lisp/d (bug#42572)."
+ (should (equal (help-function-arglist
+ (symbol-function #'comp-tests-ffuncall-callee-opt-rest-dyn-f)
+ t)
+ '(a b &optional c &rest d))))
+
+(comp-deftest cl-macro-exp ()
+ "Verify CL macro expansion (bug#42088)."
+ (should (equal (comp-tests-cl-macro-exp-f) '(a b))))
+
+(comp-deftest cl-uninterned-arg-parse-f ()
+ "Verify the parsing of a lambda list with uninterned symbols (bug#42120)."
+ (should (equal (comp-tests-cl-uninterned-arg-parse-f 1 2)
+ '(1 2))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Middle-end specific tests. ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun comp-tests-mentioned-p-1 (x insn)
+ (cl-loop for y in insn
+ when (cond
+ ((consp y) (comp-tests-mentioned-p x y))
+ ((and (comp-mvar-p y) (comp-cstr-imm-vld-p y))
+ (equal (comp-cstr-imm y) x))
+ (t (equal x y)))
+ return t))
+
+(defun comp-tests-mentioned-p (x insn)
+ "Check if X is actively mentioned in INSN."
+ (unless (eq (car-safe insn)
+ 'comment)
+ (comp-tests-mentioned-p-1 x insn)))
+
+(defun comp-tests-map-checker (func-name checker)
+ "Apply CHECKER to each insn of FUNC-NAME.
+Return a list of results."
+ (cl-loop
+ with func-c-name = (comp-c-func-name (or func-name 'anonymous-lambda) "F"
t)
+ with f = (gethash func-c-name (comp-ctxt-funcs-h comp-ctxt))
+ for bb being each hash-value of (comp-func-blocks f)
+ nconc
+ (cl-loop
+ for insn in (comp-block-insns bb)
+ collect (funcall checker insn))))
+
+(defun comp-tests-tco-checker (_)
+ "Check that inside `comp-tests-tco-f' we have no recursion."
+ (should
+ (cl-notany
+ #'identity
+ (comp-tests-map-checker
+ 'comp-tests-tco-f
+ (lambda (insn)
+ (or (comp-tests-mentioned-p 'comp-tests-tco-f insn)
+ (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-tco-f "F" t)
+ insn)))))))
+
+(comp-deftest tco ()
+ "Check for tail recursion elimination."
+ (let ((comp-speed 3)
+ ;; Disable ipa-pure otherwise `comp-tests-tco-f' gets
+ ;; optimized-out.
+ (comp-disabled-passes '(comp-ipa-pure))
+ (comp-post-pass-hooks '((comp-tco comp-tests-tco-checker)
+ (comp-final comp-tests-tco-checker))))
+ (eval '(defun comp-tests-tco-f (a b count)
+ (if (= count 0)
+ b
+ (comp-tests-tco-f (+ a b) a (- count 1))))
+ t)
+ (native-compile #'comp-tests-tco-f)
+ (should (subr-native-elisp-p (symbol-function #'comp-tests-tco-f)))
+ (should (= (comp-tests-tco-f 1 0 10) 55))))
+
+(defun comp-tests-fw-prop-checker-1 (_)
+ "Check that inside `comp-tests-fw-prop-f' `concat' and `length' are folded."
+ (should
+ (cl-notany
+ #'identity
+ (comp-tests-map-checker
+ 'comp-tests-fw-prop-1-f
+ (lambda (insn)
+ (or (comp-tests-mentioned-p 'concat insn)
+ (comp-tests-mentioned-p 'length insn)))))))
+
+(comp-deftest fw-prop-1 ()
+ "Some tests for forward propagation."
+ (let ((comp-speed 2)
+ (comp-post-pass-hooks '((comp-final comp-tests-fw-prop-checker-1))))
+ (eval '(defun comp-tests-fw-prop-1-f ()
+ (let* ((a "xxx")
+ (b "yyy")
+ (c (concat a b))) ; <= has to optimize
+ (length c))) ; <= has to optimize
+ t)
+ (native-compile #'comp-tests-fw-prop-1-f)
+ (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f)))
+ (should (= (comp-tests-fw-prop-1-f) 6))))
+
+(defun comp-tests-check-ret-type-spec (func-form ret-type)
+ (let ((lexical-binding t)
+ (comp-speed 2)
+ (f-name (cl-second func-form)))
+ (eval func-form t)
+ (native-compile f-name)
+ (should (equal (cl-third (subr-type (symbol-function f-name)))
+ ret-type))))
+
+(cl-eval-when (compile eval load)
+ (defconst comp-tests-type-spec-tests
+ `(
+ ;; 1
+ ((defun comp-tests-ret-type-spec-f (x)
+ x)
+ t)
+
+ ;; 2
+ ((defun comp-tests-ret-type-spec-f ()
+ 1)
+ (integer 1 1))
+
+ ;; 3
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if x 1 3))
+ (or (integer 1 1) (integer 3 3)))
+
+ ;; 4
+ ((defun comp-tests-ret-type-spec-f (x)
+ (let (y)
+ (if x
+ (setf y 1)
+ (setf y 2))
+ y))
+ (integer 1 2))
+
+ ;; 5
+ ((defun comp-tests-ret-type-spec-f (x)
+ (let (y)
+ (if x
+ (setf y 1)
+ (setf y 3))
+ y))
+ (or (integer 1 1) (integer 3 3)))
+
+ ;; 6
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if x
+ (list x)
+ 3))
+ (or cons (integer 3 3)))
+
+ ;; 7
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if x
+ 'foo
+ 3))
+ (or (member foo) (integer 3 3)))
+
+ ;; 8
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (eq x 3)
+ x
+ 'foo))
+ (or (member foo) (integer 3 3)))
+
+ ;; 9
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (eq 3 x)
+ x
+ 'foo))
+ (or (member foo) (integer 3 3)))
+
+ ;; 10
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (eql x 3)
+ x
+ 'foo))
+ (or (member foo) (integer 3 3)))
+
+ ;; 11
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (eql 3 x)
+ x
+ 'foo))
+ (or (member foo) (integer 3 3)))
+
+ ;; 12
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (eql x 3)
+ 'foo
+ x))
+ (not (integer 3 3)))
+
+ ;; 13
+ ((defun comp-tests-ret-type-spec-f (x y)
+ (if (= x y)
+ x
+ 'foo))
+ (or (member foo) marker number))
+
+ ;; 14
+ ((defun comp-tests-ret-type-spec-f (x)
+ (comp-hint-fixnum x))
+ (integer ,most-negative-fixnum ,most-positive-fixnum))
+
+ ;; 15
+ ((defun comp-tests-ret-type-spec-f (x)
+ (comp-hint-cons x))
+ cons)
+
+ ;; 16
+ ((defun comp-tests-ret-type-spec-f (x)
+ (let (y)
+ (when x
+ (setf y 4))
+ y))
+ (or null (integer 4 4)))
+
+ ;; 17
+ ((defun comp-tests-ret-type-spec-f ()
+ (let (x
+ (y 3))
+ (setf x y)
+ y))
+ (integer 3 3))
+
+ ;; 18
+ ((defun comp-tests-ret-type-spec-f (x)
+ (let ((y 3))
+ (when x
+ (setf y x))
+ y))
+ t)
+
+ ;; 19
+ ((defun comp-tests-ret-type-spec-f (x y)
+ (eq x y))
+ boolean)
+
+ ;; 20
+ ((defun comp-tests-ret-type-spec-f (x)
+ (when x
+ 'foo))
+ (or (member foo) null))
+
+ ;; 21
+ ((defun comp-tests-ret-type-spec-f (x)
+ (unless x
+ 'foo))
+ (or (member foo) null))
+
+ ;; 22
+ ((defun comp-tests-ret-type-spec-f (x)
+ (when (> x 3)
+ x))
+ (or null float (integer 4 *)))
+
+ ;; 23
+ ((defun comp-tests-ret-type-spec-f (x)
+ (when (>= x 3)
+ x))
+ (or null float (integer 3 *)))
+
+ ;; 24
+ ((defun comp-tests-ret-type-spec-f (x)
+ (when (< x 3)
+ x))
+ (or null float (integer * 2)))
+
+ ;; 25
+ ((defun comp-tests-ret-type-spec-f (x)
+ (when (<= x 3)
+ x))
+ (or null float (integer * 3)))
+
+ ;; 26
+ ((defun comp-tests-ret-type-spec-f (x)
+ (when (> 3 x)
+ x))
+ (or null float (integer * 2)))
+
+ ;; 27
+ ((defun comp-tests-ret-type-spec-f (x)
+ (when (>= 3 x)
+ x))
+ (or null float (integer * 3)))
+
+ ;; 28
+ ((defun comp-tests-ret-type-spec-f (x)
+ (when (< 3 x)
+ x))
+ (or null float (integer 4 *)))
+
+ ;; 29
+ ((defun comp-tests-ret-type-spec-f (x)
+ (when (<= 3 x)
+ x))
+ (or null float (integer 3 *)))
+
+ ;; 30
+ ((defun comp-tests-ret-type-spec-f (x)
+ (let ((y 3))
+ (when (> x y)
+ x)))
+ (or null float (integer 4 *)))
+
+ ;; 31
+ ((defun comp-tests-ret-type-spec-f (x)
+ (let ((y 3))
+ (when (> y x)
+ x)))
+ (or null float (integer * 2)))
+
+ ;; 32
+ ((defun comp-tests-ret-type-spec-f (x)
+ (when (and (> x 3)
+ (< x 10))
+ x))
+ (or null float (integer 4 9)))
+
+ ;; 33
+ ((defun comp-tests-ret-type-spec-f (x)
+ (when (or (> x 3)
+ (< x 10))
+ x))
+ (or null float integer))
+
+ ;; 34
+ ((defun comp-tests-ret-type-spec-f (x)
+ (when (or (< x 3)
+ (> x 10))
+ x))
+ (or null float (integer * 2) (integer 11 *)))
+
+ ;; 35 No float range support.
+ ((defun comp-tests-ret-type-spec-f (x)
+ (when (> x 1.0)
+ x))
+ (or null marker number))
+
+ ;; 36
+ ((defun comp-tests-ret-type-spec-f (x y)
+ (when (and (> x 3)
+ (> y 2))
+ (+ x y)))
+ (or null float (integer 7 *)))
+
+ ;; 37
+ ;; SBCL: (OR REAL NULL)
+ ((defun comp-tests-ret-type-spec-f (x y)
+ (when (and (<= x 3)
+ (<= y 2))
+ (+ x y)))
+ (or null float (integer * 5)))
+
+ ;; 38
+ ((defun comp-tests-ret-type-spec-f (x y)
+ (when (and (< 1 x 5)
+ (< 1 y 5))
+ (+ x y)))
+ (or null float (integer 4 8)))
+
+ ;; 39
+ ;; SBCL gives: (OR REAL NULL)
+ ((defun comp-tests-ret-type-spec-f (x y)
+ (when (and (<= 1 x 10)
+ (<= 2 y 3))
+ (+ x y)))
+ (or null float (integer 3 13)))
+
+ ;; 40
+ ;; SBCL: (OR REAL NULL)
+ ((defun comp-tests-ret-type-spec-f (x y)
+ (when (and (<= 1 x 10)
+ (<= 2 y 3))
+ (- x y)))
+ (or null float (integer -2 8)))
+
+ ;; 41
+ ((defun comp-tests-ret-type-spec-f (x y)
+ (when (and (<= 1 x)
+ (<= 2 y 3))
+ (- x y)))
+ (or null float (integer -2 *)))
+
+ ;; 42
+ ((defun comp-tests-ret-type-spec-f (x y)
+ (when (and (<= 1 x 10)
+ (<= 2 y))
+ (- x y)))
+ (or null float (integer * 8)))
+
+ ;; 43
+ ((defun comp-tests-ret-type-spec-f (x y)
+ (when (and (<= x 10)
+ (<= 2 y))
+ (- x y)))
+ (or null float (integer * 8)))
+
+ ;; 44
+ ((defun comp-tests-ret-type-spec-f (x y)
+ (when (and (<= x 10)
+ (<= y 3))
+ (- x y)))
+ (or null float integer))
+
+ ;; 45
+ ((defun comp-tests-ret-type-spec-f (x y)
+ (when (and (<= 2 x)
+ (<= 3 y))
+ (- x y)))
+ (or null float integer))
+
+ ;; 46
+ ;; SBCL: (OR (RATIONAL (6) (30)) (SINGLE-FLOAT 6.0 30.0)
+ ;; (DOUBLE-FLOAT 6.0d0 30.0d0) NULL)
+ ((defun comp-tests-ret-type-spec-f (x y z i j k)
+ (when (and (< 1 x 5)
+ (< 1 y 5)
+ (< 1 z 5)
+ (< 1 i 5)
+ (< 1 j 5)
+ (< 1 k 5))
+ (+ x y z i j k)))
+ (or null float (integer 12 24)))
+
+ ;; 47
+ ((defun comp-tests-ret-type-spec-f (x)
+ (when (<= 1 x 5)
+ (1+ x)))
+ (or null float (integer 2 6)))
+
+ ;;48
+ ((defun comp-tests-ret-type-spec-f (x)
+ (when (<= 1 x 5)
+ (1- x)))
+ (or null float (integer 0 4)))
+
+ ;; 49
+ ((defun comp-tests-ret-type-spec-f ()
+ (error "foo"))
+ nil)
+
+ ;; 50
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (stringp x)
+ x
+ 'bar))
+ (or (member bar) string))
+
+ ;; 51
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (stringp x)
+ 'bar
+ x))
+ (not string))
+
+ ;; 52
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (integerp x)
+ x
+ 'bar))
+ (or (member bar) integer))
+
+ ;; 53
+ ((defun comp-tests-ret-type-spec-f (x)
+ (when (integerp x)
+ x))
+ (or null integer))
+
+ ;; 54
+ ((defun comp-tests-ret-type-spec-f (x)
+ (unless (symbolp x)
+ x))
+ t)
+
+ ;; 55
+ ((defun comp-tests-ret-type-spec-f (x)
+ (unless (integerp x)
+ x))
+ (not integer))
+
+ ;; 56
+ ((defun comp-tests-ret-type-spec-f (x)
+ (cl-ecase x
+ (1 (message "one"))
+ (5 (message "five")))
+ x)
+ t
+ ;; FIXME improve `comp-cond-cstrs-target-mvar' to cross block
+ ;; boundary if necessary as this should return:
+ ;; (or (integer 1 1) (integer 5 5))
+ )
+
+ ;; 57
+ ((defun comp-tests-ret-type-spec-f (x)
+ (unless (or (eq x 'foo)
+ (eql x 3))
+ (error "Not foo or 3"))
+ x)
+ (or (member foo) (integer 3 3)))
+
+ ;;58
+ ((defun comp-tests-ret-type-spec-f (x y)
+ (if (and (natnump x)
+ (natnump y)
+ (<= x y))
+ x
+ (error "")))
+ (integer 0 *))
+
+ ;; 59
+ ((defun comp-tests-ret-type-spec-f (x y)
+ (if (and (>= x 3)
+ (<= y 10)
+ (<= x y))
+ x
+ (error "")))
+ (or float (integer 3 10)))
+
+ ;; 60
+ ((defun comp-tests-ret-type-spec-f (x y)
+ (if (and (<= x 10)
+ (>= y 3)
+ (>= x y))
+ x
+ (error "")))
+ (or float (integer 3 10)))
+
+ ;; 61
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (= x 1.0)
+ x
+ (error "")))
+ (or (member 1.0) (integer 1 1)))
+
+ ;; 62
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (= x 1.0)
+ x
+ (error "")))
+ (or (member 1.0) (integer 1 1)))
+
+ ;; 63
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (= x 1.1)
+ x
+ (error "")))
+ (member 1.1))
+
+ ;; 64
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (= x 1)
+ x
+ (error "")))
+ (or (member 1.0) (integer 1 1)))
+
+ ;; 65
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (= x 1)
+ x
+ (error "")))
+ (or (member 1.0) (integer 1 1)))
+
+ ;; 66
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (eql x 0.0)
+ x
+ (error "")))
+ float)
+
+ ;; 67
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (equal x '(1 2 3))
+ x
+ (error "")))
+ cons)
+
+ ;; 68
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (and (floatp x)
+ (= x 1))
+ x
+ (error "")))
+ ;; Conservative (see cstr relax in `comp-cstr-=').
+ (or (member 1.0) (integer 1 1)))
+
+ ;; 69
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (and (integer x)
+ (= x 1))
+ x
+ (error "")))
+ ;; Conservative (see cstr relax in `comp-cstr-=').
+ (or (member 1.0) (integer 1 1)))
+
+ ;; 70
+ ((defun comp-tests-ret-type-spec-f (x y)
+ (if (and (floatp x)
+ (integerp y)
+ (= x y))
+ x
+ (error "")))
+ (or float integer))
+
+ ;; 71
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (= x 0.0)
+ x
+ (error "")))
+ (or (member -0.0 0.0) (integer 0 0)))
+
+ ;; 72
+ ((defun comp-tests-ret-type-spec-f (x)
+ (unless (= x 0.0)
+ (error ""))
+ (unless (eql x -0.0)
+ (error ""))
+ x)
+ float)
+
+ ;; 73
+ ((defun comp-tests-ret-type-spec-f (x)
+ (when (eql x 1.0)
+ (error ""))
+ x)
+ t)))
+
+ (defun comp-tests-define-type-spec-test (number x)
+ `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) ()
+ ,(format "Type specifier test number %d." number)
+ (let ((comp-ctxt (make-comp-cstr-ctxt)))
+ (comp-tests-check-ret-type-spec ',(car x) ',(cadr x))))))
+
+(defmacro comp-tests-define-type-spec-tests ()
+ "Define all type specifier tests."
+ `(progn
+ ,@(cl-loop
+ for test in comp-tests-type-spec-tests
+ for n from 1
+ collect (comp-tests-define-type-spec-test n test))))
+
+(comp-tests-define-type-spec-tests)
+
+(defun comp-tests-pure-checker-1 (_)
+ "Check that inside `comp-tests-pure-caller-f' `comp-tests-pure-callee-f' is
+ folded."
+ (should
+ (cl-notany
+ #'identity
+ (comp-tests-map-checker
+ 'comp-tests-pure-caller-f
+ (lambda (insn)
+ (or (comp-tests-mentioned-p 'comp-tests-pure-callee-f insn)
+ (comp-tests-mentioned-p (comp-c-func-name
+ 'comp-tests-pure-callee-f "F" t)
+ insn)))))))
+
+(defun comp-tests-pure-checker-2 (_)
+ "Check that `comp-tests-pure-fibn-f' is folded."
+ (should
+ (cl-notany
+ #'identity
+ (comp-tests-map-checker
+ 'comp-tests-pure-fibn-entry-f
+ (lambda (insn)
+ (or (comp-tests-mentioned-p 'comp-tests-pure-fibn-f insn)
+ (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-pure-fibn-f
"F" t)
+ insn)))))))
+
+(comp-deftest pure ()
+ "Some tests for pure functions optimization."
+ (let ((comp-speed 3)
+ (comp-post-pass-hooks '((comp-final comp-tests-pure-checker-1
+ comp-tests-pure-checker-2))))
+ (load (native-compile (ert-resource-file "comp-test-pure.el")))
+
+ (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-caller-f)))
+ (should (= (comp-tests-pure-caller-f) 4))
+
+ (should (subr-native-elisp-p (symbol-function
#'comp-tests-pure-fibn-entry-f)))
+ (should (= (comp-tests-pure-fibn-entry-f) 6765))))
+
+(defvar comp-tests-cond-rw-checked-function nil
+ "Function to be checked.")
+(defun comp-tests-cond-rw-checker-val (_)
+ "Check we manage to propagate the correct return value."
+ (should
+ (cl-some
+ #'identity
+ (comp-tests-map-checker
+ comp-tests-cond-rw-checked-function
+ (lambda (insn)
+ (pcase insn
+ (`(return ,mvar)
+ (and (comp-cstr-imm-vld-p mvar)
+ (eql (comp-cstr-imm mvar) 123)))))))))
+
+(defvar comp-tests-cond-rw-expected-type nil
+ "Type to expect in `comp-tests-cond-rw-checker-type'.")
+(defun comp-tests-cond-rw-checker-type (_)
+ "Check we manage to propagate the correct return type."
+ (should
+ (cl-some
+ #'identity
+ (comp-tests-map-checker
+ comp-tests-cond-rw-checked-function
+ (lambda (insn)
+ (pcase insn
+ (`(return ,mvar)
+ (equal (comp-mvar-typeset mvar)
+ comp-tests-cond-rw-expected-type))))))))
+
+;;; comp-tests.el ends here
diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el
index ea80da4..a731a95 100644
--- a/test/src/editfns-tests.el
+++ b/test/src/editfns-tests.el
@@ -1,4 +1,4 @@
-;;; editfns-tests.el -- tests for editfns.c -*- lexical-binding:t -*-
+;;; editfns-tests.el --- tests for editfns.c -*- lexical-binding:t -*-
;; Copyright (C) 2016-2021 Free Software Foundation, Inc.
diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el
index af5bc2a..0a68d51 100644
--- a/test/src/emacs-module-tests.el
+++ b/test/src/emacs-module-tests.el
@@ -1,4 +1,4 @@
-;;; emacs-module-tests --- Test GNU Emacs modules. -*- lexical-binding: t; -*-
+;;; emacs-module-tests.el --- Test GNU Emacs modules. -*- lexical-binding: t;
-*-
;; Copyright 2015-2021 Free Software Foundation, Inc.
diff --git a/test/src/emacs-resources/seccomp-filter-exec.bpf
b/test/src/emacs-resources/seccomp-filter-exec.bpf
new file mode 120000
index 0000000..5b0e997
--- /dev/null
+++ b/test/src/emacs-resources/seccomp-filter-exec.bpf
@@ -0,0 +1 @@
+../../../lib-src/seccomp-filter-exec.bpf
\ No newline at end of file
diff --git a/test/src/emacs-resources/seccomp-filter.bpf
b/test/src/emacs-resources/seccomp-filter.bpf
new file mode 120000
index 0000000..b3d603d
--- /dev/null
+++ b/test/src/emacs-resources/seccomp-filter.bpf
@@ -0,0 +1 @@
+../../../lib-src/seccomp-filter.bpf
\ No newline at end of file
diff --git a/test/src/emacs-tests.el b/test/src/emacs-tests.el
new file mode 100644
index 0000000..ee5586f
--- /dev/null
+++ b/test/src/emacs-tests.el
@@ -0,0 +1,257 @@
+;;; emacs-tests.el --- unit tests for emacs.c -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Unit tests for src/emacs.c.
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'ert)
+(require 'ert-x)
+(require 'rx)
+(require 'subr-x)
+
+(ert-deftest emacs-tests/seccomp/absent-file ()
+ (skip-unless (string-match-p (rx bow "SECCOMP" eow)
+ system-configuration-features))
+ (let ((emacs
+ (expand-file-name invocation-name invocation-directory))
+ (process-environment nil))
+ (skip-unless (file-executable-p emacs))
+ (should-not (file-exists-p "/does-not-exist.bpf"))
+ (should-not
+ (eql (call-process emacs nil nil nil
+ "--quick" "--batch"
+ "--seccomp=/does-not-exist.bpf")
+ 0))))
+
+(cl-defmacro emacs-tests--with-temp-file
+ (var (prefix &optional suffix text) &rest body)
+ "Evaluate BODY while a new temporary file exists.
+Bind VAR to the name of the file. Pass PREFIX, SUFFIX, and TEXT
+to `make-temp-file', which see."
+ (declare (indent 2) (debug (symbolp (form form form) body)))
+ (cl-check-type var symbol)
+ ;; Use an uninterned symbol so that the code still works if BODY
+ ;; changes VAR.
+ (let ((filename (make-symbol "filename")))
+ `(let ((,filename (make-temp-file ,prefix nil ,suffix ,text)))
+ (unwind-protect
+ (let ((,var ,filename))
+ ,@body)
+ (delete-file ,filename)))))
+
+(ert-deftest emacs-tests/seccomp/empty-file ()
+ (skip-unless (string-match-p (rx bow "SECCOMP" eow)
+ system-configuration-features))
+ (let ((emacs
+ (expand-file-name invocation-name invocation-directory))
+ (process-environment nil))
+ (skip-unless (file-executable-p emacs))
+ (emacs-tests--with-temp-file filter ("seccomp-invalid-" ".bpf")
+ ;; The --seccomp option is processed early, without filename
+ ;; handlers. Therefore remote or quoted filenames wouldn't
+ ;; work.
+ (should-not (file-remote-p filter))
+ (cl-callf file-name-unquote filter)
+ ;; According to the Seccomp man page, a filter must have at
+ ;; least one element, so Emacs should reject an empty file.
+ (should-not
+ (eql (call-process emacs nil nil nil
+ "--quick" "--batch"
+ (concat "--seccomp=" filter))
+ 0)))))
+
+(ert-deftest emacs-tests/seccomp/file-too-large ()
+ (skip-unless (string-match-p (rx bow "SECCOMP" eow)
+ system-configuration-features))
+ (let ((emacs
+ (expand-file-name invocation-name invocation-directory))
+ (process-environment nil)
+ ;; This value should be correct on all supported systems.
+ (ushort-max #xFFFF)
+ ;; Either 8 or 16, but 16 should be large enough in all cases.
+ (filter-size 16))
+ (skip-unless (file-executable-p emacs))
+ (emacs-tests--with-temp-file
+ filter ("seccomp-too-large-" ".bpf"
+ (make-string (* (1+ ushort-max) filter-size) ?a))
+ ;; The --seccomp option is processed early, without filename
+ ;; handlers. Therefore remote or quoted filenames wouldn't
+ ;; work.
+ (should-not (file-remote-p filter))
+ (cl-callf file-name-unquote filter)
+ ;; The filter count must fit into an `unsigned short'. A bigger
+ ;; file should be rejected.
+ (should-not
+ (eql (call-process emacs nil nil nil
+ "--quick" "--batch"
+ (concat "--seccomp=" filter))
+ 0)))))
+
+(ert-deftest emacs-tests/seccomp/invalid-file-size ()
+ (skip-unless (string-match-p (rx bow "SECCOMP" eow)
+ system-configuration-features))
+ (let ((emacs
+ (expand-file-name invocation-name invocation-directory))
+ (process-environment nil))
+ (skip-unless (file-executable-p emacs))
+ (emacs-tests--with-temp-file filter ("seccomp-invalid-" ".bpf"
+ "123456")
+ ;; The --seccomp option is processed early, without filename
+ ;; handlers. Therefore remote or quoted filenames wouldn't
+ ;; work.
+ (should-not (file-remote-p filter))
+ (cl-callf file-name-unquote filter)
+ ;; The Seccomp filter file must have a file size that's a
+ ;; multiple of the size of struct sock_filter, which is 8 or 16,
+ ;; but never 6.
+ (should-not
+ (eql (call-process emacs nil nil nil
+ "--quick" "--batch"
+ (concat "--seccomp=" filter))
+ 0)))))
+
+(ert-deftest emacs-tests/seccomp/allows-stdout ()
+ (skip-unless (string-match-p (rx bow "SECCOMP" eow)
+ system-configuration-features))
+ (let ((emacs
+ (expand-file-name invocation-name invocation-directory))
+ (filter (ert-resource-file "seccomp-filter.bpf"))
+ (process-environment nil))
+ (skip-unless (file-executable-p emacs))
+ (skip-unless (file-readable-p filter))
+ ;; The --seccomp option is processed early, without filename
+ ;; handlers. Therefore remote or quoted filenames wouldn't work.
+ (should-not (file-remote-p filter))
+ (cl-callf file-name-unquote filter)
+ (with-temp-buffer
+ (let ((start-time (current-time))
+ (status (call-process
+ emacs nil t nil
+ "--quick" "--batch"
+ (concat "--seccomp=" filter)
+ (format "--eval=%S" '(message "Hi"))))
+ (end-time (current-time)))
+ (ert-info ((emacs-tests--seccomp-debug start-time end-time))
+ (should (eql status 0)))
+ (should (equal (string-trim (buffer-string)) "Hi"))))))
+
+(ert-deftest emacs-tests/seccomp/forbids-subprocess ()
+ (skip-unless (string-match-p (rx bow "SECCOMP" eow)
+ system-configuration-features))
+ (let ((emacs
+ (expand-file-name invocation-name invocation-directory))
+ (filter (ert-resource-file "seccomp-filter.bpf"))
+ (process-environment nil))
+ (skip-unless (file-executable-p emacs))
+ (skip-unless (file-readable-p filter))
+ ;; The --seccomp option is processed early, without filename
+ ;; handlers. Therefore remote or quoted filenames wouldn't work.
+ (should-not (file-remote-p filter))
+ (cl-callf file-name-unquote filter)
+ (with-temp-buffer
+ (let ((start-time (current-time))
+ (status
+ (call-process
+ emacs nil t nil
+ "--quick" "--batch"
+ (concat "--seccomp=" filter)
+ (format "--eval=%S" `(call-process ,emacs nil nil nil
+ "--version"))))
+ (end-time (current-time)))
+ (ert-info ((emacs-tests--seccomp-debug start-time end-time))
+ (should-not (eql status 0)))))))
+
+(ert-deftest emacs-tests/bwrap/allows-stdout ()
+ (let ((bash (executable-find "bash"))
+ (bwrap (executable-find "bwrap"))
+ (emacs
+ (expand-file-name invocation-name invocation-directory))
+ (filter (ert-resource-file "seccomp-filter-exec.bpf"))
+ (process-environment nil))
+ (skip-unless bash)
+ (skip-unless bwrap)
+ (skip-unless (file-executable-p emacs))
+ (skip-unless (file-readable-p filter))
+ (should-not (file-remote-p bwrap))
+ (should-not (file-remote-p emacs))
+ (should-not (file-remote-p filter))
+ (with-temp-buffer
+ (let* ((command
+ (concat
+ (mapconcat #'shell-quote-argument
+ `(,(file-name-unquote bwrap)
+ "--ro-bind" "/" "/"
+ "--seccomp" "20"
+ "--"
+ ,(file-name-unquote emacs)
+ "--quick" "--batch"
+ ,(format "--eval=%S" '(message "Hi")))
+ " ")
+ " 20< "
+ (shell-quote-argument (file-name-unquote filter))))
+ (start-time (current-time))
+ (status (call-process bash nil t nil "-c" command))
+ (end-time (current-time)))
+ (ert-info ((emacs-tests--seccomp-debug start-time end-time))
+ (should (eql status 0)))
+ (should (equal (string-trim (buffer-string)) "Hi"))))))
+
+(defun emacs-tests--seccomp-debug (start-time end-time)
+ "Return potentially useful debugging information for Seccomp.
+Assume that the current buffer contains subprocess output for the
+failing process. START-TIME and END-TIME are time values between
+which the process was running."
+ ;; Add a bit of slack for the timestamps.
+ (cl-callf time-subtract start-time 5)
+ (cl-callf time-add end-time 5)
+ (with-output-to-string
+ (princ "Process output:")
+ (terpri)
+ (princ (buffer-substring-no-properties (point-min) (point-max)))
+ ;; Search audit logs for Seccomp messages.
+ (when-let ((ausearch (executable-find "ausearch")))
+ (terpri)
+ (princ "Potentially relevant Seccomp audit events:")
+ (terpri)
+ (let ((process-environment '("LC_TIME=C")))
+ (call-process ausearch nil standard-output nil
+ "--message" "SECCOMP"
+ "--start"
+ (format-time-string "%D" start-time)
+ (format-time-string "%T" start-time)
+ "--end"
+ (format-time-string "%D" end-time)
+ (format-time-string "%T" end-time)
+ "--interpret")))
+ ;; Print coredump information if available.
+ (when-let ((coredumpctl (executable-find "coredumpctl")))
+ (terpri)
+ (princ "Potentially useful coredump information:")
+ (terpri)
+ (call-process coredumpctl nil standard-output nil
+ "info"
+ "--since" (format-time-string "%F %T" start-time)
+ "--until" (format-time-string "%F %T" end-time)
+ "--no-pager"))))
+
+;;; emacs-tests.el ends here
diff --git a/test/src/fileio-tests.el b/test/src/fileio-tests.el
index 7f193d4..b989c97 100644
--- a/test/src/fileio-tests.el
+++ b/test/src/fileio-tests.el
@@ -1,4 +1,4 @@
-;;; unit tests for src/fileio.c -*- lexical-binding: t; -*-
+;;; fileio-tests.el --- unit tests for src/fileio.c -*- lexical-binding:
t; -*-
;; Copyright 2017-2021 Free Software Foundation, Inc.
diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el
index f14d242..fc7bc74 100644
--- a/test/src/thread-tests.el
+++ b/test/src/thread-tests.el
@@ -1,4 +1,4 @@
-;;; threads.el --- tests for threads. -*- lexical-binding: t -*-
+;;; thread-tests.el --- tests for threads. -*- lexical-binding: t -*-
;; Copyright (C) 2012-2021 Free Software Foundation, Inc.
@@ -315,8 +315,8 @@
"Test signaling a thread as soon as it is started by the OS."
(skip-unless (featurep 'threads))
(let ((thread
- (make-thread #'(lambda ()
- (while t (thread-yield))))))
+ (make-thread (lambda ()
+ (while t (thread-yield))))))
(thread-signal thread 'error nil)
(sit-for 1)
(should-not (thread-live-p thread))
@@ -331,7 +331,7 @@
(let (buffer-read-only)
(erase-buffer))
(let ((thread
- (make-thread #'(lambda () (thread-signal main-thread 'error nil)))))
+ (make-thread (lambda () (thread-signal main-thread 'error nil)))))
(while (thread-live-p thread)
(thread-yield))
(read-event nil nil 0.1)
diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el
index e55bd1e..0a450a7 100644
--- a/test/src/timefns-tests.el
+++ b/test/src/timefns-tests.el
@@ -1,4 +1,4 @@
-;;; timefns-tests.el -- tests for timefns.c -*- lexical-binding: t -*-
+;;; timefns-tests.el --- tests for timefns.c -*- lexical-binding: t -*-
;; Copyright (C) 2016-2021 Free Software Foundation, Inc.