Merge from trunk

11 files changed, 304 insertions, 151 deletions

diff --git a/lisp/emacs-lisp/assoc.el b/lisp/emacs-lisp/assoc.el
index aa85916cc3f..31be851f2dd 100644
--- a/lisp/emacs-lisp/assoc.el
+++ b/lisp/emacs-lisp/assoc.el
@@ -1,4 +1,4 @@
-;;; assoc.el --- insert/delete/sort functions on association lists
+;;; assoc.el --- insert/delete functions on association lists
 
 ;; Copyright (C) 1996, 2001-2011  Free Software Foundation, Inc.
 
@@ -35,7 +35,7 @@ head is one matching KEY.  Returns the sorted list and doesn't affect
 the order of any other key-value pair.  Side effect sets alist to new
 sorted list."
   (set alist-symbol
-       (sort (copy-alist (eval alist-symbol))
+       (sort (copy-alist (symbol-value alist-symbol))
 	     (function (lambda (a b) (equal (car a) key))))))
 
 
@@ -75,7 +75,7 @@ of the alist (with value nil if VALUE is nil or not supplied)."
   (lexical-let ((elem (aelement key value))
 		alist)
     (asort alist-symbol key)
-    (setq alist (eval alist-symbol))
+    (setq alist (symbol-value alist-symbol))
     (cond ((null alist) (set alist-symbol elem))
 	  ((anot-head-p alist key) (set alist-symbol (nconc elem alist)))
 	  (value (setcar alist (car elem)))
@@ -87,7 +87,7 @@ of the alist (with value nil if VALUE is nil or not supplied)."
 Alist is referenced by ALIST-SYMBOL and the key-value pair to remove
 is pair matching KEY.  Returns the altered alist."
   (asort alist-symbol key)
-  (lexical-let ((alist (eval alist-symbol)))
+  (lexical-let ((alist (symbol-value alist-symbol)))
     (cond ((null alist) nil)
 	  ((anot-head-p alist key) alist)
 	  (t (set alist-symbol (cdr alist))))))
@@ -133,7 +133,7 @@ extra values are ignored.  Returns the created alist."
 	  (t
 	   (amake alist-symbol keycdr valcdr)
 	   (aput alist-symbol keycar valcar))))
