procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge from trunk

Browse source
This commit is contained in:
Stefan Monnier 2011-03-06 16:22:16 -05:00
commit 0d6459dfb5
280 changed files with 17698 additions and 14132 deletions
Download patch file Download diff file Expand all files Collapse all files

10
lisp/emacs-lisp/assoc.el
View file

@ -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)

16
lisp/emacs-lisp/autoload.el
View file

@ -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))))

1
lisp/emacs-lisp/bytecomp.el
View file

@ -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

18
lisp/emacs-lisp/cl-loaddefs.el
View file

@ -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)

2
lisp/emacs-lisp/cl-macs.el
View file

@ -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)"

2
lisp/emacs-lisp/elp.el
View file

@ -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))))))

62
lisp/emacs-lisp/ert.el
View file

@ -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)

2
lisp/emacs-lisp/ewoc.el
View file

@ -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)

89
lisp/emacs-lisp/package-x.el
View file

@ -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)

124
lisp/emacs-lisp/package.el
View file

@ -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))))))))

129
lisp/emacs-lisp/pcase.el
View file

@ -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))