summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/authors.el94
-rw-r--r--lisp/emacs-lisp/autoload.el203
-rw-r--r--lisp/emacs-lisp/bytecomp.el40
-rw-r--r--lisp/emacs-lisp/cl-extra.el2
-rw-r--r--lisp/emacs-lisp/cl-loaddefs.el7
-rw-r--r--lisp/emacs-lisp/cl-macs.el63
-rw-r--r--lisp/emacs-lisp/copyright.el22
-rw-r--r--lisp/emacs-lisp/derived.el2
-rw-r--r--lisp/emacs-lisp/easy-mmode.el80
-rw-r--r--lisp/emacs-lisp/edebug.el34
-rw-r--r--lisp/emacs-lisp/eldoc.el14
-rw-r--r--lisp/emacs-lisp/find-gc.el2
-rw-r--r--lisp/emacs-lisp/lisp-mnt.el4
-rw-r--r--lisp/emacs-lisp/lisp-mode.el19
-rw-r--r--lisp/emacs-lisp/lisp.el49
-rw-r--r--lisp/emacs-lisp/macroexp.el4
-rw-r--r--lisp/emacs-lisp/package-x.el226
-rw-r--r--lisp/emacs-lisp/package.el1569
-rw-r--r--lisp/emacs-lisp/pcase.el489
-rw-r--r--lisp/emacs-lisp/re-builder.el25
-rw-r--r--lisp/emacs-lisp/smie.el1072
-rw-r--r--lisp/emacs-lisp/timer.el6
22 files changed, 3787 insertions, 239 deletions
diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el
index 7728215bb91..5aea033fc78 100644
--- a/lisp/emacs-lisp/authors.el
+++ b/lisp/emacs-lisp/authors.el
@@ -220,6 +220,9 @@ If REALNAME is nil, ignore that author.")
'("vc-\\*\\.el$"
"spec.txt$"
".*loaddefs.el$" ; not obsolete, but auto-generated
+ "\\.\\(cvs\\|git\\)ignore$" ; obsolete or uninteresting
+ "\\.arch-inventory$"
+ "preferences\\.\\(nib\\|gorm\\)"
"vc-\\(rcs\\|cvs\\|sccs\\)-hooks\\.el$")
"List of regexps matching obsolete files.
Changes to files matching one of the regexps in this list are not
@@ -244,6 +247,14 @@ listed.")
"Imakefile" "icons/sink.ico" "aixcc.lex"
"nxml/char-name/unicode"
"js2-mode.el" ; only installed very briefly, replaced by js.el
+ "cedet/tests/testtemplates.cpp"
+ "cedet/tests/testusing.cpp"
+ "cedet/tests/scopetest.cpp"
+ "cedet/tests/scopetest.java"
+ "cedet/tests/test.cpp"
+ "cedet/tests/test.py"
+ "cedet/tests/teststruct.cpp"
+ "*.el"
;; Autogen:
"cus-load.el" "finder-inf.el" "ldefs-boot.el"
;; Never had any meaningful changes logged, now deleted:
@@ -255,7 +266,7 @@ listed.")
"3B-MAXMEM" "AIX.DUMP" "SUN-SUPPORT" "XENIX"
"CODINGS" "CHARSETS"
"calc/INSTALL" "calc/Makefile"
- "vms-pp.trans" "_emacs" "batcomp.com"
+ "vms-pp.trans" "_emacs" "batcomp.com" "notes/cpp" ; admin/
;; MH-E stuff not in Emacs:
"import-emacs" "release-utils"
;; Erc stuff not in Emacs:
@@ -286,6 +297,42 @@ listed.")
"List of files and directories to ignore.
Changes to files in this list are not listed.")
+;; List via: find . -name '*.el' | sed 's/.*\///g' | sort | uniq -d
+;; FIXME It would be better to discover these dynamically.
+;; Note that traditionally "Makefile.in" etc have not been in this list.
+;; Ditto for "abbrev.texi" etc.
+(defconst authors-ambiguous-files
+ '("chart.el"
+ "compile.el"
+ "complete.el"
+ "cpp.el"
+ "ctxt.el"
+ "debug.el"
+ "dired.el"
+ "el.el"
+ "files.el"
+ "find.el"
+ "format.el"
+ "grep.el"
+ "imenu.el"
+ "java.el"
+ "linux.el"
+ "locate.el"
+ "make.el"
+ "mode.el"
+ "python.el"
+ "semantic.el"
+ "shell.el"
+ "simple.el"
+ "sort.el"
+ "speedbar.el"
+ "srecode.el"
+ "table.el"
+ "texi.el"
+ "util.el"
+ "wisent.el")
+ "List of basenames occurring more than once in the source.")
+
;; FIXME :cowrote entries here can be overwritten by :wrote entries
;; derived from a file's Author: header (eg mh-e). This really means
;; the Author: header is erroneous.
@@ -307,7 +354,7 @@ Changes to files in this list are not listed.")
;; No longer distributed.
;;; ("Viktor Dukhovni" :wrote "unexsunos4.c")
("Paul Eggert" :wrote "rcs2log" "vcdiff")
- ("Fred Fish" :changed "unexec.c")
+ ("Fred Fish" :changed "unexcoff.c")
;; No longer distributed.
;;; ("Tim Fleehart" :wrote "makefile.nt")
("Keith Gabryelski" :wrote "hexl.c")
@@ -330,13 +377,13 @@ Changes to files in this list are not listed.")
"indent.c" "search.c" "xdisp.c" "region-cache.c" "region-cache.h")
;; ibmrt.h, ibmrt-aix.h no longer distributed.
("International Business Machines" :changed "emacs.c" "fileio.c"
- "process.c" "sysdep.c" "unexec.c")
+ "process.c" "sysdep.c" "unexcoff.c")
;; No longer distributed.
;;; ("Ishikawa Chiaki" :changed "aviion.h" "dgux.h")
;; ymakefile no longer distributed.
("Michael K. Johnson" :changed "configure.in" "emacs.c" "intel386.h"
"mem-limits.h" "process.c" "template.h" "sysdep.c" "syssignal.h"
- "systty.h" "unexec.c" "linux.h")
+ "systty.h" "unexcoff.c" "linux.h")
;; No longer distributed.
;;; ("Kyle Jones" :wrote "mldrag.el")
("Henry Kautz" :wrote "bib-mode.el")
@@ -361,7 +408,7 @@ Changes to files in this list are not listed.")
"rmail.el" "rmailedit.el" "rmailkwd.el"
"rmailmsc.el" "rmailout.el" "rmailsum.el" "scribe.el"
;; It was :wrote for xmenu.c, but it has been rewritten since.
- "server.el" "lisp.h" "sysdep.c" "unexec.c" "xmenu.c")
+ "server.el" "lisp.h" "sysdep.c" "unexcoff.c" "xmenu.c")
("Niall Mansfield" :changed "etags.c")
("Brian Marick" :cowrote "hideif.el")
("Marko Kohtala" :changed "info.el")
@@ -416,9 +463,9 @@ Changes to files in this list are not listed.")
("Kayvan Sylvan" :changed "supercite.el")
;; No longer distributed: emacsserver.c, tcp.c.
("Spencer Thomas" :changed "emacsclient.c" "server.el"
- "dabbrev.el" "unexec.c" "gnus.texi")
+ "dabbrev.el" "unexcoff.c" "gnus.texi")
("Jonathan Vail" :changed "vc.el")
- ("James Van Artsdalen" :changed "usg5-4.h" "unexec.c")
+ ("James Van Artsdalen" :changed "usg5-4.h" "unexcoff.c")
;; No longer distributed: src/makefile.nt, lisp/makefile.nt
;; winnt.el renamed to w32-fns.el; nt.[ch] to w32.[ch];
;; ntheap.[ch] to w32heap.[ch]; ntinevt.c to w32inevt.c;
@@ -427,6 +474,7 @@ Changes to files in this list are not listed.")
("Geoff Voelker" :wrote "w32-fns.el" "w32.c" "w32.h" "w32heap.c"
"w32heap.h" "w32inevt.c" "w32proc.c" "w32term.c" "ms-w32.h")
("Morten Welinder" :wrote "dosfns.c" "[many MS-DOS files]" "msdos.h")
+ ("Eli Zaretskii" :wrote "bidi.c" "[bidirectional display in xdisp.c]")
;; Not using this version any more.
;;; ("Pace Willisson" :wrote "ispell.el")
;; FIXME overwritten by Author:.
@@ -457,17 +505,21 @@ Changes to files in this list are not listed.")
"getdate.y"
"ymakefile"
"permute-index" "index.perm"
+ "ibmrs6000.inp"
"emacs.ico"
"emacs21.ico"
"LPF" "LEDIT" "OTHER.EMACSES"
"emacs16_mac.png" "emacs24_mac.png"
"emacs256_mac.png" "emacs32_mac.png"
"emacs48_mac.png" "emacs512_mac.png"
+ "revdiff" ; admin/
+ "mainmake" "sed1.inp" "sed2.inp" "sed3.inp" ; msdos/
+ "mac-fix-env.m"
;; Deleted vms stuff:
"temacs.opt" "descrip.mms" "compile.com" "link.com"
)
- "File names which are valid, but no longer exist (or cannot be
-found) in the repository.")
+ "File names which are valid, but no longer exist (or cannot be found)
+in the repository.")
(defconst authors-renamed-files-alist
'(("nt.c" . "w32.c") ("nt.h" . "w32.h")
@@ -504,6 +556,7 @@ found) in the repository.")
;; index and pick merged into search.
("mh-index.el" . "mh-search.el")
("mh-pick.el" . "mh-search.el")
+ ("font-setting.el" . "dynamic-setting.el")
;; INSTALL-CVS -> .CVS -> .BZR
("INSTALL-CVS" . "INSTALL.BZR")
("INSTALL.CVS" . "INSTALL.BZR")
@@ -529,6 +582,7 @@ found) in the repository.")
("schema/docbook-dyntbl.rnc" . "schema/docbk-dyntbl.rnc")
("schema/docbook-soextbl.rnc" . "schema/docbk-soextbl.rn" )
("texi/url.txi" . "url.texi")
+ ("edt-user.doc" . "edt.texi")
;; Moved to different directories.
("ctags.1" . "ctags.1")
("etags.1" . "etags.1")
@@ -573,10 +627,25 @@ Otherwise, the file name is accepted as is.")
(defvar authors-checked-files-alist)
(defvar authors-invalid-file-names)
+(defun authors-disambiguate-file-name (fullname)
+ "Convert FULLNAME to an unambiguous relative-name."
+ (let ((relname (file-name-nondirectory fullname))
+ parent)
+ (if (member relname authors-ambiguous-files)
+ ;; In case of ambiguity, just prepend the parent directory.
+ ;; FIXME obviously this is not a perfect solution.
+ (if (string-equal "lisp"
+ (setq parent (file-name-nondirectory
+ (directory-file-name
+ (file-name-directory fullname)))))
+ relname
+ (format "%s/%s" parent relname))
+ relname)))
+
(defun authors-canonical-file-name (file log-file pos author)
"Return canonical file name for FILE found in LOG-FILE.
Checks whether FILE is a valid (existing) file name, has been renamed,
-or is on the list of removed files. Returns the non-diretory part of
+or is on the list of removed files. Returns the non-directory part of
the file name. Only uses the LOG-FILE position POS and associated AUTHOR
to print a message if FILE is not found."
;; FILE should be re-checked in every different directory associated
@@ -593,7 +662,7 @@ to print a message if FILE is not found."
(file-exists-p file)
(file-exists-p relname)
(file-exists-p (concat "etc/" relname)))
- (setq valid relname)
+ (setq valid (authors-disambiguate-file-name fullname))
(setq valid (assoc file authors-renamed-files-alist))
(if valid
(setq valid (cdr valid))
@@ -610,6 +679,7 @@ to print a message if FILE is not found."
(cons (cons fullname valid) authors-checked-files-alist))
(unless (or valid
(member file authors-ignored-files)
+ (authors-obsolete-file-p file)
(string-match "[*]" file)
(string-match "^[0-9.]+$" file))
(setq authors-invalid-file-names
@@ -758,7 +828,7 @@ TABLE is a hash table to add author information to."
(enable-local-variables :safe) ; for find-file, hence let*
(enable-local-eval nil)
(buffer (find-file-noselect file)))
- (setq file (file-name-nondirectory file))
+ (setq file (authors-disambiguate-file-name (expand-file-name file)))
(with-current-buffer buffer
(save-restriction
(widen)
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el
index c985aae07b6..6951e90c8b4 100644
--- a/lisp/emacs-lisp/autoload.el
+++ b/lisp/emacs-lisp/autoload.el
@@ -1,7 +1,8 @@
;; autoload.el --- maintain autoloads in loaddefs.el
;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Roland McGrath <roland@gnu.org>
;; Keywords: maint
@@ -108,29 +109,48 @@ or macro definition or a defcustom)."
(let* ((macrop (memq car '(defmacro defmacro*)))
(name (nth 1 form))
(args (case car
- ((defun defmacro defun* defmacro*
- define-overloadable-function) (nth 2 form))
- ((define-skeleton) '(&optional str arg))
- ((define-generic-mode define-derived-mode
- define-compilation-mode) nil)
- (t)))
+ ((defun defmacro defun* defmacro*
+ define-overloadable-function) (nth 2 form))
+ ((define-skeleton) '(&optional str arg))
+ ((define-generic-mode define-derived-mode
+ define-compilation-mode) nil)
+ (t)))
(body (nthcdr (get car 'doc-string-elt) form))
(doc (if (stringp (car body)) (pop body))))
(when (listp args)
;; Add the usage form at the end where describe-function-1
;; can recover it.
(setq doc (help-add-fundoc-usage doc args)))
- ;; `define-generic-mode' quotes the name, so take care of that
- (list 'autoload (if (listp name) name (list 'quote name)) file doc
- (or (and (memq car '(define-skeleton define-derived-mode
- define-generic-mode
- easy-mmode-define-global-mode
- define-global-minor-mode
- define-globalized-minor-mode
- easy-mmode-define-minor-mode
- define-minor-mode)) t)
- (eq (car-safe (car body)) 'interactive))
- (if macrop (list 'quote 'macro) nil))))
+ (let ((exp
+ ;; `define-generic-mode' quotes the name, so take care of that
+ (list 'autoload (if (listp name) name (list 'quote name))
+ file doc
+ (or (and (memq car '(define-skeleton define-derived-mode
+ define-generic-mode
+ easy-mmode-define-global-mode
+ define-global-minor-mode
+ define-globalized-minor-mode
+ easy-mmode-define-minor-mode
+ define-minor-mode)) t)
+ (eq (car-safe (car body)) 'interactive))
+ (if macrop (list 'quote 'macro) nil))))
+ (when macrop
+ ;; Special case to autoload some of the macro's declarations.
+ (let ((decls (nth (if (stringp (nth 3 form)) 4 3) form))
+ (exps '()))
+ (when (eq (car decls) 'declare)
+ ;; FIXME: We'd like to reuse macro-declaration-function,
+ ;; but we can't since it doesn't return anything.
+ (dolist (decl decls)
+ (case (car-safe decl)
+ (indent
+ (push `(put ',name 'lisp-indent-function ',(cadr decl))
+ exps))
+ (doc-string
+ (push `(put ',name 'doc-string-elt ',(cadr decl)) exps))))
+ (when exps
+ (setq exp `(progn ,exp ,@exps))))))
+ exp)))
;; For defclass forms, use `eieio-defclass-autoload'.
((eq car 'defclass)
@@ -258,14 +278,17 @@ put the output in."
TYPE (default \"autoloads\") is a string stating the type of
information contained in FILE. If FEATURE is non-nil, FILE
will provide a feature. FEATURE may be a string naming the
-feature, otherwise it will be based on FILE's name."
+feature, otherwise it will be based on FILE's name.
+
+At present, a feature is in fact always provided, but this should
+not be relied upon."
(let ((basename (file-name-nondirectory file)))
(concat ";;; " basename
" --- automatically extracted " (or type "autoloads") "\n"
";;\n"
";;; Code:\n\n"
" \n"
- ;; This is used outside of autoload.el.
+ ;; This is used outside of autoload.el, eg cus-dep, finder.
"(provide '"
(if (stringp feature)
feature
@@ -324,7 +347,29 @@ which lists the file name and which functions are in it, etc."
"File local variable to prevent scanning this file for autoload cookies.")
(defun autoload-file-load-name (file)
- (let ((name (file-name-nondirectory file)))
+ "Compute the name that will be used to load FILE."
+ ;; OUTFILE should be the name of the global loaddefs.el file, which
+ ;; is expected to be at the root directory of the files we're
+ ;; scanning for autoloads and will be in the `load-path'.
+ (let* ((outfile (default-value 'generated-autoload-file))
+ (name (file-relative-name file (file-name-directory outfile)))
+ (names '())
+ (dir (file-name-directory outfile)))
+ ;; If `name' has directory components, only keep the
+ ;; last few that are really needed.
+ (while name
+ (setq name (directory-file-name name))
+ (push (file-name-nondirectory name) names)
+ (setq name (file-name-directory name)))
+ (while (not name)
+ (cond
+ ((null (cdr names)) (setq name (car names)))
+ ((file-exists-p (expand-file-name "subdirs.el" dir))
+ ;; FIXME: here we only check the existence of subdirs.el,
+ ;; without checking its content. This makes it generate wrong load
+ ;; names for cases like lisp/term which is not added to load-path.
+ (setq dir (expand-file-name (pop names) dir)))
+ (t (setq name (mapconcat 'identity names "/")))))
(if (string-match "\\.elc?\\(\\.\\|\\'\\)" name)
(substring name 0 (match-beginning 0))
name)))
@@ -339,6 +384,8 @@ Return non-nil in the case where no autoloads were added at point."
(interactive "fGenerate autoloads for file: ")
(autoload-generate-file-autoloads file (current-buffer)))
+(defvar print-readably)
+
;; When called from `generate-file-autoloads' we should ignore
;; `generated-autoload-file' altogether. When called from
;; `update-file-autoloads' we don't know `outbuf'. And when called from
@@ -369,9 +416,8 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE
(visited (get-file-buffer file))
(otherbuf nil)
(absfile (expand-file-name file))
- relfile
;; nil until we found a cookie.
- output-start)
+ output-start ostart)
(with-current-buffer (or visited
;; It is faster to avoid visiting the file.
(autoload-find-file file))
@@ -381,7 +427,10 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE
(setq load-name
(if (stringp generated-autoload-load-name)
generated-autoload-load-name
- (autoload-file-load-name file)))
+ (autoload-file-load-name absfile)))
+ (when (and outfile
+ (not (equal outfile (autoload-generated-file))))
+ (setq otherbuf t))
(save-excursion
(save-restriction
(widen)
@@ -392,26 +441,22 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE
((looking-at (regexp-quote generate-autoload-cookie))
;; If not done yet, figure out where to insert this text.
(unless output-start
- (when (and outfile
- (not (equal outfile (autoload-generated-file))))
- ;; A file-local setting of autoload-generated-file says
- ;; we should ignore OUTBUF.
- (setq outbuf nil)
- (setq otherbuf t))
- (unless outbuf
- (setq outbuf (autoload-find-destination absfile))
- (unless outbuf
- ;; The file has autoload cookies, but they're
- ;; already up-to-date. If OUTFILE is nil, the
- ;; entries are in the expected OUTBUF, otherwise
- ;; they're elsewhere.
- (throw 'done outfile)))
- (with-current-buffer outbuf
- (setq relfile (file-relative-name absfile))
- (setq output-start (point)))
- ;; (message "file=%S, relfile=%S, dest=%S"
- ;; file relfile (autoload-generated-file))
- )
+ (let ((outbuf
+ (or (if otherbuf
+ ;; A file-local setting of
+ ;; autoload-generated-file says we
+ ;; should ignore OUTBUF.
+ nil
+ outbuf)
+ (autoload-find-destination absfile load-name)
+ ;; The file has autoload cookies, but they're
+ ;; already up-to-date. If OUTFILE is nil, the
+ ;; entries are in the expected OUTBUF,
+ ;; otherwise they're elsewhere.
+ (throw 'done otherbuf))))
+ (with-current-buffer outbuf
+ (setq output-start (point-marker)
+ ostart (point)))))
(search-forward generate-autoload-cookie)
(skip-chars-forward " \t")
(if (eolp)
@@ -423,7 +468,8 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE
(if autoload
(push (nth 1 form) autoloads-done)
(setq autoload form))
- (let ((autoload-print-form-outbuf outbuf))
+ (let ((autoload-print-form-outbuf
+ (marker-buffer output-start)))
(autoload-print-form autoload)))
(error
(message "Error in %s: %S" file err)))
@@ -438,7 +484,7 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE
(forward-char 1))
(point))
(progn (forward-line 1) (point)))
- outbuf)))
+ (marker-buffer output-start))))
((looking-at ";")
;; Don't read the comment.
(forward-line 1))
@@ -450,40 +496,44 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE
(let ((secondary-autoloads-file-buf
(if (local-variable-p 'generated-autoload-file)
(current-buffer))))
- (with-current-buffer outbuf
+ (with-current-buffer (marker-buffer output-start)
(save-excursion
;; Insert the section-header line which lists the file name
;; and which functions are in it, etc.
+ (assert (= ostart output-start))
(goto-char output-start)
- (autoload-insert-section-header
- outbuf autoloads-done load-name relfile
- (if secondary-autoloads-file-buf
- ;; MD5 checksums are much better because they do not
- ;; change unless the file changes (so they'll be
- ;; equal on two different systems and will change
- ;; less often than time-stamps, thus leading to fewer
- ;; unneeded changes causing spurious conflicts), but
- ;; using time-stamps is a very useful optimization,
- ;; so we use time-stamps for the main autoloads file
- ;; (loaddefs.el) where we have special ways to
- ;; circumvent the "random change problem", and MD5
- ;; checksum in secondary autoload files where we do
- ;; not need the time-stamp optimization because it is
- ;; already provided by the primary autoloads file.
- (md5 secondary-autoloads-file-buf
- ;; We'd really want to just use
- ;; `emacs-internal' instead.
- nil nil 'emacs-mule-unix)
- (nth 5 (file-attributes relfile))))
- (insert ";;; Generated autoloads from " relfile "\n"))
+ (let ((relfile (file-relative-name absfile)))
+ (autoload-insert-section-header
+ (marker-buffer output-start)
+ autoloads-done load-name relfile
+ (if secondary-autoloads-file-buf
+ ;; MD5 checksums are much better because they do not
+ ;; change unless the file changes (so they'll be
+ ;; equal on two different systems and will change
+ ;; less often than time-stamps, thus leading to fewer
+ ;; unneeded changes causing spurious conflicts), but
+ ;; using time-stamps is a very useful optimization,
+ ;; so we use time-stamps for the main autoloads file
+ ;; (loaddefs.el) where we have special ways to
+ ;; circumvent the "random change problem", and MD5
+ ;; checksum in secondary autoload files where we do
+ ;; not need the time-stamp optimization because it is
+ ;; already provided by the primary autoloads file.
+ (md5 secondary-autoloads-file-buf
+ ;; We'd really want to just use
+ ;; `emacs-internal' instead.
+ nil nil 'emacs-mule-unix)
+ (nth 5 (file-attributes relfile))))
+ (insert ";;; Generated autoloads from " relfile "\n")))
(insert generate-autoload-section-trailer))))
(message "Generating autoloads for %s...done" file))
(or visited
;; We created this buffer, so we should kill it.
(kill-buffer (current-buffer))))
- ;; If the entries were added to some other buffer, then the file
- ;; doesn't add entries to OUTFILE.
- (or (not output-start) otherbuf))))
+ (or (not output-start)
+ ;; If the entries were added to some other buffer, then the file
+ ;; doesn't add entries to OUTFILE.
+ otherbuf))))
(defun autoload-save-buffers ()
(while autoload-modified-buffers
@@ -507,15 +557,14 @@ Return FILE if there was no autoload cookie in it, else nil."
(message "Autoload section for %s is up to date." file)))
(if no-autoloads file)))
-(defun autoload-find-destination (file)
+(defun autoload-find-destination (file load-name)
"Find the destination point of the current buffer's autoloads.
FILE is the file name of the current buffer.
Returns a buffer whose point is placed at the requested location.
Returns nil if the file's autoloads are uptodate, otherwise
removes any prior now out-of-date autoload entries."
(catch 'up-to-date
- (let* ((load-name (autoload-file-load-name file))
- (buf (current-buffer))
+ (let* ((buf (current-buffer))
(existing-buffer (if buffer-file-name buf))
(found nil))
(with-current-buffer
@@ -528,7 +577,7 @@ removes any prior now out-of-date autoload entries."
(unless (zerop (coding-system-eol-type buffer-file-coding-system))
(set-buffer-file-coding-system 'unix))
(or (> (buffer-size) 0)
- (error "Autoloads file %s does not exist" buffer-file-name))
+ (error "Autoloads file %s lacks boilerplate" buffer-file-name))
(or (file-writable-p buffer-file-name)
(error "Autoloads file %s is not writable" buffer-file-name))
(widen)
@@ -648,6 +697,7 @@ directory or directories specified."
(t
(autoload-remove-section (match-beginning 0))
(if (autoload-generate-file-autoloads
+ ;; Passing `current-buffer' makes it insert at point.
file (current-buffer) buffer-file-name)
(push file no-autoloads))))
(push file done)
@@ -656,6 +706,9 @@ directory or directories specified."
(dolist (file files)
(cond
((member (expand-file-name file) autoload-excludes) nil)
+ ;; Passing nil as second argument forces
+ ;; autoload-generate-file-autoloads to look for the right
+ ;; spot where to insert each autoloads section.
((autoload-generate-file-autoloads file nil buffer-file-name)
(push file no-autoloads))))
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 394169be99d..217afea9f8a 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -3333,21 +3333,31 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
(setq for-effect nil)))
(defun byte-compile-setq-default (form)
- (let ((bytecomp-args (cdr form))
- setters)
- (while bytecomp-args
- (let ((var (car bytecomp-args)))
- (and (or (not (symbolp var))
- (byte-compile-const-symbol-p var t))
- (byte-compile-warning-enabled-p 'constants)
- (byte-compile-warn
- "variable assignment to %s `%s'"
- (if (symbolp var) "constant" "nonvariable")
- (prin1-to-string var)))
- (push (list 'set-default (list 'quote var) (car (cdr bytecomp-args)))
- setters))
- (setq bytecomp-args (cdr (cdr bytecomp-args))))
- (byte-compile-form (cons 'progn (nreverse setters)))))
+ (setq form (cdr form))
+ (if (> (length form) 2)
+ (let ((setters ()))
+ (while (consp form)
+ (push `(setq-default ,(pop form) ,(pop form)) setters))
+ (byte-compile-form (cons 'progn (nreverse setters))))
+ (let ((var (car form)))
+ (and (or (not (symbolp var))
+ (byte-compile-const-symbol-p var t))
+ (byte-compile-warning-enabled-p 'constants)
+ (byte-compile-warn
+ "variable assignment to %s `%s'"
+ (if (symbolp var) "constant" "nonvariable")
+ (prin1-to-string var)))
+ (byte-compile-normal-call `(set-default ',var ,@(cdr form))))))
+
+(byte-defop-compiler-1 set-default)
+(defun byte-compile-set-default (form)
+ (let ((varexp (car-safe (cdr-safe form))))
+ (if (eq (car-safe varexp) 'quote)
+ ;; If the varexp is constant, compile it as a setq-default
+ ;; so we get more warnings.
+ (byte-compile-setq-default `(setq-default ,(car-safe (cdr varexp))
+ ,@(cddr form)))
+ (byte-compile-normal-call form))))
(defun byte-compile-quote (form)
(byte-compile-constant (car (cdr form))))
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 3211f79c9e9..c6aae373589 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -685,7 +685,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
(setq last (point))
(goto-char (1+ pt))
(while (search-forward "(quote " last t)
- (delete-backward-char 7)
+ (delete-char -7)
(insert "'")
(forward-sexp)
(delete-char 1))
diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el
index 7640a0b1575..b14c879fcf7 100644
--- a/lisp/emacs-lisp/cl-loaddefs.el
+++ b/lisp/emacs-lisp/cl-loaddefs.el
@@ -10,7 +10,7 @@
;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p
;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively
;;;;;; notevery notany every some mapcon mapcan mapl maplist map
-;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "d93072a26c59f663a92b10df8bc28187")
+;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "deb3495d75c36a222e5238eadb8e347c")
;;; Generated autoloads from cl-extra.el
(autoload 'coerce "cl-extra" "\
@@ -282,7 +282,7 @@ Not documented
;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist
;;;;;; do* do loop return-from return block etypecase typecase ecase
;;;;;; case load-time-value eval-when destructuring-bind function*
-;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "49b7d96626dd8ba5d39551909edbd4c7")
+;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "36cafd5054969b5bb0b1ce6a21605fed")
;;; Generated autoloads from cl-macs.el
(autoload 'gensym "cl-macs" "\
@@ -1242,7 +1242,6 @@ Keywords supported: :test :test-not :key
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
+;; coding: utf-8
;; End:
-
-;; arch-tag: 08cc5aab-e992-47f6-992e-12a7428c1a0e
;;; cl-loaddefs.el ends here
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 3e800c53008..694a06f8338 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -128,6 +128,12 @@
(and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x)))
(defun cl-expr-access-order (x v)
+ ;; This apparently tries to return nil iff the expression X evaluates
+ ;; the variables V in the same order as they appear in V (so as to
+ ;; be able to replace those vars with the expressions they're bound
+ ;; to).
+ ;; FIXME: This is very naive, it doesn't even check to see if those
+ ;; variables appear more than once.
(if (cl-const-expr-p x) v
(if (consp x)
(progn
@@ -1763,6 +1769,7 @@ Example:
(defsetf frame-visible-p cl-set-frame-visible-p)
(defsetf frame-width set-screen-width t)
(defsetf frame-parameter set-frame-parameter t)
+(defsetf terminal-parameter set-terminal-parameter)
(defsetf getenv setenv t)
(defsetf get-register set-register)
(defsetf global-key-binding global-set-key)
@@ -1806,6 +1813,7 @@ Example:
(defsetf window-height () (store)
(list 'progn (list 'enlarge-window (list '- store '(window-height))) store))
(defsetf window-hscroll set-window-hscroll)
+(defsetf window-parameter set-window-parameter)
(defsetf window-point set-window-point)
(defsetf window-start set-window-start)
(defsetf window-width () (store)
@@ -1815,10 +1823,26 @@ Example:
(defsetf x-get-secondary-selection x-own-secondary-selection t)
(defsetf x-get-selection x-own-selection t)
+;; This is a hack that allows (setf (eq a 7) B) to mean either
+;; (setq a 7) or (setq a nil) depending on whether B is nil or not.
+;; This is useful when you have control over the PLACE but not over
+;; the VALUE, as is the case in define-minor-mode's :variable.
+(define-setf-method eq (place val)
+ (let ((method (get-setf-method place cl-macro-environment))
+ (val-temp (make-symbol "--eq-val--"))
+ (store-temp (make-symbol "--eq-store--")))
+ (list (append (nth 0 method) (list val-temp))
+ (append (nth 1 method) (list val))
+ (list store-temp)
+ `(let ((,(car (nth 2 method))
+ (if ,store-temp ,val-temp (not ,val-temp))))
+ ,(nth 3 method) ,store-temp)
+ `(eq ,(nth 4 method) ,val-temp))))
+
;;; More complex setf-methods.
-;;; These should take &environment arguments, but since full arglists aren't
-;;; available while compiling cl-macs, we fake it by referring to the global
-;;; variable cl-macro-environment directly.
+;; These should take &environment arguments, but since full arglists aren't
+;; available while compiling cl-macs, we fake it by referring to the global
+;; variable cl-macro-environment directly.
(define-setf-method apply (func arg1 &rest rest)
(or (and (memq (car-safe func) '(quote function function*))
@@ -2616,21 +2640,36 @@ surrounded by (block NAME ...).
(cons '&cl-quote args))
(list* 'cl-defsubst-expand (list 'quote argns)
(list 'quote (list* 'block name body))
- (not (or unsafe (cl-expr-access-order pbody argns)))
+ ;; We used to pass `simple' as
+ ;; (not (or unsafe (cl-expr-access-order pbody argns)))
+ ;; But this is much too simplistic since it
+ ;; does not pay attention to the argvs (and
+ ;; cl-expr-access-order itself is also too naive).
+ nil
(and (memq '&key args) 'cl-whole) unsafe argns)))
(list* 'defun* name args body))))
(defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs)
(if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole
(if (cl-simple-exprs-p argvs) (setq simple t))
- (let ((lets (delq nil
- (mapcar* (function
- (lambda (argn argv)
- (if (or simple (cl-const-expr-p argv))
- (progn (setq body (subst argv argn body))
- (and unsafe (list argn argv)))
- (list argn argv))))
- argns argvs))))
+ (let* ((substs ())
+ (lets (delq nil
+ (mapcar* (function
+ (lambda (argn argv)
+ (if (or simple (cl-const-expr-p argv))
+ (progn (push (cons argn argv) substs)
+ (and unsafe (list argn argv)))
+ (list argn argv))))
+ argns argvs))))
+ ;; FIXME: `sublis/subst' will happily substitute the symbol
+ ;; `argn' in places where it's not used as a reference
+ ;; to a variable.
+ ;; FIXME: `sublis/subst' will happily copy `argv' to a different
+ ;; scope, leading to name capture.
+ (setq body (cond ((null substs) body)
+ ((null (cdr substs))
+ (subst (cdar substs) (caar substs) body))
+ (t (sublis substs body))))
(if lets (list 'let lets body) body))))
diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el
index 6f7a43af844..43eb61b0bee 100644
--- a/lisp/emacs-lisp/copyright.el
+++ b/lisp/emacs-lisp/copyright.el
@@ -158,13 +158,15 @@ When this is `function', only ask when called non-interactively."
(unless (string= (buffer-substring (- (match-end 3) 2) (match-end 3))
(substring copyright-current-year -2))
(if (or noquery
- ;; Fixes some point-moving oddness (bug#2209).
- (save-excursion
- (y-or-n-p (if replace
- (concat "Replace copyright year(s) by "
- copyright-current-year "? ")
- (concat "Add " copyright-current-year
- " to copyright? ")))))
+ (save-window-excursion
+ (switch-to-buffer (current-buffer))
+ ;; Fixes some point-moving oddness (bug#2209).
+ (save-excursion
+ (y-or-n-p (if replace
+ (concat "Replace copyright year(s) by "
+ copyright-current-year "? ")
+ (concat "Add " copyright-current-year
+ " to copyright? "))))))
(if replace
(replace-match copyright-current-year t t nil 3)
(let ((size (save-excursion (skip-chars-backward "0-9"))))
@@ -224,8 +226,10 @@ version \\([0-9]+\\), or (at"
(string-to-number copyright-current-gpl-version))
(or noquery
(save-match-data
- (y-or-n-p (format "Replace GPL version by %s? "
- copyright-current-gpl-version))))
+ (save-window-excursion
+ (switch-to-buffer (current-buffer))
+ (y-or-n-p (format "Replace GPL version by %s? "
+ copyright-current-gpl-version)))))
(progn
(if (match-end 2)
;; Esperanto bilingual comment in two-column.el
diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el
index debef5535f5..d6f717ccda7 100644
--- a/lisp/emacs-lisp/derived.el
+++ b/lisp/emacs-lisp/derived.el
@@ -230,7 +230,7 @@ No problems result if this variable is not bound.
; Run the parent.
(delay-mode-hooks
- (,(or parent 'kill-all-local-variables))
+ (,(or parent 'fundamental-mode))
; Identify the child mode.
(setq major-mode (quote ,child))
(setq mode-name ,name)
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index a48816f99c6..337f1d6c402 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -114,6 +114,11 @@ BODY contains code to execute each time the mode is enabled or disabled.
:lighter SPEC Same as the LIGHTER argument.
:keymap MAP Same as the KEYMAP argument.
:require SYM Same as in `defcustom'.
+:variable PLACE The location (as can be used with `setf') to use instead
+ of the variable MODE to store the state of the mode. PLACE
+ can also be of the form (GET . SET) where GET is an expression
+ that returns the current state and SET is a function that takes
+ a new state and sets it.
For example, you could write
(define-minor-mode foo-mode \"If enabled, foo on you!\"
@@ -145,6 +150,9 @@ For example, you could write
(type nil)
(extra-args nil)
(extra-keywords nil)
+ (variable nil) ;The PLACE where the state is stored.
+ (setter nil) ;The function (if any) to set the mode var.
+ (modefun mode) ;The minor mode function name we're defining.
(require t)
(hook (intern (concat mode-name "-hook")))
(hook-on (intern (concat mode-name "-on-hook")))
@@ -165,6 +173,12 @@ For example, you could write
(:type (setq type (list :type (pop body))))
(:require (setq require (pop body)))
(:keymap (setq keymap (pop body)))
+ (:variable (setq variable (pop body))
+ (if (not (functionp (cdr-safe variable)))
+ ;; PLACE is not of the form (GET . SET).
+ (setq mode variable)
+ (setq mode (car variable))
+ (setq setter (cdr variable))))
(t (push keyw extra-keywords) (push (pop body) extra-keywords))))
(setq keymap-sym (if (and keymap (symbolp keymap)) keymap
@@ -185,12 +199,16 @@ For example, you could write
`(progn
;; Define the variable to enable or disable the mode.
- ,(if (not globalp)
- `(progn
- (defvar ,mode ,init-value ,(format "Non-nil if %s is enabled.
+ ,(cond
+ ;; If :variable is specified, then the var will be
+ ;; declared elsewhere.
+ (variable nil)
+ ((not globalp)
+ `(progn
+ (defvar ,mode ,init-value ,(format "Non-nil if %s is enabled.
Use the command `%s' to change this variable." pretty-name mode))
- (make-variable-buffer-local ',mode))
-
+ (make-variable-buffer-local ',mode)))
+ (t
(let ((base-doc-string
(concat "Non-nil if %s is enabled.
See the command `%s' for a description of this minor mode."
@@ -205,10 +223,10 @@ or call the function `%s'."))))
,@group
,@type
,@(unless (eq require t) `(:require ,require))
- ,@(nreverse extra-keywords))))
+ ,@(nreverse extra-keywords)))))
;; The actual function.
- (defun ,mode (&optional arg ,@extra-args)
+ (defun ,modefun (&optional arg ,@extra-args)
,(or doc
(format (concat "Toggle %s on or off.
Interactively, with no prefix argument, toggle the mode.
@@ -219,22 +237,19 @@ With zero or negative ARG turn mode off.
;; repeat-command still does the toggling correctly.
(interactive (list (or current-prefix-arg 'toggle)))
(let ((,last-message (current-message)))
- (setq ,mode
- (cond
- ((eq arg 'toggle) (not ,mode))
- (arg (> (prefix-numeric-value arg) 0))
- (t
- (if (null ,mode) t
- (message
- "Toggling %s off; better pass an explicit argument."
- ',mode)
- nil))))
+ (,@(if setter (list setter)
+ (list (if (symbolp mode) 'setq 'setf) mode))
+ (if (eq arg 'toggle)
+ (not ,mode)
+ ;; A nil argument also means ON now.
+ (> (prefix-numeric-value arg) 0)))
,@body
;; The on/off hooks are here for backward compatibility only.
(run-hooks ',hook (if ,mode ',hook-on ',hook-off))
(if (called-interactively-p 'any)
(progn
- ,(if globalp `(customize-mark-as-set ',mode))
+ ,(if (and globalp (symbolp mode))
+ `(customize-mark-as-set ',mode))
;; Avoid overwriting a message shown by the body,
;; but do overwrite previous messages.
(unless (and (current-message)
@@ -259,9 +274,15 @@ With zero or negative ARG turn mode off.
(t (error "Invalid keymap %S" ,keymap))))
,(format "Keymap for `%s'." mode-name)))
- (add-minor-mode ',mode ',lighter
- ,(if keymap keymap-sym
- `(if (boundp ',keymap-sym) ,keymap-sym))))))
+ ,(if (not (symbolp mode))
+ (if (or lighter keymap)
+ (error ":lighter and :keymap unsupported with mode expression %s" mode))
+ `(with-no-warnings
+ (add-minor-mode ',mode ',lighter
+ ,(if keymap keymap-sym
+ `(if (boundp ',keymap-sym) ,keymap-sym))
+ nil
+ ,(unless (eq mode modefun) 'modefun)))))))
;;;
;;; make global minor mode
@@ -341,9 +362,11 @@ See `%s' for more information on %s."
(progn
(add-hook 'after-change-major-mode-hook
',MODE-enable-in-buffers)
+ (add-hook 'fundamental-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 'fundamental-mode-hook ',MODE-enable-in-buffers)
(remove-hook 'find-file-hook ',MODE-check-buffers)
(remove-hook 'change-major-mode-hook ',MODE-cmhh))
@@ -364,13 +387,14 @@ See `%s' for more information on %s."
(dolist (buf ,MODE-buffers)
(when (buffer-live-p buf)
(with-current-buffer buf
- (if ,mode
- (unless (eq ,MODE-major-mode major-mode)
- (,mode -1)
- (,turn-on)
- (setq ,MODE-major-mode major-mode))
- (,turn-on)
- (setq ,MODE-major-mode major-mode))))))
+ (unless (eq ,MODE-major-mode major-mode)
+ (if ,mode
+ (progn
+ (,mode -1)
+ (,turn-on)
+ (setq ,MODE-major-mode major-mode))
+ (,turn-on)
+ (setq ,MODE-major-mode major-mode)))))))
(put ',MODE-enable-in-buffers 'definition-name ',global-mode)
(defun ,MODE-check-buffers ()
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 8bf20b0ccef..43fb5762647 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -885,17 +885,12 @@ already is one.)"
(edebug-storing-offsets (1- (point)) 'quote)
(edebug-read-storing-offsets stream)))
-(defvar edebug-read-backquote-level 0
- "If non-zero, we're in a new-style backquote.
-It should never be negative. This controls how we read comma constructs.")
-
(defun edebug-read-backquote (stream)
;; Turn `thing into (\` thing)
(forward-char 1)
(list
(edebug-storing-offsets (1- (point)) '\`)
- (let ((edebug-read-backquote-level (1+ edebug-read-backquote-level)))
- (edebug-read-storing-offsets stream))))
+ (edebug-read-storing-offsets stream)))
(defun edebug-read-comma (stream)
;; Turn ,thing into (\, thing). Handle ,@ and ,. also.
@@ -910,12 +905,9 @@ It should never be negative. This controls how we read comma constructs.")
(forward-char 1)))
;; Generate the same structure of offsets we would have
;; if the resulting list appeared verbatim in the input text.
- (if (zerop edebug-read-backquote-level)
- (edebug-storing-offsets opoint symbol)
- (list
- (edebug-storing-offsets opoint symbol)
- (let ((edebug-read-backquote-level (1- edebug-read-backquote-level)))
- (edebug-read-storing-offsets stream)))))))
+ (list
+ (edebug-storing-offsets opoint symbol)
+ (edebug-read-storing-offsets stream)))))
(defun edebug-read-function (stream)
;; Turn #'thing into (function thing)
@@ -937,17 +929,7 @@ It should never be negative. This controls how we read comma constructs.")
(prog1
(let ((elements))
(while (not (memq (edebug-next-token-class) '(rparen dot)))
- (if (and (eq (edebug-next-token-class) 'backquote)
- (null elements)
- (zerop edebug-read-backquote-level))
- (progn
- ;; Old style backquote.
- (forward-char 1) ; Skip backquote.
- ;; Call edebug-storing-offsets here so that we
- ;; produce the same offsets we would have had
- ;; if the backquote were an ordinary symbol.
- (push (edebug-storing-offsets (1- (point)) '\`) elements))
- (push (edebug-read-storing-offsets stream) elements)))
+ (push (edebug-read-storing-offsets stream) elements))
(setq elements (nreverse elements))
(if (eq 'dot (edebug-next-token-class))
(let (dotted-form)
@@ -4455,7 +4437,7 @@ With prefix argument, make it a temporary breakpoint."
(add-hook 'cl-load-hook
(function (lambda () (require 'cl-specs)))))
-;;; edebug-cl-read and cl-read are available from liberte@cs.uiuc.edu
+;; edebug-cl-read and cl-read are available from liberte@cs.uiuc.edu
(if (featurep 'cl-read)
(add-hook 'edebug-setup-hook
(function (lambda () (require 'edebug-cl-read))))
@@ -4466,8 +4448,8 @@ With prefix argument, make it a temporary breakpoint."
;;; Finalize Loading
-;;; Finally, hook edebug into the rest of Emacs.
-;;; There are probably some other things that could go here.
+;; Finally, hook edebug into the rest of Emacs.
+;; There are probably some other things that could go here.
;; Install edebug read and eval functions.
(edebug-install-read-eval-functions)
diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el
index 961d576433a..b4845495c9e 100644
--- a/lisp/emacs-lisp/eldoc.el
+++ b/lisp/emacs-lisp/eldoc.el
@@ -530,13 +530,13 @@ The words \"&rest\", \"&optional\" are returned unchanged."
;; Prime the command list.
(eldoc-add-command-completions
- "backward-" "beginning-of-" "move-beginning-of-" "delete-other-windows"
- "delete-window" "handle-select-window"
- "end-of-" "move-end-of-" "exchange-point-and-mark" "forward-"
- "indent-for-tab-command" "goto-" "mark-page" "mark-paragraph"
- "mouse-set-point" "move-" "pop-global-mark" "next-" "other-window"
- "previous-" "recenter" "scroll-" "self-insert-command"
- "split-window-" "up-list" "down-list")
+ "backward-" "beginning-of-" "delete-other-windows" "delete-window"
+ "down-list" "end-of-" "exchange-point-and-mark" "forward-" "goto-"
+ "handle-select-window" "indent-for-tab-command" "left-" "mark-page"
+ "mark-paragraph" "mouse-set-point" "move-" "move-beginning-of-"
+ "move-end-of-" "next-" "other-window" "pop-global-mark" "previous-"
+ "recenter" "right-" "scroll-" "self-insert-command" "split-window-"
+ "up-list")
(provide 'eldoc)
diff --git a/lisp/emacs-lisp/find-gc.el b/lisp/emacs-lisp/find-gc.el
index 3ca1df466b9..49d3a7075d4 100644
--- a/lisp/emacs-lisp/find-gc.el
+++ b/lisp/emacs-lisp/find-gc.el
@@ -60,7 +60,7 @@ Each entry has the form (FUNCTION . FUNCTIONS-IT-CALLS).")
"indent.c" "search.c" "regex.c" "undo.c"
"alloc.c" "data.c" "doc.c" "editfns.c"
"callint.c" "eval.c" "fns.c" "print.c" "lread.c"
- "abbrev.c" "syntax.c" "unexec.c"
+ "abbrev.c" "syntax.c" "unexcoff.c"
"bytecode.c" "process.c" "callproc.c" "doprnt.c"
"x11term.c" "x11fns.c"))
diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el
index 8a1c753f5f6..10b7baf294f 100644
--- a/lisp/emacs-lisp/lisp-mnt.el
+++ b/lisp/emacs-lisp/lisp-mnt.el
@@ -458,7 +458,9 @@ each line."
"Return list of keywords given in file FILE."
(let ((keywords (lm-keywords file)))
(if keywords
- (split-string keywords "[, \t\n]+" t))))
+ (if (string-match-p "," keywords)
+ (split-string keywords ",[ \t\n]*" t)
+ (split-string keywords "[ \t\n]+" t)))))
(defvar finder-known-keywords)
(defun lm-keywords-finder-p (&optional file)
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 4b58a4e68c2..21a9f80fa90 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -85,7 +85,7 @@
(let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
(modify-syntax-entry ?\[ "_ " table)
(modify-syntax-entry ?\] "_ " table)
- (modify-syntax-entry ?# "' 14b" table)
+ (modify-syntax-entry ?# "' 14" table)
(modify-syntax-entry ?| "\" 23bn" table)
table)
"Syntax table used in `lisp-mode'.")
@@ -221,8 +221,6 @@ font-lock keywords will not be case sensitive."
;;(set (make-local-variable 'adaptive-fill-mode) nil)
(make-local-variable 'indent-line-function)
(setq indent-line-function 'lisp-indent-line)
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments t)
(make-local-variable 'outline-regexp)
(setq outline-regexp ";;;\\(;* [^ \t\n]\\|###autoload\\)\\|(")
(make-local-variable 'outline-level)
@@ -431,7 +429,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
:type 'hook
:group 'lisp)
-(define-derived-mode emacs-lisp-mode nil "Emacs-Lisp"
+(define-derived-mode emacs-lisp-mode prog-mode "Emacs-Lisp"
"Major mode for editing Lisp code to run in Emacs.
Commands:
Delete converts tabs to spaces as it moves back.
@@ -466,7 +464,7 @@ if that value is non-nil."
"Keymap for ordinary Lisp mode.
All commands in `lisp-mode-shared-map' are inherited by this map.")
-(defun lisp-mode ()
+(define-derived-mode lisp-mode prog-mode "Lisp"
"Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp.
Commands:
Delete converts tabs to spaces as it moves back.
@@ -478,19 +476,12 @@ or to switch back to an existing one.
Entry to this mode calls the value of `lisp-mode-hook'
if that value is non-nil."
- (interactive)
- (kill-all-local-variables)
- (use-local-map lisp-mode-map)
- (setq major-mode 'lisp-mode)
- (setq mode-name "Lisp")
(lisp-mode-variables nil t)
+ (set (make-local-variable 'find-tag-default-function) 'lisp-find-tag-default)
(make-local-variable 'comment-start-skip)
(setq comment-start-skip
"\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *")
- (setq imenu-case-fold-search t)
- (set-syntax-table lisp-mode-syntax-table)
- (run-mode-hooks 'lisp-mode-hook))
-(put 'lisp-mode 'find-tag-default-function 'lisp-find-tag-default)
+ (setq imenu-case-fold-search t))
(defun lisp-find-tag-default ()
(let ((default (find-tag-default)))
diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el
index 54fa4d615cd..c728abab496 100644
--- a/lisp/emacs-lisp/lisp.el
+++ b/lisp/emacs-lisp/lisp.el
@@ -142,7 +142,13 @@ This command assumes point is not in a string or comment."
(or arg (setq arg 1))
(let ((inc (if (> arg 0) 1 -1)))
(while (/= arg 0)
- (goto-char (or (scan-lists (point) inc 1) (buffer-end arg)))
+ (if forward-sexp-function
+ (condition-case err
+ (while (let ((pos (point)))
+ (forward-sexp inc)
+ (/= (point) pos)))
+ (scan-error (goto-char (nth 2 err))))
+ (goto-char (or (scan-lists (point) inc 1) (buffer-end arg))))
(setq arg (- arg inc)))))
(defun kill-sexp (&optional arg)
@@ -624,21 +630,25 @@ considered."
(interactive)
(let* ((data (lisp-completion-at-point predicate))
(plist (nthcdr 3 data)))
- (let ((completion-annotate-function (plist-get plist :annotate-function)))
+ (if (null data)
+ (minibuffer-message "Nothing to complete")
+ (let ((completion-annotate-function
+ (plist-get plist :annotate-function)))
(completion-in-region (nth 0 data) (nth 1 data) (nth 2 data)
- (plist-get plist :predicate)))))
+ (plist-get plist :predicate))))))
(defun lisp-completion-at-point (&optional predicate)
"Function used for `completion-at-point-functions' in `emacs-lisp-mode'."
;; FIXME: the `end' could be after point?
- (let* ((end (point))
+ (let* ((pos (point))
(beg (with-syntax-table emacs-lisp-mode-syntax-table
- (save-excursion
- (backward-sexp 1)
- (while (= (char-syntax (following-char)) ?\')
- (forward-char 1))
- (point))))
+ (condition-case nil
+ (save-excursion
+ (backward-sexp 1)
+ (skip-syntax-forward "'")
+ (point))
+ (scan-error pos))))
(predicate
(or predicate
(save-excursion
@@ -657,12 +667,23 @@ considered."
;; Maybe a `let' varlist or something.
nil
;; Else, we assume that a function name is expected.
- 'fboundp))))))
- (list beg end obarray
- :predicate predicate
- :annotate-function
+ 'fboundp)))))
+ (end
+ (unless (or (eq beg (point-max))
+ (member (char-syntax (char-after beg)) '(?\" ?\( ?\))))
+ (condition-case nil
+ (save-excursion
+ (goto-char beg)
+ (forward-sexp 1)
+ (when (>= (point) pos)
+ (point)))
+ (scan-error pos)))))
+ (when end
+ (list beg end obarray
+ :predicate predicate
+ :annotate-function
(unless (eq predicate 'fboundp)
- (lambda (str) (if (fboundp (intern-soft str)) " <f>"))))))
+ (lambda (str) (if (fboundp (intern-soft str)) " <f>")))))))
;; arch-tag: aa7fa8a4-2e6f-4e9b-9cd9-fef06340e67e
;;; lisp.el ends here
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 364e3540703..876b9a468ac 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -134,7 +134,7 @@ Assumes the caller has bound `macroexpand-all-environment'."
(maybe-cons fun
(maybe-cons (macroexpand-all-forms (cadr form) 2)
nil
- (cadr form))
+ (cdr form))
form)
form))
((memq fun '(let let*))
@@ -146,7 +146,7 @@ Assumes the caller has bound `macroexpand-all-environment'."
((eq fun 'quote)
form)
((and (consp fun) (eq (car fun) 'lambda))
- ;; embedded lambda
+ ;; Embedded lambda in function position.
(maybe-cons (macroexpand-all-forms fun 2)
(macroexpand-all-forms (cdr form))
form))
diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el
new file mode 100644
index 00000000000..b93950049e0
--- /dev/null
+++ b/lisp/emacs-lisp/package-x.el
@@ -0,0 +1,226 @@
+;;; package-x.el --- Package extras
+
+;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Tom Tromey <tromey@redhat.com>
+;; Created: 10 Mar 2007
+;; Version: 0.9
+;; Keywords: tools
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, 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; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; This file currently contains parts of the package system most
+;; people won't need, such as package uploading.
+
+;;; Code:
+
+(require 'package)
+(defvar gnus-article-buffer)
+
+;; Note that this only works if you have the password, which you
+;; probably don't :-).
+(defvar package-archive-upload-base nil
+ "Base location for uploading to package archive.")
+
+(defun package--encode (string)
+ "Encode a string by replacing some characters with XML entities."
+ ;; We need a special case for translating "&" to "&amp;".
+ (let ((index))
+ (while (setq index (string-match "[&]" string index))
+ (setq string (replace-match "&amp;" t nil string))
+ (setq index (1+ index))))
+ (while (string-match "[<]" string)
+ (setq string (replace-match "&lt;" t nil string)))
+ (while (string-match "[>]" string)
+ (setq string (replace-match "&gt;" t nil string)))
+ (while (string-match "[']" string)
+ (setq string (replace-match "&apos;" t nil string)))
+ (while (string-match "[\"]" string)
+ (setq string (replace-match "&quot;" t nil string)))
+ string)
+
+(defun package--make-rss-entry (title text archive-url)
+ (let ((date-string (format-time-string "%a, %d %B %Y %T %z")))
+ (concat "<item>\n"
+ "<title>" (package--encode title) "</title>\n"
+ ;; FIXME: should have a link in the web page.
+ "<link>" archive-url "news.html</link>\n"
+ "<description>" (package--encode text) "</description>\n"
+ "<pubDate>" date-string "</pubDate>\n"
+ "</item>\n")))
+
+(defun package--make-html-entry (title text)
+ (concat "<li> " (format-time-string "%B %e") " - "
+ title " - " (package--encode text)
+ " </li>\n"))
+
+(defun package--update-file (file location text)
+ (save-excursion
+ (let ((old-buffer (find-buffer-visiting file)))
+ (with-current-buffer (let ((find-file-visit-truename t))
+ (or old-buffer (find-file-noselect file)))
+ (goto-char (point-min))
+ (search-forward location)
+ (forward-line)
+ (insert text)
+ (let ((file-precious-flag t))
+ (save-buffer))
+ (unless old-buffer
+ (kill-buffer (current-buffer)))))))
+
+(defun package-maint-add-news-item (title description archive-url)
+ "Add a news item to the ELPA web pages.
+TITLE is the title of the news item.
+DESCRIPTION is the text of the news item.
+You need administrative access to ELPA to use this."
+ (interactive "sTitle: \nsText: ")
+ (package--update-file (concat package-archive-upload-base "elpa.rss")
+ "<description>"
+ (package--make-rss-entry title description archive-url))
+ (package--update-file (concat package-archive-upload-base "news.html")
+ "New entries go here"
+ (package--make-html-entry title description)))
+
+(defun package--update-news (package version description archive-url)
+ "Update the ELPA web pages when a package is uploaded."
+ (package-maint-add-news-item (concat package " version " version)
+ description
+ archive-url))
+
+(defun package-upload-buffer-internal (pkg-info extension &optional archive-url)
+ "Upload a package whose contents are in the current buffer.
+PKG-INFO is the package info, see `package-buffer-info'.
+EXTENSION is the file extension, a string. It can be either
+\"el\" or \"tar\".
+
+Optional arg ARCHIVE-URL is the URL of the destination archive.
+If nil, the \"gnu\" archive is used."
+ (unless archive-url
+ (or (setq archive-url (cdr (assoc "gnu" package-archives)))
+ (error "No destination URL")))
+ (save-excursion
+ (save-restriction
+ (let* ((file-type (cond
+ ((equal extension "el") 'single)
+ ((equal extension "tar") 'tar)
+ (t (error "Unknown extension `%s'" extension))))
+ (file-name (aref pkg-info 0))
+ (pkg-name (intern file-name))
+ (requires (aref pkg-info 1))
+ (desc (if (string= (aref pkg-info 2) "")
+ (read-string "Description of package: ")
+ (aref pkg-info 2)))
+ (pkg-version (aref pkg-info 3))
+ (commentary (aref pkg-info 4))
+ (split-version (version-to-list pkg-version))
+ (pkg-buffer (current-buffer))
+
+ ;; Download latest archive-contents.
+ (buffer (url-retrieve-synchronously
+ (concat archive-url "archive-contents"))))
+
+ ;; Parse archive-contents.
+ (set-buffer buffer)
+ (package-handle-response)
+ (re-search-forward "^$" nil 'move)
+ (forward-char)
+ (delete-region (point-min) (point))
+ (let ((contents (package-read-from-string
+ (buffer-substring-no-properties (point-min)
+ (point-max))))
+ (new-desc (vector split-version requires desc file-type)))
+ (if (> (car contents) package-archive-version)
+ (error "Unrecognized archive version %d" (car contents)))
+ (let ((elt (assq pkg-name (cdr contents))))
+ (if elt
+ (if (version-list-<= split-version
+ (package-desc-vers (cdr elt)))
+ (error "New package has smaller version: %s" pkg-version)
+ (setcdr elt new-desc))
+ (setq contents (cons (car contents)
+ (cons (cons pkg-name new-desc)
+ (cdr contents))))))
+
+ ;; Now CONTENTS is the updated archive contents. Upload
+ ;; this and the package itself. For now we assume ELPA is
+ ;; writable via file primitives.
+ (let ((print-level nil)
+ (print-length nil))
+ (write-region (concat (pp-to-string contents) "\n")
+ nil
+ (concat package-archive-upload-base
+ "archive-contents")))
+
+ ;; If there is a commentary section, write it.
+ (when commentary
+ (write-region commentary nil
+ (concat package-archive-upload-base
+ (symbol-name pkg-name) "-readme.txt")))
+
+ (set-buffer pkg-buffer)
+ (kill-buffer buffer)
+ (write-region (point-min) (point-max)
+ (concat package-archive-upload-base
+ file-name "-" pkg-version
+ "." extension)
+ nil nil nil 'excl)
+
+ ;; Write a news entry.
+ (package--update-news (concat file-name "." extension)
+ pkg-version desc archive-url)
+
+ ;; special-case "package": write a second copy so that the
+ ;; installer can easily find the latest version.
+ (if (string= file-name "package")
+ (write-region (point-min) (point-max)
+ (concat package-archive-upload-base
+ file-name "." extension)
+ nil nil nil 'ask)))))))
+
+(defun package-upload-buffer ()
+ "Upload a single .el file to ELPA from the current buffer."
+ (interactive)
+ (save-excursion
+ (save-restriction
+ ;; Find the package in this buffer.
+ (let ((pkg-info (package-buffer-info)))
+ (package-upload-buffer-internal pkg-info "el")))))
+
+(defun package-upload-file (file)
+ (interactive "fPackage file name: ")
+ (with-temp-buffer
+ (insert-file-contents-literally file)
+ (let ((info (cond
+ ((string-match "\\.tar$" file) (package-tar-file-info file))
+ ((string-match "\\.el$" file) (package-buffer-info))
+ (t (error "Unrecognized extension `%s'"
+ (file-name-extension file))))))
+ (package-upload-buffer-internal info (file-name-extension file)))))
+
+(defun package-gnus-summary-upload ()
+ "Upload a package contained in the current *Article* buffer.
+This should be invoked from the gnus *Summary* buffer."
+ (interactive)
+ (with-current-buffer gnus-article-buffer
+ (package-upload-buffer)))
+
+(provide 'package-x)
+
+;;; package.el ends here
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
new file mode 100644
index 00000000000..2e8c7dc7d4f
--- /dev/null
+++ b/lisp/emacs-lisp/package.el
@@ -0,0 +1,1569 @@
+;;; package.el --- Simple package system for Emacs
+
+;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Tom Tromey <tromey@redhat.com>
+;; Created: 10 Mar 2007
+;; Version: 0.9
+;; Keywords: tools
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, 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; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Change Log:
+
+;; 2 Apr 2007 - now using ChangeLog file
+;; 15 Mar 2007 - updated documentation
+;; 14 Mar 2007 - Changed how obsolete packages are handled
+;; 13 Mar 2007 - Wrote package-install-from-buffer
+;; 12 Mar 2007 - Wrote package-menu mode
+
+;;; Commentary:
+
+;; The idea behind package.el is to be able to download packages and
+;; install them. Packages are versioned and have versioned
+;; dependencies. Furthermore, this supports built-in packages which
+;; may or may not be newer than user-specified packages. This makes
+;; it possible to upgrade Emacs and automatically disable packages
+;; which have moved from external to core. (Note though that we don't
+;; currently register any of these, so this feature does not actually
+;; work.)
+
+;; A package is described by its name and version. The distribution
+;; format is either a tar file or a single .el file.
+
+;; A tar file should be named "NAME-VERSION.tar". The tar file must
+;; unpack into a directory named after the package and version:
+;; "NAME-VERSION". It must contain a file named "PACKAGE-pkg.el"
+;; which consists of a call to define-package. It may also contain a
+;; "dir" file and the info files it references.
+
+;; A .el file is named "NAME-VERSION.el" in the remote archive, but is
+;; installed as simply "NAME.el" in a directory named "NAME-VERSION".
+
+;; The downloader downloads all dependent packages. By default,
+;; packages come from the official GNU sources, but others may be
+;; added by customizing the `package-archives' alist. Packages get
+;; byte-compiled at install time.
+
+;; At activation time we will set up the load-path and the info path,
+;; and we will load the package's autoloads. If a package's
+;; dependencies are not available, we will not activate that package.
+
+;; Conceptually a package has multiple state transitions:
+;;
+;; * Download. Fetching the package from ELPA.
+;; * Install. Untar the package, or write the .el file, into
+;; ~/.emacs.d/elpa/ directory.
+;; * Byte compile. Currently this phase is done during install,
+;; but we may change this.
+;; * Activate. Evaluate the autoloads for the package to make it
+;; available to the user.
+;; * Load. Actually load the package and run some code from it.
+
+;; Other external functions you may want to use:
+;;
+;; M-x package-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.
+;;
+;; M-x package-list-packages-no-fetch
+;; Like package-list-packages, but does not automatically fetch the
+;; new list of packages.
+;;
+;; M-x package-install-from-buffer
+;; Install a package consisting of a single .el file that appears
+;; in the current buffer. This only works for packages which
+;; define a Version header properly; package.el also supports the
+;; extension headers Package-Version (in case Version is an RCS id
+;; or similar), and Package-Requires (if the package requires other
+;; packages).
+;;
+;; M-x package-install-file
+;; 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.
+
+;;; Thanks:
+;;; (sorted by sort-lines):
+
+;; Jim Blandy <jimb@red-bean.com>
+;; Karl Fogel <kfogel@red-bean.com>
+;; Kevin Ryde <user42@zip.com.au>
+;; Lawrence Mitchell
+;; Michael Olson <mwolson@member.fsf.org>
+;; Sebastian Tennant <sebyte@smolny.plus.com>
+;; Stefan Monnier <monnier@iro.umontreal.ca>
+;; Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Phil Hagelberg <phil@hagelb.org>
+
+;;; ToDo:
+
+;; - putting info dirs at the start of the info path means
+;; users see a weird ordering of categories. OTOH we want to
+;; override later entries. maybe emacs needs to enforce
+;; the standard layout?
+;; - put bytecode in a separate directory tree
+;; - perhaps give users a way to recompile their bytecode
+;; or do it automatically when emacs changes
+;; - give users a way to know whether a package is installed ok
+;; - give users a way to view a package's documentation when it
+;; only appears in the .el
+;; - use/extend checkdoc so people can tell if their package will work
+;; - "installed" instead of a blank in the status column
+;; - tramp needs its files to be compiled in a certain order.
+;; how to handle this? fix tramp?
+;; - on emacs 21 we don't kill the -autoloads.el buffer. what about 22?
+;; - maybe we need separate .elc directories for various emacs versions
+;; and also emacs-vs-xemacs. That way conditional compilation can
+;; work. But would this break anything?
+;; - should store the package's keywords in archive-contents, then
+;; let the users filter the package-menu by keyword. See
+;; finder-by-keyword. (We could also let people view the
+;; Commentary, but it isn't clear how useful this is.)
+;; - William Xu suggests being able to open a package file without
+;; installing it
+;; - Interface with desktop.el so that restarting after an install
+;; works properly
+;; - Implement M-x package-upgrade, to upgrade any/all existing packages
+;; - Use hierarchical layout. PKG/etc PKG/lisp PKG/info
+;; ... except maybe lisp?
+;; - It may be nice to have a macro that expands to the package's
+;; private data dir, aka ".../etc". Or, maybe data-directory
+;; needs to be a list (though this would be less nice)
+;; a few packages want this, eg sokoban
+;; - package menu needs:
+;; ability to know which packages are built-in & thus not deletable
+;; it can sometimes print odd results, like 0.3 available but 0.4 active
+;; why is that?
+;; - Allow multiple versions on the server...?
+;; [ why bother? ]
+;; - Don't install a package which will invalidate dependencies overall
+;; - Allow something like (or (>= emacs 21.0) (>= xemacs 21.5))
+;; [ currently thinking, why bother.. KISS ]
+;; - Allow optional package dependencies
+;; then if we require 'bbdb', bbdb-specific lisp in lisp/bbdb
+;; and just don't compile to add to load path ...?
+;; - Have a list of archive URLs? [ maybe there's no point ]
+;; - David Kastrup pointed out on the xemacs list that for GPL it
+;; is friendlier to ship the source tree. We could "support" that
+;; by just having a "src" subdir in the package. This isn't ideal
+;; but it probably is not worth trying to support random source
+;; tree layouts, build schemes, etc.
+;; - Our treatment of the info path is somewhat bogus
+;; - perhaps have an "unstable" tree in ELPA as well as a stable one
+
+;;; Code:
+
+(defgroup package nil
+ "Manager for Emacs Lisp packages."
+ :group 'applications
+ :version "24.1")
+
+;;;###autoload
+(defcustom package-enable-at-startup t
+ "Whether to activate installed packages when Emacs starts.
+If non-nil, packages are activated after reading the init file
+and before `after-init-hook'. Activation is not done if
+`user-init-file' is nil (e.g. Emacs was started with \"-q\").
+
+Even if the value is nil, you can type \\[package-initialize] to
+activate the package system at any time."
+ :type 'boolean
+ :group 'package
+ :version "24.1")
+
+(defcustom package-load-list '(all)
+ "List of packages for `package-initialize' to load.
+Each element in this list should be a list (NAME VERSION), or the
+symbol `all'. The symbol `all' says to load the latest installed
+versions of all packages not specified by other elements.
+
+For an element (NAME VERSION), NAME is a package name (a symbol).
+VERSION should be t, a string, or nil.
+If VERSION is t, all versions are loaded, though obsolete ones
+ will be put in `package-obsolete-alist' and not activated.
+If VERSION is a string, only that version is ever loaded.
+ Any other version, even if newer, is silently ignored.
+ Hence, the package is \"held\" at that version.
+If VERSION is nil, the package is not loaded (it is \"disabled\")."
+ :type '(repeat symbol)
+ :risky t
+ :group 'package
+ :version "24.1")
+
+(defvar Info-directory-list)
+(declare-function info-initialize "info" ())
+(declare-function url-http-parse-response "url-http" ())
+(declare-function lm-header "lisp-mnt" (header))
+(declare-function lm-commentary "lisp-mnt" (&optional file))
+(declare-function dired-delete-file "dired" (file &optional recursive trash))
+
+(defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/"))
+ "An alist of archives from which to fetch.
+The default value points to the GNU Emacs package repository.
+Each element has the form (ID . URL), where ID is an identifier
+string for an archive and URL is a http: URL (a string)."
+ :type '(alist :key-type (string :tag "Archive name")
+ :value-type (string :tag "Archive URL"))
+ :risky t
+ :group 'package
+ :version "24.1")
+
+(defconst package-archive-version 1
+ "Version number of the package archive understood by this file.
+Lower version numbers than this will probably be understood as well.")
+
+(defconst package-el-version "1.0"
+ "Version of package.el.")
+
+;; We don't prime the cache since it tends to get out of date.
+(defvar package-archive-contents nil
+ "Cache of the contents of the Emacs Lisp Package Archive.
+This is an alist mapping package names (symbols) to package
+descriptor vectors. These are like the vectors for `package-alist'
+but have extra entries: one which is 'tar for tar packages and
+'single for single-file packages, and one which is the name of
+the archive from which it came.")
+(put 'package-archive-contents 'risky-local-variable t)
+
+(defcustom package-user-dir (locate-user-emacs-file "elpa")
+ "Directory containing the user's Emacs Lisp packages.
+The directory name should be absolute.
+Apart from this directory, Emacs also looks for system-wide
+packages in `package-directory-list'."
+ :type 'directory
+ :risky t
+ :group 'package
+ :version "24.1")
+
+(defcustom package-directory-list
+ ;; Defaults are subdirs named "elpa" in the site-lisp dirs.
+ (let (result)
+ (dolist (f load-path)
+ (if (equal (file-name-nondirectory f) "site-lisp")
+ (push (expand-file-name "elpa" f) result)))
+ (nreverse result))
+ "List of additional directories containing Emacs Lisp packages.
+Each directory name should be absolute.
+
+These directories contain packages intended for system-wide; in
+contrast, `package-user-dir' contains packages for personal use."
+ :type '(repeat directory)
+ :risky t
+ :group 'package
+ :version "24.1")
+
+(defconst package--builtins-base
+ ;; We use package-version split here to make sure to pick up the
+ ;; minor version.
+ `((emacs . [,(version-to-list emacs-version) nil
+ "GNU Emacs"])
+ (package . [,(version-to-list package-el-version)
+ nil "Simple package system for GNU Emacs"]))
+ "Packages which are always built-in.")
+
+(defvar package--builtins
+ (delq nil
+ (append
+ package--builtins-base
+ (if (>= emacs-major-version 22)
+ ;; FIXME: emacs 22 includes tramp, rcirc, maybe
+ ;; other things...
+ '((erc . [(5 2) nil "Internet Relay Chat client"])
+ ;; The external URL is version 1.15, so make sure the
+ ;; built-in one looks newer.
+ (url . [(1 16) nil "URL handling libary"])))
+ (if (>= emacs-major-version 23)
+ '(;; Strangely, nxml-version is missing in Emacs 23.
+ ;; We pick the merge date as the version.
+ (nxml . [(20071123) nil "Major mode for XML documents"])
+ (bubbles . [(0 5) nil "A puzzle game"])))))
+ "Alist of all built-in packages.
+Maps the package name to a vector [VERSION REQS DOCSTRING].")
+(put 'package--builtins 'risky-local-variable t)
+
+(defvar package-alist package--builtins
+ "Alist of all packages available for activation.
+This maps the package name to a vector [VERSION REQS DOCSTRING].
+
+The value is generated by `package-load-descriptor', usually
+called via `package-initialize'. For user customizations of
+which packages to load/activate, see `package-load-list'.")
+(put 'package-archive-contents 'risky-local-variable t)
+
+(defvar package-activated-list
+ (mapcar #'car package-alist)
+ "List of the names of currently activated packages.")
+(put 'package-activated-list 'risky-local-variable t)
+
+(defvar package-obsolete-alist nil
+ "Representation of obsolete packages.
+Like `package-alist', but maps package name to a second alist.
+The inner alist is keyed by version.")
+(put 'package-obsolete-alist 'risky-local-variable t)
+
+(defconst package-subdirectory-regexp
+ "^\\([^.].*\\)-\\([0-9]+\\(?:[.][0-9]+\\)*\\)$"
+ "Regular expression matching the name of a package subdirectory.
+The first subexpression is the package name.
+The second subexpression is the version string.")
+
+(defun package-version-join (l)
+ "Turn a list of version numbers into a version string."
+ (mapconcat 'int-to-string l "."))
+
+(defun package-strip-version (dirname)
+ "Strip the version from a combined package name and version.
+E.g., if given \"quux-23.0\", will return \"quux\""
+ (if (string-match package-subdirectory-regexp dirname)
+ (match-string 1 dirname)))
+
+(defun package-load-descriptor (dir package)
+ "Load the description file in directory DIR for package PACKAGE."
+ (let* ((pkg-dir (expand-file-name package dir))
+ (pkg-file (expand-file-name
+ (concat (package-strip-version package) "-pkg")
+ pkg-dir)))
+ (when (and (file-directory-p pkg-dir)
+ (file-exists-p (concat pkg-file ".el")))
+ (load pkg-file nil t))))
+
+(defun package-load-all-descriptors ()
+ "Load descriptors for installed Emacs Lisp packages.
+This looks for package subdirectories in `package-user-dir' and
+`package-directory-list'. The variable `package-load-list'
+controls which package subdirectories may be loaded.
+
+In each valid package subdirectory, this function loads the
+description file containing a call to `define-package', which
+updates `package-alist' and `package-obsolete-alist'."
+ (let ((all (memq 'all package-load-list))
+ name version force)
+ (dolist (dir (cons package-user-dir package-directory-list))
+ (when (file-directory-p dir)
+ (dolist (subdir (directory-files dir))
+ (when (and (file-directory-p (expand-file-name subdir dir))
+ (string-match package-subdirectory-regexp subdir))
+ (setq name (intern (match-string 1 subdir))
+ version (match-string 2 subdir)
+ force (assq name package-load-list))
+ (when (cond
+ ((null force)
+ all) ; not in package-load-list
+ ((null (setq force (cadr force)))
+ nil) ; disabled
+ ((eq force t)
+ t)
+ ((stringp force) ; held
+ (version-list-= (version-to-list version)
+ (version-to-list force)))
+ (t
+ (error "Invalid element in `package-load-list'")))
+ (package-load-descriptor dir subdir))))))))
+
+(defsubst package-desc-vers (desc)
+ "Extract version from a package description vector."
+ (aref desc 0))
+
+(defsubst package-desc-reqs (desc)
+ "Extract requirements from a package description vector."
+ (aref desc 1))
+
+(defsubst package-desc-doc (desc)
+ "Extract doc string from a package description vector."
+ (aref desc 2))
+
+(defsubst package-desc-kind (desc)
+ "Extract the kind of download from an archive package description vector."
+ (aref desc 3))
+
+(defun package--dir (name version-string)
+ (let* ((subdir (concat name "-" version-string))
+ (dir-list (cons package-user-dir package-directory-list))
+ pkg-dir)
+ (while dir-list
+ (let ((subdir-full (expand-file-name subdir (car dir-list))))
+ (if (file-directory-p subdir-full)
+ (setq pkg-dir subdir-full
+ dir-list nil)
+ (setq dir-list (cdr dir-list)))))
+ pkg-dir))
+
+(defun package-activate-1 (package pkg-vec)
+ (let* ((name (symbol-name package))
+ (version-str (package-version-join (package-desc-vers pkg-vec)))
+ (pkg-dir (package--dir name version-str)))
+ (unless pkg-dir
+ (error "Internal error: could not find directory for %s-%s"
+ name version-str))
+ ;; Add info node.
+ (if (file-exists-p (expand-file-name "dir" pkg-dir))
+ (progn
+ ;; FIXME: not the friendliest, but simple.
+ (require 'info)
+ (info-initialize)
+ (setq Info-directory-list (cons pkg-dir Info-directory-list))))
+ ;; Add to load path, add autoloads, and activate the package.
+ (setq load-path (cons pkg-dir load-path))
+ (load (expand-file-name (concat name "-autoloads") pkg-dir) nil t)
+ (setq package-activated-list (cons package package-activated-list))
+ ;; Don't return nil.
+ t))
+
+(defun package--built-in (package version)
+ "Return true if the package is built-in to Emacs."
+ (let ((elt (assq package package--builtins)))
+ (and elt (version-list-= (package-desc-vers (cdr elt)) version))))
+
+;; FIXME: return a reason instead?
+(defun package-activate (package version)
+ "Activate a package, and recursively activate its dependencies.
+Return nil if the package could not be activated."
+ ;; Assume the user knows what he is doing -- go ahead and activate a
+ ;; newer version of a package if an older one has already been
+ ;; activated. This is not ideal; we'd at least need to check to see
+ ;; if the package has actually been loaded, and not merely
+ ;; activated. However, don't try to activate 'emacs', as that makes
+ ;; no sense.
+ (unless (eq package 'emacs)
+ (let* ((pkg-desc (assq package package-alist))
+ (this-version (package-desc-vers (cdr pkg-desc)))
+ (req-list (package-desc-reqs (cdr pkg-desc)))
+ ;; If the package was never activated, do it now.
+ (keep-going (or (not (memq package package-activated-list))
+ (version-list-< version this-version))))
+ (while (and req-list keep-going)
+ (let* ((req (car req-list))
+ (req-name (car req))
+ (req-version (cadr req)))
+ (or (package-activate req-name req-version)
+ (setq keep-going nil)))
+ (setq req-list (cdr req-list)))
+ (if keep-going
+ (package-activate-1 package (cdr pkg-desc))
+ ;; We get here if a dependency failed to activate -- but we
+ ;; can also get here if the requested package was already
+ ;; activated. Return non-nil in the latter case.
+ (and (memq package package-activated-list)
+ (version-list-<= version this-version))))))
+
+(defun package-mark-obsolete (package pkg-vec)
+ "Put package on the obsolete list, if not already there."
+ (let ((elt (assq package package-obsolete-alist)))
+ (if elt
+ ;; If this obsolete version does not exist in the list, update
+ ;; it the list.
+ (unless (assoc (package-desc-vers pkg-vec) (cdr elt))
+ (setcdr elt (cons (cons (package-desc-vers pkg-vec) pkg-vec)
+ (cdr elt))))
+ ;; Make a new association.
+ (setq package-obsolete-alist
+ (cons (cons package (list (cons (package-desc-vers pkg-vec)
+ pkg-vec)))
+ package-obsolete-alist)))))
+
+;; (define-package "emacs" "21.4.1" "GNU Emacs core package.")
+;; (define-package "erc" "5.1" "ERC - irc client" '((emacs "21.0")))
+(defun define-package (name-str version-string
+ &optional docstring requirements)
+ "Define a new package.
+NAME is the name of the package, a string.
+VERSION-STRING is the version of the package, a dotted sequence
+of integers.
+DOCSTRING is the optional description.
+REQUIREMENTS is a list of requirements on other packages.
+Each requirement is of the form (OTHER-PACKAGE \"VERSION\")."
+ (let* ((name (intern name-str))
+ (pkg-desc (assq name package-alist))
+ (new-version (version-to-list version-string))
+ (new-pkg-desc
+ (cons name
+ (vector new-version
+ (mapcar
+ (lambda (elt)
+ (list (car elt)
+ (version-to-list (car (cdr elt)))))
+ requirements)
+ docstring))))
+ ;; Only redefine a package if the redefinition is newer.
+ (if (or (not pkg-desc)
+ (version-list-< (package-desc-vers (cdr pkg-desc))
+ new-version))
+ (progn
+ (when pkg-desc
+ ;; Remove old package and declare it obsolete.
+ (setq package-alist (delq pkg-desc package-alist))
+ (package-mark-obsolete (car pkg-desc) (cdr pkg-desc)))
+ ;; Add package to the alist.
+ (setq package-alist (cons new-pkg-desc package-alist)))
+ ;; You can have two packages with the same version, for instance
+ ;; one in the system package directory and one in your private
+ ;; directory. We just let the first one win.
+ (unless (version-list-= new-version
+ (package-desc-vers (cdr pkg-desc)))
+ ;; The package is born obsolete.
+ (package-mark-obsolete (car new-pkg-desc) (cdr new-pkg-desc))))))
+
+;; From Emacs 22.
+(defun package-autoload-ensure-default-file (file)
+ "Make sure that the autoload file FILE exists and if not create it."
+ (unless (file-exists-p file)
+ (write-region
+ (concat ";;; " (file-name-nondirectory file)
+ " --- automatically extracted autoloads\n"
+ ";;\n"
+ ";;; Code:\n\n"
+ " \n;; Local Variables:\n"
+ ";; version-control: never\n"
+ ";; no-byte-compile: t\n"
+ ";; no-update-autoloads: t\n"
+ ";; End:\n"
+ ";;; " (file-name-nondirectory file)
+ " ends here\n")
+ nil file))
+ file)
+
+(defun package-generate-autoloads (name pkg-dir)
+ (let* ((auto-name (concat name "-autoloads.el"))
+ (ignore-name (concat name "-pkg.el"))
+ (generated-autoload-file (expand-file-name auto-name pkg-dir))
+ (version-control 'never))
+ (require 'autoload)
+ (unless (fboundp 'autoload-ensure-default-file)
+ (package-autoload-ensure-default-file generated-autoload-file))
+ (update-directory-autoloads pkg-dir)))
+
+(defun package-untar-buffer ()
+ "Untar the current buffer.
+This uses `tar-untar-buffer' if it is available.
+Otherwise it uses an external `tar' program.
+`default-directory' should be set by the caller."
+ (require 'tar-mode)
+ (if (fboundp 'tar-untar-buffer)
+ (progn
+ ;; tar-mode messes with narrowing, so we just let it have the
+ ;; whole buffer to play with.
+ (delete-region (point-min) (point))
+ (tar-mode)
+ (tar-untar-buffer))
+ ;; FIXME: check the result.
+ (call-process-region (point) (point-max) "tar" nil '(nil nil) nil
+ "xf" "-")))
+
+(defun package-unpack (name version)
+ (let ((pkg-dir (expand-file-name (concat (symbol-name name) "-" version)
+ package-user-dir)))
+ ;; Be careful!!
+ (make-directory package-user-dir t)
+ (if (file-directory-p pkg-dir)
+ (mapc (lambda (file) nil) ; 'delete-file -- FIXME: when we're
+ ; more confident
+ (directory-files pkg-dir t "^[^.]")))
+ (let* ((default-directory (file-name-as-directory package-user-dir)))
+ (package-untar-buffer)
+ (package-generate-autoloads (symbol-name name) pkg-dir)
+ (let ((load-path (cons pkg-dir load-path)))
+ (byte-recompile-directory pkg-dir 0 t)))))
+
+(defun package--write-file-no-coding (file-name excl)
+ (let ((buffer-file-coding-system 'no-conversion))
+ (write-region (point-min) (point-max) file-name nil nil nil excl)))
+
+(defun package-unpack-single (file-name version desc requires)
+ "Install the contents of the current buffer as a package."
+ ;; Special case "package".
+ (if (string= file-name "package")
+ (package--write-file-no-coding
+ (expand-file-name (concat file-name ".el") package-user-dir)
+ nil)
+ (let* ((pkg-dir (expand-file-name (concat file-name "-" version)
+ package-user-dir))
+ (el-file (expand-file-name (concat file-name ".el") pkg-dir))
+ (pkg-file (expand-file-name (concat file-name "-pkg.el") pkg-dir)))
+ (make-directory pkg-dir t)
+ (package--write-file-no-coding el-file 'excl)
+ (let ((print-level nil)
+ (print-length nil))
+ (write-region
+ (concat
+ (prin1-to-string
+ (list 'define-package
+ file-name
+ version
+ desc
+ (list 'quote
+ ;; Turn version lists into string form.
+ (mapcar
+ (lambda (elt)
+ (list (car elt)
+ (package-version-join (car (cdr elt)))))
+ requires))))
+ "\n")
+ nil
+ pkg-file
+ nil nil nil 'excl))
+ (package-generate-autoloads file-name pkg-dir)
+ (let ((load-path (cons pkg-dir load-path)))
+ (byte-recompile-directory pkg-dir 0 t)))))
+
+(defun package-handle-response ()
+ "Handle the response from the server.
+Parse the HTTP response and throw if an error occurred.
+The url package seems to require extra processing for this.
+This should be called in a `save-excursion', in the download buffer.
+It will move point to somewhere in the headers."
+ ;; We assume HTTP here.
+ (require 'url-http)
+ (let ((response (url-http-parse-response)))
+ (when (or (< response 200) (>= response 300))
+ (display-buffer (current-buffer))
+ (error "Error during download request:%s"
+ (buffer-substring-no-properties (point) (progn
+ (end-of-line)
+ (point)))))))
+
+(defun package-download-single (name version desc requires)
+ "Download and install a single-file package."
+ (let ((buffer (url-retrieve-synchronously
+ (concat (package-archive-url name)
+ (symbol-name name) "-" version ".el"))))
+ (with-current-buffer buffer
+ (package-handle-response)
+ (re-search-forward "^$" nil 'move)
+ (forward-char)
+ (delete-region (point-min) (point))
+ (package-unpack-single (symbol-name name) version desc requires)
+ (kill-buffer buffer))))
+
+(defun package-download-tar (name version)
+ "Download and install a tar package."
+ (let ((tar-buffer (url-retrieve-synchronously
+ (concat (package-archive-url name)
+ (symbol-name name) "-" version ".tar"))))
+ (with-current-buffer tar-buffer
+ (package-handle-response)
+ (re-search-forward "^$" nil 'move)
+ (forward-char)
+ (package-unpack name version)
+ (kill-buffer tar-buffer))))
+
+(defun package-installed-p (package &optional min-version)
+ (let ((pkg-desc (assq package package-alist)))
+ (and pkg-desc
+ (version-list-<= min-version
+ (package-desc-vers (cdr pkg-desc))))))
+
+(defun package-compute-transaction (result requirements)
+ (dolist (elt requirements)
+ (let* ((next-pkg (car elt))
+ (next-version (cadr elt)))
+ (unless (package-installed-p next-pkg next-version)
+ ;; A package is required, but not installed. It might also be
+ ;; blocked via `package-load-list'.
+ (let ((pkg-desc (assq next-pkg package-archive-contents))
+ hold)
+ (when (setq hold (assq next-pkg package-load-list))
+ (setq hold (cadr hold))
+ (cond ((eq hold nil)
+ (error "Required package '%s' is disabled"
+ (symbol-name next-pkg)))
+ ((null (stringp hold))
+ (error "Invalid element in `package-load-list'"))
+ ((version-list-< (version-to-list hold) next-version)
+ (error "Package '%s' held at version %s, \
+but version %s required"
+ (symbol-name next-pkg) hold
+ (package-version-join next-version)))))
+ (unless pkg-desc
+ (error "Package '%s' is not available for installation"
+ (symbol-name next-pkg)))
+ (unless (version-list-<= next-version
+ (package-desc-vers (cdr pkg-desc)))
+ (error
+ "Need package '%s' with version %s, but only %s is available"
+ (symbol-name next-pkg) (package-version-join next-version)
+ (package-version-join (package-desc-vers (cdr pkg-desc)))))
+ ;; Only add to the transaction if we don't already have it.
+ (unless (memq next-pkg result)
+ (setq result (cons next-pkg result)))
+ (setq result
+ (package-compute-transaction result
+ (package-desc-reqs
+ (cdr pkg-desc))))))))
+ result)
+
+(defun package-read-from-string (str)
+ "Read a Lisp expression from STR.
+Signal an error if the entire string was not used."
+ (let* ((read-data (read-from-string str))
+ (more-left
+ (condition-case nil
+ ;; The call to `ignore' suppresses a compiler warning.
+ (progn (ignore (read-from-string
+ (substring str (cdr read-data))))
+ t)
+ (end-of-file nil))))
+ (if more-left
+ (error "Can't read whole string")
+ (car read-data))))
+
+(defun package--read-archive-file (file)
+ "Re-read archive file FILE, if it exists.
+Will return the data from the file, or nil if the file does not exist.
+Will throw an error if the archive version is too new."
+ (let ((filename (expand-file-name file package-user-dir)))
+ (if (file-exists-p filename)
+ (with-temp-buffer
+ (insert-file-contents-literally filename)
+ (let ((contents (package-read-from-string
+ (buffer-substring-no-properties (point-min)
+ (point-max)))))
+ (if (> (car contents) package-archive-version)
+ (error "Package archive version %d is greater than %d - upgrade package.el"
+ (car contents) package-archive-version))
+ (cdr contents))))))
+
+(defun package-read-all-archive-contents ()
+ "Re-read `archive-contents' and `builtin-packages', if they exist.
+Set `package-archive-contents' and `package--builtins' if successful.
+Throw an error if the archive version is too new."
+ (dolist (archive package-archives)
+ (package-read-archive-contents (car archive)))
+ (let ((builtins (package--read-archive-file "builtin-packages")))
+ (if builtins
+ ;; Version 1 of 'builtin-packages' is a list where the car is
+ ;; a split emacs version and the cdr is an alist suitable for
+ ;; package--builtins.
+ (let ((our-version (version-to-list emacs-version))
+ (result package--builtins-base))
+ (setq package--builtins
+ (dolist (elt builtins result)
+ (if (version-list-<= (car elt) our-version)
+ (setq result (append (cdr elt) result)))))))))
+
+(defun package-read-archive-contents (archive)
+ "Re-read `archive-contents' and `builtin-packages' for ARCHIVE.
+If successful, set `package-archive-contents' and `package--builtins'.
+If the archive version is too new, signal an error."
+ (let ((archive-contents (package--read-archive-file
+ (concat "archives/" archive
+ "/archive-contents"))))
+ (if archive-contents
+ ;; Version 1 of 'archive-contents' is identical to our
+ ;; internal representation.
+ ;; TODO: merge archive lists
+ (dolist (package archive-contents)
+ (package--add-to-archive-contents package archive)))))
+
+(defun package--add-to-archive-contents (package archive)
+ "Add the PACKAGE from the given ARCHIVE if necessary.
+Also, add the originating archive to the end of the package vector."
+ (let* ((name (car package))
+ (version (aref (cdr package) 0))
+ (entry (cons (car package)
+ (vconcat (cdr package) (vector archive))))
+ (existing-package (cdr (assq name package-archive-contents))))
+ (when (or (not existing-package)
+ (version-list-< (aref existing-package 0) version))
+ (add-to-list 'package-archive-contents entry))))
+
+(defun package-download-transaction (transaction)
+ "Download and install all the packages in the given transaction."
+ (dolist (elt transaction)
+ (let* ((desc (cdr (assq elt package-archive-contents)))
+ ;; As an exception, if package is "held" in
+ ;; `package-load-list', download the held version.
+ (hold (cadr (assq elt package-load-list)))
+ (v-string (or (and (stringp hold) hold)
+ (package-version-join (package-desc-vers desc))))
+ (kind (package-desc-kind desc)))
+ (cond
+ ((eq kind 'tar)
+ (package-download-tar elt v-string))
+ ((eq kind 'single)
+ (package-download-single elt v-string
+ (package-desc-doc desc)
+ (package-desc-reqs desc)))
+ (t
+ (error "Unknown package kind: %s" (symbol-name kind)))))))
+
+;;;###autoload
+(defun package-install (name)
+ "Install the package named NAME.
+Interactively, prompt for the package name.
+The package is found on one of the archives in `package-archives'."
+ (interactive
+ (list (intern (completing-read "Install package: "
+ (mapcar (lambda (elt)
+ (cons (symbol-name (car elt))
+ nil))
+ package-archive-contents)
+ nil t))))
+ (let ((pkg-desc (assq name package-archive-contents)))
+ (unless pkg-desc
+ (error "Package '%s' is not available for installation"
+ (symbol-name name)))
+ (package-download-transaction
+ (package-compute-transaction (list name)
+ (package-desc-reqs (cdr pkg-desc)))))
+ ;; Try to activate it.
+ (package-initialize))
+
+(defun package-strip-rcs-id (v-str)
+ "Strip RCS version ID from the version string.
+If the result looks like a dotted numeric version, return it.
+Otherwise return nil."
+ (if v-str
+ (if (string-match "^[ \t]*[$]Revision:[ \t]\([0-9.]+\)[ \t]*[$]$" v-str)
+ (match-string 1 v-str)
+ (if (string-match "^[0-9.]*$" v-str)
+ v-str))))
+
+(defun package-buffer-info ()
+ "Return a vector of information about the package in the current buffer.
+The vector looks like [FILENAME REQUIRES DESCRIPTION VERSION COMMENTARY]
+FILENAME is the file name, a string. It does not have the \".el\" extension.
+REQUIRES is a requires list, or nil.
+DESCRIPTION is the package description (a string).
+VERSION is the version, a string.
+COMMENTARY is the commentary section, a string, or nil if none.
+Throws an exception if the buffer does not contain a conforming package.
+If there is a package, narrows the buffer to the file's boundaries.
+May narrow buffer or move point even on failure."
+ (goto-char (point-min))
+ (if (re-search-forward "^;;; \\([^ ]*\\)\\.el --- \\(.*\\)$" nil t)
+ (let ((file-name (match-string 1))
+ (desc (match-string 2))
+ (start (progn (beginning-of-line) (point))))
+ (if (search-forward (concat ";;; " file-name ".el ends here"))
+ (progn
+ ;; Try to include a trailing newline.
+ (forward-line)
+ (narrow-to-region start (point))
+ (require 'lisp-mnt)
+ ;; Use some headers we've invented to drive the process.
+ (let* ((requires-str (lm-header "package-requires"))
+ (requires (if requires-str
+ (package-read-from-string requires-str)))
+ ;; Prefer Package-Version, because if it is
+ ;; defined the package author probably wants us
+ ;; to use it. Otherwise try Version.
+ (pkg-version
+ (or (package-strip-rcs-id (lm-header "package-version"))
+ (package-strip-rcs-id (lm-header "version"))))
+ (commentary (lm-commentary)))
+ (unless pkg-version
+ (error
+ "Package does not define a usable \"Version\" or \"Package-Version\" header"))
+ ;; Turn string version numbers into list form.
+ (setq requires
+ (mapcar
+ (lambda (elt)
+ (list (car elt)
+ (version-to-list (car (cdr elt)))))
+ requires))
+ (set-text-properties 0 (length file-name) nil file-name)
+ (set-text-properties 0 (length pkg-version) nil pkg-version)
+ (set-text-properties 0 (length desc) nil desc)
+ (vector file-name requires desc pkg-version commentary)))
+ (error "Package missing a terminating comment")))
+ (error "No starting comment for package")))
+
+(defun package-tar-file-info (file)
+ "Find package information for a tar file.
+FILE is the name of the tar file to examine.
+The return result is a vector like `package-buffer-info'."
+ (unless (string-match "^\\(.+\\)-\\([0-9.]+\\)\\.tar$" file)
+ (error "`%s' doesn't have a package-ish name" file))
+ (let* ((pkg-name (file-name-nondirectory (match-string-no-properties 1 file)))
+ (pkg-version (match-string-no-properties 2 file))
+ ;; Extract the package descriptor.
+ (pkg-def-contents (shell-command-to-string
+ ;; Requires GNU tar.
+ (concat "tar -xOf " file " "
+ pkg-name "-" pkg-version "/"
+ pkg-name "-pkg.el")))
+ (pkg-def-parsed (package-read-from-string pkg-def-contents)))
+ (unless (eq (car pkg-def-parsed) 'define-package)
+ (error "%s-pkg.el doesn't contain `define-package' sexp" pkg-name))
+ (let ((name-str (nth 1 pkg-def-parsed))
+ (version-string (nth 2 pkg-def-parsed))
+ (docstring (nth 3 pkg-def-parsed))
+ (requires (nth 4 pkg-def-parsed))
+
+ (readme (shell-command-to-string
+ ;; Requires GNU tar.
+ (concat "tar -xOf " file " "
+ pkg-name "-" pkg-version "/README"))))
+ (unless (equal pkg-version version-string)
+ (error "Inconsistent versions!"))
+ (unless (equal pkg-name name-str)
+ (error "Inconsistent names!"))
+ ;; Kind of a hack.
+ (if (string-match ": Not found in archive" readme)
+ (setq readme nil))
+ ;; Turn string version numbers into list form.
+ (if (eq (car requires) 'quote)
+ (setq requires (car (cdr requires))))
+ (setq requires
+ (mapcar
+ (lambda (elt)
+ (list (car elt)
+ (version-to-list (car (cdr elt)))))
+ requires))
+ (vector pkg-name requires docstring version-string readme))))
+
+(defun package-install-buffer-internal (pkg-info type)
+ (save-excursion
+ (save-restriction
+ (let* ((file-name (aref pkg-info 0))
+ (requires (aref pkg-info 1))
+ (desc (if (string= (aref pkg-info 2) "")
+ "No description available."
+ (aref pkg-info 2)))
+ (pkg-version (aref pkg-info 3)))
+ ;; Download and install the dependencies.
+ (let ((transaction (package-compute-transaction nil requires)))
+ (package-download-transaction transaction))
+ ;; Install the package itself.
+ (cond
+ ((eq type 'single)
+ (package-unpack-single file-name pkg-version desc requires))
+ ((eq type 'tar)
+ (package-unpack (intern file-name) pkg-version))
+ (t
+ (error "Unknown type: %s" (symbol-name type))))
+ ;; Try to activate it.
+ (package-initialize)))))
+
+;;;###autoload
+(defun package-install-from-buffer ()
+ "Install a package from the current buffer.
+The package is assumed to be a single .el file which
+follows the elisp comment guidelines; see
+info node `(elisp)Library Headers'."
+ (interactive)
+ (package-install-buffer-internal (package-buffer-info) 'single))
+
+;;;###autoload
+(defun package-install-file (file)
+ "Install a package from a file.
+The file can either be a tar file or an Emacs Lisp file."
+ (interactive "fPackage file name: ")
+ (with-temp-buffer
+ (insert-file-contents-literally file)
+ (cond
+ ((string-match "\\.el$" file) (package-install-from-buffer))
+ ((string-match "\\.tar$" file)
+ (package-install-buffer-internal (package-tar-file-info file) 'tar))
+ (t (error "Unrecognized extension `%s'" (file-name-extension file))))))
+
+(defun package-delete (name version)
+ (require 'dired) ; for dired-delete-file
+ (dired-delete-file (expand-file-name (concat name "-" version)
+ package-user-dir)
+ ;; FIXME: query user?
+ 'always))
+
+(defun package-archive-url (name)
+ "Return the archive containing the package NAME."
+ (let ((desc (cdr (assq (intern-soft name) package-archive-contents))))
+ (cdr (assoc (aref desc (- (length desc) 1)) package-archives))))
+
+(defun package--download-one-archive (archive file)
+ "Download an archive file FILE from ARCHIVE, and cache it locally."
+ (let* ((archive-name (car archive))
+ (archive-url (cdr archive))
+ (dir (expand-file-name "archives" package-user-dir))
+ (dir (expand-file-name archive-name dir))
+ (buffer (url-retrieve-synchronously (concat archive-url file))))
+ (with-current-buffer buffer
+ (package-handle-response)
+ (re-search-forward "^$" nil 'move)
+ (forward-char)
+ (delete-region (point-min) (point))
+ (make-directory dir t)
+ (setq buffer-file-name (expand-file-name file dir))
+ (let ((version-control 'never))
+ (save-buffer)))
+ (kill-buffer buffer)))
+
+(defun package-refresh-contents ()
+ "Download the ELPA archive description if needed.
+Invoking this will ensure that Emacs knows about the latest versions
+of all packages. This will let Emacs make them available for
+download."
+ (interactive)
+ (unless (file-exists-p package-user-dir)
+ (make-directory package-user-dir t))
+ (dolist (archive package-archives)
+ (package--download-one-archive archive "archive-contents"))
+ (package-read-all-archive-contents))
+
+;;;###autoload
+(defun package-initialize ()
+ "Load Emacs Lisp packages, and activate them.
+The variable `package-load-list' controls which packages to load."
+ (interactive)
+ (setq package-obsolete-alist nil)
+ (package-load-all-descriptors)
+ (package-read-all-archive-contents)
+ ;; Try to activate all our packages.
+ (mapc (lambda (elt)
+ (package-activate (car elt) (package-desc-vers (cdr elt))))
+ package-alist))
+
+
+;;;; Package description buffer.
+
+;;;###autoload
+(defun describe-package (package)
+ "Display the full documentation of PACKAGE (a symbol)."
+ (interactive
+ (let* ((packages (append (mapcar 'car package-alist)
+ (mapcar 'car package-archive-contents)))
+ (guess (function-called-at-point))
+ val)
+ (unless (memq guess packages)
+ (setq guess nil))
+ (setq packages (mapcar 'symbol-name packages))
+ (setq val
+ (completing-read (if guess
+ (format "Describe package (default %s): "
+ guess)
+ "Describe package: ")
+ packages nil t nil nil guess))
+ (list (if (equal val "")
+ guess
+ (intern val)))))
+ (if (or (null package) (null (symbolp package)))
+ (message "You did not specify a package")
+ (help-setup-xref (list #'describe-package package)
+ (called-interactively-p 'interactive))
+ (with-help-window (help-buffer)
+ (with-current-buffer standard-output
+ (describe-package-1 package)))))
+
+(defun describe-package-1 (package)
+ (let ((desc (cdr (assq package package-alist)))
+ reqs version installable)
+ (prin1 package)
+ (princ " is ")
+ (cond
+ (desc
+ ;; This package is loaded (i.e. in `package-alist').
+ (let (pkg-dir)
+ (setq version (package-version-join (package-desc-vers desc)))
+ (if (assq package package--builtins)
+ (princ "a built-in package.\n\n")
+ (setq pkg-dir (package--dir (symbol-name package) version))
+ (if pkg-dir
+ (progn
+ (insert "a package installed in `")
+ (help-insert-xref-button (file-name-as-directory pkg-dir)
+ 'help-package-def pkg-dir)
+ (insert "'.\n\n"))
+ ;; This normally does not happen.
+ (insert "a deleted package.\n\n")
+ (setq version nil)))))
+ (t
+ ;; An uninstalled package.
+ (setq desc (cdr (assq package package-archive-contents))
+ version (package-version-join (package-desc-vers desc))
+ installable t)
+ (insert "an installable package.\n\n")))
+ (if version
+ (insert " Version: " version "\n"))
+ (setq reqs (package-desc-reqs desc))
+ (when reqs
+ (insert " Requires: ")
+ (let ((first t)
+ name vers text)
+ (dolist (req reqs)
+ (setq name (car req)
+ vers (cadr req)
+ text (format "%s-%s" (symbol-name name)
+ (package-version-join vers)))
+ (cond (first (setq first nil))
+ ((>= (+ 2 (current-column) (length text))
+ (window-width))
+ (insert ",\n "))
+ (t (insert ", ")))
+ (help-insert-xref-button text 'help-package name))
+ (insert "\n")))
+ (insert " Description: " (package-desc-doc desc) "\n")
+ ;; Todo: button for uninstalling a package.
+ (when installable
+ (let ((button-text (if (display-graphic-p)
+ "Install"
+ "[Install]"))
+ (button-face (if (display-graphic-p)
+ '(:box (:line-width 2 :color "dark grey")
+ :background "light grey"
+ :foreground "black")
+ 'link)))
+ (insert "\n")
+ (insert-text-button button-text
+ 'face button-face
+ 'follow-link t
+ 'package-symbol package
+ 'action (lambda (button)
+ (package-install
+ (button-get button 'package-symbol))
+ (revert-buffer nil t)
+ (goto-char (point-min))))
+ (insert "\n")))))
+
+
+;;;; Package menu mode.
+
+(defvar package-menu-mode-map
+ (let ((map (make-keymap))
+ (menu-map (make-sparse-keymap "Package")))
+ (suppress-keymap map)
+ (define-key map "\C-m" 'package-menu-describe-package)
+ (define-key map "q" 'quit-window)
+ (define-key map "n" 'next-line)
+ (define-key map "p" 'previous-line)
+ (define-key map "u" 'package-menu-mark-unmark)
+ (define-key map "\177" 'package-menu-backup-unmark)
+ (define-key map "d" 'package-menu-mark-delete)
+ (define-key map "i" 'package-menu-mark-install)
+ (define-key map "g" 'package-menu-revert)
+ (define-key map "r" 'package-menu-refresh)
+ (define-key map "~" 'package-menu-mark-obsolete-for-deletion)
+ (define-key map "x" 'package-menu-execute)
+ (define-key map "h" 'package-menu-quick-help)
+ (define-key map "?" 'package-menu-view-commentary)
+ (define-key map [menu-bar package-menu] (cons "Package" menu-map))
+ (define-key menu-map [mq]
+ '(menu-item "Quit" quit-window
+ :help "Quit package selection"))
+ (define-key menu-map [s1] '("--"))
+ (define-key menu-map [mn]
+ '(menu-item "Next" next-line
+ :help "Next Line"))
+ (define-key menu-map [mp]
+ '(menu-item "Previous" previous-line
+ :help "Previous Line"))
+ (define-key menu-map [s2] '("--"))
+ (define-key menu-map [mu]
+ '(menu-item "Unmark" package-menu-mark-unmark
+ :help "Clear any marks on a package and move to the next line"))
+ (define-key menu-map [munm]
+ '(menu-item "Unmark backwards" package-menu-backup-unmark
+ :help "Back up one line and clear any marks on that package"))
+ (define-key menu-map [md]
+ '(menu-item "Mark for deletion" package-menu-mark-delete
+ :help "Mark a package for deletion and move to the next line"))
+ (define-key menu-map [mi]
+ '(menu-item "Mark for install" package-menu-mark-install
+ :help "Mark a package for installation and move to the next line"))
+ (define-key menu-map [s3] '("--"))
+ (define-key menu-map [mg]
+ '(menu-item "Update package list" package-menu-revert
+ :help "Update the list of packages"))
+ (define-key menu-map [mr]
+ '(menu-item "Refresh package list" package-menu-refresh
+ :help "Download the ELPA archive"))
+ (define-key menu-map [s4] '("--"))
+ (define-key menu-map [mt]
+ '(menu-item "Mark obsolete packages" package-menu-mark-obsolete-for-deletion
+ :help "Mark all obsolete packages for deletion"))
+ (define-key menu-map [mx]
+ '(menu-item "Execute actions" package-menu-execute
+ :help "Perform all the marked actions"))
+ (define-key menu-map [s5] '("--"))
+ (define-key menu-map [mh]
+ '(menu-item "Help" package-menu-quick-help
+ :help "Show short key binding help for package-menu-mode"))
+ (define-key menu-map [mc]
+ '(menu-item "View Commentary" package-menu-view-commentary
+ :help "Display information about this package"))
+ map)
+ "Local keymap for `package-menu-mode' buffers.")
+
+(defvar package-menu-sort-button-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [header-line mouse-1] 'package-menu-sort-by-column)
+ (define-key map [follow-link] 'mouse-face)
+ map)
+ "Local keymap for package menu sort buttons.")
+
+(put 'package-menu-mode 'mode-class 'special)
+
+(defun package-menu-mode ()
+ "Major mode for browsing a list of packages.
+Letters do not insert themselves; instead, they are commands.
+\\<package-menu-mode-map>
+\\{package-menu-mode-map}"
+ (kill-all-local-variables)
+ (use-local-map package-menu-mode-map)
+ (setq major-mode 'package-menu-mode)
+ (setq mode-name "Package Menu")
+ (setq truncate-lines t)
+ (setq buffer-read-only t)
+ ;; Support Emacs 21.
+ (if (fboundp 'run-mode-hooks)
+ (run-mode-hooks 'package-menu-mode-hook)
+ (run-hooks 'package-menu-mode-hook)))
+
+(defun package-menu-refresh ()
+ "Download the ELPA archive.
+This fetches the file describing the current contents of
+the Emacs Lisp Package Archive, and then refreshes the
+package menu. This lets you see what new packages are
+available for download."
+ (interactive)
+ (package-refresh-contents)
+ (package-list-packages-internal))
+
+(defun package-menu-revert ()
+ "Update the list of packages."
+ (interactive)
+ (package-list-packages-internal))
+
+(defun package-menu-describe-package ()
+ "Describe the package in the current line."
+ (interactive)
+ (let ((name (package-menu-get-package)))
+ (if name
+ (describe-package (intern name))
+ (message "No package on this line"))))
+
+(defun package-menu-mark-internal (what)
+ (unless (eobp)
+ (let ((buffer-read-only nil))
+ (beginning-of-line)
+ (delete-char 1)
+ (insert what)
+ (forward-line))))
+
+;; fixme numeric argument
+(defun package-menu-mark-delete (num)
+ "Mark a package for deletion and move to the next line."
+ (interactive "p")
+ (package-menu-mark-internal "D"))
+
+(defun package-menu-mark-install (num)
+ "Mark a package for installation and move to the next line."
+ (interactive "p")
+ (package-menu-mark-internal "I"))
+
+(defun package-menu-mark-unmark (num)
+ "Clear any marks on a package and move to the next line."
+ (interactive "p")
+ (package-menu-mark-internal " "))
+
+(defun package-menu-backup-unmark ()
+ "Back up one line and clear any marks on that package."
+ (interactive)
+ (forward-line -1)
+ (package-menu-mark-internal " ")
+ (forward-line -1))
+
+(defun package-menu-mark-obsolete-for-deletion ()
+ "Mark all obsolete packages for deletion."
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line 2)
+ (while (not (eobp))
+ (if (looking-at ".*\\s obsolete\\s ")
+ (package-menu-mark-internal "D")
+ (forward-line 1)))))
+
+(defun package-menu-quick-help ()
+ "Show short key binding help for package-menu-mode."
+ (interactive)
+ (message "n-ext, i-nstall, d-elete, u-nmark, x-ecute, r-efresh, h-elp"))
+
+(defun package-menu-view-commentary ()
+ "Display information about this package.
+For single-file packages, shows the commentary section from the header.
+For larger packages, shows the README file."
+ (interactive)
+ (let* ((pkg-name (package-menu-get-package))
+ (buffer (url-retrieve-synchronously
+ (concat (package-archive-url pkg-name)
+ pkg-name
+ "-readme.txt")))
+ start-point ok)
+ (with-current-buffer buffer
+ ;; FIXME: it would be nice to work with any URL type.
+ (setq start-point url-http-end-of-headers)
+ (setq ok (eq (url-http-parse-response) 200)))
+ (let ((new-buffer (get-buffer-create "*Package Info*")))
+ (with-current-buffer new-buffer
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (insert "Package information for " pkg-name "\n\n")
+ (if ok
+ (insert-buffer-substring buffer start-point)
+ (insert "This package lacks a README file or commentary.\n"))
+ (goto-char (point-min))
+ (view-mode)))
+ (display-buffer new-buffer t))))
+
+;; Return the name of the package on the current line.
+(defun package-menu-get-package ()
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at ". \\([^ \t]*\\)")
+ (match-string-no-properties 1))))
+
+;; Return the version of the package on the current line.
+(defun package-menu-get-version ()
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at ". [^ \t]*[ \t]*\\([0-9.]*\\)")
+ (match-string 1))))
+
+(defun package-menu-get-status ()
+ (save-excursion
+ (if (looking-at ". [^ \t]*[ \t]*[^ \t]*[ \t]*\\([^ \t]*\\)")
+ (match-string 1)
+ "")))
+
+(defun package-menu-execute ()
+ "Perform all the marked actions.
+Packages marked for installation will be downloaded and
+installed. Packages marked for deletion will be removed.
+Note that after installing packages you will want to restart
+Emacs."
+ (interactive)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (let ((cmd (char-after))
+ (pkg-name (package-menu-get-package))
+ (pkg-vers (package-menu-get-version))
+ (pkg-status (package-menu-get-status)))
+ (cond
+ ((eq cmd ?D)
+ (when (and (string= pkg-status "installed")
+ (string= pkg-name "package"))
+ ;; FIXME: actually, we could be tricky and remove all info.
+ ;; But that is drastic and the user can do that instead.
+ (error "Can't delete most recent version of `package'"))
+ ;; Ask for confirmation here? Maybe if package status is ""?
+ ;; Or if any lisp from package is actually loaded?
+ (message "Deleting %s-%s..." pkg-name pkg-vers)
+ (package-delete pkg-name pkg-vers)
+ (message "Deleting %s-%s... done" pkg-name pkg-vers))
+ ((eq cmd ?I)
+ (package-install (intern pkg-name)))))
+ (forward-line))
+ (package-menu-revert))
+
+(defun package-print-package (package version key desc)
+ (let ((face
+ (cond ((string= key "built-in") 'font-lock-builtin-face)
+ ((string= key "available") 'default)
+ ((string= key "held") 'font-lock-constant-face)
+ ((string= key "disabled") 'font-lock-warning-face)
+ ((string= key "installed") 'font-lock-comment-face)
+ (t ; obsolete, but also the default.
+ 'font-lock-warning-face))))
+ (insert (propertize " " 'font-lock-face face))
+ (insert-text-button (symbol-name package)
+ 'face 'link
+ 'follow-link t
+ 'package-symbol package
+ 'action (lambda (button)
+ (describe-package
+ (button-get button 'package-symbol))))
+ (indent-to 20 1)
+ (insert (propertize (package-version-join version) 'font-lock-face face))
+ (indent-to 32 1)
+ (insert (propertize key 'font-lock-face face))
+ ;; FIXME: this 'when' is bogus...
+ (when desc
+ (indent-to 43 1)
+ (let ((opoint (point)))
+ (insert (propertize desc 'font-lock-face face))
+ (upcase-region opoint (min (point) (1+ opoint)))))
+ (insert "\n")))
+
+(defun package-list-maybe-add (package version status description result)
+ (unless (assoc (cons package version) result)
+ (setq result (cons (list (cons package version) status description)
+ result)))
+ result)
+
+;; This decides how we should sort; nil means by package name.
+(defvar package-menu-sort-key nil)
+
+(defun package-list-packages-internal ()
+ (package-initialize) ; FIXME: do this here?
+ (with-current-buffer (get-buffer-create "*Packages*")
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (let ((info-list)
+ name desc hold
+ builtin)
+ ;; List installed packages
+ (dolist (elt package-alist)
+ ;; Ignore the Emacs package.
+ (setq name (car elt)
+ desc (cdr elt)
+ hold (assq name package-load-list))
+ (unless (eq name 'emacs)
+ (setq info-list
+ (package-list-maybe-add
+ name (package-desc-vers desc)
+ ;; FIXME: it turns out to be tricky to see if this
+ ;; package is presently activated.
+ (cond ((stringp (cadr hold))
+ "held")
+ ((and (setq builtin (assq name package--builtins))
+ (version-list-=
+ (package-desc-vers (cdr builtin))
+ (package-desc-vers desc)))
+ "built-in")
+ (t "installed"))
+ (package-desc-doc desc)
+ info-list))))
+ ;; List available packages
+ (dolist (elt package-archive-contents)
+ (setq name (car elt)
+ desc (cdr elt)
+ hold (assq name package-load-list))
+ (unless (and hold (stringp (cadr hold))
+ (package-installed-p
+ name (version-to-list (cadr hold))))
+ (setq info-list
+ (package-list-maybe-add name
+ (package-desc-vers desc)
+ (if (and hold (null (cadr hold)))
+ "disabled"
+ "available")
+ (package-desc-doc (cdr elt))
+ info-list))))
+ ;; List obsolete packages
+ (mapc (lambda (elt)
+ (mapc (lambda (inner-elt)
+ (setq info-list
+ (package-list-maybe-add (car elt)
+ (package-desc-vers
+ (cdr inner-elt))
+ "obsolete"
+ (package-desc-doc
+ (cdr inner-elt))
+ info-list)))
+ (cdr elt)))
+ package-obsolete-alist)
+ (let ((selector (cond
+ ((string= package-menu-sort-key "Version")
+ ;; FIXME this doesn't work.
+ #'(lambda (e) (cdr (car e))))
+ ((string= package-menu-sort-key "Status")
+ #'(lambda (e) (car (cdr e))))
+ ((string= package-menu-sort-key "Description")
+ #'(lambda (e) (car (cdr (cdr e)))))
+ (t ; "Package" is default.
+ #'(lambda (e) (symbol-name (car (car e))))))))
+ (setq info-list
+ (sort info-list
+ (lambda (left right)
+ (let ((vleft (funcall selector left))
+ (vright (funcall selector right)))
+ (string< vleft vright))))))
+ (mapc (lambda (elt)
+ (package-print-package (car (car elt))
+ (cdr (car elt))
+ (car (cdr elt))
+ (car (cdr (cdr elt)))))
+ info-list))
+ (goto-char (point-min))
+ (current-buffer)))
+
+(defun package-menu-sort-by-column (&optional e)
+ "Sort the package menu by the last column clicked on."
+ (interactive (list last-input-event))
+ (if e (mouse-select-window e))
+ (let* ((pos (event-start e))
+ (obj (posn-object pos))
+ (col (if obj
+ (get-text-property (cdr obj) 'column-name (car obj))
+ (get-text-property (posn-point pos) 'column-name))))
+ (setq package-menu-sort-key col))
+ (package-list-packages-internal))
+
+(defun package--list-packages ()
+ "Display a list of packages.
+Helper function that does all the work for the user-facing functions."
+ (with-current-buffer (package-list-packages-internal)
+ (package-menu-mode)
+ ;; Set up the header line.
+ (setq header-line-format
+ (mapconcat
+ (lambda (pair)
+ (let ((column (car pair))
+ (name (cdr pair)))
+ (concat
+ ;; Insert a space that aligns the button properly.
+ (propertize " " 'display (list 'space :align-to column)
+ 'face 'fixed-pitch)
+ ;; Set up the column button.
+ (if (string= name "Version")
+ name
+ (propertize name
+ 'column-name name
+ 'help-echo "mouse-1: sort by column"
+ 'mouse-face 'highlight
+ 'keymap package-menu-sort-button-map)))))
+ ;; We take a trick from buff-menu and have a dummy leading
+ ;; space to align the header line with the beginning of the
+ ;; text. This doesn't really work properly on Emacs 21,
+ ;; but it is close enough.
+ '((0 . "")
+ (2 . "Package")
+ (20 . "Version")
+ (32 . "Status")
+ (43 . "Description"))
+ ""))
+
+ ;; It's okay to use pop-to-buffer here. The package menu buffer
+ ;; has keybindings, and the user just typed 'M-x
+ ;; package-list-packages', suggesting that they might want to use
+ ;; them.
+ (pop-to-buffer (current-buffer))))
+
+;;;###autoload
+(defun package-list-packages ()
+ "Display a list of packages.
+Fetches the updated list of packages before displaying.
+The list is displayed in a buffer named `*Packages*'."
+ (interactive)
+ (package-refresh-contents)
+ (package--list-packages))
+
+(defun package-list-packages-no-fetch ()
+ "Display a list of packages.
+Does not fetch the updated list of packages before displaying.
+The list is displayed in a buffer named `*Packages*'."
+ (interactive)
+ (package--list-packages))
+
+(provide 'package)
+
+;;; package.el ends here
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
new file mode 100644
index 00000000000..0b46eb2a301
--- /dev/null
+++ b/lisp/emacs-lisp/pcase.el
@@ -0,0 +1,489 @@
+;;; pcase.el --- ML-style pattern-matching macro for Elisp
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; ML-style pattern matching.
+;; The entry points are autoloaded.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+;; Macro-expansion of pcase is reasonably fast, so it's not a problem
+;; when byte-compiling a file, but when interpreting the code, if the pcase
+;; is in a loop, the repeated macro-expansion becomes terribly costly, so we
+;; memoize previous macro expansions to try and avoid recomputing them
+;; over and over again.
+(defconst pcase-memoize (make-hash-table :weakness t :test 'equal))
+
+;;;###autoload
+(defmacro pcase (exp &rest cases)
+ "Perform ML-style pattern matching on EXP.
+CASES is a list of elements of the form (UPATTERN CODE...).
+
+UPatterns can take the following forms:
+ _ matches anything.
+ SYMBOL matches anything and binds it to SYMBOL.
+ (or UPAT...) matches if any of the patterns matches.
+ (and UPAT...) matches if all the patterns match.
+ `QPAT matches if the QPattern QPAT matches.
+ (pred PRED) matches if PRED applied to the object returns non-nil.
+
+QPatterns can take the following forms:
+ (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr.
+ ,UPAT matches if the UPattern UPAT matches.
+ ATOM matches if the object is `eq' to ATOM.
+QPatterns for vectors are not implemented yet.
+
+PRED can take the form
+ FUNCTION in which case it gets called with one argument.
+ (FUN ARG1 .. ARGN) in which case it gets called with N+1 arguments.
+A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION).
+PRED patterns can refer to variables bound earlier in the pattern.
+E.g. you can match pairs where the cdr is larger than the car with a pattern
+like `(,a . ,(pred (< a))) or, with more checks:
+`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))"
+ (declare (indent 1) (debug case))
+ (or (gethash (cons exp cases) pcase-memoize)
+ (puthash (cons exp cases)
+ (pcase-expand exp cases)
+ pcase-memoize)))
+
+;;;###autoload
+(defmacro pcase-let* (bindings body)
+ "Like `let*' but where you can use `pcase' patterns for bindings.
+BODY should be an expression, and BINDINGS should be a list of bindings
+of the form (UPAT EXP)."
+ (if (null bindings) body
+ `(pcase ,(cadr (car bindings))
+ (,(caar bindings) (plet* ,(cdr bindings) ,body))
+ (t (error "Pattern match failure in `plet'")))))
+
+;;;###autoload
+(defmacro pcase-let (bindings body)
+ "Like `let' but where you can use `pcase' patterns for bindings.
+BODY should be an expression, and BINDINGS should be a list of bindings
+of the form (UPAT EXP)."
+ (if (null (cdr bindings))
+ `(plet* ,bindings ,body)
+ (setq bindings (mapcar (lambda (x) (cons (make-symbol "x") x)) bindings))
+ `(let ,(mapcar (lambda (binding) (list (nth 0 binding) (nth 2 binding)))
+ bindings)
+ (plet* ,(mapcar (lambda (binding) (list (nth 1 binding) (nth 0 binding)))
+ bindings)
+ ,body))))
+
+(defun pcase-expand (exp cases)
+ (let* ((defs (if (symbolp exp) '()
+ (let ((sym (make-symbol "x")))
+ (prog1 `((,sym ,exp)) (setq exp sym)))))
+ (seen '())
+ (codegen
+ (lambda (code vars)
+ (let ((prev (assq code seen)))
+ (if (not prev)
+ (let ((res (pcase-codegen code vars)))
+ (push (list code vars res) seen)
+ res)
+ ;; Since we use a tree-based pattern matching
+ ;; technique, the leaves (the places that contain the
+ ;; code to run once a pattern is matched) can get
+ ;; copied a very large number of times, so to avoid
+ ;; code explosion, we need to keep track of how many
+ ;; times we've used each leaf and move it
+ ;; to a separate function if that number is too high.
+ ;;
+ ;; We've already used this branch. So it is shared.
+ (destructuring-bind (code prevvars res) prev
+ (unless (symbolp res)
+ ;; This is the first repeat, so we have to move
+ ;; the branch to a separate function.
+ (let ((bsym
+ (make-symbol (format "pcase-%d" (length defs)))))
+ (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) defs)
+ (setcar res 'funcall)
+ (setcdr res (cons bsym (mapcar #'cdr prevvars)))
+ (setcar (cddr prev) bsym)
+ (setq res bsym)))
+ (setq vars (copy-sequence vars))
+ (let ((args (mapcar (lambda (pa)
+ (let ((v (assq (car pa) vars)))
+ (setq vars (delq v vars))
+ (cdr v)))
+ prevvars)))
+ (when vars ;New additional vars.
+ (error "The vars %s are only bound in some paths"
+ (mapcar #'car vars)))
+ `(funcall ,res ,@args)))))))
+ (main
+ (pcase-u
+ (mapcar (lambda (case)
+ `((match ,exp . ,(car case))
+ ,(apply-partially
+ (if (pcase-small-branch-p (cdr case))
+ ;; Don't bother sharing multiple
+ ;; occurrences of this leaf since it's small.
+ #'pcase-codegen codegen)
+ (cdr case))))
+ cases))))
+ `(let ,defs ,main)))
+
+(defun pcase-codegen (code vars)
+ `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars)
+ ,@code))
+
+(defun pcase-small-branch-p (code)
+ (and (= 1 (length code))
+ (or (not (consp (car code)))
+ (let ((small t))
+ (dolist (e (car code))
+ (if (consp e) (setq small nil)))
+ small))))
+
+;; Try to use `cond' rather than a sequence of `if's, so as to reduce
+;; the depth of the generated tree.
+(defun pcase-if (test then else)
+ (cond
+ ((eq else :pcase-dontcare) then)
+ ((eq (car-safe else) 'if)
+ `(cond (,test ,then)
+ (,(nth 1 else) ,(nth 2 else))
+ (t ,@(nthcdr 3 else))))
+ ((eq (car-safe else) 'cond)
+ `(cond (,test ,then)
+ ,@(cdr else)))
+ (t `(if ,test ,then ,else))))
+
+(defun pcase-upat (qpattern)
+ (cond
+ ((eq (car-safe qpattern) '\,) (cadr qpattern))
+ (t (list '\` qpattern))))
+
+;; Note about MATCH:
+;; When we have patterns like `(PAT1 . PAT2), after performing the `consp'
+;; check, we want to turn all the similar patterns into ones of the form
+;; (and (match car PAT1) (match cdr PAT2)), so you naturally need conjunction.
+;; Earlier code hence used branches of the form (MATCHES . CODE) where
+;; MATCHES was a list (implicitly a conjunction) of (SYM . PAT).
+;; But if we have a pattern of the form (or `(PAT1 . PAT2) PAT3), there is
+;; no easy way to eliminate the `consp' check in such a representation.
+;; So we replaced the MATCHES by the MATCH below which can be made up
+;; of conjunctions and disjunctions, so if we know `foo' is a cons, we can
+;; turn (match foo . (or `(PAT1 . PAT2) PAT3)) into
+;; (or (and (match car . `PAT1) (match cdr . `PAT2)) (match foo . PAT3)).
+;; The downside is that we now have `or' and `and' both in MATCH and
+;; in PAT, so there are different equivalent representations and we
+;; need to handle them all. We do not try to systematically
+;; canonicalize them to one form over another, but we do occasionally
+;; turn one into the other.
+
+(defun pcase-u (branches)
+ "Expand matcher for rules BRANCHES.
+Each BRANCH has the form (MATCH CODE . VARS) where
+CODE is the code generator for that branch.
+VARS is the set of vars already bound by earlier matches.
+MATCH is the pattern that needs to be matched, of the form:
+ (match VAR . UPAT)
+ (and MATCH ...)
+ (or MATCH ...)"
+ (when (setq branches (delq nil branches))
+ (destructuring-bind (match code &rest vars) (car branches)
+ (pcase-u1 (list match) code vars (cdr branches)))))
+
+(defun pcase-and (match matches)
+ (if matches `(and ,match ,@matches) match))
+
+(defun pcase-split-match (sym splitter match)
+ (case (car match)
+ ((match)
+ (if (not (eq sym (cadr match)))
+ (cons match match)
+ (let ((pat (cddr match)))
+ (cond
+ ;; Hoist `or' and `and' patterns to `or' and `and' matches.
+ ((memq (car-safe pat) '(or and))
+ (pcase-split-match sym splitter
+ (cons (car pat)
+ (mapcar (lambda (alt)
+ `(match ,sym . ,alt))
+ (cdr pat)))))
+ (t (let ((res (funcall splitter (cddr match))))
+ (cons (or (car res) match) (or (cdr res) match))))))))
+ ((or and)
+ (let ((then-alts '())
+ (else-alts '())
+ (neutral-elem (if (eq 'or (car match)) :pcase-fail :pcase-succeed))
+ (zero-elem (if (eq 'or (car match)) :pcase-succeed :pcase-fail)))
+ (dolist (alt (cdr match))
+ (let ((split (pcase-split-match sym splitter alt)))
+ (unless (eq (car split) neutral-elem)
+ (push (car split) then-alts))
+ (unless (eq (cdr split) neutral-elem)
+ (push (cdr split) else-alts))))
+ (cons (cond ((memq zero-elem then-alts) zero-elem)
+ ((null then-alts) neutral-elem)
+ ((null (cdr then-alts)) (car then-alts))
+ (t (cons (car match) (nreverse then-alts))))
+ (cond ((memq zero-elem else-alts) zero-elem)
+ ((null else-alts) neutral-elem)
+ ((null (cdr else-alts)) (car else-alts))
+ (t (cons (car match) (nreverse else-alts)))))))
+ (t (error "Uknown MATCH %s" match))))
+
+(defun pcase-split-rest (sym splitter rest)
+ (let ((then-rest '())
+ (else-rest '()))
+ (dolist (branch rest)
+ (let* ((match (car branch))
+ (code&vars (cdr branch))
+ (splitted
+ (pcase-split-match sym splitter match)))
+ (unless (eq (car splitted) :pcase-fail)
+ (push (cons (car splitted) code&vars) then-rest))
+ (unless (eq (cdr splitted) :pcase-fail)
+ (push (cons (cdr splitted) code&vars) else-rest))))
+ (cons (nreverse then-rest) (nreverse else-rest))))
+
+(defun pcase-split-consp (syma symd pat)
+ (cond
+ ;; A QPattern for a cons, can only go the `then' side.
+ ((and (eq (car-safe pat) '\`) (consp (cadr pat)))
+ (let ((qpat (cadr pat)))
+ (cons `(and (match ,syma . ,(pcase-upat (car qpat)))
+ (match ,symd . ,(pcase-upat (cdr qpat))))
+ :pcase-fail)))
+ ;; A QPattern but not for a cons, can only go the `else' side.
+ ((eq (car-safe pat) '\`) (cons :pcase-fail nil))))
+
+(defun pcase-split-eq (elem pat)
+ (cond
+ ;; The same match will give the same result.
+ ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem))
+ (cons :pcase-succeed :pcase-fail))
+ ;; A different match will fail if this one succeeds.
+ ((and (eq (car-safe pat) '\`)
+ ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
+ ;; (consp (cadr pat)))
+ )
+ (cons :pcase-fail nil))))
+
+(defun pcase-split-memq (elems pat)
+ ;; Based on pcase-split-eq.
+ (cond
+ ;; The same match will give the same result.
+ ((and (eq (car-safe pat) '\`) (member (cadr pat) elems))
+ (cons :pcase-succeed nil))
+ ;; A different match will fail if this one succeeds.
+ ((and (eq (car-safe pat) '\`)
+ ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
+ ;; (consp (cadr pat)))
+ )
+ (cons :pcase-fail nil))))
+
+(defun pcase-split-pred (upat pat)
+ ;; FIXME: For predicates like (pred (> a)), two such predicates may
+ ;; actually refer to different variables `a'.
+ (if (equal upat pat)
+ (cons :pcase-succeed :pcase-fail)))
+
+(defun pcase-fgrep (vars sexp)
+ "Check which of the symbols VARS appear in SEXP."
+ (let ((res '()))
+ (while (consp sexp)
+ (dolist (var (pcase-fgrep vars (pop sexp)))
+ (unless (memq var res) (push var res))))
+ (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
+ res))
+
+;; It's very tempting to use `pcase' below, tho obviously, it'd create
+;; bootstrapping problems.
+(defun pcase-u1 (matches code vars rest)
+ "Return code that runs CODE (with VARS) if MATCHES match.
+and otherwise defers to REST which is a list of branches of the form
+\(ELSE-MATCH ELSE-CODE . ELSE-VARS)."
+ ;; Depending on the order in which we choose to check each of the MATCHES,
+ ;; the resulting tree may be smaller or bigger. So in general, we'd want
+ ;; to be careful to chose the "optimal" order. But predicate
+ ;; patterns make this harder because they create dependencies
+ ;; between matches. So we don't bother trying to reorder anything.
+ (cond
+ ((null matches) (funcall code vars))
+ ((eq :pcase-fail (car matches)) (pcase-u rest))
+ ((eq :pcase-succeed (car matches))
+ (pcase-u1 (cdr matches) code vars rest))
+ ((eq 'and (caar matches))
+ (pcase-u1 (append (cdar matches) (cdr matches)) code vars rest))
+ ((eq 'or (caar matches))
+ (let* ((alts (cdar matches))
+ (var (if (eq (caar alts) 'match) (cadr (car alts))))
+ (simples '()) (others '()))
+ (when var
+ (dolist (alt alts)
+ (if (and (eq (car alt) 'match) (eq var (cadr alt))
+ (let ((upat (cddr alt)))
+ (and (eq (car-safe upat) '\`)
+ (or (integerp (cadr upat)) (symbolp (cadr upat))))))
+ (push (cddr alt) simples)
+ (push alt others))))
+ (cond
+ ((null alts) (error "Please avoid it") (pcase-u rest))
+ ((> (length simples) 1)
+ ;; De-hoist the `or' MATCH into an `or' pattern that will be
+ ;; turned into a `memq' below.
+ (pcase-u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches))
+ code vars
+ (if (null others) rest
+ (cons (list*
+ (pcase-and (if (cdr others)
+ (cons 'or (nreverse others))
+ (car others))
+ (cdr matches))
+ code vars)
+ rest))))
+ (t
+ (pcase-u1 (cons (pop alts) (cdr matches)) code vars
+ (if (null alts) (progn (error "Please avoid it") rest)
+ (cons (list*
+ (pcase-and (if (cdr alts)
+ (cons 'or alts) (car alts))
+ (cdr matches))
+ code vars)
+ rest)))))))
+ ((eq 'match (caar matches))
+ (destructuring-bind (op sym &rest upat) (pop matches)
+ (cond
+ ((memq upat '(t _)) (pcase-u1 matches code vars rest))
+ ((eq upat 'dontcare) :pcase-dontcare)
+ ((functionp upat) (error "Feature removed, use (pred %s)" upat))
+ ((eq (car-safe upat) 'pred)
+ (destructuring-bind (then-rest &rest else-rest)
+ (pcase-split-rest
+ sym (apply-partially 'pcase-split-pred upat) rest)
+ (pcase-if (if (symbolp (cadr upat))
+ `(,(cadr upat) ,sym)
+ (let* ((exp (cadr upat))
+ ;; `vs' is an upper bound on the vars we need.
+ (vs (pcase-fgrep (mapcar #'car vars) exp)))
+ (if vs
+ ;; Let's not replace `vars' in `exp' since it's
+ ;; too difficult to do it right, instead just
+ ;; let-bind `vars' around `exp'.
+ `(let ,(mapcar (lambda (var)
+ (list var (cdr (assq var vars))))
+ vs)
+ ;; FIXME: `vars' can capture `sym'. E.g.
+ ;; (pcase x ((and `(,x . ,y) (pred (fun x)))))
+ (,@exp ,sym))
+ `(,@exp ,sym))))
+ (pcase-u1 matches code vars then-rest)
+ (pcase-u else-rest))))
+ ((symbolp upat)
+ (pcase-u1 matches code (cons (cons upat sym) vars) rest))
+ ((eq (car-safe upat) '\`)
+ (pcase-q1 sym (cadr upat) matches code vars rest))
+ ((eq (car-safe upat) 'or)
+ (let ((all (> (length (cdr upat)) 1)))
+ (when all
+ (dolist (alt (cdr upat))
+ (unless (and (eq (car-safe alt) '\`)
+ (or (symbolp (cadr alt)) (integerp (cadr alt))))
+ (setq all nil))))
+ (if all
+ ;; Use memq for (or `a `b `c `d) rather than a big tree.
+ (let ((elems (mapcar 'cadr (cdr upat))))
+ (destructuring-bind (then-rest &rest else-rest)
+ (pcase-split-rest
+ sym (apply-partially 'pcase-split-memq elems) rest)
+ (pcase-if `(memq ,sym ',elems)
+ (pcase-u1 matches code vars then-rest)
+ (pcase-u else-rest))))
+ (pcase-u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars
+ (append (mapcar (lambda (upat)
+ `((and (match ,sym . ,upat) ,@matches)
+ ,code ,@vars))
+ (cddr upat))
+ rest)))))
+ ((eq (car-safe upat) 'and)
+ (pcase-u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat)) (cdr upat))
+ matches)
+ code vars rest))
+ ((eq (car-safe upat) 'not)
+ ;; FIXME: The implementation below is naive and results in
+ ;; inefficient code.
+ ;; To make it work right, we would need to turn pcase-u1's
+ ;; `code' and `vars' into a single argument of the same form as
+ ;; `rest'. We would also need to split this new `then-rest' argument
+ ;; for every test (currently we don't bother to do it since
+ ;; it's only useful for odd patterns like (and `(PAT1 . PAT2)
+ ;; `(PAT3 . PAT4)) which the programmer can easily rewrite
+ ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))).
+ (pcase-u1 `((match ,sym . ,(cadr upat)))
+ (lexical-let ((rest rest))
+ ;; FIXME: This codegen is not careful to share its
+ ;; code if used several times: code blow up is likely.
+ (lambda (vars)
+ ;; `vars' will likely contain bindings which are
+ ;; not always available in other paths to
+ ;; `rest', so there' no point trying to pass
+ ;; them down.
+ (pcase-u rest)))
+ vars
+ (list `((and . ,matches) ,code . ,vars))))
+ (t (error "Unknown upattern `%s'" upat)))))
+ (t (error "Incorrect MATCH %s" (car matches)))))
+
+(defun pcase-q1 (sym qpat matches code vars rest)
+ "Return code that runs CODE if SYM matches QPAT and if MATCHES match.
+and if not, defers to REST which is a list of branches of the form
+\(OTHER_MATCH OTHER-CODE . OTHER-VARS)."
+ (cond
+ ((eq (car-safe qpat) '\,) (error "Can't use `,UPATTERN"))
+ ((floatp qpat) (error "Floating point patterns not supported"))
+ ((vectorp qpat)
+ ;; FIXME.
+ (error "Vector QPatterns not implemented yet"))
+ ((consp qpat)
+ (let ((syma (make-symbol "xcar"))
+ (symd (make-symbol "xcdr")))
+ (destructuring-bind (then-rest &rest else-rest)
+ (pcase-split-rest sym (apply-partially 'pcase-split-consp syma symd)
+ rest)
+ (pcase-if `(consp ,sym)
+ `(let ((,syma (car ,sym))
+ (,symd (cdr ,sym)))
+ ,(pcase-u1 `((match ,syma . ,(pcase-upat (car qpat)))
+ (match ,symd . ,(pcase-upat (cdr qpat)))
+ ,@matches)
+ code vars then-rest))
+ (pcase-u else-rest)))))
+ ((or (integerp qpat) (symbolp qpat))
+ (destructuring-bind (then-rest &rest else-rest)
+ (pcase-split-rest sym (apply-partially 'pcase-split-eq qpat) rest)
+ (pcase-if `(eq ,sym ',qpat)
+ (pcase-u1 matches code vars then-rest)
+ (pcase-u else-rest))))
+ (t (error "Unkown QPattern %s" qpat))))
+
+
+(provide 'pcase)
+;;; pcase.el ends here
diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el
index ec1a704ce0b..1845effd5bb 100644
--- a/lisp/emacs-lisp/re-builder.el
+++ b/lisp/emacs-lisp/re-builder.el
@@ -61,14 +61,12 @@
;; this limit allowing an easy way to see all matches.
;; Currently `re-builder' understands five different forms of input,
-;; namely `read', `string', `rx', `sregex' and `lisp-re' syntax. Read
+;; namely `read', `string', `rx', and `sregex' syntax. Read
;; syntax and string syntax are both delimited by `"'s and behave
;; according to their name. With the `string' syntax there's no need
;; to escape the backslashes and double quotes simplifying the editing
;; somewhat. The other three allow editing of symbolic regular
-;; expressions supported by the packages of the same name. (`lisp-re'
-;; is a package by me and its support may go away as it is nearly the
-;; same as the `sregex' package in Emacs)
+;; expressions supported by the packages of the same name.
;; Editing symbolic expressions is done through a major mode derived
;; from `emacs-lisp-mode' so you'll get all the good stuff like
@@ -128,12 +126,11 @@
(defcustom reb-re-syntax 'read
"Syntax for the REs in the RE Builder.
-Can either be `read', `string', `sregex', `lisp-re', `rx'."
+Can either be `read', `string', `sregex', or `rx'."
:group 're-builder
:type '(choice (const :tag "Read syntax" read)
(const :tag "String syntax" string)
(const :tag "`sregex' syntax" sregex)
- (const :tag "`lisp-re' syntax" lisp-re)
(const :tag "`rx' syntax" rx)))
(defcustom reb-auto-match-limit 200
@@ -281,9 +278,8 @@ Except for Lisp syntax this is the same as `reb-regexp'.")
(define-derived-mode reb-lisp-mode
emacs-lisp-mode "RE Builder Lisp"
"Major mode for interactively building symbolic Regular Expressions."
- (cond ((eq reb-re-syntax 'lisp-re) ; Pull in packages
- (require 'lisp-re)) ; as needed
- ((eq reb-re-syntax 'sregex) ; sregex is not autoloaded
+ ;; Pull in packages as needed
+ (cond ((eq reb-re-syntax 'sregex) ; sregex is not autoloaded
(require 'sregex)) ; right now..
((eq reb-re-syntax 'rx) ; rx-to-string is autoloaded
(require 'rx))) ; require rx anyway
@@ -329,7 +325,7 @@ Except for Lisp syntax this is the same as `reb-regexp'.")
(defsubst reb-lisp-syntax-p ()
"Return non-nil if RE Builder uses a Lisp syntax."
- (memq reb-re-syntax '(lisp-re sregex rx)))
+ (memq reb-re-syntax '(sregex rx)))
(defmacro reb-target-binding (symbol)
"Return binding for SYMBOL in the RE Builder target buffer."
@@ -489,10 +485,10 @@ Optional argument SYNTAX must be specified if called non-interactively."
(list (intern
(completing-read "Select syntax: "
(mapcar (lambda (el) (cons (symbol-name el) 1))
- '(read string lisp-re sregex rx))
+ '(read string sregex rx))
nil t (symbol-name reb-re-syntax)))))
- (if (memq syntax '(read string lisp-re sregex rx))
+ (if (memq syntax '(read string sregex rx))
(let ((buffer (get-buffer reb-buffer)))
(setq reb-re-syntax syntax)
(when buffer
@@ -616,10 +612,7 @@ optional fourth argument FORCE is non-nil."
(defun reb-cook-regexp (re)
"Return RE after processing it according to `reb-re-syntax'."
- (cond ((eq reb-re-syntax 'lisp-re)
- (when (fboundp 'lre-compile-string)
- (lre-compile-string (eval (car (read-from-string re))))))
- ((eq reb-re-syntax 'sregex)
+ (cond ((eq reb-re-syntax 'sregex)
(apply 'sregex (eval (car (read-from-string re)))))
((eq reb-re-syntax 'rx)
(rx-to-string (eval (car (read-from-string re)))))
diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el
new file mode 100644
index 00000000000..2fbf0628dbe
--- /dev/null
+++ b/lisp/emacs-lisp/smie.el
@@ -0,0 +1,1072 @@
+;;; smie.el --- Simple Minded Indentation Engine
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords: languages, lisp, internal, parsing, indentation
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; While working on the SML indentation code, the idea grew that maybe
+;; I could write something generic to do the same thing, and at the
+;; end of working on the SML code, I had a pretty good idea of what it
+;; could look like. That idea grew stronger after working on
+;; LaTeX indentation.
+;;
+;; So at some point I decided to try it out, by writing a new
+;; indentation code for Coq while trying to keep most of the code
+;; "table driven", where only the tables are Coq-specific. The result
+;; (which was used for Beluga-mode as well) turned out to be based on
+;; something pretty close to an operator precedence parser.
+
+;; So here is another rewrite, this time following the actual principles of
+;; operator precedence grammars. Why OPG? Even though they're among the
+;; weakest kinds of parsers, these parsers have some very desirable properties
+;; for Emacs:
+;; - most importantly for indentation, they work equally well in either
+;; direction, so you can use them to parse backward from the indentation
+;; point to learn the syntactic context;
+;; - they work locally, so there's no need to keep a cache of
+;; the parser's state;
+;; - because of that locality, indentation also works just fine when earlier
+;; parts of the buffer are syntactically incorrect since the indentation
+;; looks at "as little as possible" of the buffer to make an indentation
+;; decision.
+;; - they typically have no error handling and can't even detect a parsing
+;; error, so we don't have to worry about what to do in case of a syntax
+;; error because the parser just automatically does something. Better yet,
+;; we can afford to use a sloppy grammar.
+
+;; The development (especially the parts building the 2D precedence
+;; tables and then computing the precedence levels from it) is largely
+;; inspired from page 187-194 of "Parsing techniques" by Dick Grune
+;; and Ceriel Jacobs (BookBody.pdf available at
+;; http://www.cs.vu.nl/~dick/PTAPG.html).
+;;
+;; 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.
+
+;;; Code:
+
+;; FIXME: I think the behavior on empty lines is wrong. It shouldn't
+;; look at the next token on subsequent lines.
+
+(eval-when-compile (require 'cl))
+
+(defvar comment-continue)
+(declare-function comment-string-strip "newcomment" (str beforep afterp))
+
+;;; Building precedence level tables from BNF specs.
+
+(defun smie-set-prec2tab (table x y val &optional override)
+ (assert (and x y))
+ (let* ((key (cons x y))
+ (old (gethash key table)))
+ (if (and old (not (eq old val)))
+ (if (and override (gethash key override))
+ ;; FIXME: The override is meant to resolve ambiguities,
+ ;; but it also hides real conflicts. It would be great to
+ ;; be able to distinguish the two cases so that overrides
+ ;; don't hide real conflicts.
+ (puthash key (gethash key override) table)
+ (display-warning 'smie (format "Conflict: %s %s/%s %s" x old val y)))
+ (puthash key val table))))
+
+(defun smie-precs-precedence-table (precs)
+ "Compute a 2D precedence table from a list of precedences.
+PRECS should be a list, sorted by precedence (e.g. \"+\" will
+come before \"*\"), of elements of the form \(left OP ...)
+or (right OP ...) or (nonassoc OP ...) or (assoc OP ...). All operators in
+one of those elements share the same precedence level and associativity."
+ (let ((prec2-table (make-hash-table :test 'equal)))
+ (dolist (prec precs)
+ (dolist (op (cdr prec))
+ (let ((selfrule (cdr (assq (car prec)
+ '((left . >) (right . <) (assoc . =))))))
+ (when selfrule
+ (dolist (other-op (cdr prec))
+ (smie-set-prec2tab prec2-table op other-op selfrule))))
+ (let ((op1 '<) (op2 '>))
+ (dolist (other-prec precs)
+ (if (eq prec other-prec)
+ (setq op1 '> op2 '<)
+ (dolist (other-op (cdr other-prec))
+ (smie-set-prec2tab prec2-table op other-op op2)
+ (smie-set-prec2tab prec2-table other-op op op1)))))))
+ prec2-table))
+
+(defun smie-merge-prec2s (&rest tables)
+ (if (null (cdr tables))
+ (car tables)
+ (let ((prec2 (make-hash-table :test 'equal)))
+ (dolist (table tables)
+ (maphash (lambda (k v)
+ (smie-set-prec2tab prec2 (car k) (cdr k) v))
+ table))
+ prec2)))
+
+(defun smie-bnf-precedence-table (bnf &rest precs)
+ (let ((nts (mapcar 'car bnf)) ;Non-terminals
+ (first-ops-table ())
+ (last-ops-table ())
+ (first-nts-table ())
+ (last-nts-table ())
+ (prec2 (make-hash-table :test 'equal))
+ (override (apply 'smie-merge-prec2s
+ (mapcar 'smie-precs-precedence-table precs)))
+ again)
+ (dolist (rules bnf)
+ (let ((nt (car rules))
+ (last-ops ())
+ (first-ops ())
+ (last-nts ())
+ (first-nts ()))
+ (dolist (rhs (cdr rules))
+ (assert (consp rhs))
+ (if (not (member (car rhs) nts))
+ (pushnew (car rhs) first-ops)
+ (pushnew (car rhs) first-nts)
+ (when (consp (cdr rhs))
+ ;; If the first is not an OP we add the second (which
+ ;; should be an OP if BNF is an "operator grammar").
+ ;; Strictly speaking, this should only be done if the
+ ;; first is a non-terminal which can expand to a phrase
+ ;; without any OP in it, but checking doesn't seem worth
+ ;; the trouble, and it lets the writer of the BNF
+ ;; be a bit more sloppy by skipping uninteresting base
+ ;; cases which are terminals but not OPs.
+ (assert (not (member (cadr rhs) nts)))
+ (pushnew (cadr rhs) first-ops)))
+ (let ((shr (reverse rhs)))
+ (if (not (member (car shr) nts))
+ (pushnew (car shr) last-ops)
+ (pushnew (car shr) last-nts)
+ (when (consp (cdr shr))
+ (assert (not (member (cadr shr) nts)))
+ (pushnew (cadr shr) last-ops)))))
+ (push (cons nt first-ops) first-ops-table)
+ (push (cons nt last-ops) last-ops-table)
+ (push (cons nt first-nts) first-nts-table)
+ (push (cons nt last-nts) last-nts-table)))
+ ;; Compute all first-ops by propagating the initial ones we have
+ ;; now, according to first-nts.
+ (setq again t)
+ (while (prog1 again (setq again nil))
+ (dolist (first-nts first-nts-table)
+ (let* ((nt (pop first-nts))
+ (first-ops (assoc nt first-ops-table)))
+ (dolist (first-nt first-nts)
+ (dolist (op (cdr (assoc first-nt first-ops-table)))
+ (unless (member op first-ops)
+ (setq again t)
+ (push op (cdr first-ops))))))))
+ ;; Same thing for last-ops.
+ (setq again t)
+ (while (prog1 again (setq again nil))
+ (dolist (last-nts last-nts-table)
+ (let* ((nt (pop last-nts))
+ (last-ops (assoc nt last-ops-table)))
+ (dolist (last-nt last-nts)
+ (dolist (op (cdr (assoc last-nt last-ops-table)))
+ (unless (member op last-ops)
+ (setq again t)
+ (push op (cdr last-ops))))))))
+ ;; Now generate the 2D precedence table.
+ (dolist (rules bnf)
+ (dolist (rhs (cdr rules))
+ (while (cdr rhs)
+ (cond
+ ((member (car rhs) nts)
+ (dolist (last (cdr (assoc (car rhs) last-ops-table)))
+ (smie-set-prec2tab prec2 last (cadr rhs) '> override)))
+ ((member (cadr rhs) nts)
+ (dolist (first (cdr (assoc (cadr rhs) first-ops-table)))
+ (smie-set-prec2tab prec2 (car rhs) first '< override))
+ (if (and (cddr rhs) (not (member (car (cddr rhs)) nts)))
+ (smie-set-prec2tab prec2 (car rhs) (car (cddr rhs))
+ '= override)))
+ (t (smie-set-prec2tab prec2 (car rhs) (cadr rhs) '= override)))
+ (setq rhs (cdr rhs)))))
+ prec2))
+
+(defun smie-prec2-levels (prec2)
+ ;; FIXME: Rather than only return an alist of precedence levels, we should
+ ;; also extract other useful data from it:
+ ;; - matching sets of block openers&closers (which can otherwise become
+ ;; collapsed into a single equivalence class in smie-op-levels) for
+ ;; smie-close-block as well as to detect mismatches in smie-next-sexp
+ ;; or in blink-paren (as well as to do the blink-paren for inner
+ ;; keywords like the "in" of "let..in..end").
+ ;; - better default indentation rules (i.e. non-zero indentation after inner
+ ;; keywords like the "in" of "let..in..end") for smie-indent-after-keyword.
+ ;; Of course, maybe those things would be even better handled in the
+ ;; bnf->prec function.
+ "Take a 2D precedence table and turn it into an alist of precedence levels.
+PREC2 is a table as returned by `smie-precs-precedence-table' or
+`smie-bnf-precedence-table'."
+ ;; For each operator, we create two "variables" (corresponding to
+ ;; the left and right precedence level), which are represented by
+ ;; cons cells. Those are the vary cons cells that appear in the
+ ;; final `table'. The value of each "variable" is kept in the `car'.
+ (let ((table ())
+ (csts ())
+ (eqs ())
+ tmp x y)
+ ;; From `prec2' we construct a list of constraints between
+ ;; variables (aka "precedence levels"). These can be either
+ ;; equality constraints (in `eqs') or `<' constraints (in `csts').
+ (maphash (lambda (k v)
+ (if (setq tmp (assoc (car k) table))
+ (setq x (cddr tmp))
+ (setq x (cons nil nil))
+ (push (cons (car k) (cons nil x)) table))
+ (if (setq tmp (assoc (cdr k) table))
+ (setq y (cdr tmp))
+ (setq y (cons nil (cons nil nil)))
+ (push (cons (cdr k) y) table))
+ (ecase v
+ (= (push (cons x y) eqs))
+ (< (push (cons x y) csts))
+ (> (push (cons y x) csts))))
+ prec2)
+ ;; First process the equality constraints.
+ (let ((eqs eqs))
+ (while eqs
+ (let ((from (caar eqs))
+ (to (cdar eqs)))
+ (setq eqs (cdr eqs))
+ (if (eq to from)
+ nil ;Nothing to do.
+ (dolist (other-eq eqs)
+ (if (eq from (cdr other-eq)) (setcdr other-eq to))
+ (when (eq from (car other-eq))
+ ;; This can happen because of `assoc' settings in precs
+ ;; or because of a rhs like ("op" foo "op").
+ (setcar other-eq to)))
+ (dolist (cst csts)
+ (if (eq from (cdr cst)) (setcdr cst to))
+ (if (eq from (car cst)) (setcar cst to)))))))
+ ;; Then eliminate trivial constraints iteratively.
+ (let ((i 0))
+ (while csts
+ (let ((rhvs (mapcar 'cdr csts))
+ (progress nil))
+ (dolist (cst csts)
+ (unless (memq (car cst) rhvs)
+ (setq progress t)
+ ;; We could give each var in a given iteration the same value,
+ ;; but we can also give them arbitrarily different values.
+ ;; Basically, these are vars between which there is no
+ ;; constraint (neither equality nor inequality), so
+ ;; anything will do.
+ ;; We give them arbitrary values, which means that we
+ ;; replace the "no constraint" case with either > or <
+ ;; but not =. The reason we do that is so as to try and
+ ;; distinguish associative operators (which will have
+ ;; left = right).
+ (unless (caar cst)
+ (setcar (car cst) i)
+ (incf i))
+ (setq csts (delq cst csts))))
+ (unless progress
+ (error "Can't resolve the precedence table to precedence levels")))
+ (incf i 10))
+ ;; Propagate equalities back to their source.
+ (dolist (eq (nreverse eqs))
+ (assert (or (null (caar eq)) (eq (car eq) (cdr eq))))
+ (setcar (car eq) (cadr eq)))
+ ;; Finally, fill in the remaining vars (which only appeared on the
+ ;; right side of the < constraints).
+ (dolist (x table)
+ ;; When both sides are nil, it means this operator binds very
+ ;; very tight, but it's still just an operator, so we give it
+ ;; the highest precedence.
+ ;; OTOH if only one side is nil, it usually means it's like an
+ ;; open-paren, which is very important for indentation purposes,
+ ;; so we keep it nil, to make it easier to recognize.
+ (unless (or (nth 1 x) (nth 2 x))
+ (setf (nth 1 x) i)
+ (setf (nth 2 x) i))))
+ table))
+
+;;; Parsing using a precedence level table.
+
+(defvar smie-op-levels 'unset
+ "List of token parsing info.
+Each element is of the form (TOKEN LEFT-LEVEL RIGHT-LEVEL).
+Parsing is done using an operator precedence parser.
+LEFT-LEVEL and RIGHT-LEVEL can be either numbers or nil, where nil
+means that this operator does not bind on the corresponding side,
+i.e. a LEFT-LEVEL of nil means this is a token that behaves somewhat like
+an open-paren, whereas a RIGHT-LEVEL of nil would correspond to something
+like a close-paren.")
+
+(defvar smie-forward-token-function 'smie-default-forward-token
+ "Function to scan forward for the next token.
+Called with no argument should return a token and move to its end.
+If no token is found, return nil or the empty string.
+It can return nil when bumping into a parenthesis, which lets SMIE
+use syntax-tables to handle them in efficient C code.")
+
+(defvar smie-backward-token-function 'smie-default-backward-token
+ "Function to scan backward the previous token.
+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)
+
+(defun smie-default-backward-token ()
+ (forward-comment (- (point)))
+ (buffer-substring-no-properties
+ (point)
+ (progn (if (zerop (skip-syntax-backward "."))
+ (skip-syntax-backward "w_'"))
+ (point))))
+
+(defun smie-default-forward-token ()
+ (forward-comment (point-max))
+ (buffer-substring-no-properties
+ (point)
+ (progn (if (zerop (skip-syntax-forward "."))
+ (skip-syntax-forward "w_'"))
+ (point))))
+
+(defun smie-associative-p (toklevels)
+ ;; in "a + b + c" we want to stop at each +, but in
+ ;; "if a then b elsif c then d else c" we don't want to stop at each keyword.
+ ;; To distinguish the two cases, we made smie-prec2-levels choose
+ ;; different levels for each part of "if a then b else c", so that
+ ;; by checking if the left-level is equal to the right level, we can
+ ;; figure out that it's an associative operator.
+ ;; This is not 100% foolproof, tho, since the "elsif" will have to have
+ ;; equal left and right levels (since it's optional), so smie-next-sexp
+ ;; has to be careful to distinguish those different cases.
+ (eq (smie-op-left toklevels) (smie-op-right toklevels)))
+
+(defun smie-next-sexp (next-token next-sexp op-forw op-back halfsexp)
+ "Skip over one sexp.
+NEXT-TOKEN is a function of no argument that moves forward by one
+token (after skipping comments if needed) and returns it.
+NEXT-SEXP is a lower-level function to skip one sexp.
+OP-FORW is the accessor to the forward level of the level data.
+OP-BACK is the accessor to the backward level of the level data.
+HALFSEXP if non-nil, means skip over a partial sexp if needed. I.e. if the
+first token we see is an operator, skip over its left-hand-side argument.
+Possible return values:
+ (FORW-LEVEL POS TOKEN): we couldn't skip TOKEN because its back-level
+ is too high. FORW-LEVEL is the forw-level of TOKEN,
+ POS is its start position in the buffer.
+ (t POS TOKEN): same thing when we bump on the wrong side of a paren.
+ (nil POS TOKEN): we skipped over a paren-like pair.
+ nil: we skipped over an identifier, matched parentheses, ..."
+ (catch 'return
+ (let ((levels ()))
+ (while
+ (let* ((pos (point))
+ (token (funcall next-token))
+ (toklevels (cdr (assoc token smie-op-levels))))
+ (cond
+ ((null toklevels)
+ (when (zerop (length token))
+ (condition-case err
+ (progn (goto-char pos) (funcall next-sexp 1) nil)
+ (scan-error (throw 'return
+ (list t (caddr err)
+ (buffer-substring-no-properties
+ (caddr err)
+ (+ (caddr err)
+ (if (< (point) (caddr err))
+ -1 1)))))))
+ (if (eq pos (point))
+ ;; We did not move, so let's abort the loop.
+ (throw 'return (list t (point))))))
+ ((null (funcall op-back toklevels))
+ ;; A token like a paren-close.
+ (assert (funcall op-forw toklevels)) ;Otherwise, why mention it?
+ (push toklevels levels))
+ (t
+ (while (and levels (< (funcall op-back toklevels)
+ (funcall op-forw (car levels))))
+ (setq levels (cdr levels)))
+ (cond
+ ((null levels)
+ (if (and halfsexp (funcall op-forw toklevels))
+ (push toklevels levels)
+ (throw 'return
+ (prog1 (list (or (car toklevels) t) (point) token)
+ (goto-char pos)))))
+ (t
+ (let ((lastlevels levels))
+ (if (and levels (= (funcall op-back toklevels)
+ (funcall op-forw (car levels))))
+ (setq levels (cdr levels)))
+ ;; We may have found a match for the previously pending
+ ;; operator. Is this the end?
+ (cond
+ ;; Keep looking as long as we haven't matched the
+ ;; topmost operator.
+ (levels
+ (if (funcall op-forw toklevels)
+ (push toklevels levels)))
+ ;; We matched the topmost operator. If the new operator
+ ;; is the last in the corresponding BNF rule, we're done.
+ ((null (funcall op-forw toklevels))
+ ;; It is the last element, let's stop here.
+ (throw 'return (list nil (point) token)))
+ ;; If the new operator is not the last in the BNF rule,
+ ;; ans is not associative, it's one of the inner operators
+ ;; (like the "in" in "let .. in .. end"), so keep looking.
+ ((not (smie-associative-p toklevels))
+ (push toklevels levels))
+ ;; The new operator is associative. Two cases:
+ ;; - it's really just an associative operator (like + or ;)
+ ;; in which case we should have stopped right before.
+ ((and lastlevels
+ (smie-associative-p (car lastlevels)))
+ (throw 'return
+ (prog1 (list (or (car toklevels) t) (point) token)
+ (goto-char pos))))
+ ;; - it's an associative operator within a larger construct
+ ;; (e.g. an "elsif"), so we should just ignore it and keep
+ ;; looking for the closing element.
+ (t (setq levels lastlevels))))))))
+ levels)
+ (setq halfsexp nil)))))
+
+(defun smie-backward-sexp (&optional halfsexp)
+ "Skip over one sexp.
+HALFSEXP if non-nil, means skip over a partial sexp if needed. I.e. if the
+first token we see is an operator, skip over its left-hand-side argument.
+Possible return values:
+ (LEFT-LEVEL POS TOKEN): we couldn't skip TOKEN because its right-level
+ is too high. LEFT-LEVEL is the left-level of TOKEN,
+ POS is its start position in the buffer.
+ (t POS TOKEN): same thing but for an open-paren or the beginning of buffer.
+ (nil POS TOKEN): we skipped over a paren-like pair.
+ nil: we skipped over an identifier, matched parentheses, ..."
+ (smie-next-sexp
+ (indirect-function smie-backward-token-function)
+ (indirect-function 'backward-sexp)
+ (indirect-function 'smie-op-left)
+ (indirect-function 'smie-op-right)
+ halfsexp))
+
+(defun smie-forward-sexp (&optional halfsexp)
+ "Skip over one sexp.
+HALFSEXP if non-nil, means skip over a partial sexp if needed. I.e. if the
+first token we see is an operator, skip over its left-hand-side argument.
+Possible return values:
+ (RIGHT-LEVEL POS TOKEN): we couldn't skip TOKEN because its left-level
+ is too high. RIGHT-LEVEL is the right-level of TOKEN,
+ POS is its end position in the buffer.
+ (t POS TOKEN): same thing but for an open-paren or the beginning of buffer.
+ (nil POS TOKEN): we skipped over a paren-like pair.
+ nil: we skipped over an identifier, matched parentheses, ..."
+ (smie-next-sexp
+ (indirect-function smie-forward-token-function)
+ (indirect-function 'forward-sexp)
+ (indirect-function 'smie-op-right)
+ (indirect-function 'smie-op-left)
+ halfsexp))
+
+;;; Miscellanous commands using the precedence parser.
+
+(defun smie-backward-sexp-command (&optional n)
+ "Move backward through N logical elements."
+ (interactive "^p")
+ (smie-forward-sexp-command (- n)))
+
+(defun smie-forward-sexp-command (&optional n)
+ "Move forward through N logical elements."
+ (interactive "^p")
+ (let ((forw (> n 0))
+ (forward-sexp-function nil))
+ (while (/= n 0)
+ (setq n (- n (if forw 1 -1)))
+ (let ((pos (point))
+ (res (if forw
+ (smie-forward-sexp 'halfsexp)
+ (smie-backward-sexp 'halfsexp))))
+ (if (and (car res) (= pos (point)) (not (if forw (eobp) (bobp))))
+ (signal 'scan-error
+ (list "Containing expression ends prematurely"
+ (cadr res) (cadr res)))
+ nil)))))
+
+(defvar smie-closer-alist nil
+ "Alist giving the closer corresponding to an opener.")
+
+(defun smie-close-block ()
+ "Close the closest surrounding block."
+ (interactive)
+ (let ((closer
+ (save-excursion
+ (backward-up-list 1)
+ (if (looking-at "\\s(")
+ (string (cdr (syntax-after (point))))
+ (let* ((open (funcall smie-forward-token-function))
+ (closer (cdr (assoc open smie-closer-alist)))
+ (levels (list (assoc open smie-op-levels)))
+ (seen '())
+ (found '()))
+ (cond
+ ;; Even if we improve the auto-computation of closers,
+ ;; there are still cases where we need manual
+ ;; intervention, e.g. for Octave's use of `until'
+ ;; as a pseudo-closer of `do'.
+ (closer)
+ ((or (equal levels '(nil)) (nth 1 (car levels)))
+ (error "Doesn't look like a block"))
+ (t
+ ;; FIXME: With grammars like Octave's, every closer ("end",
+ ;; "endif", "endwhile", ...) has the same level, so we'd need
+ ;; to look at the BNF or at least at the 2D prec-table, in
+ ;; order to find the right closer for a given opener.
+ (while levels
+ (let ((level (pop levels)))
+ (dolist (other smie-op-levels)
+ (when (and (eq (nth 2 level) (nth 1 other))
+ (not (memq other seen)))
+ (push other seen)
+ (if (nth 2 other)
+ (push other levels)
+ (push (car other) found))))))
+ (cond
+ ((null found) (error "No known closer for opener %s" open))
+ ;; FIXME: what should we do if there are various closers?
+ (t (car found))))))))))
+ (unless (save-excursion (skip-chars-backward " \t") (bolp))
+ (newline))
+ (insert closer)
+ (if (save-excursion (skip-chars-forward " \t") (eolp))
+ (indent-according-to-mode)
+ (reindent-then-newline-and-indent))))
+
+;;; The indentation engine.
+
+(defcustom smie-indent-basic 4
+ "Basic amount of indentation."
+ :type 'integer)
+
+(defvar smie-indent-rules 'unset
+ ;; TODO: For SML, we need more rule formats, so as to handle
+ ;; structure Foo =
+ ;; Bar (toto)
+ ;; and
+ ;; structure Foo =
+ ;; struct ... end
+ ;; I.e. the indentation after "=" depends on the parent ("structure")
+ ;; as well as on the following token ("struct").
+ "Rules of the following form.
+\((:before . TOK) . OFFSET-RULES) how to indent TOK itself.
+\(TOK . OFFSET-RULES) how to indent right after TOK.
+\(list-intro . TOKENS) declare TOKENS as being followed by what may look like
+ a funcall but is just a sequence of expressions.
+\(t . OFFSET) basic indentation step.
+\(args . OFFSET) indentation of arguments.
+\((T1 . T2) OFFSET) like ((:before . T2) (:parent T1 OFFSET)).
+
+OFFSET-RULES is a list of elements which can each either be:
+
+\(:hanging . OFFSET-RULES) if TOK is hanging, use OFFSET-RULES.
+\(:parent PARENT . OFFSET-RULES) if TOK's parent is PARENT, use OFFSET-RULES.
+\(:next TOKEN . OFFSET-RULES) if TOK is followed by TOKEN, use OFFSET-RULES.
+\(:prev TOKEN . OFFSET-RULES) if TOK is preceded by TOKEN, use
+\(:bolp . OFFSET-RULES) If TOK is first on a line, use OFFSET-RULES.
+OFFSET the offset to use.
+
+PARENT can be either the name of the parent or `open' to mean any parent
+which acts as an open-paren (i.e. has a nil left-precedence).
+
+OFFSET can be of the form:
+`point' align with the token.
+`parent' align with the parent.
+NUMBER offset by NUMBER.
+\(+ OFFSETS...) use the sum of OFFSETS.
+
+The precise meaning of `point' depends on various details: it can
+either mean the position of the token we're indenting, or the
+position of its parent, or the position right after its parent.
+
+A nil offset for indentation after a token defaults to `smie-indent-basic'.")
+
+(defun smie-indent-hanging-p ()
+ ;; A hanging keyword is one that's at the end of a line except it's not at
+ ;; the beginning of a line.
+ (and (save-excursion
+ (when (zerop (length (funcall smie-forward-token-function)))
+ ;; Could be an open-paren.
+ (forward-char 1))
+ (skip-chars-forward " \t")
+ (eolp))
+ (not (smie-bolp))))
+
+(defun smie-bolp ()
+ (save-excursion (skip-chars-backward " \t") (bolp)))
+
+(defun smie-indent-offset (elem)
+ (or (cdr (assq elem smie-indent-rules))
+ (cdr (assq t smie-indent-rules))
+ smie-indent-basic))
+
+(defvar smie-indent-debug-log)
+
+(defun smie-indent-offset-rule (tokinfo &optional after parent)
+ "Apply the OFFSET-RULES in TOKINFO.
+Point is expected to be right in front of the token corresponding to TOKINFO.
+If computing the indentation after the token, then AFTER is the position
+after the token, otherwise it should be nil.
+PARENT if non-nil should be the parent info returned by `smie-backward-sexp'."
+ (let ((rules (cdr tokinfo))
+ next prev
+ offset)
+ (while (consp rules)
+ (let ((rule (pop rules)))
+ (cond
+ ((not (consp rule)) (setq offset rule))
+ ((eq (car rule) '+) (setq offset rule))
+ ((eq (car rule) :hanging)
+ (when (smie-indent-hanging-p)
+ (setq rules (cdr rule))))
+ ((eq (car rule) :bolp)
+ (when (smie-bolp)
+ (setq rules (cdr rule))))
+ ((eq (car rule) :eolp)
+ (unless after
+ (error "Can't use :eolp in :before indentation rules"))
+ (when (> after (line-end-position))
+ (setq rules (cdr rule))))
+ ((eq (car rule) :prev)
+ (unless prev
+ (save-excursion
+ (setq prev (smie-indent-backward-token))))
+ (when (equal (car prev) (cadr rule))
+ (setq rules (cddr rule))))
+ ((eq (car rule) :next)
+ (unless next
+ (unless after
+ (error "Can't use :next in :before indentation rules"))
+ (save-excursion
+ (goto-char after)
+ (setq next (smie-indent-forward-token))))
+ (when (equal (car next) (cadr rule))
+ (setq rules (cddr rule))))
+ ((eq (car rule) :parent)
+ (unless parent
+ (save-excursion
+ (if after (goto-char after))
+ (setq parent (smie-backward-sexp 'halfsexp))))
+ (when (or (equal (nth 2 parent) (cadr rule))
+ (and (eq (cadr rule) 'open) (null (car parent))))
+ (setq rules (cddr rule))))
+ (t (error "Unknown rule %s for indentation of %s"
+ rule (car tokinfo))))))
+ ;; If `offset' is not set yet, use `rules' to handle the case where
+ ;; the tokinfo uses the old-style ((PARENT . TOK). OFFSET).
+ (unless offset (setq offset rules))
+ (when (boundp 'smie-indent-debug-log)
+ (push (list (point) offset tokinfo) smie-indent-debug-log))
+ offset))
+
+(defun smie-indent-column (offset &optional base parent virtual-point)
+ "Compute the actual column to use for a given OFFSET.
+BASE is the base position to use, and PARENT is the parent info, if any.
+If VIRTUAL-POINT is non-nil, then `point' is virtual."
+ (cond
+ ((eq (car-safe offset) '+)
+ (apply '+ (mapcar (lambda (offset) (smie-indent-column offset nil parent))
+ (cdr offset))))
+ ((integerp offset)
+ (+ offset
+ (case base
+ ((nil) 0)
+ (parent (goto-char (cadr parent))
+ (smie-indent-virtual))
+ (t
+ (goto-char base)
+ ;; For indentation after "(let" in SML-mode, we end up accumulating
+ ;; the offset of "(" and the offset of "let", so we use `min' to try
+ ;; and get it right either way.
+ (min (smie-indent-virtual) (current-column))))))
+ ((eq offset 'point)
+ ;; In indent-keyword, if we're indenting `then' wrt `if', we want to use
+ ;; indent-virtual rather than use just current-column, so that we can
+ ;; apply the (:before . "if") rule which does the "else if" dance in SML.
+ ;; But in other cases, we do not want to use indent-virtual
+ ;; (e.g. indentation of "*" w.r.t "+", or ";" wrt "("). We could just
+ ;; always use indent-virtual and then have indent-rules say explicitly
+ ;; to use `point' after things like "(" or "+" when they're not at EOL,
+ ;; but you'd end up with lots of those rules.
+ ;; So we use a heuristic here, which is that we only use virtual if
+ ;; the parent is tightly linked to the child token (they're part of
+ ;; the same BNF rule).
+ (if (and virtual-point (null (car parent))) ;Black magic :-(
+ (smie-indent-virtual) (current-column)))
+ ((eq offset 'parent)
+ (unless parent
+ (setq parent (or (smie-backward-sexp 'halfsexp) :notfound)))
+ (if (consp parent) (goto-char (cadr parent)))
+ (smie-indent-virtual))
+ ((eq offset nil) nil)
+ (t (error "Unknown indentation offset %s" offset))))
+
+(defun smie-indent-forward-token ()
+ "Skip token forward and return it, along with its levels."
+ (let ((tok (funcall smie-forward-token-function)))
+ (cond
+ ((< 0 (length tok)) (assoc tok smie-op-levels))
+ ((looking-at "\\s(")
+ (forward-char 1)
+ (list (buffer-substring (1- (point)) (point)) nil 0)))))
+
+(defun smie-indent-backward-token ()
+ "Skip token backward and return it, along with its levels."
+ (let ((tok (funcall smie-backward-token-function)))
+ (cond
+ ((< 0 (length tok)) (assoc tok smie-op-levels))
+ ;; 4 == Open paren syntax.
+ ((eq 4 (syntax-class (syntax-after (1- (point)))))
+ (forward-char -1)
+ (list (buffer-substring (point) (1+ (point))) nil 0)))))
+
+(defun smie-indent-virtual ()
+ ;; We used to take an optional arg (with value :not-hanging) to specify that
+ ;; we should only use (smie-indent-calculate) if we're looking at a hanging
+ ;; keyword. This was a bad idea, because the virtual indent of a position
+ ;; should not depend on the caller, since it leads to situations where two
+ ;; dependent indentations get indented differently.
+ "Compute the virtual indentation to use for point.
+This is used when we're not trying to indent point but just
+need to compute the column at which point should be indented
+in order to figure out the indentation of some other (further down) point."
+ ;; Trust pre-existing indentation on other lines.
+ (if (smie-bolp) (current-column) (smie-indent-calculate)))
+
+(defun smie-indent-fixindent ()
+ ;; Obey the `fixindent' special comment.
+ (and (smie-bolp)
+ (save-excursion
+ (comment-normalize-vars)
+ (re-search-forward (concat comment-start-skip
+ "fixindent"
+ comment-end-skip)
+ ;; 1+ to account for the \n comment termination.
+ (1+ (line-end-position)) t))
+ (current-column)))
+
+(defun smie-indent-bob ()
+ ;; Start the file at column 0.
+ (save-excursion
+ (forward-comment (- (point)))
+ (if (bobp) 0)))
+
+(defun smie-indent-close ()
+ ;; Align close paren with opening paren.
+ (save-excursion
+ ;; (forward-comment (point-max))
+ (when (looking-at "\\s)")
+ (while (not (zerop (skip-syntax-forward ")")))
+ (skip-chars-forward " \t"))
+ (condition-case nil
+ (progn
+ (backward-sexp 1)
+ (smie-indent-virtual)) ;:not-hanging
+ (scan-error nil)))))
+
+(defun smie-indent-keyword ()
+ ;; Align closing token with the corresponding opening one.
+ ;; (e.g. "of" with "case", or "in" with "let").
+ (save-excursion
+ (let* ((pos (point))
+ (toklevels (smie-indent-forward-token))
+ (token (pop toklevels)))
+ (if (null (car toklevels))
+ (save-excursion
+ (goto-char pos)
+ ;; Different cases:
+ ;; - smie-bolp: "indent according to others".
+ ;; - common hanging: "indent according to others".
+ ;; - SML-let hanging: "indent like parent".
+ ;; - if-after-else: "indent-like parent".
+ ;; - middle-of-line: "trust current position".
+ (cond
+ ((null (cdr toklevels)) nil) ;Not a keyword.
+ ((smie-bolp)
+ ;; For an open-paren-like thingy at BOL, always indent only
+ ;; based on other rules (typically smie-indent-after-keyword).
+ nil)
+ (t
+ ;; We're only ever here for virtual-indent, which is why
+ ;; we can use (current-column) as answer for `point'.
+ (let* ((tokinfo (or (assoc (cons :before token)
+ smie-indent-rules)
+ ;; By default use point unless we're hanging.
+ `((:before . ,token) (:hanging nil) point)))
+ ;; (after (prog1 (point) (goto-char pos)))
+ (offset (smie-indent-offset-rule tokinfo)))
+ (smie-indent-column offset)))))
+
+ ;; FIXME: This still looks too much like black magic!!
+ ;; FIXME: Rather than a bunch of rules like (PARENT . TOKEN), we
+ ;; want a single rule for TOKEN with different cases for each PARENT.
+ (let* ((parent (smie-backward-sexp 'halfsexp))
+ (tokinfo
+ (or (assoc (cons (caddr parent) token)
+ smie-indent-rules)
+ (assoc (cons :before token) smie-indent-rules)
+ ;; Default rule.
+ `((:before . ,token)
+ ;; (:parent open 0)
+ point)))
+ (offset (save-excursion
+ (goto-char pos)
+ (smie-indent-offset-rule tokinfo nil parent))))
+ ;; Different behaviors:
+ ;; - align with parent.
+ ;; - parent + offset.
+ ;; - after parent's column + offset (actually, after or before
+ ;; depending on where backward-sexp stopped).
+ ;; ? let it drop to some other indentation function (almost never).
+ ;; ? parent + offset + parent's own offset.
+ ;; Different cases:
+ ;; - bump into a same-level operator.
+ ;; - bump into a specific known parent.
+ ;; - find a matching open-paren thingy.
+ ;; - bump into some random parent.
+ ;; ? borderline case (almost never).
+ ;; ? bump immediately into a parent.
+ (cond
+ ((not (or (< (point) pos)
+ (and (cadr parent) (< (cadr parent) pos))))
+ ;; If we didn't move at all, that means we didn't really skip
+ ;; what we wanted. Should almost never happen, other than
+ ;; maybe when an infix or close-paren is at the beginning
+ ;; of a buffer.
+ nil)
+ ((eq (car parent) (car toklevels))
+ ;; We bumped into a same-level operator. align with it.
+ (if (and (smie-bolp) (/= (point) pos)
+ (save-excursion
+ (goto-char (goto-char (cadr parent)))
+ (not (smie-bolp)))
+ ;; Check the offset of `token' rather then its parent
+ ;; because its parent may have used a special rule. E.g.
+ ;; function foo;
+ ;; line2;
+ ;; line3;
+ ;; The ; on the first line had a special rule, but when
+ ;; indenting line3, we don't care about it and want to
+ ;; align with line2.
+ (memq offset '(point nil)))
+ ;; If the parent is at EOL and its children are indented like
+ ;; itself, then we can just obey the indentation chosen for the
+ ;; child.
+ ;; This is important for operators like ";" which
+ ;; are usually at EOL (and have an offset of 0): otherwise we'd
+ ;; always go back over all the statements, which is
+ ;; a performance problem and would also mean that fixindents
+ ;; in the middle of such a sequence would be ignored.
+ ;;
+ ;; This is a delicate point!
+ ;; Even if the offset is not 0, we could follow the same logic
+ ;; and subtract the offset from the child's indentation.
+ ;; But that would more often be a bad idea: OT1H we generally
+ ;; want to reuse the closest similar indentation point, so that
+ ;; the user's choice (or the fixindents) are obeyed. But OTOH
+ ;; we don't want this to affect "unrelated" parts of the code.
+ ;; E.g. a fixindent in the body of a "begin..end" should not
+ ;; affect the indentation of the "end".
+ (current-column)
+ (goto-char (cadr parent))
+ ;; Don't use (smie-indent-virtual :not-hanging) here, because we
+ ;; want to jump back over a sequence of same-level ops such as
+ ;; a -> b -> c
+ ;; -> d
+ ;; So as to align with the earliest appropriate place.
+ (smie-indent-virtual)))
+ (tokinfo
+ (if (and (= (point) pos) (smie-bolp)
+ (or (eq offset 'point)
+ (and (consp offset) (memq 'point offset))))
+ ;; Since we started at BOL, we're not computing a virtual
+ ;; indentation, and we're still at the starting point, so
+ ;; we can't use `current-column' which would cause
+ ;; indentation to depend on itself.
+ nil
+ (smie-indent-column offset 'parent parent
+ ;; If we're still at pos, indent-virtual
+ ;; will inf-loop.
+ (unless (= (point) pos) 'virtual))))))))))
+
+(defun smie-indent-comment ()
+ "Compute indentation of a comment."
+ ;; Don't do it for virtual indentations. We should normally never be "in
+ ;; front of a comment" when doing virtual-indentation anyway. And if we are
+ ;; (as can happen in octave-mode), moving forward can lead to inf-loops.
+ (and (smie-bolp)
+ (looking-at comment-start-skip)
+ (save-excursion
+ (forward-comment (point-max))
+ (skip-chars-forward " \t\r\n")
+ (smie-indent-calculate))))
+
+(defun smie-indent-comment-continue ()
+ ;; indentation of comment-continue lines.
+ (let ((continue (and comment-continue
+ (comment-string-strip comment-continue t t))))
+ (and (< 0 (length continue))
+ (looking-at (regexp-quote continue)) (nth 4 (syntax-ppss))
+ (let ((ppss (syntax-ppss)))
+ (save-excursion
+ (forward-line -1)
+ (if (<= (point) (nth 8 ppss))
+ (progn (goto-char (1+ (nth 8 ppss))) (current-column))
+ (skip-chars-forward " \t")
+ (if (looking-at (regexp-quote continue))
+ (current-column))))))))
+
+(defun smie-indent-after-keyword ()
+ ;; Indentation right after a special keyword.
+ (save-excursion
+ (let* ((pos (point))
+ (toklevel (smie-indent-backward-token))
+ (tok (car toklevel))
+ (tokinfo (assoc tok smie-indent-rules)))
+ ;; Set some default indent rules.
+ (if (and toklevel (null (cadr toklevel)) (null tokinfo))
+ (setq tokinfo (list (car toklevel))))
+ ;; (if (and tokinfo (null toklevel))
+ ;; (error "Token %S has indent rule but has no parsing info" tok))
+ (when toklevel
+ (unless tokinfo
+ ;; The default indentation after a keyword/operator is 0 for
+ ;; infix and t for prefix.
+ ;; Using the BNF syntax, we could come up with better
+ ;; defaults, but we only have the precedence levels here.
+ (setq tokinfo (list tok 'default-rule
+ (if (cadr toklevel) 0 (smie-indent-offset t)))))
+ (let ((offset
+ (or (smie-indent-offset-rule tokinfo pos)
+ (smie-indent-offset t))))
+ (let ((before (point)))
+ (goto-char pos)
+ (smie-indent-column offset before)))))))
+
+(defun smie-indent-exps ()
+ ;; Indentation of sequences of simple expressions without
+ ;; intervening keywords or operators. E.g. "a b c" or "g (balbla) f".
+ ;; Can be a list of expressions or a function call.
+ ;; If it's a function call, the first element is special (it's the
+ ;; function). We distinguish function calls from mere lists of
+ ;; expressions based on whether the preceding token is listed in
+ ;; the `list-intro' entry of smie-indent-rules.
+ ;;
+ ;; TODO: to indent Lisp code, we should add a way to specify
+ ;; particular indentation for particular args depending on the
+ ;; function (which would require always skipping back until the
+ ;; function).
+ ;; TODO: to indent C code, such as "if (...) {...}" we might need
+ ;; to add similar indentation hooks for particular positions, but
+ ;; based on the preceding token rather than based on the first exp.
+ (save-excursion
+ (let ((positions nil)
+ arg)
+ (while (and (null (car (smie-backward-sexp)))
+ (push (point) positions)
+ (not (smie-bolp))))
+ (save-excursion
+ ;; Figure out if the atom we just skipped is an argument rather
+ ;; than a function.
+ (setq arg (or (null (car (smie-backward-sexp)))
+ (member (funcall smie-backward-token-function)
+ (cdr (assoc 'list-intro smie-indent-rules))))))
+ (cond
+ ((null positions)
+ ;; We're the first expression of the list. In that case, the
+ ;; indentation should be (have been) determined by its context.
+ nil)
+ (arg
+ ;; There's a previous element, and it's not special (it's not
+ ;; the function), so let's just align with that one.
+ (goto-char (car positions))
+ (current-column))
+ ((cdr positions)
+ ;; We skipped some args plus the function and bumped into something.
+ ;; Align with the first arg.
+ (goto-char (cadr positions))
+ (current-column))
+ (positions
+ ;; We're the first arg.
+ (goto-char (car positions))
+ (+ (smie-indent-offset 'args)
+ ;; We used to use (smie-indent-virtual), but that
+ ;; doesn't seem right since it might then indent args less than
+ ;; the function itself.
+ (current-column)))))))
+
+(defvar smie-indent-functions
+ '(smie-indent-fixindent smie-indent-bob smie-indent-close smie-indent-comment
+ smie-indent-comment-continue smie-indent-keyword smie-indent-after-keyword
+ smie-indent-exps)
+ "Functions to compute the indentation.
+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.")
+
+(defun smie-indent-calculate ()
+ "Compute the indentation to use for point."
+ (run-hook-with-args-until-success 'smie-indent-functions))
+
+(defun smie-indent-line ()
+ "Indent current line using the SMIE indentation engine."
+ (interactive)
+ (let* ((savep (point))
+ (indent (condition-case-no-debug nil
+ (save-excursion
+ (forward-line 0)
+ (skip-chars-forward " \t")
+ (if (>= (point) savep) (setq savep nil))
+ (or (smie-indent-calculate) 0))
+ (error 0))))
+ (if (not (numberp indent))
+ ;; If something funny is used (e.g. `noindent'), return it.
+ indent
+ (if (< indent 0) (setq indent 0)) ;Just in case.
+ (if savep
+ (save-excursion (indent-line-to indent))
+ (indent-line-to indent)))))
+
+(defun smie-indent-debug ()
+ "Show the rules used to compute indentation of current line."
+ (interactive)
+ (let ((smie-indent-debug-log '()))
+ (smie-indent-calculate)
+ ;; FIXME: please improve!
+ (message "%S" smie-indent-debug-log)))
+
+(defun smie-setup (op-levels indent-rules)
+ (set (make-local-variable 'smie-indent-rules) indent-rules)
+ (set (make-local-variable 'smie-op-levels) op-levels)
+ (set (make-local-variable 'indent-line-function) 'smie-indent-line))
+
+
+(provide 'smie)
+;;; smie.el ends here
diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el
index f3b8ddcd123..94f39940b66 100644
--- a/lisp/emacs-lisp/timer.el
+++ b/lisp/emacs-lisp/timer.el
@@ -321,7 +321,11 @@ This function is called, by name, directly by the C code."
;; We do this after rescheduling so that the handler function
;; can cancel its own timer successfully with cancel-timer.
(condition-case nil
- (apply (timer--function timer) (timer--args timer))
+ ;; Timer functions should not change the current buffer.
+ ;; If they do, all kinds of nasty surprises can happen,
+ ;; and it can be hellish to track down their source.
+ (save-current-buffer
+ (apply (timer--function timer) (timer--args timer)))
(error nil))
(if retrigger
(setf (timer--triggered timer) nil)))
generated by cgit v1.2.3 (git 2.39.1) at 2025-06-29 07:49:02 +0000