-  (eval alist-symbol))
+  (symbol-value alist-symbol))
 
 (provide 'assoc)
 
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el
index 7b610d11b0f..d6e7ee9e3cb 100644
--- a/lisp/emacs-lisp/autoload.el
+++ b/lisp/emacs-lisp/autoload.el
@@ -537,7 +537,8 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE
 (defun autoload-save-buffers ()
   (while autoload-modified-buffers
     (with-current-buffer (pop autoload-modified-buffers)
-      (save-buffer))))
+      (let ((version-control 'never))
+	(save-buffer)))))
 
 ;;;###autoload
 (defun update-file-autoloads (file &optional save-after)
@@ -569,8 +570,9 @@ removes any prior now out-of-date autoload entries."
       (with-current-buffer
           ;; We used to use `raw-text' to read this file, but this causes
           ;; problems when the file contains non-ASCII characters.
-          (find-file-noselect
-           (autoload-ensure-default-file (autoload-generated-file)))
+	  (let ((enable-local-variables :safe))
+	    (find-file-noselect
+	     (autoload-ensure-default-file (autoload-generated-file))))
         ;; This is to make generated-autoload-file have Unix EOLs, so
         ;; that it is portable to all platforms.
         (or (eq 0 (coding-system-eol-type buffer-file-coding-system))
@@ -656,8 +658,9 @@ directory or directories specified."
          (autoload-modified-buffers nil))
 
     (with-current-buffer
-	(find-file-noselect
-         (autoload-ensure-default-file (autoload-generated-file)))
+	(let ((enable-local-variables :safe))
+	  (find-file-noselect
+	   (autoload-ensure-default-file (autoload-generated-file))))
       (save-excursion
 
 	;; Canonicalize file names and remove the autoload file itself.
@@ -721,7 +724,8 @@ directory or directories specified."
 	 (current-buffer) nil nil no-autoloads this-time)
 	(insert generate-autoload-section-trailer))
 
-      (save-buffer)
+      (let ((version-control 'never))
+	(save-buffer))
       ;; In case autoload entries were added to other files because of
       ;; file-local autoload-generated-file settings.
       (autoload-save-buffers))))
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 297655a235a..7b785c9ace6 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -238,6 +238,7 @@ the functions you loaded will not be able to run.")
 
 (defvar byte-compile-disable-print-circle nil
   "If non-nil, disable `print-circle' on printing a byte-compiled code.")
+(make-obsolete-variable 'byte-compile-disable-print-circle nil "24.1")
 ;;;###autoload(put 'byte-compile-disable-print-circle 'safe-local-variable 'booleanp)
 
 (defcustom byte-compile-dynamic-docstrings t
diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el
index df9460154e8..17046f1ffb4 100644
--- a/lisp/emacs-lisp/cl-loaddefs.el
+++ b/lisp/emacs-lisp/cl-loaddefs.el
@@ -282,7 +282,7 @@ Not documented
 ;;;;;;  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" "7602128fa01003de9a8df4c752865300")
+;;;;;;  gensym) "cl-macs" "cl-macs.el" "5bdba3fbbcbfcf57a2c9ca87a6318150")
 ;;; Generated autoloads from cl-macs.el
 
 (autoload 'gensym "cl-macs" "\
@@ -319,7 +319,7 @@ its argument list allows full Common Lisp conventions.
 \(fn FUNC)" nil (quote macro))
 
 (autoload 'destructuring-bind "cl-macs" "\
-Not documented
+
 
 \(fn ARGS EXPR &rest BODY)" nil (quote macro))
 
@@ -445,7 +445,7 @@ from OBARRAY.
 \(fn (VAR [OBARRAY [RESULT]]) BODY...)" nil (quote macro))
 
 (autoload 'do-all-symbols "cl-macs" "\
-Not documented
+
 
 \(fn SPEC &rest BODY)" nil (quote macro))
 
@@ -505,7 +505,7 @@ lexical closures as in Common Lisp.
 (autoload 'lexical-let* "cl-macs" "\
 Like `let*', but lexically scoped.
 The main visible difference is that lambdas inside BODY, and in
-successive bindings within BINDINGS, will create lexical closures
+successive bindings within VARLIST, will create lexical closures
 as in Common Lisp.  This is similar to the behavior of `let*' in
 Common Lisp.
 
@@ -531,12 +531,12 @@ values.  For compatibility, (values A B C) is a synonym for (list A B C).
 \(fn (SYM...) FORM)" nil (quote macro))
 
 (autoload 'locally "cl-macs" "\
-Not documented
+
 
 \(fn &rest BODY)" nil (quote macro))
 
 (autoload 'declare "cl-macs" "\
-Not documented
+
 
 \(fn &rest SPECS)" nil (quote macro))
 
@@ -596,7 +596,7 @@ before assigning any PLACEs to the corresponding values.
 \(fn PLACE VAL PLACE VAL ...)" nil (quote macro))
 
 (autoload 'cl-do-pop "cl-macs" "\
-Not documented
+
 
 \(fn PLACE)" nil nil)
 
@@ -684,7 +684,7 @@ value, that slot cannot be set via `setf'.
 \(fn NAME SLOTS...)" nil (quote macro))
 
 (autoload 'cl-struct-setf-expander "cl-macs" "\
-Not documented
+
 
 \(fn X NAME ACCESSOR PRED-FORM POS)" nil nil)
 
@@ -730,7 +730,7 @@ and then returning foo.
 \(fn FUNC ARGS &rest BODY)" nil (quote macro))
 
 (autoload 'compiler-macroexpand "cl-macs" "\
-Not documented
+
 
 \(fn FORM)" nil nil)
 
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 093e4fbf258..8b1fc9d5f53 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -1476,7 +1476,7 @@ lexical closures as in Common Lisp.
 (defmacro lexical-let* (bindings &rest body)
   "Like `let*', but lexically scoped.
 The main visible difference is that lambdas inside BODY, and in
-successive bindings within BINDINGS, will create lexical closures
+successive bindings within VARLIST, will create lexical closures
 as in Common Lisp.  This is similar to the behavior of `let*' in
 Common Lisp.
 \n(fn VARLIST BODY)"
diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el
index 910eff3c78f..73af3a5708f 100644
--- a/lisp/emacs-lisp/elp.el
+++ b/lisp/emacs-lisp/elp.el
@@ -630,7 +630,7 @@ displayed."
                                    'display (list 'space :align-to column)
                                    'face 'fixed-pitch)
                        title)
-                    (setq column (+ column 1
+                    (setq column (+ column 2
                                     (if (= column 0)
                                         elp-field-len
                                       (length title))))))
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index b3c95fcc78f..5bd8fd01b1e 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -219,7 +219,7 @@ Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'."
   ;; This implementation is inefficient.  Rather than making it
   ;; efficient, let's hope bug 6581 gets fixed so that we can delete
   ;; it altogether.
-  (not (ert--explain-not-equal-including-properties a b)))
+  (not (ert--explain-equal-including-properties a b)))
 
 
 ;;; Defining and locating tests.
@@ -571,16 +571,15 @@ failed."
    (when (and (not firstp) (eq fast slow)) (return nil))))
 
 (defun ert--explain-format-atom (x)
-  "Format the atom X for `ert--explain-not-equal'."
+  "Format the atom X for `ert--explain-equal'."
   (typecase x
     (fixnum (list x (format "#x%x" x) (format "?%c" x)))
     (t x)))
 
-(defun ert--explain-not-equal (a b)
-  "Explainer function for `equal'.
+(defun ert--explain-equal-rec (a b)
+  "Returns a programmer-readable explanation of why A and B are not `equal'.
 
-Returns a programmer-readable explanation of why A and B are not
-`equal', or nil if they are."
+Returns nil if they are."
   (if (not (equal (type-of a) (type-of b)))
       `(different-types ,a ,b)
     (etypecase a
@@ -598,13 +597,13 @@ Returns a programmer-readable explanation of why A and B are not
                  (loop for i from 0
                        for ai in a
                        for bi in b
-                       for xi = (ert--explain-not-equal ai bi)
+                       for xi = (ert--explain-equal-rec ai bi)
                        do (when xi (return `(list-elt ,i ,xi)))
                        finally (assert (equal a b) t)))
-             (let ((car-x (ert--explain-not-equal (car a) (car b))))
+             (let ((car-x (ert--explain-equal-rec (car a) (car b))))
                (if car-x
                    `(car ,car-x)
-                 (let ((cdr-x (ert--explain-not-equal (cdr a) (cdr b))))
+                 (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b))))
                    (if cdr-x
                        `(cdr ,cdr-x)
                      (assert (equal a b) t)
@@ -618,7 +617,7 @@ Returns a programmer-readable explanation of why A and B are not
                (loop for i from 0
                      for ai across a
                      for bi across b
-                     for xi = (ert--explain-not-equal ai bi)
+                     for xi = (ert--explain-equal-rec ai bi)
                      do (when xi (return `(array-elt ,i ,xi)))
                      finally (assert (equal a b) t))))
       (atom (if (not (equal a b))
@@ -627,7 +626,15 @@ Returns a programmer-readable explanation of why A and B are not
                   `(different-atoms ,(ert--explain-format-atom a)
                                     ,(ert--explain-format-atom b)))
               nil)))))
-(put 'equal 'ert-explainer 'ert--explain-not-equal)
+
+(defun ert--explain-equal (a b)
+  "Explainer function for `equal'."
+  ;; Do a quick comparison in C to avoid running our expensive
+  ;; comparison when possible.
+  (if (equal a b)
+      nil
+    (ert--explain-equal-rec a b)))
+(put 'equal 'ert-explainer 'ert--explain-equal)
 
 (defun ert--significant-plist-keys (plist)
   "Return the keys of PLIST that have non-null values, in order."
@@ -658,8 +665,8 @@ key/value pairs in each list does not matter."
                    (value-b (plist-get b key)))
                (assert (not (equal value-a value-b)) t)
                `(different-properties-for-key
-                 ,key ,(ert--explain-not-equal-including-properties value-a
-                                                                    value-b)))))
+                 ,key ,(ert--explain-equal-including-properties value-a
+                                                                value-b)))))
       (cond (keys-in-a-not-in-b
              (explain-with-key (first keys-in-a-not-in-b)))
             (keys-in-b-not-in-a
@@ -681,13 +688,16 @@ If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix."
           (t
            (substring s 0 len)))))
 
-(defun ert--explain-not-equal-including-properties (a b)
+;; TODO(ohler): Once bug 6581 is fixed, rename this to
+;; `ert--explain-equal-including-properties-rec' and add a fast-path
+;; wrapper like `ert--explain-equal'.
+(defun ert--explain-equal-including-properties (a b)
   "Explainer function for `ert-equal-including-properties'.
 
 Returns a programmer-readable explanation of why A and B are not
 `ert-equal-including-properties', or nil if they are."
   (if (not (equal a b))
-      (ert--explain-not-equal a b)
+      (ert--explain-equal a b)
     (assert (stringp a) t)
     (assert (stringp b) t)
     (assert (eql (length a) (length b)) t)
@@ -713,7 +723,7 @@ Returns a programmer-readable explanation of why A and B are not
           )))
 (put 'ert-equal-including-properties
      'ert-explainer
-     'ert--explain-not-equal-including-properties)
+     'ert--explain-equal-including-properties)
 
 
 ;;; Implementation of `ert-info'.
@@ -1244,12 +1254,14 @@ Also changes the counters in STATS to match."
                    (ert-test-passed (incf (ert--stats-passed-expected stats) d))
                    (ert-test-failed (incf (ert--stats-failed-expected stats) d))
                    (null)
-                   (ert-test-aborted-with-non-local-exit))
+                   (ert-test-aborted-with-non-local-exit)
+                   (ert-test-quit))
                (etypecase (aref results pos)
                  (ert-test-passed (incf (ert--stats-passed-unexpected stats) d))
                  (ert-test-failed (incf (ert--stats-failed-unexpected stats) d))
                  (null)
-                 (ert-test-aborted-with-non-local-exit)))))
+                 (ert-test-aborted-with-non-local-exit)
+                 (ert-test-quit)))))
       ;; Adjust counters to remove the result that is currently in stats.
       (update -1)
       ;; Put new test and result into stats.
@@ -1342,7 +1354,8 @@ EXPECTEDP specifies whether the result was expected."
              (ert-test-passed ".P")
              (ert-test-failed "fF")
              (null "--")
-             (ert-test-aborted-with-non-local-exit "aA"))))
+             (ert-test-aborted-with-non-local-exit "aA")
+             (ert-test-quit "qQ"))))
     (elt s (if expectedp 0 1))))
 
 (defun ert-string-for-test-result (result expectedp)
@@ -1353,7 +1366,8 @@ EXPECTEDP specifies whether the result was expected."
              (ert-test-passed '("passed" "PASSED"))
              (ert-test-failed '("failed" "FAILED"))
              (null '("unknown" "UNKNOWN"))
-             (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED")))))
+             (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED"))
+             (ert-test-quit '("quit" "QUIT")))))
     (elt s (if expectedp 0 1))))
 
 (defun ert--pp-with-indentation-and-newline (object)
@@ -1478,7 +1492,9 @@ Returns the stats object."
                  (message "%s" (buffer-string))))
               (ert-test-aborted-with-non-local-exit
                (message "Test %S aborted with non-local exit"
-                        (ert-test-name test)))))
+                        (ert-test-name test)))
+              (ert-test-quit
+               (message "Quit during %S" (ert-test-name test)))))
           (let* ((max (prin1-to-string (length (ert--stats-tests stats))))
                  (format-string (concat "%9s  %"
                                         (prin1-to-string (length max))
@@ -1853,7 +1869,9 @@ non-nil, returns the face for expected results.."
                      (ert-test-result-with-condition-condition result))
                     (ert--make-xrefs-region begin (point)))))
                (ert-test-aborted-with-non-local-exit
-                (insert "    aborted\n")))
+                (insert "    aborted\n"))
+               (ert-test-quit
+                (insert "    quit\n")))
              (insert "\n")))))
   nil)
 
diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el
index bf9998695ee..a71f3c7244c 100644
--- a/lisp/emacs-lisp/ewoc.el
+++ b/lisp/emacs-lisp/ewoc.el
@@ -495,6 +495,8 @@ Return the node (or nil if we just passed the last node)."
     ;; Never step below the first element.
     ;; (unless (ewoc--filter-hf-nodes ewoc node)
     ;;   (setq node (ewoc--node-nth dll -2)))
+    (unless node
+      (error "No next"))
     (ewoc-goto-node ewoc node)))
 
 (defun ewoc-goto-node (ewoc node)
diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el
index b9994be3d39..61f23abf0a7 100644
--- a/lisp/emacs-lisp/package-x.el
+++ b/lisp/emacs-lisp/package-x.el
@@ -40,6 +40,9 @@
 (defvar package-archive-upload-base nil
   "Base location for uploading to package archive.")
 
+(defvar package-update-news-on-upload nil
+  "Whether package upload should also update NEWS and RSS feeds.")
+
 (defun package--encode (string)
   "Encode a string by replacing some characters with XML entities."
   ;; We need a special case for translating "&" to "&".
@@ -86,6 +89,36 @@
 	(unless old-buffer
 	  (kill-buffer (current-buffer)))))))
 
+(defun package--archive-contents-from-url (archive-url)
+  "Parse archive-contents file at ARCHIVE-URL.
+Return the file contents, as a string, or nil if unsuccessful."
+  (ignore-errors
+    (when archive-url
+      (let* ((buffer (url-retrieve-synchronously
+		      (concat archive-url "archive-contents"))))
+	(set-buffer buffer)
+	(package-handle-response)
+	(re-search-forward "^$" nil 'move)
+	(forward-char)
+	(delete-region (point-min) (point))
+	(prog1 (package-read-from-string
+		(buffer-substring-no-properties (point-min) (point-max)))
+	  (kill-buffer buffer))))))
+
+(defun package--archive-contents-from-file (file)
+  "Parse the given archive-contents file."
+  (if (not (file-exists-p file))
+      ;; no existing archive-contents, possibly a new ELPA repo.
+      (list package-archive-version)
+    (let ((dont-kill (find-buffer-visiting file)))
+      (with-current-buffer (let ((find-file-visit-truename t))
+			     (find-file-noselect file))
+	(prog1
+	    (package-read-from-string
+	     (buffer-substring-no-properties (point-min) (point-max)))
+	  (unless dont-kill
+	    (kill-buffer (current-buffer))))))))
+
 (defun package-maint-add-news-item (title description archive-url)
   "Add a news item to the ELPA web pages.
 TITLE is the title of the news item.
@@ -111,11 +144,20 @@ PKG-INFO is the package info, see `package-buffer-info'.
 EXTENSION is the file extension, a string.  It can be either
 \"el\" or \"tar\".
 
+The variable `package-archive-upload-base' specifies the upload
+destination.  If this is nil, signal an error.
+
 Optional arg ARCHIVE-URL is the URL of the destination archive.
-If nil, the \"gnu\" archive is used."
-  (unless archive-url
-    (or (setq archive-url (cdr (assoc "gnu" package-archives)))
-	(error "No destination URL")))
+If it is non-nil, compute the new \"archive-contents\" file
+starting from the existing \"archive-contents\" at that URL.  In
+addition, if `package-update-news-on-upload' is non-nil, call
+`package--update-news' to add a news item at that URL.
+
+If ARCHIVE-URL is nil, compute the new \"archive-contents\" file
+from the \"archive-contents\" at `package-archive-upload-base',
+if it exists."
+  (unless package-archive-upload-base
+    (error "No destination specified in `package-archive-upload-base'"))
   (save-excursion
     (save-restriction
       (let* ((file-type (cond
@@ -131,21 +173,14 @@ If nil, the \"gnu\" archive is used."
 	     (pkg-version (aref pkg-info 3))
 	     (commentary (aref pkg-info 4))
 	     (split-version (version-to-list pkg-version))
-	     (pkg-buffer (current-buffer))
+	     (pkg-buffer (current-buffer)))
 
-	     ;; Download latest archive-contents.
-	     (buffer (url-retrieve-synchronously
-		      (concat archive-url "archive-contents"))))
-
-	;; Parse archive-contents.
-	(set-buffer buffer)
-	(package-handle-response)
-	(re-search-forward "^$" nil 'move)
-	(forward-char)
-	(delete-region (point-min) (point))
-	(let ((contents (package-read-from-string
-			 (buffer-substring-no-properties (point-min)
-							 (point-max))))
+	;; Get archive-contents from ARCHIVE-URL if it's non-nil, or
+	;; from `package-archive-upload-base' otherwise.
+	(let ((contents (or (package--archive-contents-from-url archive-url)
+			    (package--archive-contents-from-file
+			     (concat package-archive-upload-base
+				     "archive-contents"))))
 	      (new-desc (vector split-version requires desc file-type)))
 	  (if (> (car contents) package-archive-version)
 	      (error "Unrecognized archive version %d" (car contents)))
@@ -176,7 +211,6 @@ If nil, the \"gnu\" archive is used."
 				  (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
@@ -184,8 +218,10 @@ If nil, the \"gnu\" archive is used."
 			nil nil nil 'excl)
 
 	  ;; Write a news entry.
-	  (package--update-news (concat file-name "." extension)
-				pkg-version desc archive-url)
+	  (and package-update-news-on-upload
+	       archive-url
+	       (package--update-news (concat file-name "." extension)
+				     pkg-version desc archive-url))
 
 	  ;; special-case "package": write a second copy so that the
 	  ;; installer can easily find the latest version.
@@ -196,7 +232,9 @@ If nil, the \"gnu\" archive is used."
 			    nil nil nil 'ask)))))))
 
 (defun package-upload-buffer ()
-  "Upload a single .el file to ELPA from the current buffer."
+  "Upload the current buffer as a single-file Emacs Lisp package.
+The variable `package-archive-upload-base' specifies the upload
+destination."
   (interactive)
   (save-excursion
     (save-restriction
@@ -205,6 +243,13 @@ If nil, the \"gnu\" archive is used."
 	(package-upload-buffer-internal pkg-info "el")))))
 
 (defun package-upload-file (file)
+  "Upload the Emacs Lisp package FILE to the package archive.
+Interactively, prompt for FILE.  The package is considered a
+single-file package if FILE ends in \".el\", and a multi-file
+package if FILE ends in \".tar\".
+
+The variable `package-archive-upload-base' specifies the upload
+destination."
   (interactive "fPackage file name: ")
   (with-temp-buffer
     (insert-file-contents-literally file)
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index ab5ba1bea56..2552ad4eb68 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -220,10 +220,15 @@ If VERSION is nil, the package is not loaded (it is \"disabled\")."
 (defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/"))
   "An alist of archives from which to fetch.
 The default value points to the GNU Emacs package repository.
-Each element has the form (ID . URL), where ID is an identifier
-string for an archive and URL is a http: URL (a string)."
+
+Each element has the form (ID . LOCATION).
+ ID is an archive name, as a string.
+ LOCATION specifies the base location for the archive.
+  If it starts with \"http:\", it is treated as a HTTP URL;
+  otherwise it should be an absolute directory name.
+  (Other types of URL are currently not supported.)"
   :type '(alist :key-type (string :tag "Archive name")
-                :value-type (string :tag "Archive URL"))
+                :value-type (string :tag "URL or directory name"))
   :risky t
   :group 'package
   :version "24.1")
@@ -617,8 +622,36 @@ Otherwise it uses an external `tar' program.
       (let ((load-path (cons pkg-dir load-path)))
 	(byte-recompile-directory pkg-dir 0 t)))))
 
+(defmacro package--with-work-buffer (location file &rest body)
+  "Run BODY in a buffer containing the contents of FILE at LOCATION.
+LOCATION is the base location of a package archive, and should be
+one of the URLs (or file names) specified in `package-archives'.
+FILE is the name of a file relative to that base location.
+
+This macro retrieves FILE from LOCATION into a temporary buffer,
+and evaluates BODY while that buffer is current.  This work
+buffer is killed afterwards.  Return the last value in BODY."
+  `(let* ((http (string-match "\\`http:" ,location))
+	  (buffer
+	   (if http
+	       (url-retrieve-synchronously (concat ,location ,file))
+	     (generate-new-buffer "*package work buffer*"))))
+     (prog1
+	 (with-current-buffer buffer
+	   (if http
+	       (progn (package-handle-response)
+		      (re-search-forward "^$" nil 'move)
+		      (forward-char)
+		      (delete-region (point-min) (point)))
+	     (unless (file-name-absolute-p ,location)
+	       (error "Archive location %s is not an absolute file name"
+		      ,location))
+	     (insert-file-contents (expand-file-name ,file ,location)))
+	   ,@body)
+       (kill-buffer buffer))))
+
 (defun package-handle-response ()
-  "Handle the response from the server.
+  "Handle the response from a `url-retrieve-synchronously' call.
 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.
@@ -627,7 +660,6 @@ It will move point to somewhere in the headers."
   (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)
@@ -635,28 +667,17 @@ It will move point to somewhere in the headers."
 
 (defun package-download-single (name version desc requires)
   "Download and install a single-file package."
-  (let ((buffer (url-retrieve-synchronously
-		 (concat (package-archive-url name)
-			 (symbol-name name) "-" version ".el"))))
-    (with-current-buffer buffer
-      (package-handle-response)
-      (re-search-forward "^$" nil 'move)
-      (forward-char)
-      (delete-region (point-min) (point))
-      (package-unpack-single (symbol-name name) version desc requires)
-      (kill-buffer buffer))))
+  (let ((location (package-archive-base name))
+	(file (concat (symbol-name name) "-" version ".el")))
+    (package--with-work-buffer location file
+      (package-unpack-single (symbol-name name) version desc requires))))
 
 (defun package-download-tar (name version)
   "Download and install a tar package."
-  (let ((tar-buffer (url-retrieve-synchronously
-		     (concat (package-archive-url name)
-			     (symbol-name name) "-" version ".tar"))))
-    (with-current-buffer tar-buffer
-      (package-handle-response)
-      (re-search-forward "^$" nil 'move)
-      (forward-char)
-      (package-unpack name version)
-      (kill-buffer tar-buffer))))
+  (let ((location (package-archive-base name))
+	(file (concat (symbol-name name) "-" version ".tar")))
+    (package--with-work-buffer location file
+      (package-unpack name version))))
 
 (defun package-installed-p (package &optional min-version)
   "Return true if PACKAGE, of VERSION or newer, is installed.
@@ -987,31 +1008,26 @@ The file can either be a tar file or an Emacs Lisp file."
       (error "Package `%s-%s' is a system package, not deleting"
 	     name version))))
 
-(defun package-archive-url (name)
+(defun package-archive-base (name)
   "Return the archive containing the package NAME."
   (let ((desc (cdr (assq (intern-soft name) package-archive-contents))))
     (cdr (assoc (aref desc (- (length desc) 1)) package-archives))))
 
 (defun package--download-one-archive (archive file)
-  "Download an archive file FILE from ARCHIVE, and cache it locally."
-  (let* ((archive-name (car archive))
-         (archive-url  (cdr archive))
-	 (dir (expand-file-name "archives" package-user-dir))
-	 (dir (expand-file-name archive-name dir))
-         (buffer (url-retrieve-synchronously (concat archive-url file))))
-    (with-current-buffer buffer
-      (package-handle-response)
-      (re-search-forward "^$" nil 'move)
-      (forward-char)
-      (delete-region (point-min) (point))
+  "Retrieve an archive file FILE from ARCHIVE, and cache it.
+ARCHIVE should be a cons cell of the form (NAME . LOCATION),
+similar to an entry in `package-alist'.  Save the cached copy to
+\"archives/NAME/archive-contents\" in `package-user-dir'."
+  (let* ((dir (expand-file-name "archives" package-user-dir))
+	 (dir (expand-file-name (car archive) dir)))
+    (package--with-work-buffer (cdr archive) file
       ;; Read the retrieved buffer to make sure it is valid (e.g. it
       ;; may fetch a URL redirect page).
       (when (listp (read buffer))
 	(make-directory dir t)
 	(setq buffer-file-name (expand-file-name file dir))
 	(let ((version-control 'never))
-	  (save-buffer))))
-    (kill-buffer buffer)))
+	  (save-buffer))))))
 
 (defun package-refresh-contents ()
   "Download the ELPA archive description if needed.
@@ -1176,27 +1192,21 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages."
 	    (while (re-search-forward "^\\(;+ ?\\)" nil t)
 	      (replace-match ""))))
       (let ((readme (expand-file-name (concat package-name "-readme.txt")
-				      package-user-dir)))
+				      package-user-dir))
+	    readme-string)
 	;; For elpa packages, try downloading the commentary.  If that
 	;; fails, try an existing readme file in `package-user-dir'.
-	(cond ((let ((buffer (ignore-errors
-			       (url-retrieve-synchronously
-				(concat (package-archive-url package)
-					package-name "-readme.txt"))))
-		     response)
-		 (when buffer
-		   (with-current-buffer buffer
-		     (setq response (url-http-parse-response))
-		     (if (or (< response 200) (>= response 300))
-			 (setq response nil)
-		       (setq buffer-file-name
-			     (expand-file-name readme package-user-dir))
-		       (delete-region (point-min) (1+ url-http-end-of-headers))
-		       (save-buffer)))
-		   (when response
-		     (insert-buffer-substring buffer)
-		     (kill-buffer buffer)
-		     t))))
+	(cond ((condition-case nil
+		   (package--with-work-buffer (package-archive-base package)
+					      (concat package-name "-readme.txt")
+		     (setq buffer-file-name
+			   (expand-file-name readme package-user-dir))
+		     (let ((version-control 'never))
+		       (save-buffer))
+		     (setq readme-string (buffer-string))
+		     t)
+		 (error nil))
+	       (insert readme-string))
 	      ((file-readable-p readme)
 	       (insert-file-contents readme)
 	       (goto-char (point-max))))))))
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 2300ebf721a..e95bcac2a70 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -3,7 +3,7 @@
 ;; Copyright (C) 2010-2011  Free Software Foundation, Inc.
 
 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords: 
+;; Keywords:
 
 ;; This file is part of GNU Emacs.
 
@@ -32,6 +32,14 @@
 ;;   could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)).
 ;;   But better would be if we could define new ways to match by having the
 ;;   extension provide its own `pcase--split-<foo>' thingy.
+;; - provide something like (setq VAR) so a var can be set rather than
+;;   let-bound.
+;; - provide a way to fallthrough to other cases.
+;; - try and be more clever to reduce the size of the decision tree, and
+;;   to reduce the number of leafs that need to be turned into function:
+;;   - first, do the tests shared by all remaining branches (it will have
+;;     to be performed anyway, so better so it first so it's shared).
+;;   - then choose the test that discriminates more (?).
 ;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to
 ;;   generate a lex-style DFA to decide whether to run E1 or E2.
 
@@ -65,12 +73,12 @@ If a SYMBOL is used twice in the same pattern (i.e. the pattern is
 QPatterns can take the following forms:
   (QPAT1 . QPAT2)	matches if QPAT1 matches the car and QPAT2 the cdr.
   ,UPAT			matches if the UPattern UPAT matches.
-  STRING			matches if the object is `equal' to STRING.
+  STRING		matches if the object is `equal' to STRING.
   ATOM			matches if the object is `eq' to ATOM.
 QPatterns for vectors are not implemented yet.
 
 PRED can take the form
-  FUNCTION	in which case it gets called with one argument.
+  FUNCTION	     in which case it gets called with one argument.
   (FUN ARG1 .. ARGN) in which case it gets called with N+1 arguments.
 A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION).
 PRED patterns can refer to variables bound earlier in the pattern.
@@ -222,6 +230,7 @@ of the form (UPAT EXP)."
 (defun pcase--if (test then else)
   (cond
    ((eq else :pcase--dontcare) then)
+   ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen?
    ((eq (car-safe else) 'if)
     (if (equal test (nth 1 else))
         ;; Doing a test a second time: get rid of the redundancy.
@@ -236,6 +245,8 @@ of the form (UPAT EXP)."
     `(cond (,test ,then)
            ;; Doing a test a second time: get rid of the redundancy, as above.
            ,@(remove (assoc test else) (cdr else))))
+   ;; Invert the test if that lets us reduce the depth of the tree.
+   ((memq (car-safe then) '(if cond)) (pcase--if `(not ,test) else then))
    (t `(if ,test ,then ,else))))
 
 (defun pcase--upat (qpattern)
@@ -280,6 +291,22 @@ MATCH is the pattern that needs to be matched, of the form:
 (defun pcase--and (match matches)
   (if matches `(and ,match ,@matches) match))
 
+(defconst pcase-mutually-exclusive-predicates
+  '((symbolp . integerp)
+    (symbolp . numberp)
+    (symbolp . consp)
+    (symbolp . arrayp)
+    (symbolp . stringp)
+    (integerp . consp)
+    (integerp . arrayp)
+    (integerp . stringp)
+    (numberp . consp)
+    (numberp . arrayp)
+    (numberp . stringp)
+    (consp . arrayp)
+    (consp . stringp)
+    (arrayp . stringp)))
+
 (defun pcase--split-match (sym splitter match)
   (cond
     ((eq (car match) 'match)
@@ -340,8 +367,14 @@ MATCH is the pattern that needs to be matched, of the form:
       (cons `(and (match ,syma . ,(pcase--upat (car qpat)))
                   (match ,symd . ,(pcase--upat (cdr qpat))))
             :pcase--fail)))
-   ;; A QPattern but not for a cons, can only go the `else' side.
-   ((eq (car-safe pat) '\`) (cons :pcase--fail nil))))
+   ;; A QPattern but not for a cons, can only go to the `else' side.
+   ((eq (car-safe pat) '\`) (cons :pcase--fail nil))
+   ((and (eq (car-safe pat) 'pred)
+         (or (member (cons 'consp (cadr pat))
+                     pcase-mutually-exclusive-predicates)
+             (member (cons (cadr pat) 'consp)
+                     pcase-mutually-exclusive-predicates)))
+    (cons :pcase--fail nil))))
 
 (defun pcase--split-equal (elem pat)
   (cond
@@ -353,7 +386,12 @@ MATCH is the pattern that needs to be matched, of the form:
          ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
          ;;     (consp (cadr pat)))
          )
-    (cons :pcase--fail nil))))
+    (cons :pcase--fail nil))
+   ((and (eq (car-safe pat) 'pred)
+         (symbolp (cadr pat))
+         (get (cadr pat) 'side-effect-free)
+         (funcall (cadr pat) elem))
+    (cons :pcase--succeed nil))))
 
 (defun pcase--split-member (elems pat)
   ;; Based on pcase--split-equal.
@@ -370,13 +408,39 @@ MATCH is the pattern that needs to be matched, of the form:
          ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
          ;;     (consp (cadr pat)))
          )
-    (cons :pcase--fail nil))))
+    (cons :pcase--fail nil))
+   ((and (eq (car-safe pat) 'pred)
+         (symbolp (cadr pat))
+         (get (cadr pat) 'side-effect-free)
+         (let ((p (cadr pat)) (all t))
+           (dolist (elem elems)
+             (unless (funcall p elem) (setq all nil)))
+           all))
+    (cons :pcase--succeed nil))))
 
 (defun pcase--split-pred (upat pat)
   ;; FIXME: For predicates like (pred (> a)), two such predicates may
   ;; actually refer to different variables `a'.
-  (if (equal upat pat)
-      (cons :pcase--succeed :pcase--fail)))
+  (cond
+   ((equal upat pat) (cons :pcase--succeed :pcase--fail))
+   ((and (eq 'pred (car upat))
+         (eq 'pred (car-safe pat))
+         (or (member (cons (cadr upat) (cadr pat))
+                     pcase-mutually-exclusive-predicates)
+             (member (cons (cadr pat) (cadr upat))
+                     pcase-mutually-exclusive-predicates)))
+    (cons :pcase--fail nil))
+   ;; ((and (eq 'pred (car upat))
+   ;;       (eq '\` (car-safe pat))
+   ;;       (symbolp (cadr upat))
+   ;;       (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
+   ;;       (get (cadr upat) 'side-effect-free)
+   ;;       (progn (message "Trying predicate %S" (cadr upat))
+   ;;              (ignore-errors
+   ;;                (funcall (cadr upat) (cadr pat)))))
+   ;;  (message "Simplify pred %S against %S" upat pat)
+   ;;  (cons nil :pcase--fail))
+   ))
 
 (defun pcase--fgrep (vars sexp)
   "Check which of the symbols VARS appear in SEXP."
@@ -391,7 +455,7 @@ MATCH is the pattern that needs to be matched, of the form:
 ;; bootstrapping problems.
 (defun pcase--u1 (matches code vars rest)
   "Return code that runs CODE (with VARS) if MATCHES match.
-and otherwise defers to REST which is a list of branches of the form
+Otherwise, it defers to REST which is a list of branches of the form
 \(ELSE-MATCH ELSE-CODE . ELSE-VARS)."
   ;; Depending on the order in which we choose to check each of the MATCHES,
   ;; the resulting tree may be smaller or bigger.  So in general, we'd want
@@ -452,8 +516,9 @@ and otherwise defers to REST which is a list of branches of the form
        ((eq upat 'dontcare) :pcase--dontcare)
        ((functionp upat)  (error "Feature removed, use (pred %s)" upat))
        ((memq (car-safe upat) '(guard pred))
+        (if (eq (car upat) 'pred) (put sym 'pcase-used t))
         (let* ((splitrest
-                (pcase--split-rest
+            (pcase--split-rest
                  sym (apply-partially #'pcase--split-pred upat) rest))
                (then-rest (car splitrest))
                (else-rest (cdr splitrest)))
@@ -480,6 +545,7 @@ and otherwise defers to REST which is a list of branches of the form
                      (pcase--u1 matches code vars then-rest)
                      (pcase--u else-rest))))
        ((symbolp upat)
+        (put sym 'pcase-used t)
         (if (not (assq upat vars))
             (pcase--u1 matches code (cons (cons upat sym) vars) rest)
           ;; Non-linear pattern.  Turn it into an `eq' test.
@@ -487,6 +553,7 @@ and otherwise defers to REST which is a list of branches of the form
                            matches)
                      code vars rest)))
        ((eq (car-safe upat) '\`)
+        (put sym 'pcase-used t)
         (pcase--q1 sym (cadr upat) matches code vars rest))
        ((eq (car-safe upat) 'or)
         (let ((all (> (length (cdr upat)) 1))
@@ -546,7 +613,7 @@ and otherwise defers to REST which is a list of branches of the form
 
 (defun pcase--q1 (sym qpat matches code vars rest)
   "Return code that runs CODE if SYM matches QPAT and if MATCHES match.
-and if not, defers to REST which is a list of branches of the form
+Otherwise, it defers to REST which is a list of branches of the form
 \(OTHER_MATCH OTHER-CODE . OTHER-VARS)."
   (cond
    ((eq (car-safe qpat) '\,) (error "Can't use `,UPATTERN"))
@@ -555,22 +622,28 @@ and if not, defers to REST which is a list of branches of the form
     ;; FIXME.
     (error "Vector QPatterns not implemented yet"))
    ((consp qpat)
-    (let ((syma (make-symbol "xcar"))
-          (symd (make-symbol "xcdr")))
-      (let* ((splitrest (pcase--split-rest
-                         sym
-                         (apply-partially #'pcase--split-consp syma symd)
-                         rest))
-             (then-rest (car splitrest))
-             (else-rest (cdr splitrest)))
-        (pcase--if `(consp ,sym)
-                   `(let ((,syma (car ,sym))
-                          (,symd (cdr ,sym)))
-                      ,(pcase--u1 `((match ,syma . ,(pcase--upat (car qpat)))
-                                    (match ,symd . ,(pcase--upat (cdr qpat)))
-                                    ,@matches)
-                                  code vars then-rest))
-                   (pcase--u else-rest)))))
+    (let* ((syma (make-symbol "xcar"))
+           (symd (make-symbol "xcdr"))
+           (splitrest (pcase--split-rest
+                       sym
+                       (apply-partially #'pcase--split-consp syma symd)
+                       rest))
+           (then-rest (car splitrest))
+           (else-rest (cdr splitrest))
+           (then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat)))
+                                   (match ,symd . ,(pcase--upat (cdr qpat)))
+                                   ,@matches)
+                                 code vars then-rest)))
+      (pcase--if
+       `(consp ,sym)
+       ;; We want to be careful to only add bindings that are used.
+       ;; The byte-compiler could do that for us, but it would have to pay
+       ;; attention to the `consp' test in order to figure out that car/cdr
+       ;; can't signal errors and our byte-compiler is not that clever.
+       `(let (,@(if (get syma 'pcase-used) `((,syma (car ,sym))))
+              ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym)))))
+          ,then-body)
+       (pcase--u else-rest))))
    ((or (integerp qpat) (symbolp qpat) (stringp qpat))
       (let* ((splitrest (pcase--split-rest
                          sym (apply-partially 'pcase--split-equal qpat) rest))