From 128440c97f540ae93a6579985292425d5f8a1cea Mon Sep 17 00:00:00 2001 From: "Aaron S. Hawley" Date: Wed, 28 Jul 2010 01:38:46 +0200 Subject: * emacs-lisp/re-builder.el: Remove references to package `lisp-re' (bug#4369). --- lisp/emacs-lisp/re-builder.el | 25 +++++++++---------------- 1 file changed, 9 insertions(+), 16 deletions(-) (limited to 'lisp/emacs-lisp') 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))))) -- cgit v1.2.3 From bc44bef76753a7cb9c4ebc050b4dceec2fdaed44 Mon Sep 17 00:00:00 2001 From: Phil Hagelberg Date: Wed, 28 Jul 2010 14:54:42 -0400 Subject: Add support for non-default package repositories. * lisp/emacs-lisp/package.el (package-archive-base): Var deleted. (package-archives): New variable. (package-archive-contents): Doc fix. (package-load-descriptor): Do nothing if descriptor file is missing. (package--write-file-no-coding): New function. (package-unpack-single): Use it. (package-archive-id): New function. (package-download-single, package-download-tar) (package-menu-view-commentary): Use it. (package-installed-p): Make second argument optional. (package-read-all-archive-contents): New function. (package-initialize): Use it. (package-read-archive-contents): Add ARCHIVE argument. (package--add-to-archive-contents): New function. (package-install): Don't call package-read-archive-contents. (package--download-one-archive): Store archive file in a subdirectory of package-user-dir. (package-menu-execute): Remove spurious line movement. * lisp/emacs-lisp/package.el (package-load-list, package-archives) (package-archive-contents, package-user-dir) (package-directory-list, package--builtins, package-alist) (package-activated-list, package-obsolete-alist): Mark as risky. --- lisp/ChangeLog | 30 +++++++ lisp/emacs-lisp/package.el | 190 +++++++++++++++++++++++++++------------------ 2 files changed, 146 insertions(+), 74 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ee80f9a718f..4beafc1caaa 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,33 @@ +2010-07-28 Chong Yidong + + * emacs-lisp/package.el (package-load-list, package-archives) + (package-archive-contents, package-user-dir) + (package-directory-list, package--builtins, package-alist) + (package-activated-list, package-obsolete-alist): Mark as risky. + +2010-07-28 Phil Hagelberg + + Add support for non-default package repositories. + * emacs-lisp/package.el (package-archive-base): Var deleted. + (package-archives): New variable. + (package-archive-contents): Doc fix. + (package-load-descriptor): Do nothing if descriptor file is + missing. + (package--write-file-no-coding): New function. + (package-unpack-single): Use it. + (package-archive-id): New function. + (package-download-single, package-download-tar) + (package-menu-view-commentary): Use it. + (package-installed-p): Make second argument optional. + (package-read-all-archive-contents): New function. + (package-initialize): Use it. + (package-read-archive-contents): Add ARCHIVE argument. + (package--add-to-archive-contents): New function. + (package-install): Don't call package-read-archive-contents. + (package--download-one-archive): Store archive file in a + subdirectory of package-user-dir. + (package-menu-execute): Remove spurious line movement. + 2010-07-28 Jan Djärv * cus-start.el (tool-bar-style): Add text-image-horiz. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index c6035442313..6470d345dff 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,6 +268,7 @@ 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") @@ -293,6 +303,7 @@ contrast, `package-user-dir' contains packages for personal use." (bubbles . [(0 5) nil "Puzzle game for Emacs."]))))) "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 +312,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]+\\)*\\)$" @@ -361,16 +375,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. @@ -613,20 +625,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 +685,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-id name) (symbol-name name) "-" version ".el")))) (with-current-buffer buffer (package-handle-response) @@ -683,7 +698,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-id name) (symbol-name name) "-" version ".tar")))) (with-current-buffer tar-buffer (package-handle-response) @@ -692,12 +707,12 @@ 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-version-compare min-version (package-desc-vers (cdr pkg-desc)) - '>=)))) + '<=)))) (defun package-compute-transaction (result requirements) (dolist (elt requirements) @@ -772,16 +787,13 @@ 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 @@ -793,6 +805,33 @@ Throw an error if the archive version is too new." (if (package-version-compare our-version (car elt) '>=) (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) + (package-version-compare version + (aref existing-package 0) '>)) + (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 +856,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-archive-base'." (interactive - (list (progn - ;; Make sure we're using the most recent download of the - ;; archive. Maybe we should be updating the archive first? - (package-read-archive-contents) - (intern (completing-read "Install package: " - (mapcar (lambda (elt) - (cons (symbol-name (car elt)) - nil)) - package-archive-contents) - nil t))))) + (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)) @@ -996,20 +1030,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-id (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 +1061,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 +1072,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 +1348,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-id 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 +1365,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 +1398,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)) -- cgit v1.2.3 From 063e52940d4d97fe372f226c895d6d0f9d87f5d4 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Thu, 29 Jul 2010 12:01:14 -0400 Subject: Update package-x to latest package.el changes. * emacs-lisp/package-x.el (package--make-rss-entry): (package-maint-add-news-item, package--update-news) (package-upload-buffer-internal): New arg ARCHIVE-URL. * emacs-lisp/package.el (package-archive-url): Rename from package-archive-id. (package-install): Doc fix. (package-download-single, package-download-tar, package-install) (package-menu-view-commentary): Callers changed. --- lisp/ChangeLog | 12 ++++++++++++ lisp/emacs-lisp/package-x.el | 27 +++++++++++++++++---------- lisp/emacs-lisp/package.el | 10 +++++----- 3 files changed, 34 insertions(+), 15 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 49dcafca9da..6cd759ee0a3 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,15 @@ +2010-07-29 Chong Yidong + + * emacs-lisp/package-x.el (package--make-rss-entry): + (package-maint-add-news-item, package--update-news) + (package-upload-buffer-internal): New arg ARCHIVE-URL. + + * emacs-lisp/package.el (package-archive-url): Rename from + package-archive-id. + (package-install): Doc fix. + (package-download-single, package-download-tar, package-install) + (package-menu-view-commentary): Callers changed. + 2010-07-29 Michael Albinus * net/tramp.el (tramp-handle-start-file-process): Check only for diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el index 21bd7960d89..2a5d84f339b 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 "\n" "" (package--encode title) "\n" ;; FIXME: should have a link in the web page. - "" package-archive-base "news.html\n" + "" archive-url "news.html\n" "" (package--encode text) "\n" "" date-string "\n" "\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") "" - (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 @@ -127,7 +134,7 @@ EXTENSION is the file extension, a string. It can be either ;; 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) @@ -178,7 +185,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 6470d345dff..73434a1717b 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -685,7 +685,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-id name) + (concat (package-archive-url name) (symbol-name name) "-" version ".el")))) (with-current-buffer buffer (package-handle-response) @@ -698,7 +698,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-id name) + (concat (package-archive-url name) (symbol-name name) "-" version ".tar")))) (with-current-buffer tar-buffer (package-handle-response) @@ -856,7 +856,7 @@ Also, add the originating archive to the end of the package vector." (defun package-install (name) "Install the package named NAME. Interactively, prompt for the package name. -The package is found on one of the archives in `package-archive-base'." +The package is found on one of the archives in `package-archives'." (interactive (list (intern (completing-read "Install package: " (mapcar (lambda (elt) @@ -1030,7 +1030,7 @@ The file can either be a tar file or an Emacs Lisp file." ;; FIXME: query user? 'always)) -(defun package-archive-id (name) +(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)))) @@ -1350,7 +1350,7 @@ For larger packages, shows the README file." (interactive) (let* ((pkg-name (package-menu-get-package)) (buffer (url-retrieve-synchronously - (concat (package-archive-id pkg-name) + (concat (package-archive-url pkg-name) pkg-name "-readme.txt"))) start-point ok) -- cgit v1.2.3 From 9aea20c9f876b8da85789f9922bc0c3b4e201d14 Mon Sep 17 00:00:00 2001 From: MON KEY Date: Sun, 1 Aug 2010 02:24:55 +0200 Subject: * lisp/emacs-lisp/syntax.el (syntax-ppss-toplevel-pos): Fix typo in docstring. Fixes: debbugs:6747 --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/syntax.el | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 2b196d22c72..a6d127a8841 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2010-08-01 MON KEY (tiny change) + + * emacs-lisp/syntax.el (syntax-ppss-toplevel-pos): + Fix typo in docstring (bug#6747). + 2010-07-30 Leo * eshell/esh-io.el (eshell-get-target): Better detection of 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 -- cgit v1.2.3 From 376c2b6b213e0cb7bec08a1ecc01731ac50865b8 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Sat, 31 Jul 2010 20:38:19 -0400 Subject: Package listing tweaks. * emacs-lisp/package.el (package--list-packages): Fix column alignment. (package--builtins): Tweak descriptions. (package-print-package): Upcase descriptions if necessary. Show all built-in packages in font-lock-builtin-face. (package-list-packages-internal): Omit "emacs" package. Show status of built-in packages as "built-in". --- lisp/ChangeLog | 10 ++++++++ lisp/emacs-lisp/package.el | 57 +++++++++++++++++++++++----------------------- 2 files changed, 39 insertions(+), 28 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index e282cef0c30..e6d67c13934 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,13 @@ +2010-08-01 Chong Yidong + + * emacs-lisp/package.el (package--list-packages): Fix column + alignment. + (package--builtins): Tweak descriptions. + (package-print-package): Upcase descriptions if necessary. Show + all built-in packages in font-lock-builtin-face. + (package-list-packages-internal): Omit "emacs" package. Show + status of built-in packages as "built-in". + 2010-07-31 Chong Yidong * mouse.el (mouse-save-then-kill): Doc fix. Deactivate mark diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 73434a1717b..bcb8349c187 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -292,15 +292,15 @@ 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) @@ -358,16 +358,6 @@ FUN can be <, <=, =, >, >=, or /=." ;; 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\"" @@ -1422,7 +1412,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) @@ -1444,7 +1434,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) @@ -1462,22 +1454,31 @@ 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)) + (package-version-compare + (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) @@ -1574,8 +1575,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 -- cgit v1.2.3 From 0798a8d85cbb4c6d5948243869bfb137782eaeeb Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 2 Aug 2010 11:00:46 +0200 Subject: * lisp/emacs-lisp/timer.el (timer-event-handler): Protect against timers that change current buffer. --- lisp/ChangeLog | 41 +++++++++++++++++++---------------------- lisp/emacs-lisp/timer.el | 6 +++++- 2 files changed, 24 insertions(+), 23 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 18b21843e87..4837023ba3b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2010-08-02 Stefan Monnier + + * emacs-lisp/timer.el (timer-event-handler): Protect against timers + that change current buffer. + 2010-08-01 YAMAMOTO Mitsuharu * mouse.el (mouse-fixup-help-message): Match "mouse-2" only at the @@ -9,13 +14,12 @@ 2010-08-01 Chong Yidong - * emacs-lisp/package.el (package--list-packages): Fix column - alignment. + * emacs-lisp/package.el (package--list-packages): Fix column alignment. (package--builtins): Tweak descriptions. - (package-print-package): Upcase descriptions if necessary. Show - all built-in packages in font-lock-builtin-face. - (package-list-packages-internal): Omit "emacs" package. Show - status of built-in packages as "built-in". + (package-print-package): Upcase descriptions if necessary. + Show all built-in packages in font-lock-builtin-face. + (package-list-packages-internal): Omit "emacs" package. + Show status of built-in packages as "built-in". 2010-07-31 Chong Yidong @@ -24,27 +28,22 @@ * term/x-win.el (x-select-text): Doc fix. -2010-07-31 Alan Mackenzie - Enhanced Java Mode to handle Java 5.0 (Tiger) and Java 6 - (Mustang). Contributed by Nathaniel Flath. The following - functions were modified or created: +2010-07-31 Nathaniel Flath + + Enhance Java Mode to handle Java 5.0 (Tiger) and Java 6 (Mustang). + The following functions were modified or created: * progmodes/cc-vars.el (c-offsets-alist, c-inside-block-syms) (objc-font-lock-extra-types): - * progmodes/cc-mode.el (c-basic-common-init): - * progmodes/cc-langs.el (c-make-mode-syntax-table) (c++-make-template-syntax-table) (c-identifier-syntax-modifications, c-symbol-start, c-operators) (c-<-op-cont-regexp, c->-op-cont-regexp, c-class-decl-kwds) (c-brace-list-decl-kwds, c-modifier-kwds, c-prefix-spec-kwds-re) (c-type-list-kwds, c-decl-prefix-re, c-opt-type-suffix-key): - - * progmodes/cc-fonts.el (c-make-inverse-face) (c-basic-matchers-after): - * progmodes/cc-engine.el (c-forward-keyword-clause) (c-forward-<>-arglist, c-forward-<>-arglist-recur) (c-forward-name, c-forward-type, c-forward-decl-or-cast-1) @@ -52,7 +51,7 @@ 2010-07-31 Jan Djärv - * faces.el (face-all-attributes): Improved documentation (Bug#6767). + * faces.el (face-all-attributes): Improve documentation (Bug#6767). 2010-07-31 Eli Zaretskii @@ -71,8 +70,8 @@ * menu-bar.el (menu-bar-showhide-tool-bar-menu-customize-enable-left) (menu-bar-showhide-tool-bar-menu-customize-disable) (menu-bar-showhide-tool-bar-menu-customize-enable-right) - (menu-bar-showhide-tool-bar-menu-customize-enable-top) - (menu-bar-showhide-tool-bar-menu-customize-enable-bottom): New functions + (menu-bar-showhide-tool-bar-menu-customize-enable-bottom) + (menu-bar-showhide-tool-bar-menu-customize-enable-top): New functions (menu-bar-showhide-tool-bar-menu): If tool bar is moveable, make a menu for Options => toolbar that can move it. @@ -112,8 +111,7 @@ * emacs-lisp/package.el (package-archive-base): Var deleted. (package-archives): New variable. (package-archive-contents): Doc fix. - (package-load-descriptor): Do nothing if descriptor file is - missing. + (package-load-descriptor): Do nothing if descriptor file is missing. (package--write-file-no-coding): New function. (package-unpack-single): Use it. (package-archive-id): New function. @@ -194,8 +192,7 @@ 2010-07-26 Daiki Ueno * epa-mail.el (epa-mail-mode-map): Add alternative key bindings - which consist of control chars only. Suggested by Richard - Stallman. + which consist of control chars only. Suggested by Richard Stallman. 2010-07-25 Daiki Ueno 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))) -- cgit v1.2.3 From 29cf3e2076352c67e2286fabe4742e5cde915a05 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 5 Aug 2010 20:11:32 +0300 Subject: Rename src/unexec.c => src/unexcoff.c. src/unexcoff.c: Renamed from unexec.c. src/deps.mk (unexcoff.o): Rename unexec.[co] => unexcoff.[co]. configure.in (UNEXEC_OBJ): Rename unexec.o => unexcoff.o. admin/MAINTAINERS: Rename src/unexec.c => src/unexcoff.c. etc/AUTHORS: Rename unexec.o => unexcoff.o. etc/PROBLEMS: Rename unexec.o => unex*.o. lisp/emacs-lisp/find-gc.el (find-gc-source-files): Rename unexec.c => unexcoff.c. lisp/emacs-lisp/authors.el (authors-fixed-entries): Rename unexec.c => unexcoff.c. msdos/sed1v2.inp (UNEXEC_OBJ): Edit to unexcoff.o, due to renaming of unexec.c => unexcoff.c. --- ChangeLog | 4 + admin/ChangeLog | 4 + configure.in | 2 +- etc/AUTHORS | 16 +- etc/ChangeLog | 5 + etc/PROBLEMS | 2 +- lisp/ChangeLog | 8 + lisp/emacs-lisp/authors.el | 12 +- lisp/emacs-lisp/find-gc.el | 2 +- msdos/ChangeLog | 5 + msdos/sed1v2.inp | 2 +- src/ChangeLog | 6 + src/deps.mk | 2 +- src/unexcoff.c | 665 +++++++++++++++++++++++++++++++++++++++++++++ src/unexec.c | 658 -------------------------------------------- 15 files changed, 716 insertions(+), 677 deletions(-) create mode 100644 src/unexcoff.c delete mode 100644 src/unexec.c (limited to 'lisp/emacs-lisp') diff --git a/ChangeLog b/ChangeLog index 678583b9cdb..8a72061226d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2010-08-05 Eli Zaretskii + + * configure.in (UNEXEC_OBJ): Rename unexec.o => unexcoff.o. + 2010-08-04 Andreas Schwab * configure.in: Restore accidentally removed use of diff --git a/admin/ChangeLog b/admin/ChangeLog index e082eee36bf..7ce3321dd31 100644 --- a/admin/ChangeLog +++ b/admin/ChangeLog @@ -1,3 +1,7 @@ +2010-08-05 Eli Zaretskii + + * MAINTAINERS: Rename src/unexec.c => src/unexcoff.c. + 2010-07-24 Christoph Scholtes * admin.el: Write version number to nt/makefile.w32-in. diff --git a/configure.in b/configure.in index 9ef12ff2881..7a4aaf4ea24 100644 --- a/configure.in +++ b/configure.in @@ -883,7 +883,7 @@ AC_SUBST(CANNOT_DUMP) UNEXEC_OBJ=unexelf.o case "$opsys" in - # MSDOS uses unexec.o + # MSDOS uses unexcoff.o # MSWindows uses unexw32.o aix4-2) UNEXEC_OBJ=unexaix.o diff --git a/etc/AUTHORS b/etc/AUTHORS index 26611a57de1..916f8cdd794 100644 --- a/etc/AUTHORS +++ b/etc/AUTHORS @@ -1042,7 +1042,7 @@ and changed nndoc.el allout.el bytecomp.el gnus-sum.el gnus-util.el François-David Collin: changed message.el mm-decode.el -Fred Fish: changed linux.h unexec.c +Fred Fish: changed linux.h unexcoff.c Fred Oberhauser: changed nnmail.el @@ -1273,7 +1273,7 @@ Inge Wallin: co-wrote avl-tree.el ewoc.el Inoue Seiichiro: changed xterm.c xfns.c xterm.h International Business Machines: changed emacs.c fileio.c process.c - sysdep.c unexec.c + sysdep.c unexcoff.c Irie Tetsuya: changed gnus.texi message.texi @@ -1334,7 +1334,7 @@ James TD Smith: changed org.el org-colview.el org-clock.el James Troup: changed gnus-sum.el -James Van Artsdalen: changed unexec.c usg5-4.h +James Van Artsdalen: changed unexcoff.c usg5-4.h James Wright: changed em-unix.el @@ -2176,7 +2176,7 @@ and changed tramp.texi dbusbind.c dbus.texi ange-ftp.el trampver.el simple.el vc.el configure.in dired.el and 50 other files Michael Ben-Gershon: changed acorn.h configure.in riscix1-1.h riscix1-2.h - unexec.c + unexcoff.c Michael D. Ernst: wrote reposition.el and changed dired-x.el uniquify.el ispell.el bibtex.el rmail.el dired.el @@ -2200,7 +2200,7 @@ Michael I. Bushnell: changed rmail.el simple.el callproc.c gnu.h gnus.el Michael K. Johnson: changed configure.in emacs.c intel386.h linux.h mem-limits.h process.c sysdep.c syssignal.h systty.h template.h - unexec.c + unexcoff.c Michael Kifer: wrote ediff-diff.el ediff-help.el ediff-hook.el ediff-init.el ediff-merg.el ediff-mult.el ediff-ptch.el ediff-util.el @@ -2259,7 +2259,7 @@ and changed gnus-score.el Microelectronics and Computer Technology Corporation: changed emacsclient.c etags.c lisp.h movemail.c rmail.el rmailedit.el rmailkwd.el rmailmsc.el rmailout.el rmailsum.el scribe.el server.el - sysdep.c unexec.c xmenu.c + sysdep.c unexcoff.c xmenu.c Mikael Djurfeldt: changed xdisp.c @@ -2685,7 +2685,7 @@ and changed files.el keyboard.c simple.el xterm.c xdisp.c Makefile.in Richard Mlynarik: wrote cl-indent.el ebuff-menu.el ehelp.el rfc822.el terminal.el yow.el and changed files.el sysdep.c rmail.el info.el keyboard.c bytecomp.el - fileio.c simple.el process.c startup.el window.c editfns.c unexec.c + fileio.c simple.el process.c startup.el window.c editfns.c unexcoff.c xfns.c keymap.c minibuf.c sendmail.el buffer.c dispnew.c emacs.c subr.el and 129 other files @@ -2921,7 +2921,7 @@ Slawomir Nowaczyk: changed emacs.py python.el TUTORIAL.pl flyspell.el ls-lisp.el w32proc.c Spencer Thomas: changed dabbrev.el emacsclient.c gnus.texi server.el - unexec.c + unexcoff.c Sriram Karra: changed message.el diff --git a/etc/ChangeLog b/etc/ChangeLog index 9aa7f767230..a4c4507fd7b 100644 --- a/etc/ChangeLog +++ b/etc/ChangeLog @@ -1,3 +1,8 @@ +2010-08-05 Eli Zaretskii + + * AUTHORS: Rename unexec.o => unexcoff.o. + * PROBLEMS: Rename unexec.o => unexcoff.o. + 2010-07-31 Eli Zaretskii * tutorials/TUTORIAL.he: New file. diff --git a/etc/PROBLEMS b/etc/PROBLEMS index 2fc0e29b30f..6609f185825 100644 --- a/etc/PROBLEMS +++ b/etc/PROBLEMS @@ -2740,7 +2740,7 @@ build Emacs in a directory on a local disk. Two causes have been seen for such problems. 1) On a system where getpagesize is not a system call, it is defined -as a macro. If the definition (in both unexec.c and malloc.c) is wrong, +as a macro. If the definition (in both unex*.c and malloc.c) is wrong, it can cause problems like this. You might be able to find the correct value in the man page for a.out (5). diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 27e66a84f86..9ab754afe62 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,11 @@ +2010-08-05 Eli Zaretskii + + * emacs-lisp/find-gc.el (find-gc-source-files): Rename + unexec.c => unexcoff.c. + + * emacs-lisp/authors.el (authors-fixed-entries): Rename + unexec.c => unexcoff.c. + 2010-08-05 Michael Albinus * net/tramp.el (tramp-handle-dired-uncache): Flush directory 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/msdos/ChangeLog b/msdos/ChangeLog index bc793666890..7df89880410 100644 --- a/msdos/ChangeLog +++ b/msdos/ChangeLog @@ -1,3 +1,8 @@ +2010-08-05 Eli Zaretskii + + * sed1v2.inp (UNEXEC_OBJ): Edit to unexcoff.o, due to renaming of + unexec.c => unexcoff.c. + 2010-07-29 Chad Brown * sed2v2.inp (HAVE_DIRENT_H): Edit to 1. diff --git a/msdos/sed1v2.inp b/msdos/sed1v2.inp index 95ef5305d4c..4be1bccefdf 100644 --- a/msdos/sed1v2.inp +++ b/msdos/sed1v2.inp @@ -118,7 +118,7 @@ s/\.h\.in/.h-in/ /^RALLOC_OBJ *=/s/@RALLOC_OBJ@/ralloc.o/ /^PRE_ALLOC_OBJ *=/s/@PRE_ALLOC_OBJ@/lastfile.o/ /^POST_ALLOC_OBJ *=/s/@POST_ALLOC_OBJ@/$(vmlimitobj)/ -/^UNEXEC_OBJ *=/s/@UNEXEC_OBJ@/unexec.o/ +/^UNEXEC_OBJ *=/s/@UNEXEC_OBJ@/unexcoff.o/ /^CANNOT_DUMP *=/s/@CANNOT_DUMP@/no/ /^DEPFLAGS *=/s/@DEPFLAGS@// /^MKDEPDIR *=/s/@MKDEPDIR@// diff --git a/src/ChangeLog b/src/ChangeLog index d8177bbe8af..6841b2644d3 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,9 @@ +2010-08-05 Eli Zaretskii + + * deps.mk (unexcoff.o): Rename unexec.[co] => unexcoff.[co]. + + * unexcoff.c: Renamed from unexec.c. + 2010-08-04 Stefan Monnier * sysdep.c (child_setup_tty): Comment-out left-over non-ICANON code. diff --git a/src/deps.mk b/src/deps.mk index e9269397720..8eeed3822d0 100644 --- a/src/deps.mk +++ b/src/deps.mk @@ -190,7 +190,7 @@ undo.o: undo.c buffer.h commands.h window.h dispextern.h lisp.h $(config_h) unexaix.o: unexaix.c lisp.h $(config_h) unexalpha.o: unexalpha.c $(config_h) unexcw.o: unexcw.c lisp.h $(config_h) -unexec.o: unexec.c lisp.h $(config_h) +unexcoff.o: unexcoff.c lisp.h $(config_h) unexelf.o: unexelf.c $(config_h) unexhp9k800.o: unexhp9k800.c $(config_h) unexmacosx.o: unexmacosx.c $(config_h) diff --git a/src/unexcoff.c b/src/unexcoff.c new file mode 100644 index 00000000000..ed319ec8e7f --- /dev/null +++ b/src/unexcoff.c @@ -0,0 +1,665 @@ +/* Copyright (C) 1985, 1986, 1987, 1988, 1992, 1993, 1994, 2001, 2002, 2003, + 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + +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 . */ + + +/* + * unexcoff.c - Convert a running program into an a.out or COFF file. + * + * ================================================================== + * Note: This file is currently used only by the MSDOS (a.k.a. DJGPP) + * build of Emacs. If you are not interested in the MSDOS build, you + * are looking at the wrong version of unexec! + * ================================================================== + * + * Author: Spencer W. Thomas + * Computer Science Dept. + * University of Utah + * Date: Tue Mar 2 1982 + * Originally under the name unexec.c. + * Modified heavily since then. + * + * Synopsis: + * unexec (new_name, a_name, data_start, bss_start, entry_address) + * char *new_name, *a_name; + * unsigned data_start, bss_start, entry_address; + * + * Takes a snapshot of the program and makes an a.out format file in the + * file named by the string argument new_name. + * If a_name is non-NULL, the symbol table will be taken from the given file. + * On some machines, an existing a_name file is required. + * + * The boundaries within the a.out file may be adjusted with the data_start + * and bss_start arguments. Either or both may be given as 0 for defaults. + * + * Data_start gives the boundary between the text segment and the data + * segment of the program. The text segment can contain shared, read-only + * program code and literal data, while the data segment is always unshared + * and unprotected. Data_start gives the lowest unprotected address. + * The value you specify may be rounded down to a suitable boundary + * as required by the machine you are using. + * + * Specifying zero for data_start means the boundary between text and data + * should not be the same as when the program was loaded. + * + * Bss_start indicates how much of the data segment is to be saved in the + * a.out file and restored when the program is executed. It gives the lowest + * unsaved address, and is rounded up to a page boundary. The default when 0 + * is given assumes that the entire data segment is to be stored, including + * the previous data and bss as well as any additional storage allocated with + * break (2). + * + * The new file is set up to start at entry_address. + * + * If you make improvements I'd like to get them too. + * harpo!utah-cs!thomas, thomas@Utah-20 + * + */ + +/* Modified to support SysVr3 shared libraries by James Van Artsdalen + * of Dell Computer Corporation. james@bigtex.cactus.org. + */ + +#ifndef emacs +#define PERROR(arg) perror (arg); return -1 +#else +#include +#define PERROR(file) report_error (file, new) +#endif + +#ifndef CANNOT_DUMP /* all rest of file! */ + +#ifdef HAVE_COFF_H +#include +#ifdef MSDOS +#include /* for O_RDONLY, O_RDWR */ +#include /* for _crt0_startup_flags and its bits */ +static int save_djgpp_startup_flags; +#define filehdr external_filehdr +#define scnhdr external_scnhdr +#define syment external_syment +#define auxent external_auxent +#define n_numaux e_numaux +#define n_type e_type +struct aouthdr +{ + unsigned short magic; /* type of file */ + unsigned short vstamp; /* version stamp */ + unsigned long tsize; /* text size in bytes, padded to FW bdry*/ + unsigned long dsize; /* initialized data " " */ + unsigned long bsize; /* uninitialized data " " */ + unsigned long entry; /* entry pt. */ + unsigned long text_start;/* base of text used for this file */ + unsigned long data_start;/* base of data used for this file */ +}; +#endif /* not MSDOS */ +#else /* not HAVE_COFF_H */ +#include +#endif /* not HAVE_COFF_H */ + +/* Define getpagesize if the system does not. + Note that this may depend on symbols defined in a.out.h. */ +#include "getpagesize.h" + +#ifndef makedev /* Try to detect types.h already loaded */ +#include +#endif /* makedev */ +#include +#include +#include + +#include + +#ifndef O_RDONLY +#define O_RDONLY 0 +#endif +#ifndef O_RDWR +#define O_RDWR 2 +#endif + + +extern char *start_of_text (); /* Start of text */ +extern char *start_of_data (); /* Start of initialized data */ + +static long block_copy_start; /* Old executable start point */ +static struct filehdr f_hdr; /* File header */ +static struct aouthdr f_ohdr; /* Optional file header (a.out) */ +long bias; /* Bias to add for growth */ +long lnnoptr; /* Pointer to line-number info within file */ +#define SYMS_START block_copy_start + +static long text_scnptr; +static long data_scnptr; + +static long coff_offset; + +static int pagemask; + +/* Correct an int which is the bit pattern of a pointer to a byte + into an int which is the number of a byte. + This is a no-op on ordinary machines, but not on all. */ + +#define ADDR_CORRECT(x) ((char *)(x) - (char*)0) + +#ifdef emacs + +#include +#include "lisp.h" + +static +report_error (file, fd) + char *file; + int fd; +{ + if (fd) + close (fd); + report_file_error ("Cannot unexec", Fcons (build_string (file), Qnil)); +} +#endif /* emacs */ + +#define ERROR0(msg) report_error_1 (new, msg, 0, 0); return -1 +#define ERROR1(msg,x) report_error_1 (new, msg, x, 0); return -1 +#define ERROR2(msg,x,y) report_error_1 (new, msg, x, y); return -1 + +static +report_error_1 (fd, msg, a1, a2) + int fd; + char *msg; + int a1, a2; +{ + close (fd); +#ifdef emacs + error (msg, a1, a2); +#else + fprintf (stderr, msg, a1, a2); + fprintf (stderr, "\n"); +#endif +} + +static int make_hdr (); +static int copy_text_and_data (); +static int copy_sym (); +static void mark_x (); + +/* **************************************************************** + * make_hdr + * + * Make the header in the new a.out from the header in core. + * Modify the text and data sizes. + */ +static int +make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) + int new, a_out; + unsigned data_start, bss_start, entry_address; + char *a_name; + char *new_name; +{ + int tem; + auto struct scnhdr f_thdr; /* Text section header */ + auto struct scnhdr f_dhdr; /* Data section header */ + auto struct scnhdr f_bhdr; /* Bss section header */ + auto struct scnhdr scntemp; /* Temporary section header */ + register int scns; + unsigned int bss_end; + + pagemask = getpagesize () - 1; + + /* Adjust text/data boundary. */ + data_start = (int) start_of_data (); + data_start = ADDR_CORRECT (data_start); + data_start = data_start & ~pagemask; /* (Down) to page boundary. */ + + bss_end = ADDR_CORRECT (sbrk (0)) + pagemask; + bss_end &= ~ pagemask; + + /* Adjust data/bss boundary. */ + if (bss_start != 0) + { + bss_start = (ADDR_CORRECT (bss_start) + pagemask); + /* (Up) to page bdry. */ + bss_start &= ~ pagemask; + if (bss_start > bss_end) + { + ERROR1 ("unexec: Specified bss_start (%u) is past end of program", + bss_start); + } + } + else + bss_start = bss_end; + + if (data_start > bss_start) /* Can't have negative data size. */ + { + ERROR2 ("unexec: data_start (%u) can't be greater than bss_start (%u)", + data_start, bss_start); + } + + coff_offset = 0L; /* stays zero, except in DJGPP */ + + /* Salvage as much info from the existing file as possible */ + if (a_out >= 0) + { +#ifdef MSDOS + /* Support the coff-go32-exe format with a prepended stub, since + this is what GCC 2.8.0 and later generates by default in DJGPP. */ + unsigned short mz_header[3]; + + if (read (a_out, &mz_header, sizeof (mz_header)) != sizeof (mz_header)) + { + PERROR (a_name); + } + if (mz_header[0] == 0x5a4d || mz_header[0] == 0x4d5a) /* "MZ" or "ZM" */ + { + coff_offset = (long)mz_header[2] * 512L; + if (mz_header[1]) + coff_offset += (long)mz_header[1] - 512L; + lseek (a_out, coff_offset, 0); + } + else + lseek (a_out, 0L, 0); +#endif /* MSDOS */ + if (read (a_out, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) + { + PERROR (a_name); + } + block_copy_start += sizeof (f_hdr); + if (f_hdr.f_opthdr > 0) + { + if (read (a_out, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) + { + PERROR (a_name); + } + block_copy_start += sizeof (f_ohdr); + } + /* Loop through section headers, copying them in */ + lseek (a_out, coff_offset + sizeof (f_hdr) + f_hdr.f_opthdr, 0); + for (scns = f_hdr.f_nscns; scns > 0; scns--) { + if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) + { + PERROR (a_name); + } + if (scntemp.s_scnptr > 0L) + { + if (block_copy_start < scntemp.s_scnptr + scntemp.s_size) + block_copy_start = scntemp.s_scnptr + scntemp.s_size; + } + if (strcmp (scntemp.s_name, ".text") == 0) + { + f_thdr = scntemp; + } + else if (strcmp (scntemp.s_name, ".data") == 0) + { + f_dhdr = scntemp; + } + else if (strcmp (scntemp.s_name, ".bss") == 0) + { + f_bhdr = scntemp; + } + } + } + else + { + ERROR0 ("can't build a COFF file from scratch yet"); + } + + /* Now we alter the contents of all the f_*hdr variables + to correspond to what we want to dump. */ + + f_hdr.f_flags |= (F_RELFLG | F_EXEC); + f_ohdr.text_start = (long) start_of_text (); + f_ohdr.tsize = data_start - f_ohdr.text_start; + f_ohdr.data_start = data_start; + f_ohdr.dsize = bss_start - f_ohdr.data_start; + f_ohdr.bsize = bss_end - bss_start; + f_thdr.s_size = f_ohdr.tsize; + f_thdr.s_scnptr = sizeof (f_hdr) + sizeof (f_ohdr); + f_thdr.s_scnptr += (f_hdr.f_nscns) * (sizeof (f_thdr)); + lnnoptr = f_thdr.s_lnnoptr; + text_scnptr = f_thdr.s_scnptr; + f_dhdr.s_paddr = f_ohdr.data_start; + f_dhdr.s_vaddr = f_ohdr.data_start; + f_dhdr.s_size = f_ohdr.dsize; + f_dhdr.s_scnptr = f_thdr.s_scnptr + f_thdr.s_size; + data_scnptr = f_dhdr.s_scnptr; + f_bhdr.s_paddr = f_ohdr.data_start + f_ohdr.dsize; + f_bhdr.s_vaddr = f_ohdr.data_start + f_ohdr.dsize; + f_bhdr.s_size = f_ohdr.bsize; + f_bhdr.s_scnptr = 0L; + bias = f_dhdr.s_scnptr + f_dhdr.s_size - block_copy_start; + + if (f_hdr.f_symptr > 0L) + { + f_hdr.f_symptr += bias; + } + + if (f_thdr.s_lnnoptr > 0L) + { + f_thdr.s_lnnoptr += bias; + } + + if (write (new, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) + { + PERROR (new_name); + } + + if (write (new, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) + { + PERROR (new_name); + } + + if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr)) + { + PERROR (new_name); + } + + if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr)) + { + PERROR (new_name); + } + + if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr)) + { + PERROR (new_name); + } + + return (0); + +} + +write_segment (new, ptr, end) + int new; + register char *ptr, *end; +{ + register int i, nwrite, ret; + char buf[80]; + /* This is the normal amount to write at once. + It is the size of block that NFS uses. */ + int writesize = 1 << 13; + int pagesize = getpagesize (); + char zeros[1 << 13]; + + memset (zeros, 0, sizeof (zeros)); + + for (i = 0; ptr < end;) + { + /* Distance to next multiple of writesize. */ + nwrite = (((int) ptr + writesize) & -writesize) - (int) ptr; + /* But not beyond specified end. */ + if (nwrite > end - ptr) nwrite = end - ptr; + ret = write (new, ptr, nwrite); + /* If write gets a page fault, it means we reached + a gap between the old text segment and the old data segment. + This gap has probably been remapped into part of the text segment. + So write zeros for it. */ + if (ret == -1 +#ifdef EFAULT + && errno == EFAULT +#endif + ) + { + /* Write only a page of zeros at once, + so that we don't overshoot the start + of the valid memory in the old data segment. */ + if (nwrite > pagesize) + nwrite = pagesize; + write (new, zeros, nwrite); + } +#if 0 /* Now that we have can ask `write' to write more than a page, + it is legit for write do less than the whole amount specified. */ + else if (nwrite != ret) + { + sprintf (buf, + "unexec write failure: addr 0x%x, fileno %d, size 0x%x, wrote 0x%x, errno %d", + ptr, new, nwrite, ret, errno); + PERROR (buf); + } +#endif + i += nwrite; + ptr += nwrite; + } +} +/* **************************************************************** + * copy_text_and_data + * + * Copy the text and data segments from memory to the new a.out + */ +static int +copy_text_and_data (new, a_out) + int new, a_out; +{ + register char *end; + register char *ptr; + +#ifdef MSDOS + /* Dump the original table of exception handlers, not the one + where our exception hooks are registered. */ + __djgpp_exception_toggle (); + + /* Switch off startup flags that might have been set at runtime + and which might change the way that dumped Emacs works. */ + save_djgpp_startup_flags = _crt0_startup_flags; + _crt0_startup_flags &= ~(_CRT0_FLAG_NO_LFN | _CRT0_FLAG_NEARPTR); +#endif + + lseek (new, (long) text_scnptr, 0); + ptr = (char *) f_ohdr.text_start; + end = ptr + f_ohdr.tsize; + write_segment (new, ptr, end); + + lseek (new, (long) data_scnptr, 0); + ptr = (char *) f_ohdr.data_start; + end = ptr + f_ohdr.dsize; + write_segment (new, ptr, end); + +#ifdef MSDOS + /* Restore our exception hooks. */ + __djgpp_exception_toggle (); + + /* Restore the startup flags. */ + _crt0_startup_flags = save_djgpp_startup_flags; +#endif + + + return 0; +} + +/* **************************************************************** + * copy_sym + * + * Copy the relocation information and symbol table from the a.out to the new + */ +static int +copy_sym (new, a_out, a_name, new_name) + int new, a_out; + char *a_name, *new_name; +{ + char page[1024]; + int n; + + if (a_out < 0) + return 0; + + if (SYMS_START == 0L) + return 0; + + if (lnnoptr) /* if there is line number info */ + lseek (a_out, coff_offset + lnnoptr, 0); /* start copying from there */ + else + lseek (a_out, coff_offset + SYMS_START, 0); /* Position a.out to symtab. */ + + while ((n = read (a_out, page, sizeof page)) > 0) + { + if (write (new, page, n) != n) + { + PERROR (new_name); + } + } + if (n < 0) + { + PERROR (a_name); + } + return 0; +} + +/* **************************************************************** + * mark_x + * + * After successfully building the new a.out, mark it executable + */ +static void +mark_x (name) + char *name; +{ + struct stat sbuf; + int um; + int new = 0; /* for PERROR */ + + um = umask (777); + umask (um); + if (stat (name, &sbuf) == -1) + { + PERROR (name); + } + sbuf.st_mode |= 0111 & ~um; + if (chmod (name, sbuf.st_mode) == -1) + PERROR (name); +} + + +/* + * If the COFF file contains a symbol table and a line number section, + * then any auxiliary entries that have values for x_lnnoptr must + * be adjusted by the amount that the line number section has moved + * in the file (bias computed in make_hdr). The #@$%&* designers of + * the auxiliary entry structures used the absolute file offsets for + * the line number entry rather than an offset from the start of the + * line number section! + * + * When I figure out how to scan through the symbol table and pick out + * the auxiliary entries that need adjustment, this routine will + * be fixed. As it is now, all such entries are wrong and sdb + * will complain. Fred Fish, UniSoft Systems Inc. + */ + +/* This function is probably very slow. Instead of reopening the new + file for input and output it should copy from the old to the new + using the two descriptors already open (WRITEDESC and READDESC). + Instead of reading one small structure at a time it should use + a reasonable size buffer. But I don't have time to work on such + things, so I am installing it as submitted to me. -- RMS. */ + +adjust_lnnoptrs (writedesc, readdesc, new_name) + int writedesc; + int readdesc; + char *new_name; +{ + register int nsyms; + register int new; + struct syment symentry; + union auxent auxentry; + + if (!lnnoptr || !f_hdr.f_symptr) + return 0; + +#ifdef MSDOS + if ((new = writedesc) < 0) +#else + if ((new = open (new_name, O_RDWR)) < 0) +#endif + { + PERROR (new_name); + return -1; + } + + lseek (new, f_hdr.f_symptr, 0); + for (nsyms = 0; nsyms < f_hdr.f_nsyms; nsyms++) + { + read (new, &symentry, SYMESZ); + if (symentry.n_numaux) + { + read (new, &auxentry, AUXESZ); + nsyms++; + if (ISFCN (symentry.n_type) || symentry.n_type == 0x2400) + { + auxentry.x_sym.x_fcnary.x_fcn.x_lnnoptr += bias; + lseek (new, -AUXESZ, 1); + write (new, &auxentry, AUXESZ); + } + } + } +#ifndef MSDOS + close (new); +#endif + return 0; +} + +extern unsigned start __asm__ ("start"); + +/* + * Return the address of the start of the text segment prior to + * doing an unexec. After unexec the return value is undefined. + * See crt0.c for further explanation and _start. + * + */ + +char * +start_of_text (void) +{ + return ((char *) &start); +} + +/* **************************************************************** + * unexec + * + * driving logic. + */ +unexec (new_name, a_name, data_start, bss_start, entry_address) + char *new_name, *a_name; + unsigned data_start, bss_start, entry_address; +{ + int new, a_out = -1; + + if (a_name && (a_out = open (a_name, O_RDONLY)) < 0) + { + PERROR (a_name); + } + if ((new = creat (new_name, 0666)) < 0) + { + PERROR (new_name); + } + + if (make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) < 0 + || copy_text_and_data (new, a_out) < 0 + || copy_sym (new, a_out, a_name, new_name) < 0 + || adjust_lnnoptrs (new, a_out, new_name) < 0 + ) + { + close (new); + /* unlink (new_name); /* Failed, unlink new a.out */ + return -1; + } + + close (new); + if (a_out >= 0) + close (a_out); + mark_x (new_name); + return 0; +} + +#endif /* not CANNOT_DUMP */ + +/* arch-tag: 62409b69-e27a-4a7c-9413-0210d6b54e7f + (do not change this comment) */ diff --git a/src/unexec.c b/src/unexec.c deleted file mode 100644 index f7f93b066de..00000000000 --- a/src/unexec.c +++ /dev/null @@ -1,658 +0,0 @@ -/* Copyright (C) 1985, 1986, 1987, 1988, 1992, 1993, 1994, 2001, 2002, 2003, - 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - -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 . */ - - -/* - * unexec.c - Convert a running program into an a.out file. - * - * Author: Spencer W. Thomas - * Computer Science Dept. - * University of Utah - * Date: Tue Mar 2 1982 - * Modified heavily since then. - * - * Synopsis: - * unexec (new_name, a_name, data_start, bss_start, entry_address) - * char *new_name, *a_name; - * unsigned data_start, bss_start, entry_address; - * - * Takes a snapshot of the program and makes an a.out format file in the - * file named by the string argument new_name. - * If a_name is non-NULL, the symbol table will be taken from the given file. - * On some machines, an existing a_name file is required. - * - * The boundaries within the a.out file may be adjusted with the data_start - * and bss_start arguments. Either or both may be given as 0 for defaults. - * - * Data_start gives the boundary between the text segment and the data - * segment of the program. The text segment can contain shared, read-only - * program code and literal data, while the data segment is always unshared - * and unprotected. Data_start gives the lowest unprotected address. - * The value you specify may be rounded down to a suitable boundary - * as required by the machine you are using. - * - * Specifying zero for data_start means the boundary between text and data - * should not be the same as when the program was loaded. - * - * Bss_start indicates how much of the data segment is to be saved in the - * a.out file and restored when the program is executed. It gives the lowest - * unsaved address, and is rounded up to a page boundary. The default when 0 - * is given assumes that the entire data segment is to be stored, including - * the previous data and bss as well as any additional storage allocated with - * break (2). - * - * The new file is set up to start at entry_address. - * - * If you make improvements I'd like to get them too. - * harpo!utah-cs!thomas, thomas@Utah-20 - * - */ - -/* Modified to support SysVr3 shared libraries by James Van Artsdalen - * of Dell Computer Corporation. james@bigtex.cactus.org. - */ - -#ifndef emacs -#define PERROR(arg) perror (arg); return -1 -#else -#include -#define PERROR(file) report_error (file, new) -#endif - -#ifndef CANNOT_DUMP /* all rest of file! */ - -#ifdef HAVE_COFF_H -#include -#ifdef MSDOS -#include /* for O_RDONLY, O_RDWR */ -#include /* for _crt0_startup_flags and its bits */ -static int save_djgpp_startup_flags; -#define filehdr external_filehdr -#define scnhdr external_scnhdr -#define syment external_syment -#define auxent external_auxent -#define n_numaux e_numaux -#define n_type e_type -struct aouthdr -{ - unsigned short magic; /* type of file */ - unsigned short vstamp; /* version stamp */ - unsigned long tsize; /* text size in bytes, padded to FW bdry*/ - unsigned long dsize; /* initialized data " " */ - unsigned long bsize; /* uninitialized data " " */ - unsigned long entry; /* entry pt. */ - unsigned long text_start;/* base of text used for this file */ - unsigned long data_start;/* base of data used for this file */ -}; -#endif /* not MSDOS */ -#else /* not HAVE_COFF_H */ -#include -#endif /* not HAVE_COFF_H */ - -/* Define getpagesize if the system does not. - Note that this may depend on symbols defined in a.out.h. */ -#include "getpagesize.h" - -#ifndef makedev /* Try to detect types.h already loaded */ -#include -#endif /* makedev */ -#include -#include -#include - -#include - -#ifndef O_RDONLY -#define O_RDONLY 0 -#endif -#ifndef O_RDWR -#define O_RDWR 2 -#endif - - -extern char *start_of_text (); /* Start of text */ -extern char *start_of_data (); /* Start of initialized data */ - -static long block_copy_start; /* Old executable start point */ -static struct filehdr f_hdr; /* File header */ -static struct aouthdr f_ohdr; /* Optional file header (a.out) */ -long bias; /* Bias to add for growth */ -long lnnoptr; /* Pointer to line-number info within file */ -#define SYMS_START block_copy_start - -static long text_scnptr; -static long data_scnptr; - -static long coff_offset; - -static int pagemask; - -/* Correct an int which is the bit pattern of a pointer to a byte - into an int which is the number of a byte. - This is a no-op on ordinary machines, but not on all. */ - -#define ADDR_CORRECT(x) ((char *)(x) - (char*)0) - -#ifdef emacs - -#include -#include "lisp.h" - -static -report_error (file, fd) - char *file; - int fd; -{ - if (fd) - close (fd); - report_file_error ("Cannot unexec", Fcons (build_string (file), Qnil)); -} -#endif /* emacs */ - -#define ERROR0(msg) report_error_1 (new, msg, 0, 0); return -1 -#define ERROR1(msg,x) report_error_1 (new, msg, x, 0); return -1 -#define ERROR2(msg,x,y) report_error_1 (new, msg, x, y); return -1 - -static -report_error_1 (fd, msg, a1, a2) - int fd; - char *msg; - int a1, a2; -{ - close (fd); -#ifdef emacs - error (msg, a1, a2); -#else - fprintf (stderr, msg, a1, a2); - fprintf (stderr, "\n"); -#endif -} - -static int make_hdr (); -static int copy_text_and_data (); -static int copy_sym (); -static void mark_x (); - -/* **************************************************************** - * make_hdr - * - * Make the header in the new a.out from the header in core. - * Modify the text and data sizes. - */ -static int -make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) - int new, a_out; - unsigned data_start, bss_start, entry_address; - char *a_name; - char *new_name; -{ - int tem; - auto struct scnhdr f_thdr; /* Text section header */ - auto struct scnhdr f_dhdr; /* Data section header */ - auto struct scnhdr f_bhdr; /* Bss section header */ - auto struct scnhdr scntemp; /* Temporary section header */ - register int scns; - unsigned int bss_end; - - pagemask = getpagesize () - 1; - - /* Adjust text/data boundary. */ - data_start = (int) start_of_data (); - data_start = ADDR_CORRECT (data_start); - data_start = data_start & ~pagemask; /* (Down) to page boundary. */ - - bss_end = ADDR_CORRECT (sbrk (0)) + pagemask; - bss_end &= ~ pagemask; - - /* Adjust data/bss boundary. */ - if (bss_start != 0) - { - bss_start = (ADDR_CORRECT (bss_start) + pagemask); - /* (Up) to page bdry. */ - bss_start &= ~ pagemask; - if (bss_start > bss_end) - { - ERROR1 ("unexec: Specified bss_start (%u) is past end of program", - bss_start); - } - } - else - bss_start = bss_end; - - if (data_start > bss_start) /* Can't have negative data size. */ - { - ERROR2 ("unexec: data_start (%u) can't be greater than bss_start (%u)", - data_start, bss_start); - } - - coff_offset = 0L; /* stays zero, except in DJGPP */ - - /* Salvage as much info from the existing file as possible */ - if (a_out >= 0) - { -#ifdef MSDOS - /* Support the coff-go32-exe format with a prepended stub, since - this is what GCC 2.8.0 and later generates by default in DJGPP. */ - unsigned short mz_header[3]; - - if (read (a_out, &mz_header, sizeof (mz_header)) != sizeof (mz_header)) - { - PERROR (a_name); - } - if (mz_header[0] == 0x5a4d || mz_header[0] == 0x4d5a) /* "MZ" or "ZM" */ - { - coff_offset = (long)mz_header[2] * 512L; - if (mz_header[1]) - coff_offset += (long)mz_header[1] - 512L; - lseek (a_out, coff_offset, 0); - } - else - lseek (a_out, 0L, 0); -#endif /* MSDOS */ - if (read (a_out, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) - { - PERROR (a_name); - } - block_copy_start += sizeof (f_hdr); - if (f_hdr.f_opthdr > 0) - { - if (read (a_out, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) - { - PERROR (a_name); - } - block_copy_start += sizeof (f_ohdr); - } - /* Loop through section headers, copying them in */ - lseek (a_out, coff_offset + sizeof (f_hdr) + f_hdr.f_opthdr, 0); - for (scns = f_hdr.f_nscns; scns > 0; scns--) { - if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) - { - PERROR (a_name); - } - if (scntemp.s_scnptr > 0L) - { - if (block_copy_start < scntemp.s_scnptr + scntemp.s_size) - block_copy_start = scntemp.s_scnptr + scntemp.s_size; - } - if (strcmp (scntemp.s_name, ".text") == 0) - { - f_thdr = scntemp; - } - else if (strcmp (scntemp.s_name, ".data") == 0) - { - f_dhdr = scntemp; - } - else if (strcmp (scntemp.s_name, ".bss") == 0) - { - f_bhdr = scntemp; - } - } - } - else - { - ERROR0 ("can't build a COFF file from scratch yet"); - } - - /* Now we alter the contents of all the f_*hdr variables - to correspond to what we want to dump. */ - - f_hdr.f_flags |= (F_RELFLG | F_EXEC); - f_ohdr.text_start = (long) start_of_text (); - f_ohdr.tsize = data_start - f_ohdr.text_start; - f_ohdr.data_start = data_start; - f_ohdr.dsize = bss_start - f_ohdr.data_start; - f_ohdr.bsize = bss_end - bss_start; - f_thdr.s_size = f_ohdr.tsize; - f_thdr.s_scnptr = sizeof (f_hdr) + sizeof (f_ohdr); - f_thdr.s_scnptr += (f_hdr.f_nscns) * (sizeof (f_thdr)); - lnnoptr = f_thdr.s_lnnoptr; - text_scnptr = f_thdr.s_scnptr; - f_dhdr.s_paddr = f_ohdr.data_start; - f_dhdr.s_vaddr = f_ohdr.data_start; - f_dhdr.s_size = f_ohdr.dsize; - f_dhdr.s_scnptr = f_thdr.s_scnptr + f_thdr.s_size; - data_scnptr = f_dhdr.s_scnptr; - f_bhdr.s_paddr = f_ohdr.data_start + f_ohdr.dsize; - f_bhdr.s_vaddr = f_ohdr.data_start + f_ohdr.dsize; - f_bhdr.s_size = f_ohdr.bsize; - f_bhdr.s_scnptr = 0L; - bias = f_dhdr.s_scnptr + f_dhdr.s_size - block_copy_start; - - if (f_hdr.f_symptr > 0L) - { - f_hdr.f_symptr += bias; - } - - if (f_thdr.s_lnnoptr > 0L) - { - f_thdr.s_lnnoptr += bias; - } - - if (write (new, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) - { - PERROR (new_name); - } - - if (write (new, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) - { - PERROR (new_name); - } - - if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr)) - { - PERROR (new_name); - } - - if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr)) - { - PERROR (new_name); - } - - if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr)) - { - PERROR (new_name); - } - - return (0); - -} - -write_segment (new, ptr, end) - int new; - register char *ptr, *end; -{ - register int i, nwrite, ret; - char buf[80]; - /* This is the normal amount to write at once. - It is the size of block that NFS uses. */ - int writesize = 1 << 13; - int pagesize = getpagesize (); - char zeros[1 << 13]; - - memset (zeros, 0, sizeof (zeros)); - - for (i = 0; ptr < end;) - { - /* Distance to next multiple of writesize. */ - nwrite = (((int) ptr + writesize) & -writesize) - (int) ptr; - /* But not beyond specified end. */ - if (nwrite > end - ptr) nwrite = end - ptr; - ret = write (new, ptr, nwrite); - /* If write gets a page fault, it means we reached - a gap between the old text segment and the old data segment. - This gap has probably been remapped into part of the text segment. - So write zeros for it. */ - if (ret == -1 -#ifdef EFAULT - && errno == EFAULT -#endif - ) - { - /* Write only a page of zeros at once, - so that we don't overshoot the start - of the valid memory in the old data segment. */ - if (nwrite > pagesize) - nwrite = pagesize; - write (new, zeros, nwrite); - } -#if 0 /* Now that we have can ask `write' to write more than a page, - it is legit for write do less than the whole amount specified. */ - else if (nwrite != ret) - { - sprintf (buf, - "unexec write failure: addr 0x%x, fileno %d, size 0x%x, wrote 0x%x, errno %d", - ptr, new, nwrite, ret, errno); - PERROR (buf); - } -#endif - i += nwrite; - ptr += nwrite; - } -} -/* **************************************************************** - * copy_text_and_data - * - * Copy the text and data segments from memory to the new a.out - */ -static int -copy_text_and_data (new, a_out) - int new, a_out; -{ - register char *end; - register char *ptr; - -#ifdef MSDOS - /* Dump the original table of exception handlers, not the one - where our exception hooks are registered. */ - __djgpp_exception_toggle (); - - /* Switch off startup flags that might have been set at runtime - and which might change the way that dumped Emacs works. */ - save_djgpp_startup_flags = _crt0_startup_flags; - _crt0_startup_flags &= ~(_CRT0_FLAG_NO_LFN | _CRT0_FLAG_NEARPTR); -#endif - - lseek (new, (long) text_scnptr, 0); - ptr = (char *) f_ohdr.text_start; - end = ptr + f_ohdr.tsize; - write_segment (new, ptr, end); - - lseek (new, (long) data_scnptr, 0); - ptr = (char *) f_ohdr.data_start; - end = ptr + f_ohdr.dsize; - write_segment (new, ptr, end); - -#ifdef MSDOS - /* Restore our exception hooks. */ - __djgpp_exception_toggle (); - - /* Restore the startup flags. */ - _crt0_startup_flags = save_djgpp_startup_flags; -#endif - - - return 0; -} - -/* **************************************************************** - * copy_sym - * - * Copy the relocation information and symbol table from the a.out to the new - */ -static int -copy_sym (new, a_out, a_name, new_name) - int new, a_out; - char *a_name, *new_name; -{ - char page[1024]; - int n; - - if (a_out < 0) - return 0; - - if (SYMS_START == 0L) - return 0; - - if (lnnoptr) /* if there is line number info */ - lseek (a_out, coff_offset + lnnoptr, 0); /* start copying from there */ - else - lseek (a_out, coff_offset + SYMS_START, 0); /* Position a.out to symtab. */ - - while ((n = read (a_out, page, sizeof page)) > 0) - { - if (write (new, page, n) != n) - { - PERROR (new_name); - } - } - if (n < 0) - { - PERROR (a_name); - } - return 0; -} - -/* **************************************************************** - * mark_x - * - * After successfully building the new a.out, mark it executable - */ -static void -mark_x (name) - char *name; -{ - struct stat sbuf; - int um; - int new = 0; /* for PERROR */ - - um = umask (777); - umask (um); - if (stat (name, &sbuf) == -1) - { - PERROR (name); - } - sbuf.st_mode |= 0111 & ~um; - if (chmod (name, sbuf.st_mode) == -1) - PERROR (name); -} - - -/* - * If the COFF file contains a symbol table and a line number section, - * then any auxiliary entries that have values for x_lnnoptr must - * be adjusted by the amount that the line number section has moved - * in the file (bias computed in make_hdr). The #@$%&* designers of - * the auxiliary entry structures used the absolute file offsets for - * the line number entry rather than an offset from the start of the - * line number section! - * - * When I figure out how to scan through the symbol table and pick out - * the auxiliary entries that need adjustment, this routine will - * be fixed. As it is now, all such entries are wrong and sdb - * will complain. Fred Fish, UniSoft Systems Inc. - */ - -/* This function is probably very slow. Instead of reopening the new - file for input and output it should copy from the old to the new - using the two descriptors already open (WRITEDESC and READDESC). - Instead of reading one small structure at a time it should use - a reasonable size buffer. But I don't have time to work on such - things, so I am installing it as submitted to me. -- RMS. */ - -adjust_lnnoptrs (writedesc, readdesc, new_name) - int writedesc; - int readdesc; - char *new_name; -{ - register int nsyms; - register int new; - struct syment symentry; - union auxent auxentry; - - if (!lnnoptr || !f_hdr.f_symptr) - return 0; - -#ifdef MSDOS - if ((new = writedesc) < 0) -#else - if ((new = open (new_name, O_RDWR)) < 0) -#endif - { - PERROR (new_name); - return -1; - } - - lseek (new, f_hdr.f_symptr, 0); - for (nsyms = 0; nsyms < f_hdr.f_nsyms; nsyms++) - { - read (new, &symentry, SYMESZ); - if (symentry.n_numaux) - { - read (new, &auxentry, AUXESZ); - nsyms++; - if (ISFCN (symentry.n_type) || symentry.n_type == 0x2400) - { - auxentry.x_sym.x_fcnary.x_fcn.x_lnnoptr += bias; - lseek (new, -AUXESZ, 1); - write (new, &auxentry, AUXESZ); - } - } - } -#ifndef MSDOS - close (new); -#endif - return 0; -} - -extern unsigned start __asm__ ("start"); - -/* - * Return the address of the start of the text segment prior to - * doing an unexec. After unexec the return value is undefined. - * See crt0.c for further explanation and _start. - * - */ - -char * -start_of_text (void) -{ - return ((char *) &start); -} - -/* **************************************************************** - * unexec - * - * driving logic. - */ -unexec (new_name, a_name, data_start, bss_start, entry_address) - char *new_name, *a_name; - unsigned data_start, bss_start, entry_address; -{ - int new, a_out = -1; - - if (a_name && (a_out = open (a_name, O_RDONLY)) < 0) - { - PERROR (a_name); - } - if ((new = creat (new_name, 0666)) < 0) - { - PERROR (new_name); - } - - if (make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) < 0 - || copy_text_and_data (new, a_out) < 0 - || copy_sym (new, a_out, a_name, new_name) < 0 - || adjust_lnnoptrs (new, a_out, new_name) < 0 - ) - { - close (new); - /* unlink (new_name); /* Failed, unlink new a.out */ - return -1; - } - - close (new); - if (a_out >= 0) - close (a_out); - mark_x (new_name); - return 0; -} - -#endif /* not CANNOT_DUMP */ - -/* arch-tag: 62409b69-e27a-4a7c-9413-0210d6b54e7f - (do not change this comment) */ -- cgit v1.2.3 From 148cef8e7a25f4d05d3b90c78fd8714f64048d24 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Mon, 9 Aug 2010 14:05:56 -0400 Subject: Use version-list-* functions in package.el. * emacs-lisp/package-x.el (package-upload-buffer-internal): Use version-to-list. (package-upload-buffer-internal): Use version-list-<=. * emacs-lisp/package.el (package-version-split) (package--version-first-nonzero, package-version-compare): Functions removed. (package-directory-list, package-load-all-descriptors) (package--built-in, package-activate, define-package) (package-installed-p, package-compute-transaction) (package-read-all-archive-contents) (package--add-to-archive-contents, package-buffer-info) (package-tar-file-info, package-list-packages-internal): Use version-to-list and version-list-*. --- lisp/ChangeLog | 17 +++++++++ lisp/emacs-lisp/package-x.el | 7 ++-- lisp/emacs-lisp/package.el | 89 +++++++++++++------------------------------- 3 files changed, 46 insertions(+), 67 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index c242b6feb78..e302160bd1f 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,20 @@ +2010-08-09 Chong Yidong + + * emacs-lisp/package.el (package-version-split) + (package--version-first-nonzero, package-version-compare): + Functions removed. + (package-directory-list, package-load-all-descriptors) + (package--built-in, package-activate, define-package) + (package-installed-p, package-compute-transaction) + (package-read-all-archive-contents) + (package--add-to-archive-contents, package-buffer-info) + (package-tar-file-info, package-list-packages-internal): Use + version-to-list and version-list-*. + + * emacs-lisp/package-x.el (package-upload-buffer-internal): Use + version-to-list. + (package-upload-buffer-internal): Use version-list-<=. + 2010-08-09 Kenichi Handa * language/hebrew.el: Exclude U+05BD (Hebrew MAQAF) from the diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el index 2a5d84f339b..b93950049e0 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el @@ -129,7 +129,7 @@ If nil, the \"gnu\" archive is used." (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. @@ -150,9 +150,8 @@ If nil, the \"gnu\" archive is used." (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) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index bcb8349c187..2e8c7dc7d4f 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -272,16 +272,12 @@ contrast, `package-user-dir' contains packages for personal use." :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.") @@ -335,29 +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-strip-version (dirname) "Strip the version from a combined package name and version. E.g., if given \"quux-23.0\", will return \"quux\"" @@ -401,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)))))))) @@ -460,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) @@ -479,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)) @@ -493,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." @@ -523,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. @@ -548,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)))))) @@ -700,9 +669,8 @@ It will move point to somewhere in the headers." (defun package-installed-p (package &optional min-version) (let ((pkg-desc (assq package package-alist))) (and pkg-desc - (package-version-compare min-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) @@ -720,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 @@ -730,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) @@ -788,11 +753,11 @@ Throw an error if the archive version is too new." ;; 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) @@ -818,8 +783,7 @@ Also, add the originating archive to the end of the package vector." (vconcat (cdr package) (vector archive)))) (existing-package (cdr (assq name package-archive-contents)))) (when (or (not existing-package) - (package-version-compare version - (aref existing-package 0) '>)) + (version-list-< (aref existing-package 0) version)) (add-to-list 'package-archive-contents entry)))) (defun package-download-transaction (transaction) @@ -915,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) @@ -964,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)))) @@ -1471,10 +1435,9 @@ Emacs." (cond ((stringp (cadr hold)) "held") ((and (setq builtin (assq name package--builtins)) - (package-version-compare + (version-list-= (package-desc-vers (cdr builtin)) - (package-desc-vers desc) - '=)) + (package-desc-vers desc))) "built-in") (t "installed")) (package-desc-doc desc) @@ -1486,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) -- cgit v1.2.3 From d02c9bcd096c44b4e3d5e2834c75967b56cdecdd Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 10 Aug 2010 15:18:14 +0200 Subject: * lisp/emacs-lisp/pcase.el: New file. --- etc/NEWS | 2 + lisp/ChangeLog | 16 +- lisp/emacs-lisp/pcase.el | 489 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 501 insertions(+), 6 deletions(-) create mode 100644 lisp/emacs-lisp/pcase.el (limited to 'lisp/emacs-lisp') diff --git a/etc/NEWS b/etc/NEWS index a92e0e3a658..bec5b3b3468 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -371,6 +371,8 @@ threads simultaneously. * New Modes and Packages in Emacs 24.1 +** pcase.el provides the ML-style pattern matching macro `pcase'. + ** smie.el is a package providing a simple generic indentation engine. ** secrets.el is an implementation of the Secret Service API, an diff --git a/lisp/ChangeLog b/lisp/ChangeLog index c8b49e4b5e7..e5b6c8182d8 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,10 +1,14 @@ +2010-08-10 Stefan Monnier + + * emacs-lisp/pcase.el: New file. + 2010-08-10 Michael Albinus * net/tramp.el (tramp-vc-registered-read-file-names): Read input as here-document, otherwise the command could exceed maximum length of command line. - (tramp-handle-vc-registered): Call script accordingly. Reported - by Toru TSUNEYOSHI . + (tramp-handle-vc-registered): Call script accordingly. + Reported by Toru TSUNEYOSHI . 2010-08-10 Kenichi Handa @@ -21,11 +25,11 @@ (package-installed-p, package-compute-transaction) (package-read-all-archive-contents) (package--add-to-archive-contents, package-buffer-info) - (package-tar-file-info, package-list-packages-internal): Use - version-to-list and version-list-*. + (package-tar-file-info, package-list-packages-internal): + Use version-to-list and version-list-*. - * emacs-lisp/package-x.el (package-upload-buffer-internal): Use - version-to-list. + * emacs-lisp/package-x.el (package-upload-buffer-internal): + Use version-to-list. (package-upload-buffer-internal): Use version-list-<=. 2010-08-09 Kenichi Handa 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 +;; 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 . + +;;; 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 -- cgit v1.2.3