summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/authors.el82
-rw-r--r--lisp/emacs-lisp/autoload.el150
-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/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/lisp-mnt.el4
-rw-r--r--lisp/emacs-lisp/lisp-mode.el17
-rw-r--r--lisp/emacs-lisp/lisp.el41
-rw-r--r--lisp/emacs-lisp/macroexp.el4
-rw-r--r--lisp/emacs-lisp/package-x.el220
-rw-r--r--lisp/emacs-lisp/package.el1563
-rw-r--r--lisp/emacs-lisp/smie.el877
17 files changed, 3013 insertions, 187 deletions
diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el
index 7728215bb91..020729e2c76 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.
@@ -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..c5316d06429 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
@@ -258,14 +259,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 +328,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 +365,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 +397,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 +408,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 +422,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 +449,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 +465,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 +477,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 +538,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 +558,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 +678,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 +687,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/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 13e08667839..5a21946183e 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -116,6 +116,11 @@ BODY contains code to execute each time the mode is activated or deactivated.
: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!\"
@@ -147,6 +152,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")))
@@ -167,6 +175,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
@@ -187,12 +201,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."
@@ -207,10 +225,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.
@@ -221,22 +239,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)
@@ -261,9 +276,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
@@ -343,9 +364,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))
@@ -366,13 +389,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/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..02477baf74f 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -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..4ef6dab8968 100644
--- a/lisp/emacs-lisp/lisp.el
+++ b/lisp/emacs-lisp/lisp.el
@@ -624,21 +624,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 +661,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..21bd7960d89
--- /dev/null
+++ b/lisp/emacs-lisp/package-x.el
@@ -0,0 +1,220 @@
+;;; 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)
+ (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>" package-archive-base "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)
+ "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))
+ (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)
+ "Update the ELPA web pages when a package is uploaded."
+ (package-maint-add-news-item (concat package " version " version)
+ description))
+
+(defun package-upload-buffer-internal (pkg-info extension)
+ "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\"."
+ (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 (package-version-split pkg-version))
+ (pkg-buffer (current-buffer))
+
+ ;; Download latest archive-contents.
+ (buffer (url-retrieve-synchronously
+ (concat package-archive-base "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 (package-version-compare 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)
+
+ ;; 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..c6035442313
--- /dev/null
+++ b/lisp/emacs-lisp/package.el
@@ -0,0 +1,1563 @@
+;;; 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.)
+
+;; This code supports a single package repository, ELPA. All packages
+;; must be registered there.
+
+;; 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 will be named "NAME-VERSION.el" in ELPA, but will be
+;; installed as simply "NAME.el" in a directory named "NAME-VERSION".
+
+;; The downloader will download all dependent packages. It will also
+;; byte-compile the package's lisp 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)
+ :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))
+
+(defconst package-archive-base "http://elpa.gnu.org/packages/"
+ "Base URL for the Emacs Lisp Package Archive (ELPA).
+Ordinarily you should not need to change this.
+Note that some code in package.el assumes that this is an http: URL.")
+
+(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 an extra entry which is 'tar for tar packages and
+'single for single-file packages.")
+
+(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
+ :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)
+ :group 'package
+ :version "24.1")
+
+(defun package-version-split (string)
+ "Split a package string into a version list."
+ (mapcar 'string-to-int (split-string string "[.]")))
+
+(defconst package--builtins-base
+ ;; We use package-version split here to make sure to pick up the
+ ;; minor version.
+ `((emacs . [,(package-version-split emacs-version) nil
+ "GNU Emacs"])
+ (package . [,(package-version-split 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 "An Emacs 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 editing XML documents."])
+ (bubbles . [(0 5) nil "Puzzle game for Emacs."])))))
+ "Alist of all built-in packages.
+Maps the package name to a vector [VERSION REQS DOCSTRING].")
+
+(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'.")
+
+(defvar package-activated-list
+ (mapcar #'car package-alist)
+ "List of the names of currently activated packages.")
+
+(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.")
+
+(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--version-first-nonzero (l)
+ (while (and l (= (car l) 0))
+ (setq l (cdr l)))
+ (if l (car l) 0))
+
+(defun package-version-compare (v1 v2 fun)
+ "Compare two version lists according to FUN.
+FUN can be <, <=, =, >, >=, or /=."
+ (while (and v1 v2 (= (car v1) (car v2)))
+ (setq v1 (cdr v1)
+ v2 (cdr v2)))
+ (if v1
+ (if v2
+ ;; Both not null; we know the cars are not =.
+ (funcall fun (car v1) (car v2))
+ ;; V1 not null, V2 null.
+ (funcall fun (package--version-first-nonzero v1) 0))
+ (if v2
+ ;; V1 null, V2 not null.
+ (funcall fun 0 (package--version-first-nonzero v2))
+ ;; Both null.
+ (funcall fun 0 0))))
+
+(defun package--test-version-compare ()
+ "Test suite for `package-version-compare'."
+ (unless (and (package-version-compare '(0) '(0) '=)
+ (not (package-version-compare '(1) '(0) '=))
+ (package-version-compare '(1 0 1) '(1) '>=)
+ (package-version-compare '(1 0 1) '(1) '>)
+ (not (package-version-compare '(0 9 1) '(1 0 2) '>=)))
+ (error "Failed"))
+ t)
+
+(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 for a package.
+DIR is the directory in which to find the package subdirectory,
+and PACKAGE is the name of the package subdirectory.
+Return nil if the package could not be found."
+ (let ((pkg-dir (expand-file-name package dir)))
+ (if (file-directory-p pkg-dir)
+ (load (expand-file-name (concat (package-strip-version package)
+ "-pkg")
+ pkg-dir)
+ 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
+ (package-version-compare (package-version-split version)
+ (package-version-split 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
+ (package-version-compare (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))
+ (package-version-compare this-version 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)
+ (package-version-compare this-version 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 (package-version-split version-string))
+ (new-pkg-desc
+ (cons name
+ (vector new-version
+ (mapcar
+ (lambda (elt)
+ (list (car elt)
+ (package-version-split (car (cdr elt)))))
+ requirements)
+ docstring))))
+ ;; Only redefine a package if the redefinition is newer.
+ (if (or (not pkg-desc)
+ (package-version-compare new-version
+ (package-desc-vers (cdr pkg-desc))
+ '>))
+ (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 (package-version-compare 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-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")
+ (write-region (point-min) (point-max)
+ (expand-file-name (concat file-name ".el")
+ package-user-dir)
+ nil nil nil 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)
+ (write-region (point-min) (point-max) el-file nil nil nil '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-base
+ (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-base
+ (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 version)
+ (let ((pkg-desc (assq package package-alist)))
+ (and pkg-desc
+ (package-version-compare 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'"))
+ ((package-version-compare next-version
+ (package-version-split hold)
+ '>)
+ (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 (package-version-compare (package-desc-vers (cdr pkg-desc))
+ next-version
+ '>=)
+ (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-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."
+ (let ((archive-contents (package--read-archive-file "archive-contents"))
+ (builtins (package--read-archive-file "builtin-packages")))
+ (if archive-contents
+ ;; Version 1 of 'archive-contents' is identical to our
+ ;; internal representation.
+ (setq package-archive-contents archive-contents))
+ (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 (package-version-split emacs-version))
+ (result package--builtins-base))
+ (setq package--builtins
+ (dolist (elt builtins result)
+ (if (package-version-compare our-version (car elt) '>=)
+ (setq result (append (cdr elt) result)))))))))
+
+(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 the archive site, see `package-archive-base'."
+ (interactive
+ (list (progn
+ ;; Make sure we're using the most recent download of the
+ ;; archive. Maybe we should be updating the archive first?
+ (package-read-archive-contents)
+ (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' not available for installation"
+ (symbol-name name)))
+ (let ((transaction
+ (package-compute-transaction (list name)
+ (package-desc-reqs (cdr pkg-desc)))))
+ (package-download-transaction transaction)))
+ ;; 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)
+ (package-version-split (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)
+ (package-version-split (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--download-one-archive (file)
+ "Download a single archive file and cache it locally."
+ (let ((buffer (url-retrieve-synchronously
+ (concat package-archive-base file))))
+ (with-current-buffer buffer
+ (package-handle-response)
+ (re-search-forward "^$" nil 'move)
+ (forward-char)
+ (delete-region (point-min) (point))
+ (setq buffer-file-name (concat (file-name-as-directory package-user-dir)
+ file))
+ (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))
+ (package--download-one-archive "archive-contents")
+ (package--download-one-archive "builtin-packages")
+ (package-read-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-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* (start-point ok
+ (pkg-name (package-menu-get-package))
+ (buffer (url-retrieve-synchronously (concat package-archive-base
+ pkg-name
+ "-readme.txt"))))
+ (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 does not have a README file or commentary comment.\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))
+ (forward-line 2)
+ (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 ((eq package 'emacs) '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)
+ (insert (propertize desc 'font-lock-face face)))
+ (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)
+ ;; List installed packages
+ (dolist (elt package-alist)
+ (setq name (car elt)
+ desc (cdr elt)
+ hold (assq name package-load-list))
+ (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.
+ (if (stringp (cadr hold))
+ "held"
+ "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 (package-version-split (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")
+ (30 . "Status")
+ (41 . "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/smie.el b/lisp/emacs-lisp/smie.el
new file mode 100644
index 00000000000..fb1e4737d39
--- /dev/null
+++ b/lisp/emacs-lisp/smie.el
@@ -0,0 +1,877 @@
+;;; 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:
+
+(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)
+ "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 (point)
+ (progn (if (zerop (skip-syntax-backward "."))
+ (skip-syntax-backward "w_'"))
+ (point))))
+
+(defun smie-default-forward-token ()
+ (forward-comment (point-max))
+ (buffer-substring (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 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 a grammar like
+ ;; (exp ("A" exp "C") ("A" exp "B" exp "C"))
+ ;; will cause "B" to have equal left and right levels, even though
+ ;; it is not an associative operator.
+ ;; A better check would be the check the actual previous operator
+ ;; against this one to see if it's the same, but we'd have to change
+ ;; `levels' to keep a stack of operators rather than only levels.
+ (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)))))
+ (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 (funcall op-forw toklevels) levels))
+ (t
+ (while (and levels (< (funcall op-back toklevels) (car levels)))
+ (setq levels (cdr levels)))
+ (cond
+ ((null levels)
+ (if (and halfsexp (funcall op-forw toklevels))
+ (push (funcall op-forw toklevels) levels)
+ (throw 'return
+ (prog1 (list (or (car toklevels) t) (point) token)
+ (goto-char pos)))))
+ (t
+ (if (and levels (= (funcall op-back toklevels) (car levels)))
+ (setq levels (cdr levels)))
+ (cond
+ ((null levels)
+ (cond
+ ((null (funcall op-forw toklevels))
+ (throw 'return (list nil (point) token)))
+ ((smie-associative-p toklevels)
+ (throw 'return
+ (prog1 (list (or (car toklevels) t) (point) token)
+ (goto-char pos))))
+ ;; We just found a match to the previously pending operator
+ ;; but this new operator is still part of a larger RHS.
+ ;; E.g. we're now looking at the "then" in
+ ;; "if a then b else c". So we have to keep parsing the
+ ;; rest of the construct.
+ (t (push (funcall op-forw toklevels) levels))))
+ (t
+ (if (funcall op-forw toklevels)
+ (push (funcall op-forw toklevels) levels))))))))
+ 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))
+
+(defun smie-backward-sexp-command (&optional n)
+ "Move backward through N logical elements."
+ (interactive "p")
+ (if (< n 0)
+ (smie-forward-sexp-command (- n))
+ (let ((forward-sexp-function nil))
+ (while (> n 0)
+ (decf n)
+ (let ((pos (point))
+ (res (smie-backward-sexp 'halfsexp)))
+ (if (and (car res) (= pos (point)) (not (bolp)))
+ (signal 'scan-error
+ (list "Containing expression ends prematurely"
+ (cadr res) (cadr res)))
+ nil))))))
+
+(defun smie-forward-sexp-command (&optional n)
+ "Move forward through N logical elements."
+ (interactive "p")
+ (if (< n 0)
+ (smie-backward-sexp-command (- n))
+ (let ((forward-sexp-function nil))
+ (while (> n 0)
+ (decf n)
+ (let ((pos (point))
+ (res (smie-forward-sexp 'halfsexp)))
+ (if (and (car res) (= pos (point)) (not (bolp)))
+ (signal 'scan-error
+ (list "Containing expression ends prematurely"
+ (cadr res) (cadr res)))
+ nil))))))
+
+;;; 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.
+\((T1 . T2) . OFFSET) how to indent token T2 w.r.t T1.
+\((t . TOK) . OFFSET) how to indent TOK with respect to its parent.
+\(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.
+
+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 OFFSET-RULES.
+a number the offset to use.
+`point' align with the token.
+`parent' align with the 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))
+
+(defun smie-indent-offset-rule (tokinfo &optional after)
+ "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."
+ (let ((rules (cdr tokinfo))
+ parent next prev
+ offset)
+ (while (consp rules)
+ (let ((rule (pop rules)))
+ (cond
+ ((not (consp rule)) (setq offset rule))
+ ((eq (car rule) :hanging)
+ (when (smie-indent-hanging-p)
+ (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 (equal (nth 2 parent) (cadr rule))
+ (setq rules (cddr rule))))
+ (t (error "Unknown rule %s for indentation of %s"
+ rule (car tokinfo))))))
+ 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))
+ ;; Different case:
+ ;; - 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
+ (let* ((tokinfo (or (assoc (cons :before token) smie-indent-rules)
+ ;; By default use point unless we're hanging.
+ (cons (cons :before token)
+ '((:hanging nil) point))))
+ (after (prog1 (point) (goto-char pos)))
+ (offset (smie-indent-offset-rule tokinfo)))
+ (cond
+ ((eq offset 'point) (current-column))
+ ((eq offset 'parent)
+ (let ((parent (smie-backward-sexp 'halfsexp)))
+ (if parent (goto-char (cadr parent))))
+ (smie-indent-virtual))
+ ((eq offset nil) nil)
+ (t (error "Unhandled offset %s in %s"
+ offset (cons :before token)))))))
+
+ ;; 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 ((res (smie-backward-sexp 'halfsexp)) tmp)
+ (cond
+ ((not (or (< (point) pos)
+ (and (cadr res) (< (cadr res) pos))))
+ ;; If we didn't move at all, that means we didn't really skip
+ ;; what we wanted.
+ nil)
+ ((eq (car res) (car toklevels))
+ ;; We bumped into a same-level operator. align with it.
+ (goto-char (cadr res))
+ ;; 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))
+ ((setq tmp (assoc (cons (caddr res) token)
+ smie-indent-rules))
+ (goto-char (cadr res))
+ (+ (cdr tmp) (smie-indent-virtual))) ;:not-hanging
+ ;; FIXME: The rules ((t . TOK) . OFFSET) either indent
+ ;; relative to "before the parent" or "after the parent",
+ ;; depending on details of the grammar.
+ ((null (car res))
+ (assert (eq (point) (cadr res)))
+ (goto-char (cadr res))
+ (+ (or (cdr (assoc (cons t token) smie-indent-rules)) 0)
+ (smie-indent-virtual))) ;:not-hanging
+ ((and (= (point) pos) (smie-bolp))
+ ;; Since we started at BOL, we're not computing a virtual
+ ;; indentation, and we're still at the starting point, so the
+ ;; next (default) rule can't be used since it uses `current-column'
+ ;; which would cause. indentation to depend on itself.
+ ;; We could just return nil, but OTOH that's not good enough in
+ ;; some cases. Instead, we want to combine the offset-rules for
+ ;; the current token with the offset-rules of the previous one.
+ (+ (or (cdr (assoc (cons t token) smie-indent-rules)) 0)
+ ;; FIXME: This is odd. Can't we make it use
+ ;; smie-indent-(calculate|virtual) somehow?
+ (smie-indent-after-keyword)))
+ (t
+ (+ (or (cdr (assoc (cons t token) smie-indent-rules)) 0)
+ (current-column)))))))))
+
+(defun smie-indent-comment ()
+ ;; Indentation of a comment.
+ (and (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)))
+ (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
+ (let ((offset
+ (cond
+ (tokinfo (or (smie-indent-offset-rule tokinfo pos)
+ (smie-indent-offset t)))
+ ;; 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.
+ ((null (cadr toklevel)) (smie-indent-offset t))
+ (t 0))))
+ ;; 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)) offset))))))
+
+(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 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)))))
+
+;;;###autoload
+(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
generated by cgit v1.2.3 (git 2.39.1) at 2025-06-27 22:13:39 +0000