summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/authors.el12
-rw-r--r--lisp/emacs-lisp/find-gc.el2
-rw-r--r--lisp/emacs-lisp/package-x.el34
-rw-r--r--lisp/emacs-lisp/package.el322
-rw-r--r--lisp/emacs-lisp/pcase.el489
-rw-r--r--lisp/emacs-lisp/re-builder.el25
-rw-r--r--lisp/emacs-lisp/syntax.el2
-rw-r--r--lisp/emacs-lisp/timer.el6
8 files changed, 695 insertions, 197 deletions
diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el
index 020729e2c76..5aea033fc78 100644
--- a/lisp/emacs-lisp/authors.el
+++ b/lisp/emacs-lisp/authors.el
@@ -354,7 +354,7 @@ Changes to files in this list are not listed.")
;; No longer distributed.
;;; ("Viktor Dukhovni" :wrote "unexsunos4.c")
("Paul Eggert" :wrote "rcs2log" "vcdiff")
- ("Fred Fish" :changed "unexec.c")
+ ("Fred Fish" :changed "unexcoff.c")
;; No longer distributed.
;;; ("Tim Fleehart" :wrote "makefile.nt")
("Keith Gabryelski" :wrote "hexl.c")
@@ -377,13 +377,13 @@ Changes to files in this list are not listed.")
"indent.c" "search.c" "xdisp.c" "region-cache.c" "region-cache.h")
;; ibmrt.h, ibmrt-aix.h no longer distributed.
("International Business Machines" :changed "emacs.c" "fileio.c"
- "process.c" "sysdep.c" "unexec.c")
+ "process.c" "sysdep.c" "unexcoff.c")
;; No longer distributed.
;;; ("Ishikawa Chiaki" :changed "aviion.h" "dgux.h")
;; ymakefile no longer distributed.
("Michael K. Johnson" :changed "configure.in" "emacs.c" "intel386.h"
"mem-limits.h" "process.c" "template.h" "sysdep.c" "syssignal.h"
- "systty.h" "unexec.c" "linux.h")
+ "systty.h" "unexcoff.c" "linux.h")
;; No longer distributed.
;;; ("Kyle Jones" :wrote "mldrag.el")
("Henry Kautz" :wrote "bib-mode.el")
@@ -408,7 +408,7 @@ Changes to files in this list are not listed.")
"rmail.el" "rmailedit.el" "rmailkwd.el"
"rmailmsc.el" "rmailout.el" "rmailsum.el" "scribe.el"
;; It was :wrote for xmenu.c, but it has been rewritten since.
- "server.el" "lisp.h" "sysdep.c" "unexec.c" "xmenu.c")
+ "server.el" "lisp.h" "sysdep.c" "unexcoff.c" "xmenu.c")
("Niall Mansfield" :changed "etags.c")
("Brian Marick" :cowrote "hideif.el")
("Marko Kohtala" :changed "info.el")
@@ -463,9 +463,9 @@ Changes to files in this list are not listed.")
("Kayvan Sylvan" :changed "supercite.el")
;; No longer distributed: emacsserver.c, tcp.c.
("Spencer Thomas" :changed "emacsclient.c" "server.el"
- "dabbrev.el" "unexec.c" "gnus.texi")
+ "dabbrev.el" "unexcoff.c" "gnus.texi")
("Jonathan Vail" :changed "vc.el")
- ("James Van Artsdalen" :changed "usg5-4.h" "unexec.c")
+ ("James Van Artsdalen" :changed "usg5-4.h" "unexcoff.c")
;; No longer distributed: src/makefile.nt, lisp/makefile.nt
;; winnt.el renamed to w32-fns.el; nt.[ch] to w32.[ch];
;; ntheap.[ch] to w32heap.[ch]; ntinevt.c to w32inevt.c;
diff --git a/lisp/emacs-lisp/find-gc.el b/lisp/emacs-lisp/find-gc.el
index 3ca1df466b9..49d3a7075d4 100644
--- a/lisp/emacs-lisp/find-gc.el
+++ b/lisp/emacs-lisp/find-gc.el
@@ -60,7 +60,7 @@ Each entry has the form (FUNCTION . FUNCTIONS-IT-CALLS).")
"indent.c" "search.c" "regex.c" "undo.c"
"alloc.c" "data.c" "doc.c" "editfns.c"
"callint.c" "eval.c" "fns.c" "print.c" "lread.c"
- "abbrev.c" "syntax.c" "unexec.c"
+ "abbrev.c" "syntax.c" "unexcoff.c"
"bytecode.c" "process.c" "callproc.c" "doprnt.c"
"x11term.c" "x11fns.c"))
diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el
index 21bd7960d89..b93950049e0 100644
--- a/lisp/emacs-lisp/package-x.el
+++ b/lisp/emacs-lisp/package-x.el
@@ -56,12 +56,12 @@
(setq string (replace-match """ t nil string)))
string)
-(defun package--make-rss-entry (title text)
+(defun package--make-rss-entry (title text archive-url)
(let ((date-string (format-time-string "%a, %d %B %Y %T %z")))
(concat "<item>\n"
"<title>" (package--encode title) "</title>\n"
;; FIXME: should have a link in the web page.
- "<link>" package-archive-base "news.html</link>\n"
+ "<link>" archive-url "news.html</link>\n"
"<description>" (package--encode text) "</description>\n"
"<pubDate>" date-string "</pubDate>\n"
"</item>\n")))
@@ -85,7 +85,7 @@
(unless old-buffer
(kill-buffer (current-buffer)))))))
-(defun package-maint-add-news-item (title description)
+(defun package-maint-add-news-item (title description archive-url)
"Add a news item to the ELPA web pages.
TITLE is the title of the news item.
DESCRIPTION is the text of the news item.
@@ -93,21 +93,28 @@ 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--make-rss-entry title description archive-url))
(package--update-file (concat package-archive-upload-base "news.html")
"New entries go here"
(package--make-html-entry title description)))
-(defun package--update-news (package version description)
+(defun package--update-news (package version description archive-url)
"Update the ELPA web pages when a package is uploaded."
(package-maint-add-news-item (concat package " version " version)
- description))
+ description
+ archive-url))
-(defun package-upload-buffer-internal (pkg-info extension)
+(defun package-upload-buffer-internal (pkg-info extension &optional archive-url)
"Upload a package whose contents are in the current buffer.
PKG-INFO is the package info, see `package-buffer-info'.
EXTENSION is the file extension, a string. It can be either
-\"el\" or \"tar\"."
+\"el\" or \"tar\".
+
+Optional arg ARCHIVE-URL is the URL of the destination archive.
+If nil, the \"gnu\" archive is used."
+ (unless archive-url
+ (or (setq archive-url (cdr (assoc "gnu" package-archives)))
+ (error "No destination URL")))
(save-excursion
(save-restriction
(let* ((file-type (cond
@@ -122,12 +129,12 @@ EXTENSION is the file extension, a string. It can be either
(aref pkg-info 2)))
(pkg-version (aref pkg-info 3))
(commentary (aref pkg-info 4))
- (split-version (package-version-split pkg-version))
+ (split-version (version-to-list pkg-version))
(pkg-buffer (current-buffer))
;; Download latest archive-contents.
(buffer (url-retrieve-synchronously
- (concat package-archive-base "archive-contents"))))
+ (concat archive-url "archive-contents"))))
;; Parse archive-contents.
(set-buffer buffer)
@@ -143,9 +150,8 @@ EXTENSION is the file extension, a string. It can be either
(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))
- '<=)
+ (if (version-list-<= split-version
+ (package-desc-vers (cdr elt)))
(error "New package has smaller version: %s" pkg-version)
(setcdr elt new-desc))
(setq contents (cons (car contents)
@@ -178,7 +184,7 @@ EXTENSION is the file extension, a string. It can be either
;; Write a news entry.
(package--update-news (concat file-name "." extension)
- pkg-version desc)
+ pkg-version desc archive-url)
;; special-case "package": write a second copy so that the
;; installer can easily find the latest version.
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index c6035442313..2e8c7dc7d4f 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -43,9 +43,6 @@
;; 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.
@@ -55,11 +52,13 @@
;; 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
+;; A .el file is named "NAME-VERSION.el" in the remote archive, but is
;; installed as simply "NAME.el" in a directory named "NAME-VERSION".
-;; The downloader will download all dependent packages. It will also
-;; byte-compile the package's lisp at install time.
+;; The downloader downloads all dependent packages. By default,
+;; packages come from the official GNU sources, but others may be
+;; added by customizing the `package-archives' alist. Packages get
+;; byte-compiled at install time.
;; At activation time we will set up the load-path and the info path,
;; and we will load the package's autoloads. If a package's
@@ -207,6 +206,7 @@ If VERSION is a string, only that version is ever loaded.
Hence, the package is \"held\" at that version.
If VERSION is nil, the package is not loaded (it is \"disabled\")."
:type '(repeat symbol)
+ :risky t
:group 'package
:version "24.1")
@@ -217,10 +217,16 @@ If VERSION is nil, the package is not loaded (it is \"disabled\")."
(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.")
+(defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/"))
+ "An alist of archives from which to fetch.
+The default value points to the GNU Emacs package repository.
+Each element has the form (ID . URL), where ID is an identifier
+string for an archive and URL is a http: URL (a string)."
+ :type '(alist :key-type (string :tag "Archive name")
+ :value-type (string :tag "Archive URL"))
+ :risky t
+ :group 'package
+ :version "24.1")
(defconst package-archive-version 1
"Version number of the package archive understood by this file.
@@ -234,8 +240,10 @@ Lower version numbers than this will probably be understood as well.")
"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.")
+but have extra entries: one which is 'tar for tar packages and
+'single for single-file packages, and one which is the name of
+the archive from which it came.")
+(put 'package-archive-contents 'risky-local-variable t)
(defcustom package-user-dir (locate-user-emacs-file "elpa")
"Directory containing the user's Emacs Lisp packages.
@@ -243,6 +251,7 @@ The directory name should be absolute.
Apart from this directory, Emacs also looks for system-wide
packages in `package-directory-list'."
:type 'directory
+ :risky t
:group 'package
:version "24.1")
@@ -259,19 +268,16 @@ Each directory name should be absolute.
These directories contain packages intended for system-wide; in
contrast, `package-user-dir' contains packages for personal use."
:type '(repeat directory)
+ :risky t
:group 'package
:version "24.1")
-(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
+ `((emacs . [,(version-to-list emacs-version) nil
"GNU Emacs"])
- (package . [,(package-version-split package-el-version)
+ (package . [,(version-to-list package-el-version)
nil "Simple package system for GNU Emacs"]))
"Packages which are always built-in.")
@@ -282,17 +288,18 @@ contrast, `package-user-dir' contains packages for personal use."
(if (>= emacs-major-version 22)
;; FIXME: emacs 22 includes tramp, rcirc, maybe
;; other things...
- '((erc . [(5 2) nil "An Emacs Internet Relay Chat client"])
+ '((erc . [(5 2) nil "Internet Relay Chat client"])
;; The external URL is version 1.15, so make sure the
;; built-in one looks newer.
(url . [(1 16) nil "URL handling libary"])))
(if (>= emacs-major-version 23)
'(;; Strangely, nxml-version is missing in Emacs 23.
;; We pick the merge date as the version.
- (nxml . [(20071123) nil "Major mode for editing XML documents."])
- (bubbles . [(0 5) nil "Puzzle game for Emacs."])))))
+ (nxml . [(20071123) nil "Major mode for XML documents"])
+ (bubbles . [(0 5) nil "A puzzle game"])))))
"Alist of all built-in packages.
Maps the package name to a vector [VERSION REQS DOCSTRING].")
+(put 'package--builtins 'risky-local-variable t)
(defvar package-alist package--builtins
"Alist of all packages available for activation.
@@ -301,15 +308,18 @@ This maps the package name to a vector [VERSION REQS DOCSTRING].
The value is generated by `package-load-descriptor', usually
called via `package-initialize'. For user customizations of
which packages to load/activate, see `package-load-list'.")
+(put 'package-archive-contents 'risky-local-variable t)
(defvar package-activated-list
(mapcar #'car package-alist)
"List of the names of currently activated packages.")
+(put 'package-activated-list 'risky-local-variable t)
(defvar package-obsolete-alist nil
"Representation of obsolete packages.
Like `package-alist', but maps package name to a second alist.
The inner alist is keyed by version.")
+(put 'package-obsolete-alist 'risky-local-variable t)
(defconst package-subdirectory-regexp
"^\\([^.].*\\)-\\([0-9]+\\(?:[.][0-9]+\\)*\\)$"
@@ -321,39 +331,6 @@ The second subexpression is the version string.")
"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\""
@@ -361,16 +338,14 @@ E.g., if given \"quux-23.0\", will return \"quux\""
(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))))
+ "Load the description file in directory DIR for package PACKAGE."
+ (let* ((pkg-dir (expand-file-name package dir))
+ (pkg-file (expand-file-name
+ (concat (package-strip-version package) "-pkg")
+ pkg-dir)))
+ (when (and (file-directory-p pkg-dir)
+ (file-exists-p (concat pkg-file ".el")))
+ (load pkg-file nil t))))
(defun package-load-all-descriptors ()
"Load descriptors for installed Emacs Lisp packages.
@@ -399,9 +374,8 @@ updates `package-alist' and `package-obsolete-alist'."
((eq force t)
t)
((stringp force) ; held
- (package-version-compare (package-version-split version)
- (package-version-split force)
- '=))
+ (version-list-= (version-to-list version)
+ (version-to-list force)))
(t
(error "Invalid element in `package-load-list'")))
(package-load-descriptor dir subdir))))))))
@@ -458,8 +432,7 @@ updates `package-alist' and `package-obsolete-alist'."
(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 '=))))
+ (and elt (version-list-= (package-desc-vers (cdr elt)) version))))
;; FIXME: return a reason instead?
(defun package-activate (package version)
@@ -477,7 +450,7 @@ Return nil if the package could not be activated."
(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 '>))))
+ (version-list-< version this-version))))
(while (and req-list keep-going)
(let* ((req (car req-list))
(req-name (car req))
@@ -491,7 +464,7 @@ Return nil if the package could not be activated."
;; 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 '>=))))))
+ (version-list-<= version this-version))))))
(defun package-mark-obsolete (package pkg-vec)
"Put package on the obsolete list, if not already there."
@@ -521,21 +494,20 @@ 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-version (version-to-list version-string))
(new-pkg-desc
(cons name
(vector new-version
(mapcar
(lambda (elt)
(list (car elt)
- (package-version-split (car (cdr elt)))))
+ (version-to-list (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))
- '>))
+ (version-list-< (package-desc-vers (cdr pkg-desc))
+ new-version))
(progn
(when pkg-desc
;; Remove old package and declare it obsolete.
@@ -546,9 +518,8 @@ Each requirement is of the form (OTHER-PACKAGE \"VERSION\")."
;; 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))
- '=)
+ (unless (version-list-= new-version
+ (package-desc-vers (cdr pkg-desc)))
;; The package is born obsolete.
(package-mark-obsolete (car new-pkg-desc) (cdr new-pkg-desc))))))
@@ -613,20 +584,23 @@ Otherwise it uses an external `tar' program.
(let ((load-path (cons pkg-dir load-path)))
(byte-recompile-directory pkg-dir 0 t)))))
+(defun package--write-file-no-coding (file-name excl)
+ (let ((buffer-file-coding-system 'no-conversion))
+ (write-region (point-min) (point-max) file-name nil nil nil excl)))
+
(defun package-unpack-single (file-name version desc requires)
"Install the contents of the current buffer as a package."
;; Special case "package".
(if (string= file-name "package")
- (write-region (point-min) (point-max)
- (expand-file-name (concat file-name ".el")
- package-user-dir)
- nil nil nil nil)
+ (package--write-file-no-coding
+ (expand-file-name (concat file-name ".el") package-user-dir)
+ nil)
(let* ((pkg-dir (expand-file-name (concat file-name "-" version)
package-user-dir))
(el-file (expand-file-name (concat file-name ".el") pkg-dir))
(pkg-file (expand-file-name (concat file-name "-pkg.el") pkg-dir)))
(make-directory pkg-dir t)
- (write-region (point-min) (point-max) el-file nil nil nil 'excl)
+ (package--write-file-no-coding el-file 'excl)
(let ((print-level nil)
(print-length nil))
(write-region
@@ -670,7 +644,7 @@ 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-base
+ (concat (package-archive-url name)
(symbol-name name) "-" version ".el"))))
(with-current-buffer buffer
(package-handle-response)
@@ -683,7 +657,7 @@ It will move point to somewhere in the headers."
(defun package-download-tar (name version)
"Download and install a tar package."
(let ((tar-buffer (url-retrieve-synchronously
- (concat package-archive-base
+ (concat (package-archive-url name)
(symbol-name name) "-" version ".tar"))))
(with-current-buffer tar-buffer
(package-handle-response)
@@ -692,12 +666,11 @@ It will move point to somewhere in the headers."
(package-unpack name version)
(kill-buffer tar-buffer))))
-(defun package-installed-p (package version)
+(defun package-installed-p (package &optional min-version)
(let ((pkg-desc (assq package package-alist)))
(and pkg-desc
- (package-version-compare version
- (package-desc-vers (cdr pkg-desc))
- '>=))))
+ (version-list-<= min-version
+ (package-desc-vers (cdr pkg-desc))))))
(defun package-compute-transaction (result requirements)
(dolist (elt requirements)
@@ -715,9 +688,7 @@ It will move point to somewhere in the headers."
(symbol-name next-pkg)))
((null (stringp hold))
(error "Invalid element in `package-load-list'"))
- ((package-version-compare next-version
- (package-version-split hold)
- '>)
+ ((version-list-< (version-to-list hold) next-version)
(error "Package '%s' held at version %s, \
but version %s required"
(symbol-name next-pkg) hold
@@ -725,9 +696,8 @@ but version %s required"
(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
- '>=)
+ (unless (version-list-<= next-version
+ (package-desc-vers (cdr pkg-desc)))
(error
"Need package '%s' with version %s, but only %s is available"
(symbol-name next-pkg) (package-version-join next-version)
@@ -772,27 +742,50 @@ Will throw an error if the archive version is too new."
(car contents) package-archive-version))
(cdr contents))))))
-(defun package-read-archive-contents ()
+(defun package-read-all-archive-contents ()
"Re-read `archive-contents' and `builtin-packages', if they exist.
Set `package-archive-contents' and `package--builtins' if successful.
Throw an error if the archive version is too new."
- (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))
+ (dolist (archive package-archives)
+ (package-read-archive-contents (car archive)))
+ (let ((builtins (package--read-archive-file "builtin-packages")))
(if builtins
;; Version 1 of 'builtin-packages' is a list where the car is
;; a split emacs version and the cdr is an alist suitable for
;; package--builtins.
- (let ((our-version (package-version-split emacs-version))
+ (let ((our-version (version-to-list emacs-version))
(result package--builtins-base))
(setq package--builtins
(dolist (elt builtins result)
- (if (package-version-compare our-version (car elt) '>=)
+ (if (version-list-<= (car elt) our-version)
(setq result (append (cdr elt) result)))))))))
+(defun package-read-archive-contents (archive)
+ "Re-read `archive-contents' and `builtin-packages' for ARCHIVE.
+If successful, set `package-archive-contents' and `package--builtins'.
+If the archive version is too new, signal an error."
+ (let ((archive-contents (package--read-archive-file
+ (concat "archives/" archive
+ "/archive-contents"))))
+ (if archive-contents
+ ;; Version 1 of 'archive-contents' is identical to our
+ ;; internal representation.
+ ;; TODO: merge archive lists
+ (dolist (package archive-contents)
+ (package--add-to-archive-contents package archive)))))
+
+(defun package--add-to-archive-contents (package archive)
+ "Add the PACKAGE from the given ARCHIVE if necessary.
+Also, add the originating archive to the end of the package vector."
+ (let* ((name (car package))
+ (version (aref (cdr package) 0))
+ (entry (cons (car package)
+ (vconcat (cdr package) (vector archive))))
+ (existing-package (cdr (assq name package-archive-contents))))
+ (when (or (not existing-package)
+ (version-list-< (aref existing-package 0) version))
+ (add-to-list 'package-archive-contents entry))))
+
(defun package-download-transaction (transaction)
"Download and install all the packages in the given transaction."
(dolist (elt transaction)
@@ -817,26 +810,21 @@ Throw an error if the archive version is too new."
(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'."
+The package is found on one of the archives in `package-archives'."
(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)))))
+ (list (intern (completing-read "Install package: "
+ (mapcar (lambda (elt)
+ (cons (symbol-name (car elt))
+ nil))
+ package-archive-contents)
+ nil t))))
(let ((pkg-desc (assq name package-archive-contents)))
(unless pkg-desc
- (error "Package '%s' not available for installation"
+ (error "Package '%s' is not available for installation"
(symbol-name name)))
- (let ((transaction
- (package-compute-transaction (list name)
- (package-desc-reqs (cdr pkg-desc)))))
- (package-download-transaction transaction)))
+ (package-download-transaction
+ (package-compute-transaction (list name)
+ (package-desc-reqs (cdr pkg-desc)))))
;; Try to activate it.
(package-initialize))
@@ -891,7 +879,7 @@ May narrow buffer or move point even on failure."
(mapcar
(lambda (elt)
(list (car elt)
- (package-version-split (car (cdr elt)))))
+ (version-to-list (car (cdr elt)))))
requires))
(set-text-properties 0 (length file-name) nil file-name)
(set-text-properties 0 (length pkg-version) nil pkg-version)
@@ -940,7 +928,7 @@ The return result is a vector like `package-buffer-info'."
(mapcar
(lambda (elt)
(list (car elt)
- (package-version-split (car (cdr elt)))))
+ (version-to-list (car (cdr elt)))))
requires))
(vector pkg-name requires docstring version-string readme))))
@@ -996,20 +984,28 @@ The file can either be a tar file or an Emacs Lisp file."
;; 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))))
+(defun package-archive-url (name)
+ "Return the archive containing the package NAME."
+ (let ((desc (cdr (assq (intern-soft name) package-archive-contents))))
+ (cdr (assoc (aref desc (- (length desc) 1)) package-archives))))
+
+(defun package--download-one-archive (archive file)
+ "Download an archive file FILE from ARCHIVE, and cache it locally."
+ (let* ((archive-name (car archive))
+ (archive-url (cdr archive))
+ (dir (expand-file-name "archives" package-user-dir))
+ (dir (expand-file-name archive-name dir))
+ (buffer (url-retrieve-synchronously (concat archive-url file))))
(with-current-buffer buffer
(package-handle-response)
(re-search-forward "^$" nil 'move)
(forward-char)
(delete-region (point-min) (point))
- (setq buffer-file-name (concat (file-name-as-directory package-user-dir)
- file))
+ (make-directory dir t)
+ (setq buffer-file-name (expand-file-name file dir))
(let ((version-control 'never))
- (save-buffer))
- (kill-buffer buffer))))
+ (save-buffer)))
+ (kill-buffer buffer)))
(defun package-refresh-contents ()
"Download the ELPA archive description if needed.
@@ -1019,9 +1015,9 @@ 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))
+ (dolist (archive package-archives)
+ (package--download-one-archive archive "archive-contents"))
+ (package-read-all-archive-contents))
;;;###autoload
(defun package-initialize ()
@@ -1030,7 +1026,7 @@ The variable `package-load-list' controls which packages to load."
(interactive)
(setq package-obsolete-alist nil)
(package-load-all-descriptors)
- (package-read-archive-contents)
+ (package-read-all-archive-contents)
;; Try to activate all our packages.
(mapc (lambda (elt)
(package-activate (car elt) (package-desc-vers (cdr elt))))
@@ -1306,11 +1302,12 @@ available for download."
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"))))
+ (let* ((pkg-name (package-menu-get-package))
+ (buffer (url-retrieve-synchronously
+ (concat (package-archive-url pkg-name)
+ pkg-name
+ "-readme.txt")))
+ start-point ok)
(with-current-buffer buffer
;; FIXME: it would be nice to work with any URL type.
(setq start-point url-http-end-of-headers)
@@ -1322,7 +1319,7 @@ For larger packages, shows the README file."
(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"))
+ (insert "This package lacks a README file or commentary.\n"))
(goto-char (point-min))
(view-mode)))
(display-buffer new-buffer t))))
@@ -1355,7 +1352,6 @@ 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))
@@ -1380,7 +1376,7 @@ Emacs."
(defun package-print-package (package version key desc)
(let ((face
- (cond ((eq package 'emacs) 'font-lock-builtin-face)
+ (cond ((string= key "built-in") 'font-lock-builtin-face)
((string= key "available") 'default)
((string= key "held") 'font-lock-constant-face)
((string= key "disabled") 'font-lock-warning-face)
@@ -1402,7 +1398,9 @@ Emacs."
;; FIXME: this 'when' is bogus...
(when desc
(indent-to 43 1)
- (insert (propertize desc 'font-lock-face face)))
+ (let ((opoint (point)))
+ (insert (propertize desc 'font-lock-face face))
+ (upcase-region opoint (min (point) (1+ opoint)))))
(insert "\n")))
(defun package-list-maybe-add (package version status description result)
@@ -1420,22 +1418,30 @@ Emacs."
(setq buffer-read-only nil)
(erase-buffer)
(let ((info-list)
- name desc hold)
+ name desc hold
+ builtin)
;; List installed packages
(dolist (elt package-alist)
+ ;; Ignore the Emacs package.
(setq name (car elt)
desc (cdr elt)
hold (assq name package-load-list))
- (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)))
+ (unless (eq name 'emacs)
+ (setq info-list
+ (package-list-maybe-add
+ name (package-desc-vers desc)
+ ;; FIXME: it turns out to be tricky to see if this
+ ;; package is presently activated.
+ (cond ((stringp (cadr hold))
+ "held")
+ ((and (setq builtin (assq name package--builtins))
+ (version-list-=
+ (package-desc-vers (cdr builtin))
+ (package-desc-vers desc)))
+ "built-in")
+ (t "installed"))
+ (package-desc-doc desc)
+ info-list))))
;; List available packages
(dolist (elt package-archive-contents)
(setq name (car elt)
@@ -1443,7 +1449,7 @@ Emacs."
hold (assq name package-load-list))
(unless (and hold (stringp (cadr hold))
(package-installed-p
- name (package-version-split (cadr hold))))
+ name (version-to-list (cadr hold))))
(setq info-list
(package-list-maybe-add name
(package-desc-vers desc)
@@ -1532,8 +1538,8 @@ Helper function that does all the work for the user-facing functions."
'((0 . "")
(2 . "Package")
(20 . "Version")
- (30 . "Status")
- (41 . "Description"))
+ (32 . "Status")
+ (43 . "Description"))
""))
;; It's okay to use pop-to-buffer here. The package menu buffer
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
new file mode 100644
index 00000000000..03d760b2df5
--- /dev/null
+++ b/lisp/emacs-lisp/pcase.el
@@ -0,0 +1,489 @@
+;;; pcase.el --- ML-style pattern-matching macro for Elisp
+
+;; Copyright (C) 2010 Stefan Monnier
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords:
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; ML-style pattern matching.
+;; The entry points are autoloaded.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+;; Macro-expansion of pcase is reasonably fast, so it's not a problem
+;; when byte-compiling a file, but when interpreting the code, if the pcase
+;; is in a loop, the repeated macro-expansion becomes terribly costly, so we
+;; memoize previous macro expansions to try and avoid recomputing them
+;; over and over again.
+(defconst pcase-memoize (make-hash-table :weakness t :test 'equal))
+
+;;;###autoload
+(defmacro pcase (exp &rest cases)
+ "Perform ML-style pattern matching on EXP.
+CASES is a list of elements of the form (UPATTERN CODE...).
+
+UPatterns can take the following forms:
+ _ matches anything.
+ SYMBOL matches anything and binds it to SYMBOL.
+ (or UPAT...) matches if any of the patterns matches.
+ (and UPAT...) matches if all the patterns match.
+ `QPAT matches if the QPattern QPAT matches.
+ (pred PRED) matches if PRED applied to the object returns non-nil.
+
+QPatterns can take the following forms:
+ (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr.
+ ,UPAT matches if the UPattern UPAT matches.
+ ATOM matches if the object is `eq' to ATOM.
+QPatterns for vectors are not implemented yet.
+
+PRED can take the form
+ FUNCTION in which case it gets called with one argument.
+ (FUN ARG1 .. ARGN) in which case it gets called with N+1 arguments.
+A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION).
+PRED patterns can refer to variables bound earlier in the pattern.
+E.g. you can match pairs where the cdr is larger than the car with a pattern
+like `(,a . ,(pred (< a))) or, with more checks:
+`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))"
+ (declare (indent 1) (debug case))
+ (or (gethash (cons exp cases) pcase-memoize)
+ (puthash (cons exp cases)
+ (pcase-expand exp cases)
+ pcase-memoize)))
+
+;;;###autoload
+(defmacro pcase-let* (bindings body)
+ "Like `let*' but where you can use `pcase' patterns for bindings.
+BODY should be an expression, and BINDINGS should be a list of bindings
+of the form (UPAT EXP)."
+ (if (null bindings) body
+ `(pcase ,(cadr (car bindings))
+ (,(caar bindings) (plet* ,(cdr bindings) ,body))
+ (t (error "Pattern match failure in `plet'")))))
+
+;;;###autoload
+(defmacro pcase-let (bindings body)
+ "Like `let' but where you can use `pcase' patterns for bindings.
+BODY should be an expression, and BINDINGS should be a list of bindings
+of the form (UPAT EXP)."
+ (if (null (cdr bindings))
+ `(plet* ,bindings ,body)
+ (setq bindings (mapcar (lambda (x) (cons (make-symbol "x") x)) bindings))
+ `(let ,(mapcar (lambda (binding) (list (nth 0 binding) (nth 2 binding)))
+ bindings)
+ (plet* ,(mapcar (lambda (binding) (list (nth 1 binding) (nth 0 binding)))
+ bindings)
+ ,body))))
+
+(defun pcase-expand (exp cases)
+ (let* ((defs (if (symbolp exp) '()
+ (let ((sym (make-symbol "x")))
+ (prog1 `((,sym ,exp)) (setq exp sym)))))
+ (seen '())
+ (codegen
+ (lambda (code vars)
+ (let ((prev (assq code seen)))
+ (if (not prev)
+ (let ((res (pcase-codegen code vars)))
+ (push (list code vars res) seen)
+ res)
+ ;; Since we use a tree-based pattern matching
+ ;; technique, the leaves (the places that contain the
+ ;; code to run once a pattern is matched) can get
+ ;; copied a very large number of times, so to avoid
+ ;; code explosion, we need to keep track of how many
+ ;; times we've used each leaf and move it
+ ;; to a separate function if that number is too high.
+ ;;
+ ;; We've already used this branch. So it is shared.
+ (destructuring-bind (code prevvars res) prev
+ (unless (symbolp res)
+ ;; This is the first repeat, so we have to move
+ ;; the branch to a separate function.
+ (let ((bsym
+ (make-symbol (format "pcase-%d" (length defs)))))
+ (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) defs)
+ (setcar res 'funcall)
+ (setcdr res (cons bsym (mapcar #'cdr prevvars)))
+ (setcar (cddr prev) bsym)
+ (setq res bsym)))
+ (setq vars (copy-sequence vars))
+ (let ((args (mapcar (lambda (pa)
+ (let ((v (assq (car pa) vars)))
+ (setq vars (delq v vars))
+ (cdr v)))
+ prevvars)))
+ (when vars ;New additional vars.
+ (error "The vars %s are only bound in some paths"
+ (mapcar #'car vars)))
+ `(funcall ,res ,@args)))))))
+ (main
+ (pcase-u
+ (mapcar (lambda (case)
+ `((match ,exp . ,(car case))
+ ,(apply-partially
+ (if (pcase-small-branch-p (cdr case))
+ ;; Don't bother sharing multiple
+ ;; occurrences of this leaf since it's small.
+ #'pcase-codegen codegen)
+ (cdr case))))
+ cases))))
+ `(let ,defs ,main)))
+
+(defun pcase-codegen (code vars)
+ `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars)
+ ,@code))
+
+(defun pcase-small-branch-p (code)
+ (and (= 1 (length code))
+ (or (not (consp (car code)))
+ (let ((small t))
+ (dolist (e (car code))
+ (if (consp e) (setq small nil)))
+ small))))
+
+;; Try to use `cond' rather than a sequence of `if's, so as to reduce
+;; the depth of the generated tree.
+(defun pcase-if (test then else)
+ (cond
+ ((eq else :pcase-dontcare) then)
+ ((eq (car-safe else) 'if)
+ `(cond (,test ,then)
+ (,(nth 1 else) ,(nth 2 else))
+ (t ,@(nthcdr 3 else))))
+ ((eq (car-safe else) 'cond)
+ `(cond (,test ,then)
+ ,@(cdr else)))
+ (t `(if ,test ,then ,else))))
+
+(defun pcase-upat (qpattern)
+ (cond
+ ((eq (car-safe qpattern) '\,) (cadr qpattern))
+ (t (list '\` qpattern))))
+
+;; Note about MATCH:
+;; When we have patterns like `(PAT1 . PAT2), after performing the `consp'
+;; check, we want to turn all the similar patterns into ones of the form
+;; (and (match car PAT1) (match cdr PAT2)), so you naturally need conjunction.
+;; Earlier code hence used branches of the form (MATCHES . CODE) where
+;; MATCHES was a list (implicitly a conjunction) of (SYM . PAT).
+;; But if we have a pattern of the form (or `(PAT1 . PAT2) PAT3), there is
+;; no easy way to eliminate the `consp' check in such a representation.
+;; So we replaced the MATCHES by the MATCH below which can be made up
+;; of conjunctions and disjunctions, so if we know `foo' is a cons, we can
+;; turn (match foo . (or `(PAT1 . PAT2) PAT3)) into
+;; (or (and (match car . `PAT1) (match cdr . `PAT2)) (match foo . PAT3)).
+;; The downside is that we now have `or' and `and' both in MATCH and
+;; in PAT, so there are different equivalent representations and we
+;; need to handle them all. We do not try to systematically
+;; canonicalize them to one form over another, but we do occasionally
+;; turn one into the other.
+
+(defun pcase-u (branches)
+ "Expand matcher for rules BRANCHES.
+Each BRANCH has the form (MATCH CODE . VARS) where
+CODE is the code generator for that branch.
+VARS is the set of vars already bound by earlier matches.
+MATCH is the pattern that needs to be matched, of the form:
+ (match VAR . UPAT)
+ (and MATCH ...)
+ (or MATCH ...)"
+ (when (setq branches (delq nil branches))
+ (destructuring-bind (match code &rest vars) (car branches)
+ (pcase-u1 (list match) code vars (cdr branches)))))
+
+(defun pcase-and (match matches)
+ (if matches `(and ,match ,@matches) match))
+
+(defun pcase-split-match (sym splitter match)
+ (case (car match)
+ ((match)
+ (if (not (eq sym (cadr match)))
+ (cons match match)
+ (let ((pat (cddr match)))
+ (cond
+ ;; Hoist `or' and `and' patterns to `or' and `and' matches.
+ ((memq (car-safe pat) '(or and))
+ (pcase-split-match sym splitter
+ (cons (car pat)
+ (mapcar (lambda (alt)
+ `(match ,sym . ,alt))
+ (cdr pat)))))
+ (t (let ((res (funcall splitter (cddr match))))
+ (cons (or (car res) match) (or (cdr res) match))))))))
+ ((or and)
+ (let ((then-alts '())
+ (else-alts '())
+ (neutral-elem (if (eq 'or (car match)) :pcase-fail :pcase-succeed))
+ (zero-elem (if (eq 'or (car match)) :pcase-succeed :pcase-fail)))
+ (dolist (alt (cdr match))
+ (let ((split (pcase-split-match sym splitter alt)))
+ (unless (eq (car split) neutral-elem)
+ (push (car split) then-alts))
+ (unless (eq (cdr split) neutral-elem)
+ (push (cdr split) else-alts))))
+ (cons (cond ((memq zero-elem then-alts) zero-elem)
+ ((null then-alts) neutral-elem)
+ ((null (cdr then-alts)) (car then-alts))
+ (t (cons (car match) (nreverse then-alts))))
+ (cond ((memq zero-elem else-alts) zero-elem)
+ ((null else-alts) neutral-elem)
+ ((null (cdr else-alts)) (car else-alts))
+ (t (cons (car match) (nreverse else-alts)))))))
+ (t (error "Uknown MATCH %s" match))))
+
+(defun pcase-split-rest (sym splitter rest)
+ (let ((then-rest '())
+ (else-rest '()))
+ (dolist (branch rest)
+ (let* ((match (car branch))
+ (code&vars (cdr branch))
+ (splitted
+ (pcase-split-match sym splitter match)))
+ (unless (eq (car splitted) :pcase-fail)
+ (push (cons (car splitted) code&vars) then-rest))
+ (unless (eq (cdr splitted) :pcase-fail)
+ (push (cons (cdr splitted) code&vars) else-rest))))
+ (cons (nreverse then-rest) (nreverse else-rest))))
+
+(defun pcase-split-consp (syma symd pat)
+ (cond
+ ;; A QPattern for a cons, can only go the `then' side.
+ ((and (eq (car-safe pat) '\`) (consp (cadr pat)))
+ (let ((qpat (cadr pat)))
+ (cons `(and (match ,syma . ,(pcase-upat (car qpat)))
+ (match ,symd . ,(pcase-upat (cdr qpat))))
+ :pcase-fail)))
+ ;; A QPattern but not for a cons, can only go the `else' side.
+ ((eq (car-safe pat) '\`) (cons :pcase-fail nil))))
+
+(defun pcase-split-eq (elem pat)
+ (cond
+ ;; The same match will give the same result.
+ ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem))
+ (cons :pcase-succeed :pcase-fail))
+ ;; A different match will fail if this one succeeds.
+ ((and (eq (car-safe pat) '\`)
+ ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
+ ;; (consp (cadr pat)))
+ )
+ (cons :pcase-fail nil))))
+
+(defun pcase-split-memq (elems pat)
+ ;; Based on pcase-split-eq.
+ (cond
+ ;; The same match will give the same result.
+ ((and (eq (car-safe pat) '\`) (member (cadr pat) elems))
+ (cons :pcase-succeed nil))
+ ;; A different match will fail if this one succeeds.
+ ((and (eq (car-safe pat) '\`)
+ ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
+ ;; (consp (cadr pat)))
+ )
+ (cons :pcase-fail nil))))
+
+(defun pcase-split-pred (upat pat)
+ ;; FIXME: For predicates like (pred (> a)), two such predicates may
+ ;; actually refer to different variables `a'.
+ (if (equal upat pat)
+ (cons :pcase-succeed :pcase-fail)))
+
+(defun pcase-fgrep (vars sexp)
+ "Check which of the symbols VARS appear in SEXP."
+ (let ((res '()))
+ (while (consp sexp)
+ (dolist (var (pcase-fgrep vars (pop sexp)))
+ (unless (memq var res) (push var res))))
+ (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
+ res))
+
+;; It's very tempting to use `pcase' below, tho obviously, it'd create
+;; bootstrapping problems.
+(defun pcase-u1 (matches code vars rest)
+ "Return code that runs CODE (with VARS) if MATCHES match.
+and otherwise defers to REST which is a list of branches of the form
+\(ELSE-MATCH ELSE-CODE . ELSE-VARS)."
+ ;; Depending on the order in which we choose to check each of the MATCHES,
+ ;; the resulting tree may be smaller or bigger. So in general, we'd want
+ ;; to be careful to chose the "optimal" order. But predicate
+ ;; patterns make this harder because they create dependencies
+ ;; between matches. So we don't bother trying to reorder anything.
+ (cond
+ ((null matches) (funcall code vars))
+ ((eq :pcase-fail (car matches)) (pcase-u rest))
+ ((eq :pcase-succeed (car matches))
+ (pcase-u1 (cdr matches) code vars rest))
+ ((eq 'and (caar matches))
+ (pcase-u1 (append (cdar matches) (cdr matches)) code vars rest))
+ ((eq 'or (caar matches))
+ (let* ((alts (cdar matches))
+ (var (if (eq (caar alts) 'match) (cadr (car alts))))
+ (simples '()) (others '()))
+ (when var
+ (dolist (alt alts)
+ (if (and (eq (car alt) 'match) (eq var (cadr alt))
+ (let ((upat (cddr alt)))
+ (and (eq (car-safe upat) '\`)
+ (or (integerp (cadr upat)) (symbolp (cadr upat))))))
+ (push (cddr alt) simples)
+ (push alt others))))
+ (cond
+ ((null alts) (error "Please avoid it") (pcase-u rest))
+ ((> (length simples) 1)
+ ;; De-hoist the `or' MATCH into an `or' pattern that will be
+ ;; turned into a `memq' below.
+ (pcase-u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches))
+ code vars
+ (if (null others) rest
+ (cons (list*
+ (pcase-and (if (cdr others)
+ (cons 'or (nreverse others))
+ (car others))
+ (cdr matches))
+ code vars)
+ rest))))
+ (t
+ (pcase-u1 (cons (pop alts) (cdr matches)) code vars
+ (if (null alts) (progn (error "Please avoid it") rest)
+ (cons (list*
+ (pcase-and (if (cdr alts)
+ (cons 'or alts) (car alts))
+ (cdr matches))
+ code vars)
+ rest)))))))
+ ((eq 'match (caar matches))
+ (destructuring-bind (op sym &rest upat) (pop matches)
+ (cond
+ ((memq upat '(t _)) (pcase-u1 matches code vars rest))
+ ((eq upat 'dontcare) :pcase-dontcare)
+ ((functionp upat) (error "Feature removed, use (pred %s)" upat))
+ ((eq (car-safe upat) 'pred)
+ (destructuring-bind (then-rest &rest else-rest)
+ (pcase-split-rest
+ sym (apply-partially 'pcase-split-pred upat) rest)
+ (pcase-if (if (symbolp (cadr upat))
+ `(,(cadr upat) ,sym)
+ (let* ((exp (cadr upat))
+ ;; `vs' is an upper bound on the vars we need.
+ (vs (pcase-fgrep (mapcar #'car vars) exp)))
+ (if vs
+ ;; Let's not replace `vars' in `exp' since it's
+ ;; too difficult to do it right, instead just
+ ;; let-bind `vars' around `exp'.
+ `(let ,(mapcar (lambda (var)
+ (list var (cdr (assq var vars))))
+ vs)
+ ;; FIXME: `vars' can capture `sym'. E.g.
+ ;; (pcase x ((and `(,x . ,y) (pred (fun x)))))
+ (,@exp ,sym))
+ `(,@exp ,sym))))
+ (pcase-u1 matches code vars then-rest)
+ (pcase-u else-rest))))
+ ((symbolp upat)
+ (pcase-u1 matches code (cons (cons upat sym) vars) rest))
+ ((eq (car-safe upat) '\`)
+ (pcase-q1 sym (cadr upat) matches code vars rest))
+ ((eq (car-safe upat) 'or)
+ (let ((all (> (length (cdr upat)) 1)))
+ (when all
+ (dolist (alt (cdr upat))
+ (unless (and (eq (car-safe alt) '\`)
+ (or (symbolp (cadr alt)) (integerp (cadr alt))))
+ (setq all nil))))
+ (if all
+ ;; Use memq for (or `a `b `c `d) rather than a big tree.
+ (let ((elems (mapcar 'cadr (cdr upat))))
+ (destructuring-bind (then-rest &rest else-rest)
+ (pcase-split-rest
+ sym (apply-partially 'pcase-split-memq elems) rest)
+ (pcase-if `(memq ,sym ',elems)
+ (pcase-u1 matches code vars then-rest)
+ (pcase-u else-rest))))
+ (pcase-u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars
+ (append (mapcar (lambda (upat)
+ `((and (match ,sym . ,upat) ,@matches)
+ ,code ,@vars))
+ (cddr upat))
+ rest)))))
+ ((eq (car-safe upat) 'and)
+ (pcase-u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat)) (cdr upat))
+ matches)
+ code vars rest))
+ ((eq (car-safe upat) 'not)
+ ;; FIXME: The implementation below is naive and results in
+ ;; inefficient code.
+ ;; To make it work right, we would need to turn pcase-u1's
+ ;; `code' and `vars' into a single argument of the same form as
+ ;; `rest'. We would also need to split this new `then-rest' argument
+ ;; for every test (currently we don't bother to do it since
+ ;; it's only useful for odd patterns like (and `(PAT1 . PAT2)
+ ;; `(PAT3 . PAT4)) which the programmer can easily rewrite
+ ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))).
+ (pcase-u1 `((match ,sym . ,(cadr upat)))
+ (lexical-let ((rest rest))
+ ;; FIXME: This codegen is not careful to share its
+ ;; code if used several times: code blow up is likely.
+ (lambda (vars)
+ ;; `vars' will likely contain bindings which are
+ ;; not always available in other paths to
+ ;; `rest', so there' no point trying to pass
+ ;; them down.
+ (pcase-u rest)))
+ vars
+ (list `((and . ,matches) ,code . ,vars))))
+ (t (error "Unknown upattern `%s'" upat)))))
+ (t (error "Incorrect MATCH %s" (car matches)))))
+
+(defun pcase-q1 (sym qpat matches code vars rest)
+ "Return code that runs CODE if SYM matches QPAT and if MATCHES match.
+and if not, defers to REST which is a list of branches of the form
+\(OTHER_MATCH OTHER-CODE . OTHER-VARS)."
+ (cond
+ ((eq (car-safe qpat) '\,) (error "Can't use `,UPATTERN"))
+ ((floatp qpat) (error "Floating point patterns not supported"))
+ ((vectorp qpat)
+ ;; FIXME.
+ (error "Vector QPatterns not implemented yet"))
+ ((consp qpat)
+ (let ((syma (make-symbol "xcar"))
+ (symd (make-symbol "xcdr")))
+ (destructuring-bind (then-rest &rest else-rest)
+ (pcase-split-rest sym (apply-partially 'pcase-split-consp syma symd)
+ rest)
+ (pcase-if `(consp ,sym)
+ `(let ((,syma (car ,sym))
+ (,symd (cdr ,sym)))
+ ,(pcase-u1 `((match ,syma . ,(pcase-upat (car qpat)))
+ (match ,symd . ,(pcase-upat (cdr qpat)))
+ ,@matches)
+ code vars then-rest))
+ (pcase-u else-rest)))))
+ ((or (integerp qpat) (symbolp qpat))
+ (destructuring-bind (then-rest &rest else-rest)
+ (pcase-split-rest sym (apply-partially 'pcase-split-eq qpat) rest)
+ (pcase-if `(eq ,sym ',qpat)
+ (pcase-u1 matches code vars then-rest)
+ (pcase-u else-rest))))
+ (t (error "Unkown QPattern %s" qpat))))
+
+
+(provide 'pcase)
+;;; pcase.el ends here
diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el
index ec1a704ce0b..1845effd5bb 100644
--- a/lisp/emacs-lisp/re-builder.el
+++ b/lisp/emacs-lisp/re-builder.el
@@ -61,14 +61,12 @@
;; this limit allowing an easy way to see all matches.
;; Currently `re-builder' understands five different forms of input,
-;; namely `read', `string', `rx', `sregex' and `lisp-re' syntax. Read
+;; namely `read', `string', `rx', and `sregex' syntax. Read
;; syntax and string syntax are both delimited by `"'s and behave
;; according to their name. With the `string' syntax there's no need
;; to escape the backslashes and double quotes simplifying the editing
;; somewhat. The other three allow editing of symbolic regular
-;; expressions supported by the packages of the same name. (`lisp-re'
-;; is a package by me and its support may go away as it is nearly the
-;; same as the `sregex' package in Emacs)
+;; expressions supported by the packages of the same name.
;; Editing symbolic expressions is done through a major mode derived
;; from `emacs-lisp-mode' so you'll get all the good stuff like
@@ -128,12 +126,11 @@
(defcustom reb-re-syntax 'read
"Syntax for the REs in the RE Builder.
-Can either be `read', `string', `sregex', `lisp-re', `rx'."
+Can either be `read', `string', `sregex', or `rx'."
:group 're-builder
:type '(choice (const :tag "Read syntax" read)
(const :tag "String syntax" string)
(const :tag "`sregex' syntax" sregex)
- (const :tag "`lisp-re' syntax" lisp-re)
(const :tag "`rx' syntax" rx)))
(defcustom reb-auto-match-limit 200
@@ -281,9 +278,8 @@ Except for Lisp syntax this is the same as `reb-regexp'.")
(define-derived-mode reb-lisp-mode
emacs-lisp-mode "RE Builder Lisp"
"Major mode for interactively building symbolic Regular Expressions."
- (cond ((eq reb-re-syntax 'lisp-re) ; Pull in packages
- (require 'lisp-re)) ; as needed
- ((eq reb-re-syntax 'sregex) ; sregex is not autoloaded
+ ;; Pull in packages as needed
+ (cond ((eq reb-re-syntax 'sregex) ; sregex is not autoloaded
(require 'sregex)) ; right now..
((eq reb-re-syntax 'rx) ; rx-to-string is autoloaded
(require 'rx))) ; require rx anyway
@@ -329,7 +325,7 @@ Except for Lisp syntax this is the same as `reb-regexp'.")
(defsubst reb-lisp-syntax-p ()
"Return non-nil if RE Builder uses a Lisp syntax."
- (memq reb-re-syntax '(lisp-re sregex rx)))
+ (memq reb-re-syntax '(sregex rx)))
(defmacro reb-target-binding (symbol)
"Return binding for SYMBOL in the RE Builder target buffer."
@@ -489,10 +485,10 @@ Optional argument SYNTAX must be specified if called non-interactively."
(list (intern
(completing-read "Select syntax: "
(mapcar (lambda (el) (cons (symbol-name el) 1))
- '(read string lisp-re sregex rx))
+ '(read string sregex rx))
nil t (symbol-name reb-re-syntax)))))
- (if (memq syntax '(read string lisp-re sregex rx))
+ (if (memq syntax '(read string sregex rx))
(let ((buffer (get-buffer reb-buffer)))
(setq reb-re-syntax syntax)
(when buffer
@@ -616,10 +612,7 @@ optional fourth argument FORCE is non-nil."
(defun reb-cook-regexp (re)
"Return RE after processing it according to `reb-re-syntax'."
- (cond ((eq reb-re-syntax 'lisp-re)
- (when (fboundp 'lre-compile-string)
- (lre-compile-string (eval (car (read-from-string re))))))
- ((eq reb-re-syntax 'sregex)
+ (cond ((eq reb-re-syntax 'sregex)
(apply 'sregex (eval (car (read-from-string re)))))
((eq reb-re-syntax 'rx)
(rx-to-string (eval (car (read-from-string re)))))
diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el
index a3110f8d8c5..5cc89596ef5 100644
--- a/lisp/emacs-lisp/syntax.el
+++ b/lisp/emacs-lisp/syntax.el
@@ -52,7 +52,7 @@
(defun syntax-ppss-toplevel-pos (ppss)
"Get the latest syntactically outermost position found in a syntactic scan.
-PPSS is a scan state, as returned by `partial-parse-sexp' or `syntax-ppss'.
+PPSS is a scan state, as returned by `parse-partial-sexp' or `syntax-ppss'.
An \"outermost position\" means one that it is outside of any syntactic entity:
outside of any parentheses, comments, or strings encountered in the scan.
If no such position is recorded in PPSS (because the end of the scan was
diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el
index f3b8ddcd123..94f39940b66 100644
--- a/lisp/emacs-lisp/timer.el
+++ b/lisp/emacs-lisp/timer.el
@@ -321,7 +321,11 @@ This function is called, by name, directly by the C code."
;; We do this after rescheduling so that the handler function
;; can cancel its own timer successfully with cancel-timer.
(condition-case nil
- (apply (timer--function timer) (timer--args timer))
+ ;; Timer functions should not change the current buffer.
+ ;; If they do, all kinds of nasty surprises can happen,
+ ;; and it can be hellish to track down their source.
+ (save-current-buffer
+ (apply (timer--function timer) (timer--args timer)))
(error nil))
(if retrigger
(setf (timer--triggered timer) nil)))
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-23 11:33:39 +0000