From 43b82baa79132b4ad8ae123532c8f49467d93cb1 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Sun, 1 Feb 2015 17:17:57 -0800 Subject: authors.el: backport some additions * lisp/emacs-lisp/authors.el (authors-obsolete-files-regexps) (authors-valid-file-names, authors-renamed-files-alist): Additions. --- lisp/emacs-lisp/authors.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el index e20ae9543cd..762b0a3a2f5 100644 --- a/lisp/emacs-lisp/authors.el +++ b/lisp/emacs-lisp/authors.el @@ -240,7 +240,7 @@ If REALNAME is nil, ignore that author.") (defvar authors-obsolete-files-regexps '(".*loaddefs.el$" ; not obsolete, but auto-generated - "\\.\\(cvs\\|git\\)ignore$" ; obsolete or uninteresting + "\\.\\(bzr\\|cvs\\|git\\)ignore$" ; obsolete or uninteresting "\\.arch-inventory$" "automated/data/" ; not interesting ;; TODO lib/? Matches other things? @@ -632,6 +632,7 @@ Changes to files in this list are not listed.") "images/page-down.xpm" "images/widen.pbm" "images/widen.xpm" "images/gnus/bar.xbm" "images/gnus/bar.xpm" "images/gnus/reverse-smile.xpm" + "notes/changelogs" "revdiff" ; admin/ "vcdiff" "rcs-checkin" "tindex.pl" "mainmake" "sed1.inp" "sed2.inp" "sed3.inp" ; msdos/ @@ -848,6 +849,8 @@ in the repository.") ("grammars/wisent-grammar.el" . "wisent/grammar.el") ;; Moved from admin/nt/ to nt/. ("nt/README.W32" . "README.W32") + ("notes/BRANCH" . "notes/repo") + ("notes/bzr" . "notes/repo") ) "Alist of files which have been renamed during their lifetime. Elements are (OLDNAME . NEWNAME).") -- cgit v1.2.3 From ec26c23f4815fbc6bbd16d20f400721bc7b58344 Mon Sep 17 00:00:00 2001 From: Nicolas Petton Date: Wed, 4 Feb 2015 01:11:13 +0100 Subject: authors.el: Add missing ignored and renamed files * emacs-lisp/authors.el (authors-ignored-files) (authors-renamed-files-alist): Additions. --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/authors.el | 2 ++ 2 files changed, 7 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index a61c2403dd3..e52f9a35b47 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-02-04 Nicolas Petton + + * emacs-lisp/authors.el (authors-ignored-files) + (authors-renamed-files-alist): Additions. + 2015-02-03 Michael Albinus * net/tramp.el (tramp-ssh-controlmaster-options): Don't use a diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el index 762b0a3a2f5..b44f7aa7146 100644 --- a/lisp/emacs-lisp/authors.el +++ b/lisp/emacs-lisp/authors.el @@ -354,6 +354,7 @@ Changes to files matching one of the regexps in this list are not listed.") "All" "Version" "Everywhere" "Many" "Various" "files" ;; Directories. "vms" "mac" "url" "tree-widget" + "info/dir" ) "List of files and directories to ignore. Changes to files in this list are not listed.") @@ -779,6 +780,7 @@ in the repository.") ("play/bruce.el" . "bruce.el") ("play/yow.el" . "yow.el") ("patcomp.el" . "patcomp.el") + ("emulation/ws-mode.el" . "ws-mode.el") ;; From lisp to etc/forms. ("forms-d2.el" . "forms-d2.el") ("forms-pass.el" . "forms-pass.el") -- cgit v1.2.3 From c49e769d8f141b0307db19ed2a5fa80e0696b1dc Mon Sep 17 00:00:00 2001 From: Nicolas Petton Date: Mon, 9 Feb 2015 13:14:52 +0100 Subject: Improve seq-group-by to return sequence elements in correct order * lisp/emacs-lisp/seq.el (seq-group-by): Improves seq-group-by to return sequence elements in correct order * tests/automated/seq-tests.el: Update test for seq-group-by * doc/lispref/sequences.texi (Sequence Functions): Update documentation examples for seq-group-by --- doc/lispref/ChangeLog | 5 +++++ doc/lispref/sequences.texi | 4 ++-- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/seq.el | 23 +++++++++++------------ test/ChangeLog | 6 ++++++ test/automated/seq-tests.el | 6 +++--- 6 files changed, 32 insertions(+), 17 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog index d82be3c83e7..285c725caef 100644 --- a/doc/lispref/ChangeLog +++ b/doc/lispref/ChangeLog @@ -4,6 +4,11 @@ fullscreen frame parameter. Describe `fullscreen-restore' parameter. +2015-02-09 Nicolas Petton + + * sequences.texi (Sequence Functions): Update documentation + examples for seq-group-by. + 2015-02-09 Eli Zaretskii * positions.texi (Screen Lines): Update the documentation of diff --git a/doc/lispref/sequences.texi b/doc/lispref/sequences.texi index f268c0d11e2..04404f886e0 100644 --- a/doc/lispref/sequences.texi +++ b/doc/lispref/sequences.texi @@ -731,11 +731,11 @@ of @var{sequence}. Keys are compared using @code{equal}. @example @group (seq-group-by #'integerp '(1 2.1 3 2 3.2)) -@result{} ((t 2 3 1) (nil 3.2 2.1)) +@result{} ((t 1 3 2) (nil 2.1 3.2)) @end group @group (seq-group-by #'car '((a 1) (b 2) (a 3) (c 4))) -@result{} ((a (a 3) (a 1)) (b (b 2)) (c (c 4))) +@result{} ((b (b 2)) (a (a 1) (a 3)) (c (c 4))) @end group @end example @end defun diff --git a/lisp/ChangeLog b/lisp/ChangeLog index a6e5f59503e..ece253b1336 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-02-09 Nicolas Petton + + * emacs-lisp/seq.el (seq-group-by): Improves seq-group-by to + return sequence elements in correct order. + 2015-02-11 Martin Rudalics * frame.el (toggle-frame-maximized, toggle-frame-fullscreen): diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 025d94e10b9..5fbec185b76 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -4,7 +4,7 @@ ;; Author: Nicolas Petton ;; Keywords: sequences -;; Version: 1.1 +;; Version: 1.1.1 ;; Maintainer: emacs-devel@gnu.org @@ -245,17 +245,16 @@ negative integer or 0, nil is returned." "Apply FUNCTION to each element of SEQ. Separate the elements of SEQ into an alist using the results as keys. Keys are compared using `equal'." - (nreverse - (seq-reduce - (lambda (acc elt) - (let* ((key (funcall function elt)) - (cell (assoc key acc))) - (if cell - (setcdr cell (push elt (cdr cell))) - (push (list key elt) acc)) - acc)) - seq - nil))) + (seq-reduce + (lambda (acc elt) + (let* ((key (funcall function elt)) + (cell (assoc key acc))) + (if cell + (setcdr cell (push elt (cdr cell))) + (push (list key elt) acc)) + acc)) + (seq-reverse seq) + nil)) (defun seq--drop-list (list n) "Return a list from LIST without its first N elements. diff --git a/test/ChangeLog b/test/ChangeLog index 74fc7cebd56..b080961f681 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -3,6 +3,12 @@ * automated/package-test.el (package-test-signed): More informative failure messages. +2015-02-09 Nicolas Petton + + * automated/seq-tests.el (test-seq-group-by): Update test for + seq-group-by to check that sequence elements are returned in the + correct order. + 2015-02-07 Fabián Ezequiel Gallina * automated/python-tests.el (python-eldoc--get-symbol-at-point-1) diff --git a/test/automated/seq-tests.el b/test/automated/seq-tests.el index ecbc0043210..b92a15cacc5 100644 --- a/test/automated/seq-tests.el +++ b/test/automated/seq-tests.el @@ -216,10 +216,10 @@ Evaluate BODY for each created sequence. (should (equal (seq-partition '(1 2 3) -1) '()))) (ert-deftest test-seq-group-by () - (should (equal (seq-group-by #'test-sequences-oddp [1 2 3 4]) - '((t 3 1) (nil 4 2)))) + (should (equal (seq-group-by #'test-sequences-oddp '(1 2 3 4)) + '((t 1 3) (nil 2 4)))) (should (equal (seq-group-by #'car '((a 1) (b 3) (c 4) (a 2))) - '((a (a 2) (a 1)) (b (b 3)) (c (c 4)))))) + '((b (b 3)) (c (c 4)) (a (a 1) (a 2)))))) (provide 'seq-tests) ;;; seq-tests.el ends here -- cgit v1.2.3 From 4fb5565d0a0cd9640a242028c92b8b4e2bd4683e Mon Sep 17 00:00:00 2001 From: Nicolas Petton Date: Wed, 11 Feb 2015 09:21:03 +0100 Subject: Add a backward-compatible version of seq-reverse * lisp/emacs-lisp/seq.el (seq-reverse): Add a backward-compatible version of seq-reverse that works on sequences in Emacs 24. Bump version to 1.2. * test/automated/seq-tests.el (test-seq-reverse, test-seq-group-by): Add a test for seq-reverse and update test for seq-group-by to test vectors and strings, not only lists. --- lisp/ChangeLog | 12 +++++++++--- lisp/emacs-lisp/seq.el | 28 +++++++++++++++++++++++----- test/ChangeLog | 6 ++++++ test/automated/seq-tests.el | 11 +++++++++-- 4 files changed, 47 insertions(+), 10 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ece253b1336..7e45b9db64c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,7 +1,8 @@ -2015-02-09 Nicolas Petton +2015-02-11 Nicolas Petton - * emacs-lisp/seq.el (seq-group-by): Improves seq-group-by to - return sequence elements in correct order. + * emacs-lisp/seq.el (seq-reverse): Add a backward-compatible + version of seq-reverse that works on sequences in Emacs 24. + Bump seq.el version to 1.2. 2015-02-11 Martin Rudalics @@ -74,6 +75,11 @@ (python-shell-font-lock-turn-off): Fix typo. (python-util-text-properties-replace-name): Delete function. +2015-02-09 Nicolas Petton + + * emacs-lisp/seq.el (seq-group-by): Improves seq-group-by to + return sequence elements in correct order. + 2015-02-09 Simen Heggestøyl (tiny change) * textmodes/css-mode.el (css-smie-rules): Fix paren indent (bug#19815). diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 5fbec185b76..ad4c3536b44 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -4,7 +4,7 @@ ;; Author: Nicolas Petton ;; Keywords: sequences -;; Version: 1.1.1 +;; Version: 1.2 ;; Maintainer: emacs-devel@gnu.org @@ -171,9 +171,7 @@ The result is a sequence of the same type as SEQ." (if (listp seq) (sort (seq-copy seq) pred) (let ((result (seq-sort pred (append seq nil)))) - (cond ((stringp seq) (concat result)) - ((vectorp seq) (vconcat result)) - (t (error "Unsupported sequence: %s" seq)))))) + (seq--into result (type-of seq))))) (defun seq-contains-p (seq elt &optional testfn) "Return the first element in SEQ that equals to ELT. @@ -256,6 +254,27 @@ keys. Keys are compared using `equal'." (seq-reverse seq) nil)) +(defalias 'seq-reverse + (if (ignore-errors (reverse [1 2])) + #'reverse + (lambda (seq) + "Return the reversed copy of list, vector, or string SEQ. +See also the function `nreverse', which is used more often." + (let ((result '())) + (seq-map (lambda (elt) (push elt result)) + seq) + (if (listp seq) + result + (seq--into result (type-of seq))))))) + +(defun seq--into (seq type) + "Convert the sequence SEQ into a sequence of type TYPE." + (pcase type + (`vector (vconcat seq)) + (`string (concat seq)) + (`list (append seq nil)) + (t (error "Not a sequence type name: %s" type)))) + (defun seq--drop-list (list n) "Return a list from LIST without its first N elements. This is an optimization for lists in `seq-drop'." @@ -299,7 +318,6 @@ This is an optimization for lists in `seq-take-while'." (defalias 'seq-copy #'copy-sequence) (defalias 'seq-elt #'elt) -(defalias 'seq-reverse #'reverse) (defalias 'seq-length #'length) (defalias 'seq-do #'mapc) (defalias 'seq-each #'seq-do) diff --git a/test/ChangeLog b/test/ChangeLog index b080961f681..979214c45da 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,9 @@ +2015-02-11 Nicolas Petton + + * automated/seq-tests.el (test-seq-reverse, test-seq-group-by): + Add a test for seq-reverse and update test for seq-group-by to + test vectors and strings, not only lists. + 2015-02-10 Glenn Morris * automated/package-test.el (package-test-signed): diff --git a/test/automated/seq-tests.el b/test/automated/seq-tests.el index b92a15cacc5..badb3267f43 100644 --- a/test/automated/seq-tests.el +++ b/test/automated/seq-tests.el @@ -216,10 +216,17 @@ Evaluate BODY for each created sequence. (should (equal (seq-partition '(1 2 3) -1) '()))) (ert-deftest test-seq-group-by () - (should (equal (seq-group-by #'test-sequences-oddp '(1 2 3 4)) - '((t 1 3) (nil 2 4)))) + (with-test-sequences (seq '(1 2 3 4)) + (should (equal (seq-group-by #'test-sequences-oddp seq) + '((t 1 3) (nil 2 4))))) (should (equal (seq-group-by #'car '((a 1) (b 3) (c 4) (a 2))) '((b (b 3)) (c (c 4)) (a (a 1) (a 2)))))) +(ert-deftest test-seq-reverse () + (with-test-sequences (seq '(1 2 3 4)) + (should (same-contents-p (seq-reverse seq) '(4 3 2 1))) + (should (equal (type-of (seq-reverse seq)) + (type-of seq))))) + (provide 'seq-tests) ;;; seq-tests.el ends here -- cgit v1.2.3 From 0a66ca36fa052fbd7c0c751c96c22b5d81dec658 Mon Sep 17 00:00:00 2001 From: Artur Malabarba Date: Wed, 11 Feb 2015 14:53:43 +0000 Subject: emacs-lisp/package.el (package-install): Invert the second argument. --- lisp/ChangeLog | 7 +++++++ lisp/emacs-lisp/package.el | 28 +++++++++++++--------------- 2 files changed, 20 insertions(+), 15 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 34e4e9d1c2b..def4620db02 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -3,6 +3,13 @@ * hi-lock.el (hi-lock-unface-buffer): Don't call font-lock-remove-keywords if not needed (bug#19737). +2015-02-11 Artur Malabarba + + * emacs-lisp/package.el (package-install): Invert the second + argument, for better backwards compatibility. + (package-install-button-action, package-reinstall) + (package-menu-execute): Account for the change. + 2015-02-11 Nicolas Petton * emacs-lisp/seq.el (seq-reverse): Add a backward-compatible diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index c3a2061aae2..60cf65d2305 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1221,15 +1221,15 @@ using `package-compute-transaction'." (mapc #'package-install-from-archive packages)) ;;;###autoload -(defun package-install (pkg &optional mark-selected) +(defun package-install (pkg &optional dont-select) "Install the package PKG. PKG can be a package-desc or the package name of one the available packages in an archive in `package-archives'. Interactively, prompt for its name. -If called interactively or if MARK-SELECTED is non-nil, add PKG -to `package-selected-packages'. +If called interactively or if DONT-SELECT nil, add PKG to +`package-selected-packages'. -if PKG is a package-desc and it is already installed, don't try +If PKG is a package-desc and it is already installed, don't try to install it but still mark it as selected." (interactive (progn @@ -1247,11 +1247,11 @@ to install it but still mark it as selected." (symbol-name (car elt)))) package-archive-contents)) nil t)) - t))) + nil))) (let ((name (if (package-desc-p pkg) (package-desc-name pkg) pkg))) - (when (and mark-selected (not (package--user-selected-p name))) + (unless (or dont-select (package--user-selected-p name)) (customize-save-variable 'package-selected-packages (cons name package-selected-packages)))) (if (package-desc-p pkg) @@ -1276,7 +1276,7 @@ object." (package-delete (if (package-desc-p pkg) pkg (cadr (assq pkg package-alist))) 'force 'nosave) - (package-install pkg)) + (package-install pkg 'dont-select)) (defun package-strip-rcs-id (str) "Strip RCS version ID from the version string STR. @@ -1929,7 +1929,7 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (let ((pkg-desc (button-get button 'package-desc))) (when (y-or-n-p (format "Install package `%s'? " (package-desc-full-name pkg-desc))) - (package-install pkg-desc 1) + (package-install pkg-desc nil) (revert-buffer nil t) (goto-char (point-min))))) @@ -2427,13 +2427,11 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (mapconcat #'package-desc-full-name install-list ", "))))) (mapc (lambda (p) - ;; Mark as selected if it's the exact version of a - ;; package that's already installed, or if it's not - ;; installed at all. Don't mark if it's a new - ;; version of an installed package. - (package-install p (or (package-installed-p p) - (not (package-installed-p - (package-desc-name p)))))) + ;; Don't mark as selected if it's a new version of + ;; an installed package. + (package-install p (and (not (package-installed-p p)) + (package-installed-p + (package-desc-name p))))) install-list))) ;; Delete packages, prompting if necessary. (when delete-list -- cgit v1.2.3 From 511acc77a4b0be3ed997c335f270b346a4ed0d5f Mon Sep 17 00:00:00 2001 From: Artur Malabarba Date: Wed, 11 Feb 2015 14:53:21 +0000 Subject: emacs-lisp/package.el: Indicate incompatible packages. These are packages which require a higher emacs version than the current one. --- lisp/ChangeLog | 9 +++++++++ lisp/emacs-lisp/package.el | 27 ++++++++++++++++++++++++++- 2 files changed, 35 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index def4620db02..6c51e2aee98 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -16,6 +16,15 @@ version of seq-reverse that works on sequences in Emacs 24. Bump seq.el version to 1.2. +2015-02-11 Artur Malabarba + + * emacs-lisp/package.el (package--incompatible-p): New function. + Return non-nil if PKG has no chance of being installable. + (package--emacs-version-list): New variable. + (describe-package-1, package-desc-status) + (package-menu--print-info, package-menu--status-predicate): + Account for the "incompat" status. + 2015-02-11 Martin Rudalics * frame.el (toggle-frame-maximized, toggle-frame-fullscreen): diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 60cf65d2305..67e2f4050a7 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1796,7 +1796,9 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (pkg-dir (insert (propertize (if (member status '("unsigned" "dependency")) "Installed" - (capitalize status)) ;FIXME: Why comment-face? + (if (equal status "incompat") + "Incompatible" + (capitalize status))) ;FIXME: Why comment-face? 'font-lock-face 'font-lock-comment-face)) (insert " in `") ;; Todo: Add button for uninstalling. @@ -2054,6 +2056,25 @@ package PKG-DESC, add one. The alist is keyed with PKG-DESC." (defvar package-list-unsigned nil "If non-nil, mention in the list which packages were installed w/o signature.") +(defvar package--emacs-version-list (version-to-list emacs-version) + "`emacs-version', as a list.") + +(defun package--incompatible-p (pkg) + "Return non-nil if PKG has no chance of being installable. +PKG is a package-desc object. +Return value is a string describing the reason why the package is +incompatible. + +Currently, this only checks if PKG depends on a higher +`emacs-version' than the one being used." + (let* ((reqs (package-desc-reqs pkg)) + (version (cadr (assq 'emacs reqs)))) + (if (and version (version-list-< package--emacs-version-list version)) + (format "`%s' requires Emacs %s, but current version is %s" + (package-desc-full-name pkg) + (package-version-join version) + emacs-version)))) + (defun package-desc-status (pkg-desc) (let* ((name (package-desc-name pkg-desc)) (dir (package-desc-dir pkg-desc)) @@ -2072,6 +2093,7 @@ package PKG-DESC, add one. The alist is keyed with PKG-DESC." ((version-list-< version hv) "obsolete") (t "disabled")))) ((package-built-in-p name version) "obsolete") + ((package--incompatible-p pkg-desc) "incompat") (dir ;One of the installed packages. (cond ((not (file-exists-p (package-desc-dir pkg-desc))) "deleted") @@ -2222,6 +2244,7 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." (`"installed" 'font-lock-comment-face) (`"dependency" 'font-lock-comment-face) (`"unsigned" 'font-lock-warning-face) + (`"incompat" 'font-lock-comment-face) (_ 'font-lock-warning-face)))) ; obsolete. (list pkg-desc `[,(list (symbol-name (package-desc-name pkg-desc)) @@ -2492,6 +2515,8 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." ((string= sB "built-in") nil) ((string= sA "obsolete") t) ((string= sB "obsolete") nil) + ((string= sA "incompat") t) + ((string= sB "incompat") nil) (t (string< sA sB))))) (defun package-menu--description-predicate (A B) -- cgit v1.2.3 From 3b8b549ffff5b5e774266a9662f738a9335997f2 Mon Sep 17 00:00:00 2001 From: Artur Malabarba Date: Fri, 13 Feb 2015 12:10:42 +0000 Subject: emacs-lisp/package.el (package--incompatible-p): Check dependencies. --- lisp/ChangeLog | 7 ++++++ lisp/emacs-lisp/package.el | 60 ++++++++++++++++++++++++++++++++++++++-------- 2 files changed, 57 insertions(+), 10 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d0038f43708..75adddb038d 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,10 @@ +2015-02-13 Artur Malabarba + + * emacs-lisp/package.el (package--compatibility-table): New var. + (package--add-to-compatibility-table): New function. + (package-read-all-archive-contents): Populate compatibility table. + (package--incompatible-p): Also look in dependencies. + 2015-02-13 Lars Ingebrigtsen * net/rfc2104.el: Moved here from lisp/gnus. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 67e2f4050a7..d9340e1494d 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -468,6 +468,19 @@ called via `package-initialize'. To change which packages are loaded and/or activated, customize `package-load-list'.") (put 'package-alist 'risky-local-variable t) +(defvar package--compatibility-table nil + "Hash table connecting package names to their compatibility. +Each key is a symbol, the name of a package. + +The value is either nil, representing an incompatible package, or +a version list, representing the highest compatible version of +that package which is available. + +A package is considered incompatible if it requires an Emacs +version higher than the one being used. To check for package +\(in)compatibility, don't read this table directly, use +`package--incompatible-p' which also checks dependencies.") + (defvar package-activated-list nil ;; FIXME: This should implicitly include all builtin packages. "List of the names of currently activated packages.") @@ -1131,7 +1144,10 @@ Will throw an error if the archive version is too new." If successful, set `package-archive-contents'." (setq package-archive-contents nil) (dolist (archive package-archives) - (package-read-archive-contents (car archive)))) + (package-read-archive-contents (car archive))) + ;; Build compat table. + (setq package--compatibility-table (make-hash-table :test 'eq)) + (package--mapc #'package--add-to-compatibility-table)) (defun package-read-archive-contents (archive) "Re-read archive contents for ARCHIVE. @@ -1728,6 +1744,19 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (package-activate (car elt)))) (setq package--initialized t)) +(defun package--add-to-compatibility-table (pkg) + "If PKG is compatible (without dependencies), add to the compatibility table. +PKG is a package-desc object. +Only adds if its version is higher than what's already stored in +the table." + (unless (package--incompatible-p pkg 'shallow) + (let* ((name (package-desc-name pkg)) + (version (or (package-desc-version pkg) '(0))) + (table-version (gethash name package--compatibility-table))) + (when (or (not table-version) + (version-list-< table-version version)) + (puthash name version package--compatibility-table))))) + ;;;; Package description buffer. @@ -2059,21 +2088,32 @@ package PKG-DESC, add one. The alist is keyed with PKG-DESC." (defvar package--emacs-version-list (version-to-list emacs-version) "`emacs-version', as a list.") -(defun package--incompatible-p (pkg) +(defun package--incompatible-p (pkg &optional shallow) "Return non-nil if PKG has no chance of being installable. PKG is a package-desc object. -Return value is a string describing the reason why the package is -incompatible. -Currently, this only checks if PKG depends on a higher -`emacs-version' than the one being used." +If SHALLOW is non-nil, this only checks if PKG depends on a +higher `emacs-version' than the one being used. Otherwise, also +checks the viability of dependencies, according to +`package--compatibility-table'. + +If PKG requires an incompatible Emacs version, the return value +is this version (as a string). +If PKG requires incompatible packages, the return value is a list +of these dependencies, similar to the list returned by +`package-desc-reqs'." (let* ((reqs (package-desc-reqs pkg)) (version (cadr (assq 'emacs reqs)))) (if (and version (version-list-< package--emacs-version-list version)) - (format "`%s' requires Emacs %s, but current version is %s" - (package-desc-full-name pkg) - (package-version-join version) - emacs-version)))) + (package-version-join version) + (unless shallow + (let (out) + (dolist (dep (package-desc-reqs pkg) out) + (let ((dep-name (car dep))) + (unless (eq 'emacs dep-name) + (let ((cv (gethash dep-name package--compatibility-table))) + (when (version-list-< (or cv '(0)) (or (cadr dep) '(0))) + (push dep out))))))))))) (defun package-desc-status (pkg-desc) (let* ((name (package-desc-name pkg-desc)) -- cgit v1.2.3 From a03ab7eaf532075d2948ece70b8f3c97cd26b577 Mon Sep 17 00:00:00 2001 From: Artur Malabarba Date: Fri, 13 Feb 2015 13:08:38 +0000 Subject: emacs-lisp/package.el (describe-package-1): Fix "incompat" handling. --- lisp/ChangeLog | 1 + lisp/emacs-lisp/package.el | 6 +++--- 2 files changed, 4 insertions(+), 3 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 75adddb038d..030d572d90f 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -4,6 +4,7 @@ (package--add-to-compatibility-table): New function. (package-read-all-archive-contents): Populate compatibility table. (package--incompatible-p): Also look in dependencies. + (describe-package-1): Fix "incompat" handling. 2015-02-13 Lars Ingebrigtsen diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index d9340e1494d..d8b4595b6e6 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1811,6 +1811,8 @@ the table." (installable (and archive (not built-in))) (status (if desc (package-desc-status desc) "orphan")) (signed (if desc (package-desc-signed desc)))) + (when (string= status "incompat") + (setq status "incompatible")) (prin1 name) (princ " is ") (princ (if (memq (aref status 0) '(?a ?e ?i ?o ?u)) "an " "a ")) @@ -1825,9 +1827,7 @@ the table." (pkg-dir (insert (propertize (if (member status '("unsigned" "dependency")) "Installed" - (if (equal status "incompat") - "Incompatible" - (capitalize status))) ;FIXME: Why comment-face? + (capitalize status)) ;FIXME: Why comment-face? 'font-lock-face 'font-lock-comment-face)) (insert " in `") ;; Todo: Add button for uninstalling. -- cgit v1.2.3 From 61b4c22c6eba96718327a0d208a8492d8bad76e0 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 14 Feb 2015 00:46:29 -0500 Subject: * lisp/emacs-lisp/cl*.el: Use define-inline and move some code * lisp/emacs-lisp/cl-lib.el: Move autoloaded code to cl-preload. * lisp/emacs-lisp/cl-preloaded.el (cl-struct-define): Register as children of the parent. (cl--assertion-failed): New function. (cl-assertion-failed): Move in from cl-lib.el. * lisp/emacs-lisp/cl-macs.el (cl-defstruct): Don't generate code to register as children of its parents. (cl--make-type-test, cl--compiler-macro-typep): Remove functions. (cl-typep): Reimplement using define-inline. (cl-assert): Use cl--assertion-failed. (cl-struct-slot-value): Use define-inline. --- lisp/ChangeLog | 14 ++++ lisp/emacs-lisp/cl-lib.el | 16 ---- lisp/emacs-lisp/cl-macs.el | 160 ++++++++++++++++++++-------------------- lisp/emacs-lisp/cl-preloaded.el | 26 +++++++ 4 files changed, 121 insertions(+), 95 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 257b11bd51c..24cf80a4093 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,19 @@ 2015-02-14 Stefan Monnier + * emacs-lisp/cl-preloaded.el (cl-struct-define): Register as children + of the parent. + (cl--assertion-failed): New function. + (cl-assertion-failed): Move in from cl-lib.el. + + * emacs-lisp/cl-macs.el (cl-defstruct): Don't generate code to register + as children of its parents. + (cl--make-type-test, cl--compiler-macro-typep): Remove functions. + (cl-typep): Reimplement using define-inline. + (cl-assert): Use cl--assertion-failed. + (cl-struct-slot-value): Use define-inline. + + * emacs-lisp/cl-lib.el: Move autoloaded code to cl-preload. + * textmodes/flyspell.el (flyspell-word): Defvar (bug#19844). (flyspell-generic-check-word-p): Mark as obsolete. diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 0f534181b22..4b124951446 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -731,22 +731,6 @@ If ALIST is non-nil, the new pairs are prepended to it." ;;; Miscellaneous. -;;;###autoload -(progn - ;; The `assert' macro from the cl package signals - ;; `cl-assertion-failed' at runtime so always define it. - (define-error 'cl-assertion-failed (purecopy "Assertion failed")) - ;; Make sure functions defined with cl-defsubst can be inlined even in - ;; packages which do not require CL. We don't put an autoload cookie - ;; directly on that function, since those cookies only go to cl-loaddefs. - (autoload 'cl--defsubst-expand "cl-macs") - ;; Autoload, so autoload.el and font-lock can use it even when CL - ;; is not loaded. - (put 'cl-defun 'doc-string-elt 3) - (put 'cl-defmacro 'doc-string-elt 3) - (put 'cl-defsubst 'doc-string-elt 3) - (put 'cl-defstruct 'doc-string-elt 2)) - (provide 'cl-lib) (or (load "cl-loaddefs" 'noerror 'quiet) ;; When bootstrapping, cl-loaddefs hasn't been built yet! diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index eaec2c5263c..2861d669697 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2488,13 +2488,7 @@ non-nil value, that slot cannot be set via `setf'. (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs)) type (car inc-type) named (assq 'cl-tag-slot descs)) - (if (cadr inc-type) (setq tag name named t)) - (let ((incl include)) - (while incl - (push `(cl-pushnew ',tag - ,(intern (format "cl-struct-%s-tags" incl))) - forms) - (setq incl (get incl 'cl-struct-include))))) + (if (cadr inc-type) (setq tag name named t))) (if type (progn (or (memq type '(vector list)) @@ -2661,64 +2655,70 @@ Of course, we really can't know that for sure, so it's just a heuristic." (or (cdr (assq sym byte-compile-function-environment)) (cdr (assq sym byte-compile-macro-environment)))))) -(defun cl--make-type-test (val type) - (pcase type - ((and `(,name . ,args) (guard (get name 'cl-deftype-handler))) - (cl--make-type-test val (apply (get name 'cl-deftype-handler) - args))) - (`(,(and name (or 'integer 'float 'real 'number)) - . ,(or `(,min ,max) pcase--dontcare)) - `(and ,(cl--make-type-test val name) - ,(if (memq min '(* nil)) t - (if (consp min) `(> ,val ,(car min)) - `(>= ,val ,min))) - ,(if (memq max '(* nil)) t - (if (consp max) - `(< ,val ,(car max)) - `(<= ,val ,max))))) - (`(,(and name (or 'and 'or 'not)) . ,args) - (cons name (mapcar (lambda (x) (cl--make-type-test val x)) args))) - (`(member . ,args) - `(and (cl-member ,val ',args) t)) - (`(satisfies ,pred) `(funcall #',pred ,val)) - ((and (pred symbolp) (guard (get type 'cl-deftype-handler))) - (cl--make-type-test val (funcall (get type 'cl-deftype-handler)))) - ((and (pred symbolp) (guard (get type 'cl-deftype-satisfies))) - `(funcall #',(get type 'cl-deftype-satisfies) ,val)) - ((or 'nil 't) type) - ('null `(null ,val)) - ('atom `(atom ,val)) - ('float `(floatp ,val)) - ('real `(numberp ,val)) - ('fixnum `(integerp ,val)) - ;; FIXME: Implement `base-char' and `extended-char'. - ('character `(characterp ,val)) - ((pred symbolp) - (let* ((name (symbol-name type)) - (namep (intern (concat name "p")))) - (cond - ((cl--macroexp-fboundp namep) (list namep val)) - ((cl--macroexp-fboundp - (setq namep (intern (concat name "-p")))) - (list namep val)) - ((cl--macroexp-fboundp type) (list type val)) - (t (error "Unknown type %S" type))))) - (_ (error "Bad type spec: %s" type)))) - -(defvar cl--object) +(put 'null 'cl-deftype-satisfies #'null) +(put 'atom 'cl-deftype-satisfies #'atom) +(put 'real 'cl-deftype-satisfies #'numberp) +(put 'fixnum 'cl-deftype-satisfies #'integerp) +(put 'base-char 'cl-deftype-satisfies #'characterp) +(put 'character 'cl-deftype-satisfies #'integerp) + + ;;;###autoload -(defun cl-typep (object type) ; See compiler macro below. - "Check that OBJECT is of type TYPE. -TYPE is a Common Lisp-style type specifier." - (declare (compiler-macro cl--compiler-macro-typep)) - (let ((cl--object object)) ;; Yuck!! - (eval (cl--make-type-test 'cl--object type)))) - -(defun cl--compiler-macro-typep (form val type) - (if (macroexp-const-p type) - (macroexp-let2 macroexp-copyable-p temp val - (cl--make-type-test temp (cl--const-expr-val type))) - form)) +(define-inline cl-typep (val type) + (inline-letevals (val) + (pcase (inline-const-val type) + ((and `(,name . ,args) (guard (get name 'cl-deftype-handler))) + (inline-quote + (cl-typep ,val ',(apply (get name 'cl-deftype-handler) args)))) + (`(,(and name (or 'integer 'float 'real 'number)) + . ,(or `(,min ,max) pcase--dontcare)) + (inline-quote + (and (cl-typep ,val ',name) + ,(if (memq min '(* nil)) t + (if (consp min) + (inline-quote (> ,val ',(car min))) + (inline-quote (>= ,val ',min)))) + ,(if (memq max '(* nil)) t + (if (consp max) + (inline-quote (< ,val ',(car max))) + (inline-quote (<= ,val ',max))))))) + (`(not ,type) (inline-quote (not (cl-typep ,val ',type)))) + (`(,(and name (or 'and 'or)) . ,types) + (cond + ((null types) (inline-quote ',(eq name 'and))) + ((null (cdr types)) + (inline-quote (cl-typep ,val ',(car types)))) + (t + (let ((head (car types)) + (rest `(,name . ,(cdr types)))) + (cond + ((eq name 'and) + (inline-quote (and (cl-typep ,val ',head) + (cl-typep ,val ',rest)))) + (t + (inline-quote (or (cl-typep ,val ',head) + (cl-typep ,val ',rest))))))))) + (`(member . ,args) + (inline-quote (and (memql ,val ',args) t))) + (`(satisfies ,pred) (inline-quote (funcall #',pred ,val))) + ((and (pred symbolp) type (guard (get type 'cl-deftype-handler))) + (inline-quote + (cl-typep ,val ',(funcall (get type 'cl-deftype-handler))))) + ((and (pred symbolp) type (guard (get type 'cl-deftype-satisfies))) + (inline-quote (funcall #',(get type 'cl-deftype-satisfies) ,val))) + ((and (or 'nil 't) type) (inline-quote ',type)) + ((and (pred symbolp) type) + (let* ((name (symbol-name type)) + (namep (intern (concat name "p")))) + (cond + ((cl--macroexp-fboundp namep) (inline-quote (funcall #',namep ,val))) + ((cl--macroexp-fboundp + (setq namep (intern (concat name "-p")))) + (inline-quote (funcall #',namep ,val))) + ((cl--macroexp-fboundp type) (inline-quote (funcall #',type ,val))) + (t (error "Unknown type %S" type))))) + (type (error "Bad type spec: %s" type))))) + ;;;###autoload (defmacro cl-check-type (form type &optional string) @@ -2751,10 +2751,9 @@ omitted, a default message listing FORM itself is used." (cdr form)))))) `(progn (or ,form - ,(if string - `(error ,string ,@sargs ,@args) - `(signal 'cl-assertion-failed - (list ',form ,@sargs)))) + (cl--assertion-failed + ',form ,@(if (or string sargs args) + `(,string (list ,@sargs) (list ,@args))))) nil)))) ;;; Compiler macros. @@ -2962,23 +2961,26 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (put ',name 'cl-deftype-handler (cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body))))) +(cl-deftype extended-char () `(and character (not base-char))) + ;;; Additional functions that we can now define because we've defined ;;; `cl-defsubst' and `cl-typep'. -(cl-defsubst cl-struct-slot-value (struct-type slot-name inst) - ;; The use of `cl-defsubst' here gives us both a compiler-macro - ;; and a gv-expander "for free". +(define-inline cl-struct-slot-value (struct-type slot-name inst) "Return the value of slot SLOT-NAME in INST of STRUCT-TYPE. STRUCT and SLOT-NAME are symbols. INST is a structure instance." (declare (side-effect-free t)) - (unless (cl-typep inst struct-type) - (signal 'wrong-type-argument (list struct-type inst))) - ;; We could use `elt', but since the byte compiler will resolve the - ;; branch below at compile time, it's more efficient to use the - ;; type-specific accessor. - (if (eq (cl-struct-sequence-type struct-type) 'vector) - (aref inst (cl-struct-slot-offset struct-type slot-name)) - (nth (cl-struct-slot-offset struct-type slot-name) inst))) + (inline-letevals (struct-type slot-name inst) + (inline-quote + (progn + (unless (cl-typep ,inst ,struct-type) + (signal 'wrong-type-argument (list ,struct-type ,inst))) + ;; We could use `elt', but since the byte compiler will resolve the + ;; branch below at compile time, it's more efficient to use the + ;; type-specific accessor. + (if (eq (cl-struct-sequence-type ,struct-type) 'vector) + (aref ,inst (cl-struct-slot-offset ,struct-type ,slot-name)) + (nth (cl-struct-slot-offset ,struct-type ,slot-name) ,inst)))))) (run-hooks 'cl-macs-load-hook) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index c9867b412a1..03045de509a 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -33,6 +33,10 @@ (if (boundp children-sym) (add-to-list children-sym tag) (set children-sym (list tag))) + (let* ((parent-class parent)) + (while parent-class + (add-to-list (intern (format "cl-struct-%s-tags" parent-class)) tag) + (setq parent-class (get parent-class 'cl-struct-include)))) ;; If the cl-generic support, we need to be able to check ;; if a vector is a cl-struct object, without knowing its particular type. ;; So we use the (otherwise) unused function slots of the tag symbol @@ -44,5 +48,27 @@ (if print-auto (put name 'cl-struct-print print-auto)) (if docstring (put name 'structure-documentation docstring))) +;; The `assert' macro from the cl package signals +;; `cl-assertion-failed' at runtime so always define it. +(define-error 'cl-assertion-failed (purecopy "Assertion failed")) + +(defun cl--assertion-failed (form &optional string sargs args) + (if debug-on-error + (debug `(cl-assertion-failed ,form ,string ,@sargs)) + (if string + (apply #'error string (append sargs args)) + (signal 'cl-assertion-failed `(,form ,@sargs))))) + +;; Make sure functions defined with cl-defsubst can be inlined even in +;; packages which do not require CL. We don't put an autoload cookie +;; directly on that function, since those cookies only go to cl-loaddefs. +(autoload 'cl--defsubst-expand "cl-macs") +;; Autoload, so autoload.el and font-lock can use it even when CL +;; is not loaded. +(put 'cl-defun 'doc-string-elt 3) +(put 'cl-defmacro 'doc-string-elt 3) +(put 'cl-defsubst 'doc-string-elt 3) +(put 'cl-defstruct 'doc-string-elt 2) + (provide 'cl-preloaded) ;;; cl-preloaded.el ends here -- cgit v1.2.3 From 34c75359126e78367e4542a39b4b687c8955e1c6 Mon Sep 17 00:00:00 2001 From: Artur Malabarba Date: Sat, 14 Feb 2015 11:13:29 -0200 Subject: emacs-lisp/package.el: Move the compatibility-table building logic. --- lisp/ChangeLog | 8 ++++++++ lisp/emacs-lisp/package.el | 19 +++++++++++++------ 2 files changed, 21 insertions(+), 6 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 24cf80a4093..42b386f3f22 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,11 @@ +2015-02-14 Artur Malabarba + + * emacs-lisp/package.el (package-read-all-archive-contents): Don't + build the compatibility table. + (package-refresh-contents, package-initialize): Do build the + compatibility table. + (package--build-compatibility-table): New function. + 2015-02-14 Stefan Monnier * emacs-lisp/cl-preloaded.el (cl-struct-define): Register as children diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index d8b4595b6e6..64a646a9896 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1144,10 +1144,7 @@ Will throw an error if the archive version is too new." If successful, set `package-archive-contents'." (setq package-archive-contents nil) (dolist (archive package-archives) - (package-read-archive-contents (car archive))) - ;; Build compat table. - (setq package--compatibility-table (make-hash-table :test 'eq)) - (package--mapc #'package--add-to-compatibility-table)) + (package-read-archive-contents (car archive)))) (defun package-read-archive-contents (archive) "Re-read archive contents for ARCHIVE. @@ -1691,6 +1688,12 @@ similar to an entry in `package-alist'. Save the cached copy to (epg-import-keys-from-file context file) (message "Importing %s...done" (file-name-nondirectory file)))) +(defun package--build-compatibility-table () + "Build `package--compatibility-table' with `package--mapc'." + ;; Build compat table. + (setq package--compatibility-table (make-hash-table :test 'eq)) + (package--mapc #'package--add-to-compatibility-table)) + ;;;###autoload (defun package-refresh-contents () "Download the ELPA archive description if needed. @@ -1713,7 +1716,8 @@ makes them available for download." (package--download-one-archive archive "archive-contents") (error (message "Failed to download `%s' archive." (car archive))))) - (package-read-all-archive-contents)) + (package-read-all-archive-contents) + (package--build-compatibility-table)) (defun package--find-non-dependencies () "Return a list of installed packages which are not dependencies. @@ -1742,7 +1746,10 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (unless no-activate (dolist (elt package-alist) (package-activate (car elt)))) - (setq package--initialized t)) + (setq package--initialized t) + ;; This uses `package--mapc' so it must be called after + ;; `package--initialized' is t. + (package--build-compatibility-table)) (defun package--add-to-compatibility-table (pkg) "If PKG is compatible (without dependencies), add to the compatibility table. -- cgit v1.2.3 From f4f4f93e42a0ae572a62c9f64b90e4401232d9f4 Mon Sep 17 00:00:00 2001 From: Artur Malabarba Date: Sat, 14 Feb 2015 15:06:27 -0200 Subject: emacs-lisp/package.el (describe-package-1): Describe incompatibility. --- lisp/ChangeLog | 1 + lisp/emacs-lisp/package.el | 36 +++++++++++++++++++++++------------- 2 files changed, 24 insertions(+), 13 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 42b386f3f22..3cc42a5964b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -5,6 +5,7 @@ (package-refresh-contents, package-initialize): Do build the compatibility table. (package--build-compatibility-table): New function. + (describe-package-1): Describe why a package is incompatible. 2015-02-14 Stefan Monnier diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 64a646a9896..d8a4fc9c846 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1817,8 +1817,9 @@ the table." (built-in (eq pkg-dir 'builtin)) (installable (and archive (not built-in))) (status (if desc (package-desc-status desc) "orphan")) + (incompatible-reason (package--incompatible-p desc)) (signed (if desc (package-desc-signed desc)))) - (when (string= status "incompat") + (when incompatible-reason (setq status "incompatible")) (prin1 name) (princ " is ") @@ -1850,6 +1851,12 @@ the table." (if signed (insert ".") (insert " (unsigned)."))) + (incompatible-reason + (insert (propertize "Incompatible" 'face font-lock-warning-face) + " because it depends on ") + (if (stringp incompatible-reason) + (insert "Emacs " incompatible-reason ".") + (insert "uninstallable packages."))) (installable (insert (capitalize status)) (insert " from " (format "%s" archive)) @@ -1870,19 +1877,22 @@ the table." (setq reqs (if desc (package-desc-reqs desc))) (when reqs (insert " " (propertize "Requires" 'font-lock-face 'bold) ": ") - (let ((first t) - name vers text) + (let ((first t)) (dolist (req reqs) - (setq name (car req) - vers (cadr req) - text (format "%s-%s" (symbol-name name) - (package-version-join vers))) - (cond (first (setq first nil)) - ((>= (+ 2 (current-column) (length text)) - (window-width)) - (insert ",\n ")) - (t (insert ", "))) - (help-insert-xref-button text 'help-package name)) + (let* ((name (car req)) + (vers (cadr req)) + (text (format "%s-%s" (symbol-name name) + (package-version-join vers))) + (reason (if (and (listp incompatible-reason) + (assq name incompatible-reason)) + " (not available)" ""))) + (cond (first (setq first nil)) + ((>= (+ 2 (current-column) (length text) (length reason)) + (window-width)) + (insert ",\n ")) + (t (insert ", "))) + (help-insert-xref-button text 'help-package name) + (insert reason))) (insert "\n"))) (insert " " (propertize "Summary" 'font-lock-face 'bold) ": " (if desc (package-desc-summary desc)) "\n") -- cgit v1.2.3 From 6bf61df8ab359f1371ab2e3e278bc8642d65a985 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 16 Feb 2015 01:37:57 -0500 Subject: * lisp/emacs-lisp/cl-macs.el (cl-defstruct): Keep type=nil by default. * lisp/emacs-lisp/cl-preloaded.el (cl-struct-define): Add sanity checks about relationship between `type', `named', and `slots'. * lisp/emacs-lisp/cl-generic.el (cl--generic-struct-tagcode): Adjust to new value of `cl-struct-type' property. --- lisp/ChangeLog | 12 ++++++++++-- lisp/emacs-lisp/bytecomp.el | 14 +++++++------- lisp/emacs-lisp/cl-generic.el | 4 ++-- lisp/emacs-lisp/cl-macs.el | 8 ++++---- lisp/emacs-lisp/cl-preloaded.el | 4 ++++ 5 files changed, 27 insertions(+), 15 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ca180ff6327..bb8c97badf7 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,11 @@ +2015-02-16 Stefan Monnier + + * emacs-lisp/cl-macs.el (cl-defstruct): Keep type=nil by default. + * emacs-lisp/cl-preloaded.el (cl-struct-define): Add sanity checks + about relationship between `type', `named', and `slots'. + * emacs-lisp/cl-generic.el (cl--generic-struct-tagcode): Adjust to new + value of `cl-struct-type' property. + 2015-02-15 Jérémy Compostella * net/tramp-sh.el (tramp-remote-process-environment): Disable paging @@ -5,8 +13,8 @@ 2015-02-14 Artur Malabarba - * emacs-lisp/package.el (package-read-all-archive-contents): Don't - build the compatibility table. + * emacs-lisp/package.el (package-read-all-archive-contents): + Don't build the compatibility table. (package-refresh-contents, package-initialize): Do build the compatibility table. (package--build-compatibility-table): New function. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 548aaa9626b..e929c02eefb 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1353,13 +1353,13 @@ extra args." (let ((keyword-args (cdr (cdr (cdr (cdr form))))) (name (cadr form))) (or (not (eq (car-safe name) 'quote)) - (and (eq (car form) 'custom-declare-group) - (equal name ''emacs)) - (plist-get keyword-args :group) - (not (and (consp name) (eq (car name) 'quote))) - (byte-compile-warn - "%s for `%s' fails to specify containing group" - (cdr (assq (car form) + (and (eq (car form) 'custom-declare-group) + (equal name ''emacs)) + (plist-get keyword-args :group) + (not (and (consp name) (eq (car name) 'quote))) + (byte-compile-warn + "%s for `%s' fails to specify containing group" + (cdr (assq (car form) '((custom-declare-group . defgroup) (custom-declare-face . defface) (custom-declare-variable . defcustom)))) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index c4232863cfc..ccd5bec5685 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -731,7 +731,7 @@ Can only be used from within the lexical body of a primary or around method." (defun cl--generic-struct-tagcode (type name) (and (symbolp type) (get type 'cl-struct-type) - (or (eq 'vector (car (get type 'cl-struct-type))) + (or (null (car (get type 'cl-struct-type))) (error "Can't dispatch on cl-struct %S: type is %S" type (car (get type 'cl-struct-type)))) (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots))) @@ -761,7 +761,7 @@ Can only be used from within the lexical body of a primary or around method." (let ((types (list (intern (substring (symbol-name tag) 10))))) (while (get (car types) 'cl-struct-include) (push (get (car types) 'cl-struct-include) types)) - (push 'cl-struct types) ;The "parent type" of all cl-structs. + (push 'cl-structure-object types) ;The "parent type" of all cl-structs. (nreverse types)))) ;;; Dispatch on "system types". diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 2861d669697..caaf7687dc8 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2494,7 +2494,7 @@ non-nil value, that slot cannot be set via `setf'. (or (memq type '(vector list)) (error "Invalid :type specifier: %s" type)) (if named (setq tag name))) - (setq type 'vector named 'true))) + (setq named 'true))) (or named (setq descs (delq (assq 'cl-tag-slot descs) descs))) (when (and (null predicate) named) (setq predicate (intern (format "cl--struct-%s-p" name)))) @@ -2503,7 +2503,7 @@ non-nil value, that slot cannot be set via `setf'. (length (memq (assq 'cl-tag-slot descs) descs))))) (cond - ((eq type 'vector) + ((memq type '(nil vector)) `(and (vectorp cl-x) (>= (length cl-x) ,(length descs)) (memq (aref cl-x ,pos) ,tag-symbol))) @@ -2535,7 +2535,7 @@ non-nil value, that slot cannot be set via `setf'. (list `(or ,pred-check (error "%s accessing a non-%s" ',accessor ',name)))) - ,(if (eq type 'vector) `(aref cl-x ,pos) + ,(if (memq type '(nil vector)) `(aref cl-x ,pos) (if (= pos 0) '(car cl-x) `(nth ,pos cl-x)))) forms) @@ -2593,7 +2593,7 @@ non-nil value, that slot cannot be set via `setf'. (&cl-defs '(nil ,@descs) ,@args) ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) '((declare (side-effect-free t)))) - (,type ,@make)) + (,(or type #'vector) ,@make)) forms))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) ;; Don't bother adding to cl-custom-print-functions since it's not used diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 03045de509a..401d34b449e 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -28,8 +28,12 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defun cl-struct-define (name docstring parent type named slots children-sym tag print-auto) + (cl-assert (or type (equal '(cl-tag-slot) (car slots)))) + (cl-assert (or type (not named))) (if (boundp children-sym) (add-to-list children-sym tag) (set children-sym (list tag))) -- cgit v1.2.3 From c4e2be4587ec6d0f1367b1bfe220a71360e25bea Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 16 Feb 2015 02:22:46 -0500 Subject: * lisp/emacs-lisp/eieio*.el: Align a bit better with CLOS * lisp/cedet/semantic/db-el.el (semanticdb-elisp-sym->tag): Fix copy&paste error (semanticdb-project-database => sym). Avoid eieio--class-public-a when possible. * lisp/emacs-lisp/eieio-base.el (make-instance): Add a method here rather than on eieio-constructor. * lisp/emacs-lisp/eieio-core.el (eieio--class-print-name): New function. (eieio-class-name): Make it do what the docstring claims. (eieio-defclass-internal): Simplify since `prots' isn't used any more. (eieio--slot-name-index): Simplify accordingly. (eieio-barf-if-slot-unbound): Pass the class object rather than its name to `slot-unbound'. * lisp/emacs-lisp/eieio.el (defclass): Use make-instance rather than eieio-constructor. (set-slot-value): Mark as obsolete. (eieio-object-class-name): Improve call to eieio-class-name. (eieio-slot-descriptor-name, eieio-class-slots): New functions. (object-slots): Use it. Declare obsolete. (eieio-constructor): Merge it with `make-instance'. (initialize-instance): Use `dolist'. (eieio-override-prin1, eieio-edebug-prin1-to-string): Use eieio--class-print-name. * test/automated/eieio-test-methodinvoke.el (make-instance): Add methods here rather than on eieio-constructor. --- lisp/ChangeLog | 23 ++++++++ lisp/cedet/ChangeLog | 6 ++ lisp/cedet/semantic/db-el.el | 8 ++- lisp/emacs-lisp/eieio-base.el | 2 +- lisp/emacs-lisp/eieio-core.el | 33 +++++------ lisp/emacs-lisp/eieio.el | 91 ++++++++++++++++--------------- test/ChangeLog | 5 ++ test/automated/eieio-test-methodinvoke.el | 4 +- 8 files changed, 101 insertions(+), 71 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index bb8c97badf7..e4383437c6d 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,26 @@ +2015-02-16 Stefan Monnier + + * emacs-lisp/eieio.el (defclass): Use make-instance rather than + eieio-constructor. + (set-slot-value): Mark as obsolete. + (eieio-object-class-name): Improve call to eieio-class-name. + (eieio-slot-descriptor-name, eieio-class-slots): New functions. + (object-slots): Use it. Declare obsolete. + (eieio-constructor): Merge it with `make-instance'. + (initialize-instance): Use `dolist'. + (eieio-override-prin1, eieio-edebug-prin1-to-string): + Use eieio--class-print-name. + + * emacs-lisp/eieio-core.el (eieio--class-print-name): New function. + (eieio-class-name): Make it do what the docstring claims. + (eieio-defclass-internal): Simplify since `prots' isn't used any more. + (eieio--slot-name-index): Simplify accordingly. + (eieio-barf-if-slot-unbound): Pass the class object rather than its + name to `slot-unbound'. + + * emacs-lisp/eieio-base.el (make-instance): Add a method here rather + than on eieio-constructor. + 2015-02-16 Stefan Monnier * emacs-lisp/cl-macs.el (cl-defstruct): Keep type=nil by default. diff --git a/lisp/cedet/ChangeLog b/lisp/cedet/ChangeLog index 6bbae7e08a8..838a2693491 100644 --- a/lisp/cedet/ChangeLog +++ b/lisp/cedet/ChangeLog @@ -1,3 +1,9 @@ +2015-02-16 Stefan Monnier + + * semantic/db-el.el (semanticdb-elisp-sym->tag): Fix copy&paste error + (semanticdb-project-database => sym). Avoid eieio--class-public-a + when possible. + 2015-02-04 Stefan Monnier Use cl-generic instead of EIEIO's defgeneric/defmethod. diff --git a/lisp/cedet/semantic/db-el.el b/lisp/cedet/semantic/db-el.el index e37b65a461e..b20a756f6b7 100644 --- a/lisp/cedet/semantic/db-el.el +++ b/lisp/cedet/semantic/db-el.el @@ -223,9 +223,11 @@ TOKTYPE is a hint to the type of tag desired." (symbol-name sym) "class" (semantic-elisp-desymbolify - ;; FIXME: This only gives the instance slots and ignores the - ;; class-allocated slots. - (eieio--class-public-a (find-class 'semanticdb-project-database))) ;; slots ;FIXME: eieio-- + (let ((class (find-class sym))) + (if (fboundp 'eieio-slot-descriptor-name) + (mapcar #'eieio-slot-descriptor-name + (eieio-class-slots class)) + (eieio--class-public-a class)))) (semantic-elisp-desymbolify (eieio-class-parents sym)) ;; parents )) ((not toktype) diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index fcf02b92736..1cc9f895f8a 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -140,7 +140,7 @@ Multiple calls to `make-instance' will return this object.")) A singleton is a class which will only ever have one instance." :abstract t) -(cl-defmethod eieio-constructor ((class (subclass eieio-singleton)) &rest _slots) +(cl-defmethod make-instance ((class (subclass eieio-singleton)) &rest _slots) "Constructor for singleton CLASS. NAME and SLOTS initialize the new object. This constructor guarantees that no matter how many you request, diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index e71c54d4123..408922a2daa 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -181,15 +181,15 @@ Currently under control of this var: CLASS is a symbol." ;FIXME: Is it a vector or a symbol? (and (symbolp class) (eieio--class-p (eieio--class-v class)))) +(defun eieio--class-print-name (class) + "Return a printed representation of CLASS." + (format "#" (eieio-class-name class))) + (defun eieio-class-name (class) "Return a Lisp like symbol name for CLASS." - ;; FIXME: What's a "Lisp like symbol name"? - ;; FIXME: CLOS returns a symbol, but the code returns a string. - (if (eieio--class-p class) (setq class (eieio--class-symbol class))) - (cl-check-type class class) - ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, - ;; and I wanted a string. Arg! - (format "#" (symbol-name class))) + (setq class (eieio--class-object class)) + (cl-check-type class eieio--class) + (eieio--class-symbol class)) (define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") (defalias 'eieio--class-constructor #'identity @@ -317,7 +317,7 @@ See `defclass' for more information." (newc (if (and oldc (not (eieio--class-default-object-cache oldc))) ;; The oldc class is a stub setup by eieio-defclass-autoload. ;; Reuse it instead of creating a new one, so that existing - ;; references are still valid. + ;; references stay valid. oldc (eieio--class-make cname))) (groups nil) ;; list of groups id'd from slots @@ -488,16 +488,10 @@ See `defclass' for more information." ;; Attach slot symbols into a hashtable, and store the index of ;; this slot as the value this table. (let* ((cnt 0) - (pubsyms (eieio--class-public-a newc)) - (prots (eieio--class-protection newc)) (oa (make-hash-table :test #'eq))) - (while pubsyms - (let ((newsym (list cnt))) - (setf (gethash (car pubsyms) oa) newsym) - (setq cnt (1+ cnt)) - (if (car prots) (setcdr newsym (car prots)))) - (setq pubsyms (cdr pubsyms) - prots (cdr prots))) + (dolist (pubsym (eieio--class-public-a newc)) + (setf (gethash pubsym oa) cnt) + (setq cnt (1+ cnt))) (setf (eieio--class-symbol-hashtable newc) oa)) ;; Set up a specialized doc string. @@ -895,7 +889,7 @@ INSTANCE is the object being referenced. SLOTNAME is the offending slot. If the slot is ok, return VALUE. Argument FN is the function calling this verifier." (if (and (eq value eieio-unbound) (not eieio-skip-typecheck)) - (slot-unbound instance (eieio--object-class-name instance) slotname fn) + (slot-unbound instance (eieio--object-class-object instance) slotname fn) value)) @@ -1029,8 +1023,7 @@ The slot is a symbol which is installed in CLASS by the `defclass' call. If SLOT is the value created with :initarg instead, reverse-lookup that name, and recurse with the associated slot value." ;; Removed checks to outside this call - (let* ((fsym (gethash slot (eieio--class-symbol-hashtable class))) - (fsi (car fsym))) + (let* ((fsi (gethash slot (eieio--class-symbol-hashtable class)))) (if (integerp fsi) (+ (eval-when-compile eieio--object-num-slots) fsi) (let ((fn (eieio--initarg-to-attribute class slot))) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 526090954a9..4f6b6d73183 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -272,34 +272,9 @@ This method is obsolete." ;; but hide it so we don't trigger indefinitely. `(,(car whole) (identity ,(car slots)) ,@(cdr slots))))))) - (apply #'eieio-constructor ',name slots)))))) + (apply #'make-instance ',name slots)))))) -;;; CLOS style implementation of object creators. -;; -(defun make-instance (class &rest initargs) - "Make a new instance of CLASS based on INITARGS. -CLASS is a class symbol. For example: - - (make-instance 'foo) - - INITARGS is a property list with keywords based on the :initarg -for each slot. For example: - - (make-instance 'foo :slot1 value1 :slotN valueN) - -Compatibility note: - -If the first element of INITARGS is a string, it is used as the -name of the class. - -In EIEIO, the class' constructor requires a name for use when printing. -`make-instance' in CLOS doesn't use names the way Emacs does, so the -class is used as the name slot instead when INITARGS doesn't start with -a string." - (apply (eieio--class-constructor class) initargs)) - - ;;; Get/Set slots in an object. ;; (defmacro oref (obj slot) @@ -311,6 +286,7 @@ created by the :initarg tag." (defalias 'slot-value 'eieio-oref) (defalias 'set-slot-value 'eieio-oset) +(make-obsolete 'set-slot-value "use (setf (slot-value ..) ..) instead" "25.1") (defmacro oref-default (obj slot) "Get the default value of OBJ (maybe a class) for SLOT. @@ -363,7 +339,7 @@ variable name of the same name as the slot." (declare (obsolete eieio-named "25.1"))) (defun eieio-object-name (obj &optional extra) - "Return a Lisp like symbol string for object OBJ. + "Return a printed representation for object OBJ. If EXTRA, include that in the string returned to represent the symbol." (cl-check-type obj eieio-object) (format "#<%s %s%s>" (eieio--object-class-name obj) @@ -402,7 +378,7 @@ If EXTRA, include that in the string returned to represent the symbol." (defun eieio-object-class-name (obj) "Return a Lisp like symbol name for OBJ's class." (cl-check-type obj eieio-object) - (eieio-class-name (eieio--object-class-name obj))) + (eieio-class-name (eieio--object-class-object obj))) (define-obsolete-function-alias 'object-class-name 'eieio-object-class-name "24.4") @@ -463,10 +439,23 @@ The CLOS function `class-direct-subclasses' is aliased to this function." child (pop p))) (if child t)))) +(defun eieio-slot-descriptor-name (slot) slot) + +(defun eieio-class-slots (class) + "Return list of slots available in instances of CLASS." + ;; FIXME: This only gives the instance slots and ignores the + ;; class-allocated slots. + ;; FIXME: It only gives the slot's *names* rather than actual + ;; slot descriptors. + (setq class (eieio--class-object class)) + (cl-check-type class eieio--class) + (eieio--class-public-a class)) + (defun object-slots (obj) "Return list of slots available in OBJ." + (declare (obsolete eieio-class-slots "25.1")) (cl-check-type obj eieio-object) - (eieio--class-public-a (eieio--object-class-object obj))) + (eieio-class-slots (eieio--object-class-object obj))) (defun eieio--class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." (cl-check-type class eieio--class) @@ -613,6 +602,9 @@ If SLOT is unbound, do nothing." ;;; Here are some CLOS items that need the CL package ;; +;; FIXME: Shouldn't this be a more complex gv-expander which extracts the +;; common code between oref and oset, so as to reduce the redundant work done +;; in (push foo (oref bar baz)), like we do for the `nth' expander? (gv-define-simple-setter eieio-oref eieio-oset) @@ -636,20 +628,28 @@ This class is not stored in the `parent' slot of a class vector." (defalias 'standard-class 'eieio-default-superclass) -(cl-defgeneric eieio-constructor (class &rest slots) - "Default constructor for CLASS `eieio-default-superclass'.") +(cl-defgeneric make-instance (class &rest initargs) + "Make a new instance of CLASS based on INITARGS. +For example: + + (make-instance 'foo) + +INITARGS is a property list with keywords based on the `:initarg' +for each slot. For example: + + (make-instance 'foo :slot1 value1 :slotN valueN)") -(define-obsolete-function-alias 'constructor #'eieio-constructor "25.1") +(define-obsolete-function-alias 'constructor #'make-instance "25.1") -(cl-defmethod eieio-constructor - ((class (subclass eieio-default-superclass)) &rest slots) +(cl-defmethod make-instance + ((class (subclass eieio-default-superclass)) &rest slots) "Default constructor for CLASS `eieio-default-superclass'. -SLOTS are the initialization slots used by `shared-initialize'. +SLOTS are the initialization slots used by `initialize-instance'. This static method is called when an object is constructed. It allocates the vector used to represent an EIEIO object, and then -calls `shared-initialize' on that object." +calls `initialize-instance' on that object." (let* ((new-object (copy-sequence (eieio--class-default-object-cache - (eieio--class-v class))))) + (eieio--class-object class))))) (if (and slots (let ((x (car slots))) (or (stringp x) (null x)))) @@ -662,6 +662,7 @@ calls `shared-initialize' on that object." ;; Return the created object. new-object)) +;; FIXME: CLOS uses "&rest INITARGS" instead. (cl-defgeneric shared-initialize (obj slots) "Set slots of OBJ with SLOTS which is a list of name/value pairs. Called from the constructor routine.") @@ -677,6 +678,7 @@ Called from the constructor routine." (eieio-oset obj rn (car (cdr slots))))) (setq slots (cdr (cdr slots))))) +;; FIXME: CLOS uses "&rest INITARGS" instead. (cl-defgeneric initialize-instance (this &optional slots) "Construct the new object THIS based on SLOTS.") @@ -693,9 +695,8 @@ dynamically set from SLOTS." ;; First, see if any of our defaults are `lambda', and ;; re-evaluate them and apply the value to our slots. (let* ((this-class (eieio--object-class-object this)) - (slot (eieio--class-public-a this-class)) (defaults (eieio--class-public-d this-class))) - (while slot + (dolist (slot (eieio--class-public-a this-class)) ;; For each slot, see if we need to evaluate it. ;; ;; Paul Landes said in an email: @@ -705,10 +706,9 @@ dynamically set from SLOTS." ;; > web. (let ((dflt (eieio-default-eval-maybe (car defaults)))) (when (not (eq dflt (car defaults))) - (eieio-oset this (car slot) dflt) )) + (eieio-oset this slot dflt) )) ;; Next. - (setq slot (cdr slot) - defaults (cdr defaults)))) + (setq defaults (cdr defaults)))) ;; Shared initialize will parse our slots for us. (shared-initialize this slots)) @@ -742,7 +742,8 @@ Use `slot-boundp' to determine if a slot is bound or not. In CLOS, the argument list is (CLASS OBJECT SLOT-NAME), but EIEIO can only dispatch on the first argument, so the first two are swapped." - (signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name object) + (signal 'unbound-slot (list (eieio-class-name class) + (eieio-object-name object) slot-name fn))) (cl-defgeneric clone (obj &rest params) @@ -861,7 +862,7 @@ this object." ((consp thing) (eieio-list-prin1 thing)) ((eieio--class-p thing) - (princ (eieio-class-name thing))) + (princ (eieio--class-print-name thing))) (t (prin1 thing)))) (defun eieio-list-prin1 (list) @@ -902,7 +903,7 @@ of `eq'." Used as advice around `edebug-prin1-to-string', held in the variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to `prin1-to-string' when appropriate." - (cond ((eieio--class-p object) (eieio-class-name object)) + (cond ((eieio--class-p object) (eieio--class-print-name object)) ((eieio-object-p object) (object-print object)) ((and (listp object) (or (eieio--class-p (car object)) (eieio-object-p (car object)))) diff --git a/test/ChangeLog b/test/ChangeLog index 29b7c7d59ea..87425a69148 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,8 @@ +2015-02-16 Stefan Monnier + + * automated/eieio-test-methodinvoke.el (make-instance): Add methods + here rather than on eieio-constructor. + 2015-02-13 Magnus Henoch * automated/sasl-scram-rfc-tests.el: New file. diff --git a/test/automated/eieio-test-methodinvoke.el b/test/automated/eieio-test-methodinvoke.el index da5f59a4654..62f5603d3b6 100644 --- a/test/automated/eieio-test-methodinvoke.el +++ b/test/automated/eieio-test-methodinvoke.el @@ -179,12 +179,12 @@ (if (next-method-p) (call-next-method)) ) -(defmethod eieio-constructor :STATIC ((p C-base2) &rest args) +(defmethod make-instance :STATIC ((p C-base2) &rest args) (eieio-test-method-store :STATIC 'C-base2) (if (next-method-p) (call-next-method)) ) -(defmethod eieio-constructor :STATIC ((p C) &rest args) +(defmethod make-instance :STATIC ((p C) &rest args) (eieio-test-method-store :STATIC 'C) (call-next-method) ) -- cgit v1.2.3 From 1f2c4f817ee37c7c7767e22eda1c427456885b6b Mon Sep 17 00:00:00 2001 From: Kelly Dean Date: Mon, 16 Feb 2015 04:19:41 +0000 Subject: emacs-lisp/package-x.el: Create valid tar files * emacs-lisp/package-x.el (package-upload-buffer-internal): Create valid tar files. (Bug#19536) --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/package-x.el | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b3da9dcaadf..d5080d92fd5 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-02-16 Kelly Dean + + * emacs-lisp/package-x.el (package-upload-buffer-internal): + Create valid tar files. (Bug#19536) + 2015-02-16 Kelly Dean * desktop.el (desktop-read): Conditionally re-enable desktop autosave. diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el index e0945d47a45..6955ce8f5a6 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el @@ -247,7 +247,7 @@ if it exists." (concat (symbol-name pkg-name) "-readme.txt") package-archive-upload-base))) - (set-buffer pkg-buffer) + (set-buffer (if (eq file-type 'tar) tar-data-buffer pkg-buffer)) (write-region (point-min) (point-max) (expand-file-name (format "%s-%s.%s" pkg-name pkg-version extension) -- cgit v1.2.3 From 3194809d247efdc7ea65644ea7b298885e47a392 Mon Sep 17 00:00:00 2001 From: Kelly Dean Date: Mon, 16 Feb 2015 04:21:06 +0000 Subject: emacs-lisp/easy-mmode.el: Process macro arguments correctly * emacs-lisp/easy-mmode.el (define-minor-mode): Process macro arguments correctly. (Bug#19685) --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/easy-mmode.el | 3 ++- 2 files changed, 7 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d5080d92fd5..9741baa64bd 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-02-16 Kelly Dean + + * emacs-lisp/easy-mmode.el (define-minor-mode): Process macro + arguments correctly. (Bug#19685) + 2015-02-16 Kelly Dean * emacs-lisp/package-x.el (package-upload-buffer-internal): diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index f7e8619948a..cd5720d144f 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -159,7 +159,8 @@ For example, you could write ;; Allow skipping the first three args. (cond ((keywordp init-value) - (setq body `(,init-value ,lighter ,keymap ,@body) + (setq body (if keymap `(,init-value ,lighter ,keymap ,@body) + `(,init-value ,lighter)) init-value nil lighter nil keymap nil)) ((keywordp lighter) (setq body `(,lighter ,keymap ,@body) lighter nil keymap nil)) -- cgit v1.2.3 From cc273d1c033e669c642115550d2f132c7a9618b8 Mon Sep 17 00:00:00 2001 From: Kelly Dean Date: Mon, 16 Feb 2015 04:22:16 +0000 Subject: emacs-lisp/easy-mmode.el (define-minor-mode): Clarify docs --- lisp/ChangeLog | 1 + lisp/emacs-lisp/easy-mmode.el | 9 ++++++--- 2 files changed, 7 insertions(+), 3 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 9741baa64bd..b7ca890091b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -2,6 +2,7 @@ * emacs-lisp/easy-mmode.el (define-minor-mode): Process macro arguments correctly. (Bug#19685) + (define-minor-mode): Clarify docstring. 2015-02-16 Kelly Dean diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index cd5720d144f..cc30042002b 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -114,9 +114,12 @@ Optional KEYMAP is the default keymap bound to the mode keymap. BODY contains code to execute each time the mode is enabled or disabled. It is executed after toggling the mode, and before running MODE-hook. Before the actual body code, you can write keyword arguments, i.e. - alternating keywords and values. These following special keywords - are supported (other keywords are passed to `defcustom' if the minor - mode is global): + alternating keywords and values. If you provide BODY, then you must + provide (even if just nil) INIT-VALUE, LIGHTER, and KEYMAP, or provide + at least one keyword argument, or both; otherwise, BODY would be + misinterpreted as the first omitted argument. The following special + keywords are supported (other keywords are passed to `defcustom' if + the minor mode is global): :group GROUP Custom group name to use in all generated `defcustom' forms. Defaults to MODE without the possible trailing \"-mode\". -- cgit v1.2.3 From 04096849d54e09553d25897591993d5e0221a8d8 Mon Sep 17 00:00:00 2001 From: Kelly Dean Date: Mon, 16 Feb 2015 04:24:13 +0000 Subject: emacs-lisp/easy-mmode.el: Clarify mode switch messages * emacs-lisp/easy-mmode.el (define-minor-mode): Clarify mode switch messages for minor modes. (Bug#19690) --- lisp/ChangeLog | 1 + lisp/emacs-lisp/easy-mmode.el | 13 +++++++++++-- 2 files changed, 12 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b7ca890091b..3df34d6577c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -3,6 +3,7 @@ * emacs-lisp/easy-mmode.el (define-minor-mode): Process macro arguments correctly. (Bug#19685) (define-minor-mode): Clarify docstring. + Clarify mode switch messages for minor modes. (Bug#19690) 2015-02-16 Kelly Dean diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index cc30042002b..bd95a6018ff 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -284,14 +284,23 @@ the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'. (if (called-interactively-p 'any) (progn ,(if (and globalp (symbolp mode)) + ;; Unnecessary but harmless if mode set buffer-locally `(customize-mark-as-set ',mode)) ;; Avoid overwriting a message shown by the body, ;; but do overwrite previous messages. (unless (and (current-message) (not (equal ,last-message (current-message)))) - (message ,(format "%s %%sabled" pretty-name) - (if ,mode "en" "dis"))))) + (let ((local + ,(if globalp + (if (symbolp mode) + `(if (local-variable-p ',mode) + " in current buffer" + "") + "") + " in current buffer"))) + (message ,(format "%s %%sabled%%s" pretty-name) + (if ,mode "en" "dis") local))))) ,@(when after-hook `(,after-hook))) (force-mode-line-update) ;; Return the new setting. -- cgit v1.2.3 From ad6c1be9230ac8ed517a51778b586055edb952c3 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 18 Feb 2015 11:04:15 -0500 Subject: * lisp/emacs-lisp/checkdoc.el (checkdoc-show-diagnostics): Don't make bogus assumptions about window ordering. --- etc/NEWS | 1 + lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/checkdoc.el | 17 +++++++++-------- 3 files changed, 15 insertions(+), 8 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/etc/NEWS b/etc/NEWS index 0295245d120..f359f9168b2 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -235,6 +235,7 @@ If you need your objects to be named, do it by inheriting from `eieio-named'. *** The variables are declared obsolete. *** The variables are declared obsolete. *** defgeneric and defmethod are declared obsolete. +*** `constructor' is now an obsolete alias for `make-instance'. ** ido *** New command `ido-bury-buffer-at-head' bound to C-S-b diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 704ec34606c..f6831508471 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-02-18 Stefan Monnier + + * emacs-lisp/checkdoc.el (checkdoc-show-diagnostics): Don't make bogus + assumptions about window ordering. + 2015-02-16 Kelly Dean * lisp/files.el (insert-file-contents-literally): Fix docstring typo. diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 47b6e5f81de..288e25e6060 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -2619,14 +2619,15 @@ function called to create the messages." (defun checkdoc-show-diagnostics () "Display the checkdoc diagnostic buffer in a temporary window." (if checkdoc-pending-errors - (let ((b (get-buffer checkdoc-diagnostic-buffer))) - (if b (progn (pop-to-buffer b) - (goto-char (point-max)) - (re-search-backward "\C-l" nil t) - (beginning-of-line) - (forward-line 1) - (recenter 0))) - (other-window -1) + (let* ((b (get-buffer checkdoc-diagnostic-buffer)) + (win (if b (display-buffer b)))) + (when win + (with-selected-window win + (goto-char (point-max)) + (re-search-backward "\C-l" nil t) + (beginning-of-line) + (forward-line 1) + (recenter 0))) (setq checkdoc-pending-errors nil) nil))) -- cgit v1.2.3 From 72f7eded979c672662112304cc8615c0dbcf9803 Mon Sep 17 00:00:00 2001 From: Kelly Dean Date: Wed, 18 Feb 2015 07:35:49 +0000 Subject: Use user-error where error is inappropriate * help-mode.el (help-go-back, help-go-forward, help-follow): * simple.el (yank-pop, pop-to-mark-command, exchange-point-and-mark): * winner.el (winner-redo): * windmove.el (windmove-do-window-select): * register.el (jump-to-register, increment-register, insert-register) (append-to-register, prepend-to-register): * files.el (find-alternate-file, abort-if-file-too-large, write-file) (set-visited-file-name): * emacs-lisp/lisp.el (kill-backward-up-list): Use user-error instead of error. (Bug#14480) --- lisp/ChangeLog | 15 ++++++++++++++- lisp/emacs-lisp/lisp.el | 2 +- lisp/files.el | 10 +++++----- lisp/help-mode.el | 6 +++--- lisp/register.el | 14 +++++++------- lisp/simple.el | 6 +++--- lisp/windmove.el | 4 ++-- lisp/winner.el | 2 +- 8 files changed, 36 insertions(+), 23 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index f6831508471..73e139657bb 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,16 @@ +2015-02-18 Kelly Dean + + * help-mode.el (help-go-back, help-go-forward, help-follow): + * simple.el (yank-pop, pop-to-mark-command, exchange-point-and-mark): + * winner.el (winner-redo): + * windmove.el (windmove-do-window-select): + * register.el (jump-to-register, increment-register, insert-register) + (append-to-register, prepend-to-register): + * files.el (find-alternate-file, abort-if-file-too-large, write-file) + (set-visited-file-name): + * emacs-lisp/lisp.el (kill-backward-up-list): + Use user-error instead of error. (Bug#14480) + 2015-02-18 Stefan Monnier * emacs-lisp/checkdoc.el (checkdoc-show-diagnostics): Don't make bogus @@ -5,7 +18,7 @@ 2015-02-16 Kelly Dean - * lisp/files.el (insert-file-contents-literally): Fix docstring typo. + * files.el (insert-file-contents-literally): Fix docstring typo. 2015-02-16 Kelly Dean diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 214bed7622d..fb631a73da1 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -263,7 +263,7 @@ This command assumes point is not in a string or comment." (backward-up-list arg) (kill-sexp) (insert current-sexp)) - (error "Not at a sexp")))) + (user-error "Not at a sexp")))) (defvar beginning-of-defun-function nil "If non-nil, function for `beginning-of-defun-raw' to call. diff --git a/lisp/files.el b/lisp/files.el index 83369792fe7..1914ad8814c 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -1628,10 +1628,10 @@ killed." (confirm-nonexistent-file-or-buffer) file-name) t))) (unless (run-hook-with-args-until-failure 'kill-buffer-query-functions) - (error "Aborted")) + (user-error "Aborted")) (and (buffer-modified-p) buffer-file-name (not (yes-or-no-p "Kill and replace the buffer without saving it? ")) - (error "Aborted")) + (user-error "Aborted")) (let ((obuf (current-buffer)) (ofile buffer-file-name) (onum buffer-file-number) @@ -1844,7 +1844,7 @@ OP-TYPE specifies the file operation being performed (for message to user)." (not (y-or-n-p (format "File %s is large (%s), really %s? " (file-name-nondirectory filename) (file-size-human-readable size) op-type)))) - (error "Aborted"))) + (user-error "Aborted"))) (defun warn-maybe-out-of-memory (size) "Warn if an attempt to open file of SIZE bytes may run out of memory." @@ -3883,7 +3883,7 @@ the old visited file has been renamed to the new name FILENAME." (not no-query) (not (y-or-n-p (format "A buffer is visiting %s; proceed? " filename))) - (error "Aborted"))) + (user-error "Aborted"))) (or (equal filename buffer-file-name) (progn (and filename (lock-buffer filename)) @@ -4007,7 +4007,7 @@ Interactively, confirmation is required unless you supply a prefix argument." (listp last-nonmenu-event) use-dialog-box)) (or (y-or-n-p (format "File `%s' exists; overwrite? " filename)) - (error "Canceled"))) + (user-error "Canceled"))) (set-visited-file-name filename (not confirm)))) (set-buffer-modified-p t) ;; Make buffer writable if file is writable. diff --git a/lisp/help-mode.el b/lisp/help-mode.el index b8b129dbc4a..d6679e9e4de 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -724,14 +724,14 @@ BUFFER or FRAME." (interactive) (if help-xref-stack (help-xref-go-back (current-buffer)) - (error "No previous help buffer"))) + (user-error "No previous help buffer"))) (defun help-go-forward () "Go back to next topic in this help buffer." (interactive) (if help-xref-forward-stack (help-xref-go-forward (current-buffer)) - (error "No next help buffer"))) + (user-error "No next help buffer"))) (defun help-do-xref (_pos function args) "Call the help cross-reference function FUNCTION with args ARGS. @@ -754,7 +754,7 @@ a proper [back] button." For the cross-reference format, see `help-make-xrefs'." (interactive) - (error "No cross-reference here")) + (user-error "No cross-reference here")) (defun help-follow-symbol (&optional pos) "In help buffer, show docs for symbol at POS, defaulting to point. diff --git a/lisp/register.el b/lisp/register.el index a60181e43c6..053657bd8cb 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -252,7 +252,7 @@ Interactively, reads the register using `register-read-with-preview'." (goto-char (cadr val))) ((markerp val) (or (marker-buffer val) - (error "That register's buffer no longer exists")) + (user-error "That register's buffer no longer exists")) (switch-to-buffer (marker-buffer val)) (goto-char val)) ((and (consp val) (eq (car val) 'file)) @@ -260,11 +260,11 @@ Interactively, reads the register using `register-read-with-preview'." ((and (consp val) (eq (car val) 'file-query)) (or (find-buffer-visiting (nth 1 val)) (y-or-n-p (format "Visit file %s again? " (nth 1 val))) - (error "Register access aborted")) + (user-error "Register access aborted")) (find-file (nth 1 val)) (goto-char (nth 2 val))) (t - (error "Register doesn't contain a buffer position or configuration"))))) + (user-error "Register doesn't contain a buffer position or configuration"))))) (defun register-swap-out () "Turn markers into file-query references when a buffer is killed." @@ -316,7 +316,7 @@ Interactively, reads the register using `register-read-with-preview'." (set-register register (+ number register-val)))) ((or (not register-val) (stringp register-val)) (append-to-register register (region-beginning) (region-end) prefix)) - (t (error "Register does not contain a number or text"))))) + (t (user-error "Register does not contain a number or text"))))) (defun view-register (register) "Display what is contained in register named REGISTER. @@ -449,7 +449,7 @@ Interactively, reads the register using `register-read-with-preview'." ((and (markerp val) (marker-position val)) (princ (marker-position val) (current-buffer))) (t - (error "Register does not contain text")))) + (user-error "Register does not contain text")))) (if (not arg) (exchange-point-and-mark))) (defun copy-to-register (register start end &optional delete-flag region) @@ -492,7 +492,7 @@ Interactively, reads the register using `register-read-with-preview'." (set-register register (cond ((not reg) text) ((stringp reg) (concat reg separator text)) - (t (error "Register does not contain text"))))) + (t (user-error "Register does not contain text"))))) (setq deactivate-mark t) (cond (delete-flag (delete-region start end)) @@ -516,7 +516,7 @@ Interactively, reads the register using `register-read-with-preview'." (set-register register (cond ((not reg) text) ((stringp reg) (concat text separator reg)) - (t (error "Register does not contain text"))))) + (t (user-error "Register does not contain text"))))) (setq deactivate-mark t) (cond (delete-flag (delete-region start end)) diff --git a/lisp/simple.el b/lisp/simple.el index 967fbc69cbc..b78286dc83b 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -4326,7 +4326,7 @@ When this command inserts killed text into the buffer, it honors doc string for `insert-for-yank-1', which see." (interactive "*p") (if (not (eq last-command 'yank)) - (error "Previous command was not a yank")) + (user-error "Previous command was not a yank")) (setq this-command 'yank) (unless arg (setq arg 1)) (let ((inhibit-read-only t) @@ -4958,7 +4958,7 @@ Start discarding off end if gets this big." \(Does not affect global mark ring)." (interactive) (if (null (mark t)) - (error "No mark set in this buffer") + (user-error "No mark set in this buffer") (if (= (point) (mark t)) (message "Mark popped")) (goto-char (mark t)) @@ -5107,7 +5107,7 @@ mode temporarily." (let ((omark (mark t)) (temp-highlight (eq (car-safe transient-mark-mode) 'only))) (if (null omark) - (error "No mark set in this buffer")) + (user-error "No mark set in this buffer")) (set-mark (point)) (goto-char omark) (cond (temp-highlight diff --git a/lisp/windmove.el b/lisp/windmove.el index d857dfc98dd..c461a00740a 100644 --- a/lisp/windmove.el +++ b/lisp/windmove.el @@ -479,10 +479,10 @@ DIR, ARG, and WINDOW are handled as by `windmove-other-window-loc'. If no window is at direction DIR, an error is signaled." (let ((other-window (windmove-find-other-window dir arg window))) (cond ((null other-window) - (error "No window %s from selected window" dir)) + (user-error "No window %s from selected window" dir)) ((and (window-minibuffer-p other-window) (not (minibuffer-window-active-p other-window))) - (error "Minibuffer is inactive")) + (user-error "Minibuffer is inactive")) (t (select-window other-window))))) diff --git a/lisp/winner.el b/lisp/winner.el index f244003b066..fdf62137514 100644 --- a/lisp/winner.el +++ b/lisp/winner.el @@ -415,7 +415,7 @@ In other words, \"undo\" changes in window configuration." (ring-ref winner-pending-undo-ring 0))) (unless (eq (selected-window) (minibuffer-window)) (message "Winner undid undo"))) - (t (error "Previous command was not a `winner-undo'")))) + (t (user-error "Previous command was not a `winner-undo'")))) (provide 'winner) ;;; winner.el ends here -- cgit v1.2.3 From b1d6ddd44614c84746f5ee494e1f29cd9be8a2d8 Mon Sep 17 00:00:00 2001 From: Kelly Dean Date: Wed, 18 Feb 2015 07:41:10 +0000 Subject: Push mark before goto-char in jump-to-register and check-parens * register.el (jump-to-register): * emacs-lisp/lisp.el (check-parens): Push mark before goto-char so user doesn't lose his previous place. --- lisp/ChangeLog | 6 ++++++ lisp/emacs-lisp/lisp.el | 3 ++- lisp/register.el | 3 +++ 3 files changed, 11 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index a15295f4b4e..b71b55d8477 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2015-02-18 Kelly Dean + + * register.el (jump-to-register): + * emacs-lisp/lisp.el (check-parens): + Push mark before goto-char so user doesn't lose his previous place. + 2015-02-18 Kelly Dean * rect.el (rectangle-mark-mode): diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index fb631a73da1..67d14872b3a 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -714,7 +714,8 @@ character." (condition-case data ;; Buffer can't have more than (point-max) sexps. (scan-sexps (point-min) (point-max)) - (scan-error (goto-char (nth 2 data)) + (scan-error (push-mark) + (goto-char (nth 2 data)) ;; Could print (nth 1 data), which is either ;; "Containing expression ends prematurely" or ;; "Unbalanced parentheses", but those may not be so diff --git a/lisp/register.el b/lisp/register.el index 053657bd8cb..7afbc06c7fc 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -254,6 +254,9 @@ Interactively, reads the register using `register-read-with-preview'." (or (marker-buffer val) (user-error "That register's buffer no longer exists")) (switch-to-buffer (marker-buffer val)) + (unless (or (= (point) (marker-position val)) + (eq last-command 'jump-to-register)) + (push-mark)) (goto-char val)) ((and (consp val) (eq (car val) 'file)) (find-file (cdr val))) -- cgit v1.2.3 From 99db66a01fd998942c4e75733863903247345d90 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 18 Feb 2015 20:31:17 -0500 Subject: * lisp/emacs-lisp/smie.el (smie-prec2->grammar): Fix corner case problem. --- lisp/ChangeLog | 4 ++++ lisp/emacs-lisp/smie.el | 7 +++++-- 2 files changed, 9 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b71b55d8477..933e5bbb515 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2015-02-19 Stefan Monnier + + * emacs-lisp/smie.el (smie-prec2->grammar): Fix corner case problem. + 2015-02-18 Kelly Dean * register.el (jump-to-register): diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 5b9dc6422a2..48bded4e3a6 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -612,8 +612,11 @@ PREC2 is a table as returned by `smie-precs->prec2' or (cons (pcase (cdr x) (`closer (cddr (assoc token table))) (`opener (cdr (assoc token table)))))) - (cl-assert (numberp (car cons))) - (setf (car cons) (list (car cons))))) + ;; `cons' can be nil for openers/closers which only contain + ;; "atomic" elements. + (when cons + (cl-assert (numberp (car cons))) + (setf (car cons) (list (car cons)))))) (let ((ca (gethash :smie-closer-alist prec2))) (when ca (push (cons :smie-closer-alist ca) table))) ;; (smie-check-grammar table prec2 'step3) -- cgit v1.2.3 From 235c3cb105c3bac49e44296c8066cf7f1c585472 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 19 Feb 2015 13:14:51 -0500 Subject: * lisp/emacs-lisp/cl-macs.el (cl-struct-slot-value): Handle a nil type. --- lisp/ChangeLog | 2 ++ lisp/emacs-lisp/cl-macs.el | 6 +++--- 2 files changed, 5 insertions(+), 3 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 933e5bbb515..bf6ea90510c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,7 @@ 2015-02-19 Stefan Monnier + * emacs-lisp/cl-macs.el (cl-struct-slot-value): Handle a nil type. + * emacs-lisp/smie.el (smie-prec2->grammar): Fix corner case problem. 2015-02-18 Kelly Dean diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index caaf7687dc8..c5f49b0ed91 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2978,9 +2978,9 @@ STRUCT and SLOT-NAME are symbols. INST is a structure instance." ;; We could use `elt', but since the byte compiler will resolve the ;; branch below at compile time, it's more efficient to use the ;; type-specific accessor. - (if (eq (cl-struct-sequence-type ,struct-type) 'vector) - (aref ,inst (cl-struct-slot-offset ,struct-type ,slot-name)) - (nth (cl-struct-slot-offset ,struct-type ,slot-name) ,inst)))))) + (if (eq (cl-struct-sequence-type ,struct-type) 'list) + (nth (cl-struct-slot-offset ,struct-type ,slot-name) ,inst) + (aref ,inst (cl-struct-slot-offset ,struct-type ,slot-name))))))) (run-hooks 'cl-macs-load-hook) -- cgit v1.2.3 From d4ed798d2598a914b1313e58acaff5b66c487318 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 19 Feb 2015 13:22:21 -0500 Subject: * lisp/emacs-lisp/eieio-opt.el (eieio-help-class): Fix bug#19891 Fixes: debbugs:19891 * lisp/emacs-lisp/eieio-opt.el (eieio-help-class): `eieio-class-parents' returns classes, not class names. --- lisp/ChangeLog | 3 +++ lisp/emacs-lisp/eieio-opt.el | 1 + 2 files changed, 4 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index bf6ea90510c..cdcb340614a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,8 @@ 2015-02-19 Stefan Monnier + * emacs-lisp/eieio-opt.el (eieio-help-class): `eieio-class-parents' + returns classes, not class names (bug#19891). + * emacs-lisp/cl-macs.el (cl-struct-slot-value): Handle a nil type. * emacs-lisp/smie.el (smie-prec2->grammar): Fix corner case problem. diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 304ee364dc8..a769ca7b536 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -99,6 +99,7 @@ If CLASS is actually an object, then also display current values of that object. (when pl (insert " Inherits from ") (while (setq cur (pop pl)) + (setq cur (eieio--class-symbol cur)) (insert "`") (help-insert-xref-button (symbol-name cur) 'help-function cur) -- cgit v1.2.3 From 226c1224b5805e5dfc8dd0939b93de2a2bf1e103 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Fri, 20 Feb 2015 06:18:36 -0500 Subject: # Auto-commit of loaddefs files. --- lisp/emacs-lisp/eieio.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 4f6b6d73183..cdf1992f9a5 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -930,7 +930,7 @@ Optional argument GROUP is the sub-group of slots to display. ;;;*** -;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "ff1097f185bc2c253276a7d19fe2f54a") +;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "d1910eb455f102989fc33bb3f5a9b614") ;;; Generated autoloads from eieio-opt.el (autoload 'eieio-browse "eieio-opt" "\ -- cgit v1.2.3 From 14b4e657e2fd647153b336c61a220acedda8454c Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Sat, 21 Feb 2015 20:00:16 -0800 Subject: Spelling fixes * lisp/cedet/semantic/doc.el (semantic-documentation-comment-preceding-tag): Rename from semantic-documentation-comment-preceeding-tag. All uses changed. Leave an obsolete alias behind. * src/lisp.h (DEFINE_NON_NIL_Q_SYMBOL_MACROS): Rename from DEFINE_NONNIL_Q_SYMBOL_MACROS. All uses changed. --- doc/misc/auth.texi | 4 ++-- lib-src/make-docfile.c | 2 +- lisp/ChangeLog | 2 +- lisp/cedet/ChangeLog | 7 +++++++ lisp/cedet/semantic/doc.el | 9 ++++++--- lisp/cedet/srecode/document.el | 2 +- lisp/emacs-lisp/package.el | 13 ++++++------- lisp/gnus/ChangeLog | 4 ++-- lisp/org/ChangeLog | 2 +- src/ChangeLog | 6 ++++++ src/lisp.h | 6 +++--- test/automated/vc-tests.el | 4 ++-- test/cedet/srecode-tests.el | 2 +- 13 files changed, 39 insertions(+), 24 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/misc/auth.texi b/doc/misc/auth.texi index 7c0254a9a3a..8dbde4d5ea0 100644 --- a/doc/misc/auth.texi +++ b/doc/misc/auth.texi @@ -247,8 +247,8 @@ names: Your netrc entries will then be: @example -machine gmail login account@@gmail.com password "accountpassword" port imap -machine gmail2 login account2@@gmail.com password "account2password" port imap +machine gmail login account@@gmail.com password "account password" port imap +machine gmail2 login account2@@gmail.com password "account2 password" port imap @end example @node Secret Service API diff --git a/lib-src/make-docfile.c b/lib-src/make-docfile.c index a7943e3118c..bada8df9f72 100644 --- a/lib-src/make-docfile.c +++ b/lib-src/make-docfile.c @@ -743,7 +743,7 @@ write_globals (void) puts ("#endif"); puts ("#define Qnil builtin_lisp_symbol (0)"); - puts ("#if DEFINE_NONNIL_Q_SYMBOL_MACROS"); + puts ("#if DEFINE_NON_NIL_Q_SYMBOL_MACROS"); num_symbols = 0; for (int i = 0; i < num_globals; i++) if (globals[i].type == SYMBOL && num_symbols++ != 0) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b78dd7920ae..a583d7c58e8 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -534,7 +534,7 @@ (package--sort-deps-in-alist): New function. (package-menu-mark-install): Can mark dependencies. (package--newest-p): New function. - (package-delete): Don't delesect when deleting an older version of + (package-delete): Don't deselect when deleting an older version of an upgraded package. * emacs-lisp/package.el: Add missing (require 'subr-x) diff --git a/lisp/cedet/ChangeLog b/lisp/cedet/ChangeLog index 838a2693491..c9ddc382d50 100644 --- a/lisp/cedet/ChangeLog +++ b/lisp/cedet/ChangeLog @@ -1,3 +1,10 @@ +2015-02-22 Paul Eggert + + Spelling fixes + * semantic/doc.el (semantic-documentation-comment-preceding-tag): + Rename from semantic-documentation-comment-preceeding-tag. All + uses changed. Leave an obsolete alias behind. + 2015-02-16 Stefan Monnier * semantic/db-el.el (semanticdb-elisp-sym->tag): Fix copy&paste error diff --git a/lisp/cedet/semantic/doc.el b/lisp/cedet/semantic/doc.el index 874763f0a7f..3ceb3510ad2 100644 --- a/lisp/cedet/semantic/doc.el +++ b/lisp/cedet/semantic/doc.el @@ -56,13 +56,12 @@ If nosnarf if 'lex, then only return the lex token." doctmp ;; Check just before the definition. (when (semantic-tag-with-position-p tag) - (semantic-documentation-comment-preceeding-tag tag nosnarf)) + (semantic-documentation-comment-preceding-tag tag nosnarf)) ;; Let's look for comments either after the definition, but before code: ;; Not sure yet. Fill in something clever later.... nil)))))) -;; FIXME this is not how you spell "preceding". -(defun semantic-documentation-comment-preceeding-tag (&optional tag nosnarf) +(defun semantic-documentation-comment-preceding-tag (&optional tag nosnarf) "Find a comment preceding TAG. If TAG is nil. use the tag under point. Searches the space between TAG and the preceding tag for a comment, @@ -84,6 +83,10 @@ just the lexical token and not the string." ;; of a function. (semantic-doc-snarf-comment-for-tag nosnarf))) )) +(define-obsolete-function-alias + 'semantic-documentation-comment-preceeding-tag + 'semantic-documentation-comment-preceding-tag + "25.1") (defun semantic-doc-snarf-comment-for-tag (nosnarf) "Snarf up the comment at POINT for `semantic-documentation-for-tag'. diff --git a/lisp/cedet/srecode/document.el b/lisp/cedet/srecode/document.el index 9f106a40660..47577844c74 100644 --- a/lisp/cedet/srecode/document.el +++ b/lisp/cedet/srecode/document.el @@ -395,7 +395,7 @@ It is assumed that the comment occurs just in front of FCN-IN." (beginning-of-line) (forward-char -1) - (let ((lextok (semantic-documentation-comment-preceeding-tag fcn-in 'lex)) + (let ((lextok (semantic-documentation-comment-preceding-tag fcn-in 'lex)) (doctext (srecode-document-function-name-comment fcn-in)) ) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index d8a4fc9c846..de1158d96a7 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -335,11 +335,10 @@ contents of the archive." :version "24.4") (defcustom package-selected-packages nil - "Store here packages installed explicitely by user. -This variable will be feeded automatically by emacs, -when installing a new package. -This variable will be used by `package-autoremove' to decide -which packages are no more needed. + "Store here packages installed explicitly by user. +This variable is fed automatically by Emacs when installing a new package. +This variable is used by `package-autoremove' to decide +which packages are no longer needed. You can use it to (re)install packages on other machines by running `package-user-selected-packages-install'. @@ -1280,7 +1279,7 @@ to install it but still mark it as selected." ;;;###autoload (defun package-reinstall (pkg) "Reinstall package PKG. -PKG shoul be either a symbol, the package name, or a package-desc +PKG should be either a symbol, the package name, or a package-desc object." (interactive (list (intern (completing-read "Reinstall package: " @@ -1547,7 +1546,7 @@ If NOSAVE is non-nil, the package is not removed from ;; `package-selected-packages' even if it can't be deleted. (when (and (null nosave) (package--user-selected-p name) - ;; Don't delesect if this is an older version of an + ;; Don't deselect if this is an older version of an ;; upgraded package. (package--newest-p pkg-desc)) (customize-save-variable diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 7895f378b82..07d1d471b9f 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -827,7 +827,7 @@ 2014-01-30 Lars Ingebrigtsen * nnmail.el (nnmail-split-it): Instead of redoing the search to restore - the match data, just save and restore it explictly (bug#12375). + the match data, just save and restore it explicitly (bug#12375). * gnus-sum.el (gnus-summary-read-group-1): Initialize the spam code if that's needed. @@ -24084,7 +24084,7 @@ (spam-ham-copy-or-move-routine): Return the number of processed ham messages. (spam-summary-prepare-exit): Use the above values to decide - whether status messages shouled be displayed. + whether status messages should be displayed. 2004-05-20 Katsumi Yamaoka diff --git a/lisp/org/ChangeLog b/lisp/org/ChangeLog index 081da5db73b..ce39bb7d568 100644 --- a/lisp/org/ChangeLog +++ b/lisp/org/ChangeLog @@ -852,7 +852,7 @@ in a table.el table last. * org.el (org-delete-property): Don't suggest to delete the - CATEGORY property when the category is not explicitely set in the + CATEGORY property when the category is not explicitly set in the property drawer. Also enforce matching when completing. (org-insert-heading): Fix regression: with two universal prefixes, insert heading at the end of the subtree. diff --git a/src/ChangeLog b/src/ChangeLog index 8604cfcb29f..5e4dbb7ae1c 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,9 @@ +2015-02-22 Paul Eggert + + Spelling fixes + * lisp.h (DEFINE_NON_NIL_Q_SYMBOL_MACROS): + Rename from DEFINE_NONNIL_Q_SYMBOL_MACROS. All uses changed. + 2015-02-21 Eli Zaretskii * w32term.c (queue_notifications): diff --git a/src/lisp.h b/src/lisp.h index 7795c90e5cc..9764b096ef0 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -746,10 +746,10 @@ struct Lisp_Symbol /* By default, define macros for Qt, etc., as this leads to a bit better performance in the core Emacs interpreter. A plugin can - define DEFINE_NONNIL_Q_SYMBOL_MACROS to be false, to be portable to + define DEFINE_NON_NIL_Q_SYMBOL_MACROS to be false, to be portable to other Emacs instances that assign different values to Qt, etc. */ -#ifndef DEFINE_NONNIL_Q_SYMBOL_MACROS -# define DEFINE_NONNIL_Q_SYMBOL_MACROS true +#ifndef DEFINE_NON_NIL_Q_SYMBOL_MACROS +# define DEFINE_NON_NIL_Q_SYMBOL_MACROS true #endif #include "globals.h" diff --git a/test/automated/vc-tests.el b/test/automated/vc-tests.el index e83eb85c0fe..4d9aefad7fb 100644 --- a/test/automated/vc-tests.el +++ b/test/automated/vc-tests.el @@ -331,8 +331,8 @@ For backends which dont support it, `vc-not-supported' is signalled." (let ((tmp-name (expand-file-name "foo" default-directory))) ;; Check for initial state, should be nil until it's registered. - ;; Don't pass the backend explictly, otherwise some implementations - ;; return non-nil. + ;; Don't pass the backend explicitly, otherwise some + ;; implementations return non-nil. (should (null (vc-working-revision tmp-name))) ;; Write a new file. Check state. diff --git a/test/cedet/srecode-tests.el b/test/cedet/srecode-tests.el index 423df72d5ac..f7529ecb5e3 100644 --- a/test/cedet/srecode-tests.el +++ b/test/cedet/srecode-tests.el @@ -272,7 +272,7 @@ Dump out the extracted dictionary." (not (semantic-tag-of-class-p fcn-in 'function))) (error "No tag of class 'function to insert comment for")) - (let ((lextok (semantic-documentation-comment-preceeding-tag fcn-in 'lex)) + (let ((lextok (semantic-documentation-comment-preceding-tag fcn-in 'lex)) ) (when (not lextok) -- cgit v1.2.3 From e846bbf360d1bcee3a35dd05a57bc76cbb22a6f0 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 22 Feb 2015 23:50:03 -0500 Subject: * lisp/emacs-lisp/macroexp.el (macroexp-parse-body): Handle cl-declare and :documentation. Change return value format accordingly. * lisp/emacs-lisp/cl-generic.el (cl--generic-lambda): * lisp/emacs-lisp/pcase.el (pcase-lambda): Adjust accordingly. * lisp/emacs-lisp/cl-macs.el (cl--transform-lambda): Use macroexp-parse-body. --- lisp/ChangeLog | 8 ++++++++ lisp/emacs-lisp/cl-generic.el | 2 +- lisp/emacs-lisp/cl-macs.el | 35 ++++++++++++++++------------------- lisp/emacs-lisp/macroexp.el | 19 ++++++++++--------- lisp/emacs-lisp/pcase.el | 2 +- 5 files changed, 36 insertions(+), 30 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ced342baeb9..6352d77ca3a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,11 @@ +2015-02-23 Stefan Monnier + + * emacs-lisp/macroexp.el (macroexp-parse-body): Handle cl-declare + and :documentation. Change return value format accordingly. + * emacs-lisp/cl-generic.el (cl--generic-lambda): + * emacs-lisp/pcase.el (pcase-lambda): Adjust accordingly. + * emacs-lisp/cl-macs.el (cl--transform-lambda): Use macroexp-parse-body. + 2015-02-23 Dmitry Gutov Introduce `xref-etags-mode'. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index ccd5bec5685..99924ba288f 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -278,7 +278,7 @@ This macro can only be used within the lexical scope of a cl-generic method." (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody))) (cons (not (not uses-cnm)) `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) - ,@(delq nil (car parsed-body)) + ,@(car parsed-body) ,(if (not (memq nmp uses-cnm)) nbody `(let ((,nmp (lambda () diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c5f49b0ed91..c3da091fb00 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -234,10 +234,9 @@ FORM is of the form (ARGS . BODY)." (let* ((args (car form)) (body (cdr form)) (orig-args args) (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil) (cl--bind-lets nil) (cl--bind-forms nil) - (header nil) (simple-args nil)) - (while (or (stringp (car body)) - (memq (car-safe (car body)) '(interactive declare cl-declare))) - (push (pop body) header)) + (parsed-body (macroexp-parse-body body)) + (header (car parsed-body)) (simple-args nil)) + (setq body (cdr parsed-body)) (setq args (if (listp args) (cl-copy-list args) (list '&rest args))) (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) (if (setq cl--bind-defs (cadr (memq '&cl-defs args))) @@ -258,7 +257,7 @@ FORM is of the form (ARGS . BODY)." (or (eq cl--bind-block 'cl-none) (setq body (list `(cl-block ,cl--bind-block ,@body)))) (if (null args) - (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body)) + (cl-list* nil (nreverse simple-args) (nconc header body)) (if (memq '&optional simple-args) (push '&optional args)) (cl--do-arglist args nil (- (length simple-args) (if (memq '&optional simple-args) 1 0))) @@ -266,20 +265,18 @@ FORM is of the form (ARGS . BODY)." (cl-list* nil (nconc (nreverse simple-args) (list '&rest (car (pop cl--bind-lets)))) - (nconc (let ((hdr (nreverse header))) - ;; Macro expansion can take place in the middle of - ;; apparently harmless computation, so it should not - ;; touch the match-data. - (save-match-data - (require 'help-fns) - (cons (help-add-fundoc-usage - (if (stringp (car hdr)) (pop hdr)) - ;; Be careful with make-symbol and (back)quote, - ;; see bug#12884. - (let ((print-gensym nil) (print-quoted t)) - (format "%S" (cons 'fn (cl--make-usage-args - orig-args))))) - hdr))) + (nconc (save-match-data ;; Macro expansion can take place in the + ;; middle of apparently harmless computation, so it + ;; should not touch the match-data. + (require 'help-fns) + (cons (help-add-fundoc-usage + (if (stringp (car header)) (pop header)) + ;; Be careful with make-symbol and (back)quote, + ;; see bug#12884. + (let ((print-gensym nil) (print-quoted t)) + (format "%S" (cons 'fn (cl--make-usage-args + orig-args))))) + header)) (list `(let* ,cl--bind-lets ,@(nreverse cl--bind-forms) ,@body))))))) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index b75c8cc50a7..68bf4f62c34 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -297,15 +297,16 @@ definitions to shadow the loaded ones for use in file byte-compilation." ;;; Handy functions to use in macros. -(defun macroexp-parse-body (exps) - "Parse EXPS into ((DOC DECLARE-FORM INTERACTIVE-FORM) . BODY)." - `((,(and (stringp (car exps)) - (pop exps)) - ,(and (eq (car-safe (car exps)) 'declare) - (pop exps)) - ,(and (eq (car-safe (car exps)) 'interactive) - (pop exps))) - ,@exps)) +(defun macroexp-parse-body (body) + "Parse a function BODY into (DECLARATIONS . EXPS)." + (let ((decls ())) + (while (and (cdr body) + (let ((e (car body))) + (or (stringp e) + (memq (car-safe e) + '(:documentation declare interactive cl-declare))))) + (push (pop body) decls)) + (cons (nreverse decls) body))) (defun macroexp-progn (exps) "Return an expression equivalent to `(progn ,@EXPS)." diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 057b12894f9..4706be5e57c 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -180,7 +180,7 @@ like `(,a . ,(pred (< a))) or, with more checks: (when (eq nil (car (last pats 2))) (setq pats (append (butlast pats 2) (car (last pats))))) `(lambda (&rest ,args) - ,@(remq nil (car body)) + ,@(car body) (pcase ,args (,(list '\` pats) . ,(cdr body)))))) -- cgit v1.2.3 From 8bb64d2722632fcc2b7c816e5f85d64ff10161f9 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 25 Feb 2015 01:03:14 -0500 Subject: * lisp/emacs-lisp/edebug.el (edebug--display): Save-excursion. Fixes: debbugs:19611 * lisp/emacs-lisp/debug.el (debugger-env-macro): Remove redundant save-excursion. --- lisp/ChangeLog | 6 ++++++ lisp/emacs-lisp/debug.el | 6 +----- lisp/emacs-lisp/edebug.el | 9 +++++++++ 3 files changed, 16 insertions(+), 5 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 5fa7ef757b3..fc2893e1c1d 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2015-02-25 Stefan Monnier + + * emacs-lisp/edebug.el (edebug--display): Save-excursion (bug#19611). + * emacs-lisp/debug.el (debugger-env-macro): Remove redundant + save-excursion. + 2015-02-24 Glenn Morris * mail/rmailsum.el (rmail-summary-previous-all) diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index dc0e666836e..8c1440d02f3 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -535,11 +535,7 @@ Applies to the frame whose line point is on in the backtrace." (defmacro debugger-env-macro (&rest body) "Run BODY in original environment." (declare (indent 0)) - `(save-excursion - (if (null (buffer-live-p debugger-old-buffer)) - ;; old buffer deleted - (setq debugger-old-buffer (current-buffer))) - (set-buffer debugger-old-buffer) + `(progn (set-match-data debugger-outer-match-data) (prog1 (progn ,@body) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 7faa101299e..10918775f49 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -2358,6 +2358,12 @@ MSG is printed after `::::} '." (defalias 'edebug-mark-marker 'mark-marker) (defun edebug--display (value offset-index arg-mode) + ;; edebug--display-1 is too big, we should split it. This function + ;; here was just introduced to avoid making edebug--display-1 + ;; yet a bit deeper. + (save-excursion (edebug--display-1 value offset-index arg-mode))) + +(defun edebug--display-1 (value offset-index arg-mode) (unless (marker-position edebug-def-mark) ;; The buffer holding the source has been killed. ;; Let's at least show a backtrace so the user can figure out @@ -3317,6 +3323,9 @@ Return the result of the last expression." ;; Restore outside context. (setq-default cursor-in-non-selected-windows edebug-outside-d-c-i-n-s-w) (unwind-protect + ;; FIXME: This restoring of edebug-outside-buffer and + ;; edebug-outside-point is redundant now that backtrace-eval does it + ;; for us. (with-current-buffer edebug-outside-buffer ; of edebug-buffer (goto-char edebug-outside-point) (if (marker-buffer (edebug-mark-marker)) -- cgit v1.2.3 From 26b2e9aa4d022fbd13e7878dab6a1df51eddebc5 Mon Sep 17 00:00:00 2001 From: Oleh Krehel Date: Fri, 13 Feb 2015 14:34:17 +0100 Subject: check-declare.el (check-declare-ext-errors): New defcustom. * emacs-lisp/check-declare.el (check-declare): New defgroup. (check-declare-verify): When `check-declare-ext-errors' is non-nil, warn about an unfound function, instead of saying "skipping external file". --- lisp/ChangeLog | 9 +++++++++ lisp/emacs-lisp/check-declare.el | 11 ++++++++++- 2 files changed, 19 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index fb8b1f7fc94..078fc3e3a6b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,12 @@ +2015-02-25 Oleh Krehel + + * emacs-lisp/check-declare.el (check-declare-ext-errors): New + defcustom. + (check-declare): New defgroup. + (check-declare-verify): When `check-declare-ext-errors' is + non-nil, warn about an unfound function, instead of saying + "skipping external file". + 2015-02-25 Tassilo Horn * textmodes/reftex-vars.el (reftex-include-file-commands): Call diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index 13de61c4935..40ab03d8351 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -125,6 +125,14 @@ With optional argument FULL, sums the number of elements in each element." (autoload 'byte-compile-arglist-signature "bytecomp") +(defgroup check-declare nil + "Check declare-function statements." + :group 'tools) + +(defcustom check-declare-ext-errors nil + "When non-nil, warn abount functions not found in :ext." + :type 'boolean) + (defun check-declare-verify (fnfile fnlist) "Check that FNFILE contains function definitions matching FNLIST. Each element of FNLIST has the form (FILE FN ARGLIST FILEONLY), where @@ -226,7 +234,8 @@ method\\|class\\)\\|fset\\)\\>" type) (when type (setq errlist (cons (list (car e) (cadr e) type) errlist)))) (message "%s%s" m - (if (or re (not ext)) + (if (or re (or check-declare-ext-errors + (not ext))) (check-declare-errmsg errlist) (progn (setq errlist nil) -- cgit v1.2.3 From 383722dee79aee1dd0b9def6a2af6649b26f5687 Mon Sep 17 00:00:00 2001 From: Oleh Krehel Date: Fri, 13 Feb 2015 14:59:31 +0100 Subject: check-declare.el: Use compilation-style warnings * lisp/emacs-lisp/check-declare.el (check-declare-warn): Add file-line-column info to the warning. (check-declare-files): Make sure that `check-declare-warning-buffer' is in `compilation-mode'. Make the order of the errors that same as in the file. Add code to ensure that `first-error' will work properly. --- lisp/ChangeLog | 7 +++++++ lisp/emacs-lisp/check-declare.el | 40 ++++++++++++++++++++++++++++++++-------- 2 files changed, 39 insertions(+), 8 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 078fc3e3a6b..f1dd8db5298 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,10 @@ +2015-02-25 Oleh Krehel + + * emacs-lisp/check-declare.el (check-declare-warn): Use + compilation-style warnings. + (check-declare-files): Make sure that + `check-declare-warning-buffer' is in `compilation-mode'. + 2015-02-25 Oleh Krehel * emacs-lisp/check-declare.el (check-declare-ext-errors): New diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index 40ab03d8351..c2639729fa9 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -260,12 +260,29 @@ Returned list has elements FNFILE (FILE ...)." "Warn that FILE made a false claim about FN in FNFILE. TYPE is a string giving the nature of the error. Warning is displayed in `check-declare-warning-buffer'." - (display-warning 'check-declare - (format "%s said `%s' was defined in %s: %s" - (file-name-nondirectory file) fn - (file-name-nondirectory fnfile) - type) - nil check-declare-warning-buffer)) + (let ((warning-prefix-function + (lambda (level entry) + (let ((line 0) + (col 0)) + (insert + (with-current-buffer (find-file-noselect file) + (goto-char (point-min)) + (when (re-search-forward + (format "(declare-function[ \t\n]+%s" fn) nil t) + (goto-char (match-beginning 0)) + (setq line (line-number-at-pos)) + (setq col (1+ (current-column)))) + (format "%s:%d:%d:" + (file-name-nondirectory file) + line col)))) + entry)) + (warning-fill-prefix " ")) + (display-warning 'check-declare + (format "%s said `%s' was defined in %s: %s" + (file-name-nondirectory file) fn + (file-name-nondirectory fnfile) + type) + nil check-declare-warning-buffer))) (defun check-declare-files (&rest files) "Check veracity of all `declare-function' statements in FILES. @@ -278,13 +295,20 @@ Return a list of any errors found." (dolist (e (check-declare-sort alist)) (if (setq err (check-declare-verify (car e) (cdr e))) (setq errlist (cons (cons (car e) err) errlist)))) + (setq errlist (nreverse errlist)) (if (get-buffer check-declare-warning-buffer) (kill-buffer check-declare-warning-buffer)) + (with-current-buffer (get-buffer-create check-declare-warning-buffer) + (unless (derived-mode-p 'compilation-mode) + (compilation-mode)) + (let ((inhibit-read-only t)) + (insert "\f\n")) + (compilation-forget-errors)) ;; Sort back again so that errors are ordered by the files ;; containing the declare-function statements. (dolist (e (check-declare-sort errlist)) - (dolist (f (cdr e)) - (check-declare-warn (car e) (cadr f) (car f) (nth 2 f)))) + (dolist (f (cdr e)) + (check-declare-warn (car e) (cadr f) (car f) (nth 2 f)))) errlist)) ;;;###autoload -- cgit v1.2.3 From f6b5db6c45b773f86e203368aee9153ec8527205 Mon Sep 17 00:00:00 2001 From: Daniel Colascione Date: Sun, 1 Mar 2015 23:57:51 -0800 Subject: Add support for generators diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog index 78f7e34..e7d79d5 100644 --- a/doc/lispref/ChangeLog +++ b/doc/lispref/ChangeLog @@ -1,3 +1,8 @@ +2015-03-02 Daniel Colascione + + * control.texi (Generators): New section + * elisp.text: Reference new section. + 2015-02-28 Eli Zaretskii * searching.texi (Char Classes): Update the documentation of diff --git a/doc/misc/ChangeLog b/doc/misc/ChangeLog index 448c7f2..4e9c119 100644 --- a/doc/misc/ChangeLog +++ b/doc/misc/ChangeLog @@ -1,3 +1,7 @@ +2015-03-02 Daniel Colascione + + * cl.texi (Iteration Clauses): Mention iterator support. + 2015-02-25 Tassilo Horn * reftex.texi (Multifile Documents): Document diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 7ce2e81..4ab4406 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,6 +1,8 @@ 2015-03-02 Daniel Colascione - * vc/vc.el (vc-responsible-backend): Add autoload cooking for + * emacs-lisp/generator.el: New file. + + * vc/vc.el (vc-responsible-backend): Add autoload cookie for `vc-responsible-backend'. 2015-03-01 Michael Albinus diff --git a/test/ChangeLog b/test/ChangeLog index 684e98f..64ad851 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,5 +1,7 @@ 2015-03-02 Daniel Colascione + * automated/generator-tests.el: New tests + * automated/finalizer-tests.el (finalizer-basic) (finalizer-circular-reference, finalizer-cross-reference) (finalizer-error): New tests. --- doc/lispref/ChangeLog | 5 + doc/lispref/control.texi | 116 ++++++ doc/lispref/elisp.texi | 1 + doc/misc/ChangeLog | 4 + doc/misc/cl.texi | 5 + etc/NEWS | 2 + lisp/ChangeLog | 4 +- lisp/emacs-lisp/generator.el | 789 ++++++++++++++++++++++++++++++++++++++ test/ChangeLog | 2 + test/automated/generator-tests.el | 288 ++++++++++++++ 10 files changed, 1215 insertions(+), 1 deletion(-) create mode 100644 lisp/emacs-lisp/generator.el create mode 100644 test/automated/generator-tests.el (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog index 78f7e34ca01..e7d79d55c7e 100644 --- a/doc/lispref/ChangeLog +++ b/doc/lispref/ChangeLog @@ -1,3 +1,8 @@ +2015-03-02 Daniel Colascione + + * control.texi (Generators): New section + * elisp.text: Reference new section. + 2015-02-28 Eli Zaretskii * searching.texi (Char Classes): Update the documentation of diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index d21292348a4..bec2bc92ac4 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -39,6 +39,7 @@ structure constructs (@pxref{Macros}). * Conditionals:: @code{if}, @code{cond}, @code{when}, @code{unless}. * Combining Conditions:: @code{and}, @code{or}, @code{not}. * Iteration:: @code{while} loops. +* Generators:: Generic sequences and coroutines. * Nonlocal Exits:: Jumping out of a sequence. @end menu @@ -620,6 +621,121 @@ Here is an example of using @code{dotimes} to do something 100 times: @end example @end defmac +@node Generators +@section Generators +@cindex generators + + A @dfn{generator} is a function that produces a potentially-infinite +stream of values. Each time the function produces a value, it +suspends itself and waits for a caller to request the next value. + +@defmac iter-defun name args [doc] [declare] [interactive] body@dots{} +@code{iter-defun} defines a generator function. A generator function +has the same signature as a normal function, but works differently. +Instead of executing @var{body} when called, a generator function +returns an iterator object. That iterator runs @var{body} to generate +values, emitting a value and pausing where @code{iter-yield} or +@code{iter-yield-from} appears. When @var{body} returns normally, +@code{iter-next} signals @code{iter-end-of-sequence} with @var{body}'s +result as its condition data. + +Any kind of Lisp code is valid inside @var{body}, but +@code{iter-yield} and @code{iter-yield-from} cannot appear inside +@code{unwind-protect} forms. + +@end defmac + +@defmac iter-lambda args [doc] [interactive] body@dots{} +@code{iter-lambda} produces an unnamed generator function that works +just like a generator function produced with @code{iter-defun}. +@end defmac + +@defmac iter-yield value +When it appears inside a generator function, @code{iter-yield} +indicates that the current iterator should pause and return +@var{value} from @code{iter-next}. @code{iter-yield} evaluates to the +@code{value} parameter of next call to @code{iter-next}. +@end defmac + +@defmac iter-yield-from iterator +@code{iter-yield-from} yields all the values that @var{iterator} +produces and evaluates to the value that @var{iterator}'s generator +function returns normally. While it has control, @var{iterator} +receives sent to the iterator using @code{iter-next}. +@end defmac + + To use a generator function, first call it normally, producing a +@dfn{iterator} object. An iterator is a specific instance of a +generator. Then use @code{iter-next} to retrieve values from this +iterator. When there are no more values to pull from an iterator, +@code{iter-next} raises an @code{iter-end-of-sequence} condition with +the iterator's final value. + +It's important to note that generator function bodies only execute +inside calls to @code{iter-next}. A call to a function defined with +@code{iter-defun} produces an iterator; you must ``drive'' this +iterator with @code{iter-next} for anything interesting to happen. +Each call to a generator function produces a @emph{different} +iterator, each with its own state. + +@defun iter-next iterator value +Retrieve the next value from @var{iterator}. If there are no more +values to be generated (because @var{iterator}'s generator function +returned), @code{iter-next} signals the @code{iter-end-of-sequence} +condition; the data value associated with this condition is the value +with which @var{iterator}'s generator function returned. + +@var{value} is sent into the iterator and becomes the value to which +@code{iter-yield} evaluates. @var{value} is ignored for the first +@code{iter-next} call to a given iterator, since at the start of +@var{iterator}'s generator function, the generator function is not +evaluating any @code{iter-yield} form. +@end defun + +@defun iter-close iterator +If @var{iterator} is suspended inside a @code{unwind-protect} and +becomes unreachable, Emacs will eventually run unwind handlers after a +garbage collection pass. To ensure that these handlers are run before +then, use @code{iter-close}. +@end defun + +Some convenience functions are provided to make working with +iterators easier: + +@defmac iter-do (var iterator) body @dots{} +Run @var{body} with @var{var} bound to each value that +@var{iterator} produces. +@end defmac + +The Common Lisp loop facility also contains features for working with +iterators. See @xref{Loop Facility,,,cl,Common Lisp Extensions}. + +The following piece of code demonstrates some important principles of +working with iterators. + +@example +(iter-defun my-iter (x) + (iter-yield (1+ (iter-yield (1+ x)))) + -1 ;; Return normally + ) + +(let* ((iter (my-iter 5)) + (iter2 (my-iter 0))) + ;; Prints 6 + (print (iter-next iter)) + ;; Prints 9 + (print (iter-next iter 8)) + ;; Prints 1; iter and iter2 have distinct states + (print (iter-next iter2 nil)) + + ;; We expect the iter sequence to end now + (condition-case x + (iter-next iter) + (iter-end-of-sequence + ;; Prints -1, which my-iter returned normally + (print (cdr x))))) +@end example + @node Nonlocal Exits @section Nonlocal Exits @cindex nonlocal exits diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index cdc443f07d5..3802e49ec3d 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -464,6 +464,7 @@ Control Structures * Conditionals:: @code{if}, @code{cond}, @code{when}, @code{unless}. * Combining Conditions:: @code{and}, @code{or}, @code{not}. * Iteration:: @code{while} loops. +* Generators:: Generic sequences and coroutines. * Nonlocal Exits:: Jumping out of a sequence. Nonlocal Exits diff --git a/doc/misc/ChangeLog b/doc/misc/ChangeLog index 448c7f26c1a..4e9c119379d 100644 --- a/doc/misc/ChangeLog +++ b/doc/misc/ChangeLog @@ -1,3 +1,7 @@ +2015-03-02 Daniel Colascione + + * cl.texi (Iteration Clauses): Mention iterator support. + 2015-02-25 Tassilo Horn * reftex.texi (Multifile Documents): Document diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index 66776029353..052ca6bd786 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -2237,6 +2237,11 @@ This clause is like @code{always}, except that the loop returns This clause stops the loop when the specified form is non-@code{nil}; in this case, it returns that non-@code{nil} value. If all the values were @code{nil}, the loop returns @code{nil}. + +@item iter-by @var{iterator} +This clause iterates over the values from the specified form, an +iterator object. See (@pxref{Generators,,,elisp,GNU Emacs Lisp +Reference Manual}). @end table @node Accumulation Clauses diff --git a/etc/NEWS b/etc/NEWS index 6c94a587ad5..ad8b6f27812 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -621,6 +621,8 @@ word syntax, use `\sw' instead. * Lisp Changes in Emacs 25.1 +** Emacs Lisp now supports generators. + ** New finalizer facility for running code when objects become unreachable. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 7ce2e816d45..4ab4406dba1 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,6 +1,8 @@ 2015-03-02 Daniel Colascione - * vc/vc.el (vc-responsible-backend): Add autoload cooking for + * emacs-lisp/generator.el: New file. + + * vc/vc.el (vc-responsible-backend): Add autoload cookie for `vc-responsible-backend'. 2015-03-01 Michael Albinus diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el new file mode 100644 index 00000000000..4e21e792406 --- /dev/null +++ b/lisp/emacs-lisp/generator.el @@ -0,0 +1,789 @@ +;;; generator.el --- generators -*- lexical-binding: t -*- + +;;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Daniel Colascione +;; Keywords: extensions, elisp +;; Package: emacs + +;; Copyright (C) Daniel Colascione + +;; 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: + +;; This package implements generators for Emacs Lisp through a +;; continuation-passing transformation. It provides essentially the +;; same generator API and iterator facilties that Python and +;; JavaScript ES6 provide. +;; +;; `iter-lambda' and `iter-defun' work like `lambda' and `defun', +;; except that they evaluate to or define, respectively, generator +;; functions. These functions, when called, return an iterator. +;; An iterator is an opaque object that generates a sequence of +;; values. Callers use `iter-next' to retrieve the next value from +;; the sequence; when the sequence is exhausted, `iter-next' will +;; raise the `iter-end-of-sequence' condition. +;; +;; Generator functions are written like normal functions, except that +;; they can invoke `iter-yield' to suspend themselves and return a +;; value to callers; this value becomes the return value of +;; `iter-next'. On the next call to `iter-next', execution of the +;; generator function resumes where it left off. When a generator +;; function returns normally, the `iter-next' raises +;; `iter-end-of-sequence' with the value the function returned. +;; +;; `iter-yield-from' yields all the values from another iterator; it +;; then evaluates to the value the sub-iterator returned normally. +;; This facility is useful for functional composition of generators +;; and for implementing coroutines. +;; +;; `iter-yield' is illegal inside the UNWINDFORMS of an +;; `unwind-protect' for various sordid internal reasons documented in +;; the code. +;; +;; N.B. Each call to a generator function generates a *new* iterator, +;; and each iterator maintains its own internal state. +;; +;; This raw form of iteration is general, but a bit awkward to use, so +;; this library also provides soem convenience functions: +;; +;; `iter-do' is like `cl-do', except that instead of walking a list, +;; it walks an iterator. `cl-loop' is also extended with a new +;; keyword, `iter-by', that iterates over an iterator. +;; + +;;; Implementation: + +;; +;; The internal cps transformation code uses the cps- namespace. +;; Iteration functions use the `iter-' namespace. Generator functions +;; are somewhat less efficient than conventional elisp routines, +;; although we try to avoid CPS transformation on forms that do not +;; invoke `iter-yield'. +;; + +;;; Code: + +(require 'cl-lib) +(require 'pcase) + +(defvar *cps-bindings* nil) +(defvar *cps-states* nil) +(defvar *cps-value-symbol* nil) +(defvar *cps-state-symbol* nil) +(defvar *cps-cleanup-table-symbol* nil) +(defvar *cps-cleanup-function* nil) + +(defvar *cps-dynamic-wrappers* '(identity) + "List of transformer functions to apply to atomic forms we +evaluate in CPS context.") + +(defconst cps-standard-special-forms + '(setq setq-default throw interactive) + "List of special forms that we treat just like ordinary + function applications." ) + +(defun cps--trace-funcall (func &rest args) + (message "%S: args=%S" func args) + (let ((result (apply func args))) + (message "%S: result=%S" func result) + result)) + +(defun cps--trace (fmt &rest args) + (princ (apply #'format (concat fmt "\n") args))) + +(defun cps--special-form-p (definition) + "Non-nil if and only if DEFINITION is a special form." + ;; Copied from ad-special-form-p + (if (and (symbolp definition) (fboundp definition)) + (setf definition (indirect-function definition))) + (and (subrp definition) (eq (cdr (subr-arity definition)) 'unevalled))) + +(defmacro cps--define-unsupported (function) + `(defun ,(intern (format "cps--transform-%s" function)) + (error "%s not supported in generators" ,function))) + +(defmacro cps--with-value-wrapper (wrapper &rest body) + "Continue generating CPS code with an atomic-form wrapper +to the current stack of such wrappers. WRAPPER is a function that +takes a form and returns a wrapped form. + +Whenever we generate an atomic form (i.e., a form that can't +iter-yield), we first (before actually inserting that form in our +generated code) pass that form through all the transformer +functions. We use this facility to wrap forms that can transfer +control flow non-locally in goo that diverts this control flow to +the CPS state machinery. +" + (declare (indent 1)) + `(let ((*cps-dynamic-wrappers* + (cons + ,wrapper + *cps-dynamic-wrappers*))) + ,@body)) + +(defun cps--make-dynamic-binding-wrapper (dynamic-var static-var) + (cl-assert lexical-binding) + (lambda (form) + `(let ((,dynamic-var ,static-var)) + (unwind-protect ; Update the static shadow after evaluation is done + ,form + (setf ,static-var ,dynamic-var)) + ,form))) + +(defmacro cps--with-dynamic-binding (dynamic-var static-var &rest body) + "Evaluate BODY such that generated atomic evaluations run with +DYNAMIC-VAR bound to STATIC-VAR." + (declare (indent 2)) + `(cps--with-value-wrapper + (cps--make-dynamic-binding-wrapper ,dynamic-var ,static-var) + ,@body)) + +(defun cps--add-state (kind body) + "Create a new CPS state with body BODY and return the state's name." + (declare (indent 1)) + (let* ((state (cl-gensym (format "cps-state-%s-" kind)))) + (push (list state body *cps-cleanup-function*) *cps-states*) + (push state *cps-bindings*) + state)) + +(defun cps--add-binding (original-name) + (car (push (cl-gensym (format "cps-binding-%s-" original-name)) + *cps-bindings*))) + +(defun cps--find-special-form-handler (form) + (let* ((handler-name (format "cps--transform-%s" (car-safe form))) + (handler (intern-soft handler-name))) + (and (fboundp handler) handler))) + +(defvar cps-disable-atomic-optimization nil + "When t, always rewrite forms into cps even when they +don't yield.") + +(defvar cps--yield-seen) + +(defun cps--atomic-p (form) + "Return whether the given form never yields." + + (and (not cps-disable-atomic-optimization) + (let* ((cps--yield-seen)) + (ignore (macroexpand-all + `(cl-macrolet ((cps-internal-yield + (_val) + (setf cps--yield-seen t))) + ,form))) + (not cps--yield-seen)))) + +(defun cps--make-atomic-state (form next-state) + (let ((tform `(prog1 ,form (setf ,*cps-state-symbol* ,next-state)))) + (cl-loop for wrapper in *cps-dynamic-wrappers* + do (setf tform (funcall wrapper tform))) + ;; Bind *cps-cleanup-function* to nil here because the wrapper + ;; function mechanism is responsible for cleanup here, not the + ;; generic cleanup mechanism. If we didn't make this binding, + ;; we'd run cleanup handlers twice on anything that made it out + ;; to toplevel. + (let ((*cps-cleanup-function* nil)) + (cps--add-state "atom" + `(setf ,*cps-value-symbol* ,tform))))) + +(defun cps--transform-1 (form next-state) + (pcase form + + ;; If we're looking at an "atomic" form (i.e., one that does not + ;; iter-yield), just evaluate the form as a whole instead of rewriting + ;; it into CPS. + + ((guard (cps--atomic-p form)) + (cps--make-atomic-state form next-state)) + + ;; Process `and'. + + (`(and) ; (and) -> t + (cps--transform-1 t next-state)) + (`(and ,condition) ; (and CONDITION) -> CONDITION + (cps--transform-1 condition next-state)) + (`(and ,condition . ,rest) + ;; Evaluate CONDITION; if it's true, go on to evaluate the rest + ;; of the `and'. + (cps--transform-1 + condition + (cps--add-state "and" + `(setf ,*cps-state-symbol* + (if ,*cps-value-symbol* + ,(cps--transform-1 `(and ,@rest) + next-state) + ,next-state))))) + + ;; Process `catch'. + + (`(catch ,tag . ,body) + (let ((tag-binding (cps--add-binding "catch-tag"))) + (cps--transform-1 tag + (cps--add-state "cps-update-tag" + `(setf ,tag-binding ,*cps-value-symbol* + ,*cps-state-symbol* + ,(cps--with-value-wrapper + (cps--make-catch-wrapper + tag-binding next-state) + (cps--transform-1 `(progn ,@body) + next-state))))))) + + ;; Process `cond': transform into `if' or `or' depending on the + ;; precise kind of the condition we're looking at. + + (`(cond) ; (cond) -> nil + (cps--transform-1 nil next-state)) + (`(cond (,condition) . ,rest) + (cps--transform-1 `(or ,condition (cond ,@rest)) + next-state)) + (`(cond (,condition . ,body) . ,rest) + (cps--transform-1 `(if ,condition + (progn ,@body) + (cond ,@rest)) + next-state)) + + ;; Process `condition-case': do the heavy lifting in a helper + ;; function. + + (`(condition-case ,var ,bodyform . ,handlers) + (cps--with-value-wrapper + (cps--make-condition-wrapper var next-state handlers) + (cps--transform-1 bodyform + next-state))) + + ;; Process `if'. + + (`(if ,cond ,then . ,else) + (cps--transform-1 cond + (cps--add-state "if" + `(setf ,*cps-state-symbol* + (if ,*cps-value-symbol* + ,(cps--transform-1 then + next-state) + ,(cps--transform-1 `(progn ,@else) + next-state)))))) + + ;; Process `progn' and `inline': they are identical except for the + ;; name, which has some significance to the byte compiler. + + (`(inline) (cps--transform-1 nil next-state)) + (`(inline ,form) (cps--transform-1 form next-state)) + (`(inline ,form . ,rest) + (cps--transform-1 form + (cps--transform-1 `(inline ,@rest) + next-state))) + + (`(progn) (cps--transform-1 nil next-state)) + (`(progn ,form) (cps--transform-1 form next-state)) + (`(progn ,form . ,rest) + (cps--transform-1 form + (cps--transform-1 `(progn ,@rest) + next-state))) + + ;; Process `let' in a helper function that transforms it into a + ;; let* with temporaries. + + (`(let ,bindings . ,body) + (let* ((bindings (cl-loop for binding in bindings + collect (if (symbolp binding) + (list binding nil) + binding))) + (temps (cl-loop for (var value-form) in bindings + collect (cps--add-binding var)))) + (cps--transform-1 + `(let* ,(append + (cl-loop for (var value-form) in bindings + for temp in temps + collect (list temp value-form)) + (cl-loop for (var binding) in bindings + for temp in temps + collect (list var temp))) + ,@body) + next-state))) + + ;; Process `let*' binding: process one binding at a time. Flatten + ;; lexical bindings. + + (`(let* () . ,body) + (cps--transform-1 `(progn ,@body) next-state)) + + (`(let* (,binding . ,more-bindings) . ,body) + (let* ((var (if (symbolp binding) binding (car binding))) + (value-form (car (cdr-safe binding))) + (new-var (cps--add-binding var))) + + (cps--transform-1 + value-form + (cps--add-state "let*" + `(setf ,new-var ,*cps-value-symbol* + ,*cps-state-symbol* + ,(if (or (not lexical-binding) (special-variable-p var)) + (cps--with-dynamic-binding var new-var + (cps--transform-1 + `(let* ,more-bindings ,@body) + next-state)) + (cps--transform-1 + (cps--replace-variable-references + var new-var + `(let* ,more-bindings ,@body)) + next-state))))))) + + ;; Process `or'. + + (`(or) (cps--transform-1 nil next-state)) + (`(or ,condition) (cps--transform-1 condition next-state)) + (`(or ,condition . ,rest) + (cps--transform-1 + condition + (cps--add-state "or" + `(setf ,*cps-state-symbol* + (if ,*cps-value-symbol* + ,next-state + ,(cps--transform-1 + `(or ,@rest) next-state)))))) + + ;; Process `prog1'. + + (`(prog1 ,first) (cps--transform-1 first next-state)) + (`(prog1 ,first . ,body) + (cps--transform-1 + first + (let ((temp-var-symbol (cps--add-binding "prog1-temp"))) + (cps--add-state "prog1" + `(setf ,temp-var-symbol + ,*cps-value-symbol* + ,*cps-state-symbol* + ,(cps--transform-1 + `(progn ,@body) + (cps--add-state "prog1inner" + `(setf ,*cps-value-symbol* ,temp-var-symbol + ,*cps-state-symbol* ,next-state)))))))) + + ;; Process `prog2'. + + (`(prog2 ,form1 ,form2 . ,body) + (cps--transform-1 + `(progn ,form1 (prog1 ,form2 ,@body)) + next-state)) + + ;; Process `unwind-protect': If we're inside an unwind-protect, we + ;; have a block of code UNWINDFORMS which we would like to run + ;; whenever control flows away from the main piece of code, + ;; BODYFORM. We deal with the local control flow case by + ;; generating BODYFORM such that it yields to a continuation that + ;; executes UNWINDFORMS, which then yields to NEXT-STATE. + ;; + ;; Non-local control flow is trickier: we need to ensure that we + ;; execute UNWINDFORMS even when control bypasses our normal + ;; continuation. To make this guarantee, we wrap every external + ;; application (i.e., every piece of elisp that can transfer + ;; control non-locally) in an unwind-protect that runs UNWINDFORMS + ;; before allowing the non-local control transfer to proceed. + ;; + ;; Unfortunately, because elisp lacks a mechanism for generically + ;; capturing the reason for an arbitrary non-local control + ;; transfer and restarting the transfer at a later point, we + ;; cannot reify non-local transfers and cannot allow + ;; continuation-passing code inside UNWINDFORMS. + + (`(unwind-protect ,bodyform . ,unwindforms) + ;; Signal the evaluator-generator that it needs to generate code + ;; to handle cleanup forms. + (unless *cps-cleanup-table-symbol* + (setf *cps-cleanup-table-symbol* (cl-gensym "cps-cleanup-table-"))) + (let* ((unwind-state + (cps--add-state + "unwind" + ;; N.B. It's safe to just substitute unwindforms by + ;; sexp-splicing: we've already replaced all variable + ;; references inside it with lifted equivalents. + `(progn + ,@unwindforms + (setf ,*cps-state-symbol* ,next-state)))) + (old-cleanup *cps-cleanup-function*) + (*cps-cleanup-function* + (let ((*cps-cleanup-function* nil)) + (cps--add-state "cleanup" + `(progn + ,(when old-cleanup `(funcall ,old-cleanup)) + ,@unwindforms))))) + (cps--with-value-wrapper + (cps--make-unwind-wrapper unwindforms) + (cps--transform-1 bodyform unwind-state)))) + + ;; Process `while'. + + (`(while ,test . ,body) + ;; Open-code state addition instead of using cps--add-state: we + ;; need our states to be self-referential. (That's what makes the + ;; state a loop.) + (let* ((loop-state + (cl-gensym "cps-state-while-")) + (eval-loop-condition-state + (cps--transform-1 test loop-state)) + (loop-state-body + `(progn + (setf ,*cps-state-symbol* + (if ,*cps-value-symbol* + ,(cps--transform-1 + `(progn ,@body) + eval-loop-condition-state) + ,next-state))))) + (push (list loop-state loop-state-body *cps-cleanup-function*) + *cps-states*) + (push loop-state *cps-bindings*) + eval-loop-condition-state)) + + ;; Process various kinds of `quote'. + + (`(quote ,arg) (cps--add-state "quote" + `(setf ,*cps-value-symbol* (quote ,arg) + ,*cps-state-symbol* ,next-state))) + (`(function ,arg) (cps--add-state "function" + `(setf ,*cps-value-symbol* (function ,arg) + ,*cps-state-symbol* ,next-state))) + + ;; Deal with `iter-yield'. + + (`(cps-internal-yield ,value) + (cps--transform-1 + value + (cps--add-state "iter-yield" + `(progn + (setf ,*cps-state-symbol* + ,(if *cps-cleanup-function* + (cps--add-state "after-yield" + `(setf ,*cps-state-symbol* ,next-state)) + next-state)) + (throw 'cps--yield ,*cps-value-symbol*))))) + + ;; Catch any unhandled special forms. + + ((and `(,name . ,_) + (guard (cps--special-form-p name)) + (guard (not (memq name cps-standard-special-forms)))) + name ; Shut up byte compiler + (error "special form %S incorrect or not supported" form)) + + ;; Process regular function applications with nontrivial + ;; parameters, converting them to applications of trivial + ;; let-bound parameters. + + ((and `(,function . ,arguments) + (guard (not (cl-loop for argument in arguments + always (atom argument))))) + (let ((argument-symbols + (cl-loop for argument in arguments + collect (if (atom argument) + argument + (cl-gensym "cps-argument-"))))) + + (cps--transform-1 + `(let* ,(cl-loop for argument in arguments + for argument-symbol in argument-symbols + unless (eq argument argument-symbol) + collect (list argument-symbol argument)) + ,(cons function argument-symbols)) + next-state))) + + ;; Process everything else by just evaluating the form normally. + (t (cps--make-atomic-state form next-state)))) + +(defun cps--make-catch-wrapper (tag-binding next-state) + (lambda (form) + (let ((normal-exit-symbol + (cl-gensym "cps-normal-exit-from-catch-"))) + `(let (,normal-exit-symbol) + (prog1 + (catch ,tag-binding + (prog1 + ,form + (setf ,normal-exit-symbol t))) + (unless ,normal-exit-symbol + (setf ,*cps-state-symbol* ,next-state))))))) + +(defun cps--make-condition-wrapper (var next-state handlers) + ;; Each handler is both one of the transformers with which we wrap + ;; evaluated atomic forms and a state to which we jump when we + ;; encounter the given error. + + (let* ((error-symbol (cps--add-binding "condition-case-error")) + (lexical-error-symbol (cl-gensym "cps-lexical-error-")) + (processed-handlers + (cl-loop for (condition . body) in handlers + collect (cons condition + (cps--transform-1 + (cps--replace-variable-references + var error-symbol + `(progn ,@body)) + next-state))))) + + (lambda (form) + `(condition-case + ,lexical-error-symbol + ,form + ,@(cl-loop + for (condition . error-state) in processed-handlers + collect + `(,condition + (setf ,error-symbol + ,lexical-error-symbol + ,*cps-state-symbol* + ,error-state))))))) + +(defun cps--replace-variable-references (var new-var form) + "Replace all non-shadowed references to VAR with NEW-VAR in FORM. +This routine does not modify FORM. Instead, it returns a +modified copy." + (macroexpand-all + `(cl-symbol-macrolet ((,var ,new-var)) ,form))) + +(defun cps--make-unwind-wrapper (unwind-forms) + (cl-assert lexical-binding) + (lambda (form) + (let ((normal-exit-symbol + (cl-gensym "cps-normal-exit-from-unwind-"))) + `(let (,normal-exit-symbol) + (unwind-protect + (prog1 + ,form + (setf ,normal-exit-symbol t)) + (unless ,normal-exit-symbol + ,@unwind-forms)))))) + +(put 'iter-end-of-sequence 'error-conditions '(iter-end-of-sequence)) +(put 'iter-end-of-sequence 'error-message "iteration terminated") + +(defun cps--make-close-iterator-form (terminal-state) + (if *cps-cleanup-table-symbol* + `(let ((cleanup (cdr (assq ,*cps-state-symbol* ,*cps-cleanup-table-symbol*)))) + (setf ,*cps-state-symbol* ,terminal-state + ,*cps-value-symbol* nil) + (when cleanup (funcall cleanup))) + `(setf ,*cps-state-symbol* ,terminal-state + ,*cps-value-symbol* nil))) + +(defun cps-generate-evaluator (form) + (let* (*cps-states* + *cps-bindings* + *cps-cleanup-function* + (*cps-value-symbol* (cl-gensym "cps-current-value-")) + (*cps-state-symbol* (cl-gensym "cps-current-state-")) + ;; We make *cps-cleanup-table-symbol** non-nil when we notice + ;; that we have cleanup processing to perform. + (*cps-cleanup-table-symbol* nil) + (terminal-state (cps--add-state "terminal" + `(signal 'iter-end-of-sequence + ,*cps-value-symbol*))) + (initial-state (cps--transform-1 + (macroexpand-all form) + terminal-state)) + (finalizer-symbol + (when *cps-cleanup-table-symbol* + (when *cps-cleanup-table-symbol* + (cl-gensym "cps-iterator-finalizer-"))))) + `(let ,(append (list *cps-state-symbol* *cps-value-symbol*) + (when *cps-cleanup-table-symbol* + (list *cps-cleanup-table-symbol*)) + (when finalizer-symbol + (list finalizer-symbol)) + (nreverse *cps-bindings*)) + ;; Order state list so that cleanup states are always defined + ;; before they're referenced. + ,@(cl-loop for (state body cleanup) in (nreverse *cps-states*) + collect `(setf ,state (lambda () ,body)) + when cleanup + do (cl-assert *cps-cleanup-table-symbol*) + and collect `(push (cons ,state ,cleanup) ,*cps-cleanup-table-symbol*)) + (setf ,*cps-state-symbol* ,initial-state) + + (let ((iterator + (lambda (op value) + (cond + ,@(when finalizer-symbol + `(((eq op :stash-finalizer) + (setf ,finalizer-symbol value)) + ((eq op :get-finalizer) + ,finalizer-symbol))) + ((eq op :close) + ,(cps--make-close-iterator-form terminal-state)) + ((eq op :next) + (setf ,*cps-value-symbol* value) + (let ((yielded nil)) + (unwind-protect + (prog1 + (catch 'cps--yield + (while t + (funcall ,*cps-state-symbol*))) + (setf yielded t)) + (unless yielded + ;; If we're exiting non-locally (error, quit, + ;; etc.) close the iterator. + ,(cps--make-close-iterator-form terminal-state))))) + (t (error "unknown iterator operation %S" op)))))) + ,(when finalizer-symbol + `(funcall iterator + :stash-finalizer + (make-finalizer + (lambda () + (iter-close iterator))))) + iterator)))) + +(defun iter-yield (value) + "When used inside a generator, yield control to caller. +The caller of `iter-next' receives VALUE, and the next call to +`iter-next' resumes execution at the previous +`iter-yield' point." + (identity value) + (error "`iter-yield' used outside a generator")) + +(defmacro iter-yield-from (value) + "When used inside a generator function, delegate to a sub-iterator. +The values that the sub-iterator yields are passed directly to +the caller, and values supplied to `iter-next' are sent to the +sub-iterator. `iter-yield-from' evaluates to the value that the +sub-iterator function returns via `iter-end-of-sequence'." + (let ((errsym (cl-gensym "yield-from-result")) + (valsym (cl-gensym "yield-from-value"))) + `(let ((,valsym ,value)) + (unwind-protect + (condition-case ,errsym + (let ((vs nil)) + (while t + (setf vs (iter-yield (iter-next ,valsym vs))))) + (iter-end-of-sequence (cdr ,errsym))) + (iter-close ,valsym))))) + +(defmacro iter-defun (name arglist &rest body) + "Creates a generator NAME. +When called as a function, NAME returns an iterator value that +encapsulates the state of a computation that produces a sequence +of values. Callers can retrieve each value using `iter-next'." + (declare (indent defun)) + (cl-assert lexical-binding) + `(defun ,name ,arglist + ,(cps-generate-evaluator + `(cl-macrolet ((iter-yield (value) `(cps-internal-yield ,value))) + ,@body)))) + +(defmacro iter-lambda (arglist &rest body) + "Return a lambda generator. +`iter-lambda' is to `iter-defun' as `lambda' is to `defun'." + (declare (indent defun)) + (cl-assert lexical-binding) + `(lambda ,arglist + ,(cps-generate-evaluator + `(cl-macrolet ((iter-yield (value) `(cps-internal-yield ,value))) + ,@body)))) + +(defun iter-next (iterator &optional yield-result) + "Extract a value from an iterator. +YIELD-RESULT becomes the return value of `iter-yield` in the +context of the generator. + +This routine raises the `iter-end-of-sequence' condition if the +iterator cannot supply more values." + (funcall iterator :next yield-result)) + +(defun iter-close (iterator) + "Terminate an iterator early. +Run any unwind-protect handlers in scope at the point ITERATOR +is blocked." + (funcall iterator :close nil)) + +(cl-defmacro iter-do ((var iterator) &rest body) + "Loop over values from an iterator. +Evaluate BODY with VAR bound to each value from ITERATOR. +Return the value with which ITERATOR finished iteration." + (declare (indent 1)) + (let ((done-symbol (cl-gensym "iter-do-iterator-done")) + (condition-symbol (cl-gensym "iter-do-condition")) + (it-symbol (cl-gensym "iter-do-iterator")) + (result-symbol (cl-gensym "iter-do-result"))) + `(let (,var + ,result-symbol + (,done-symbol nil) + (,it-symbol ,iterator)) + (while (not ,done-symbol) + (condition-case ,condition-symbol + (setf ,var (iter-next ,it-symbol)) + (iter-end-of-sequence + (setf ,result-symbol (cdr ,condition-symbol)) + (setf ,done-symbol t))) + (unless ,done-symbol ,@body)) + ,result-symbol))) + +(defvar cl--loop-args) + +(defmacro cps--advance-for (conscell) + ;; See cps--handle-loop-for + `(condition-case nil + (progn + (setcar ,conscell (iter-next (cdr ,conscell))) + ,conscell) + (iter-end-of-sequence + nil))) + +(defmacro cps--initialize-for (iterator) + ;; See cps--handle-loop-for + (let ((cs (cl-gensym "cps--loop-temp"))) + `(let ((,cs (cons nil ,iterator))) + (cps--advance-for ,cs)))) + +(defun cps--handle-loop-for (var) + "Support `iter-by' in `loop'. " + ;; N.B. While the cl-loop-for-handler is a documented interface, + ;; there's no documented way for cl-loop-for-handler callbacks to do + ;; anything useful! Additionally, cl-loop currently lexbinds useful + ;; internal variables, so our only option is to modify + ;; cl--loop-args. If we substitute a general-purpose for-clause for + ;; our iterating clause, however, we can't preserve the + ;; parallel-versus-sequential `loop' semantics for for clauses --- + ;; we need a terminating condition as well, which requires us to use + ;; while, and inserting a while would break and-sequencing. + ;; + ;; To work around this problem, we actually use the "for var in LIST + ;; by FUNCTION" syntax, creating a new fake list each time through + ;; the loop, this "list" being a cons cell (val . it). + (let ((it-form (pop cl--loop-args))) + (setf cl--loop-args + (append + `(for ,var + in (cps--initialize-for ,it-form) + by 'cps--advance-for) + cl--loop-args)))) + +(put 'iter-by 'cl-loop-for-handler 'cps--handle-loop-for) + +(eval-after-load 'elisp-mode + (lambda () + (font-lock-add-keywords + 'emacs-lisp-mode + '(("(\\(iter-defun\\)\\_>\\s *\\(\\(?:\\sw\\|\\s_\\)+\\)?" + (1 font-lock-keyword-face nil t) + (2 font-lock-function-name-face nil t)) + ("(\\(iter-next\\)\\_>" + (1 font-lock-keyword-face nil t)) + ("(\\(iter-lambda\\)\\_>" + (1 font-lock-keyword-face nil t)) + ("(\\(iter-yield\\)\\_>" + (1 font-lock-keyword-face nil t)) + ("(\\(iter-yield-from\\)\\_>" + (1 font-lock-keyword-face nil t)))))) + +(provide 'generator) + +;;; generator.el ends here diff --git a/test/ChangeLog b/test/ChangeLog index 684e98f880e..64ad85198af 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,5 +1,7 @@ 2015-03-02 Daniel Colascione + * automated/generator-tests.el: New tests + * automated/finalizer-tests.el (finalizer-basic) (finalizer-circular-reference, finalizer-cross-reference) (finalizer-error): New tests. diff --git a/test/automated/generator-tests.el b/test/automated/generator-tests.el new file mode 100644 index 00000000000..2c5de31b40b --- /dev/null +++ b/test/automated/generator-tests.el @@ -0,0 +1,288 @@ +;;; generator-tests.el --- Testing generators -*- lexical-binding: t -*- + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Daniel Colascione +;; Keywords: + +;; This program 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. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +(require 'generator) +(require 'ert) +(require 'cl-lib) + +(defun generator-list-subrs () + (cl-loop for x being the symbols + when (and (fboundp x) + (cps--special-form-p (symbol-function x))) + collect x)) + +(defmacro cps-testcase (name &rest body) + "Perform a simple test of the continuation-transforming code. + +`cps-testcase' defines an ERT testcase called NAME that evaluates +BODY twice: once using ordinary `eval' and once using +lambda-generators. The test ensures that the two forms produce +identical output. +" + `(progn + (ert-deftest ,name () + (should + (equal + (funcall (lambda () ,@body)) + (iter-next + (funcall + (iter-lambda () (iter-yield (progn ,@body)))))))) + (ert-deftest ,(intern (format "%s-noopt" name)) () + (should + (equal + (funcall (lambda () ,@body)) + (iter-next + (funcall + (let ((cps-disable-atomic-optimization t)) + (iter-lambda () (iter-yield (progn ,@body))))))))))) + +(put 'cps-testcase 'lisp-indent-function 1) + +(defvar *cps-test-i* nil) +(defun cps-get-test-i () + *cps-test-i*) + +(cps-testcase cps-simple-1 (progn 1 2 3)) +(cps-testcase cps-empty-progn (progn)) +(cps-testcase cps-inline-not-progn (inline 1 2 3)) +(cps-testcase cps-prog1-a (prog1 1 2 3)) +(cps-testcase cps-prog1-b (prog1 1)) +(cps-testcase cps-prog1-c (prog2 1 2 3)) +(cps-testcase cps-quote (progn 'hello)) +(cps-testcase cps-function (progn #'hello)) + +(cps-testcase cps-and-fail (and 1 nil 2)) +(cps-testcase cps-and-succeed (and 1 2 3)) +(cps-testcase cps-and-empty (and)) + +(cps-testcase cps-or-fallthrough (or nil 1 2)) +(cps-testcase cps-or-alltrue (or 1 2 3)) +(cps-testcase cps-or-empty (or)) + +(cps-testcase cps-let* (let* ((i 10)) i)) +(cps-testcase cps-let*-shadow-empty (let* ((i 10)) (let (i) i))) +(cps-testcase cps-let (let ((i 10)) i)) +(cps-testcase cps-let-shadow-empty (let ((i 10)) (let (i) i))) +(cps-testcase cps-let-novars (let nil 42)) +(cps-testcase cps-let*-novars (let* nil 42)) + +(cps-testcase cps-let-parallel + (let ((a 5) (b 6)) (let ((a b) (b a)) (list a b)))) + +(cps-testcase cps-let*-parallel + (let* ((a 5) (b 6)) (let* ((a b) (b a)) (list a b)))) + +(cps-testcase cps-while-dynamic + (setq *cps-test-i* 0) + (while (< *cps-test-i* 10) + (setf *cps-test-i* (+ *cps-test-i* 1))) + *cps-test-i*) + +(cps-testcase cps-while-lexical + (let* ((i 0) (j 10)) + (while (< i 10) + (setf i (+ i 1)) + (setf j (+ j (* i 10)))) + j)) + +(cps-testcase cps-while-incf + (let* ((i 0) (j 10)) + (while (< i 10) + (incf i) + (setf j (+ j (* i 10)))) + j)) + +(cps-testcase cps-dynbind + (setf *cps-test-i* 0) + (let* ((*cps-test-i* 5)) + (cps-get-test-i))) + +(cps-testcase cps-nested-application + (+ (+ 3 5) 1)) + +(cps-testcase cps-unwind-protect + (setf *cps-test-i* 0) + (unwind-protect + (setf *cps-test-i* 1) + (setf *cps-test-i* 2)) + *cps-test-i*) + +(cps-testcase cps-catch-unused + (catch 'mytag 42)) + +(cps-testcase cps-catch-thrown + (1+ (catch 'mytag + (throw 'mytag (+ 2 2))))) + +(cps-testcase cps-loop + (cl-loop for x from 1 to 10 collect x)) + +(cps-testcase cps-loop-backquote + `(a b ,(cl-loop for x from 1 to 10 collect x) -1)) + +(cps-testcase cps-if-branch-a + (if t 'abc)) + +(cps-testcase cps-if-branch-b + (if t 'abc 'def)) + +(cps-testcase cps-if-condition-fail + (if nil 'abc 'def)) + +(cps-testcase cps-cond-empty + (cond)) + +(cps-testcase cps-cond-atomi + (cond (42))) + +(cps-testcase cps-cond-complex + (cond (nil 22) ((1+ 1) 42) (t 'bad))) + +(put 'cps-test-error 'error-conditions '(cps-test-condition)) + +(cps-testcase cps-condition-case + (condition-case + condvar + (signal 'cps-test-error 'test-data) + (cps-test-condition condvar))) + +(cps-testcase cps-condition-case-no-error + (condition-case + condvar + 42 + (cps-test-condition condvar))) + +(ert-deftest cps-generator-basic () + (let* ((gen (iter-lambda () + (iter-yield 1) + (iter-yield 2) + (iter-yield 3) + 4)) + (gen-inst (funcall gen))) + (should (eql (iter-next gen-inst) 1)) + (should (eql (iter-next gen-inst) 2)) + (should (eql (iter-next gen-inst) 3)) + + ;; should-error doesn't catch the generator-end condition (which + ;; isn't an error), so we write our own. + (let (errored) + (condition-case x + (iter-next gen-inst) + (iter-end-of-sequence + (setf errored (cdr x)))) + (should (eql errored 4))))) + +(iter-defun mygenerator (i) + (iter-yield 1) + (iter-yield i) + (iter-yield 2)) + +(ert-deftest cps-test-iter-do () + (let (mylist) + (iter-do (x (mygenerator 4)) + (push x mylist)) + + (assert (equal mylist '(2 4 1))))) + +(iter-defun gen-using-yield-value () + (let (f) + (setf f (iter-yield 42)) + (iter-yield f) + -8)) + +(ert-deftest cps-yield-value () + (let ((it (gen-using-yield-value))) + (should (eql (iter-next it -1) 42)) + (should (eql (iter-next it -1) -1)))) + +(ert-deftest cps-loop () + (should + (equal (cl-loop for x iter-by (mygenerator 42) + collect x) + '(1 42 2)))) + +(iter-defun gen-using-yield-from () + (let ((sub-iter (gen-using-yield-value))) + (iter-yield (1+ (iter-yield-from sub-iter))))) + +(ert-deftest cps-test-yield-from-works () + (let ((it (gen-using-yield-from))) + (should (eql (iter-next it -1) 42)) + (should (eql (iter-next it -1) -1)) + (should (eql (iter-next it -1) -7)))) + +(defvar cps-test-closed-flag nil) + +(ert-deftest cps-test-iter-close () + (garbage-collect) + (let ((cps-test-closed-flag nil)) + (let ((iter (funcall + (iter-lambda () + (unwind-protect (iter-yield 1) + (setf cps-test-closed-flag t)))))) + (should (equal (iter-next iter) 1)) + (should (not cps-test-closed-flag)) + (iter-close iter) + (should cps-test-closed-flag)))) + +(ert-deftest cps-test-iter-close-idempotent () + (garbage-collect) + (let ((cps-test-closed-flag nil)) + (let ((iter (funcall + (iter-lambda () + (unwind-protect (iter-yield 1) + (setf cps-test-closed-flag t)))))) + (should (equal (iter-next iter) 1)) + (should (not cps-test-closed-flag)) + (iter-close iter) + (should cps-test-closed-flag) + (setf cps-test-closed-flag nil) + (iter-close iter) + (should (not cps-test-closed-flag))))) + +(ert-deftest cps-test-iter-close-finalizer () + (skip-unless gc-precise-p) + (garbage-collect) + (let ((cps-test-closed-flag nil)) + (let ((iter (funcall + (iter-lambda () + (unwind-protect (iter-yield 1) + (setf cps-test-closed-flag t)))))) + (should (equal (iter-next iter) 1)) + (should (not cps-test-closed-flag)) + (setf iter nil) + (garbage-collect) + (should cps-test-closed-flag)))) + +(ert-deftest cps-test-iter-cleanup-once-only () + (let* ((nr-unwound 0) + (iter + (funcall (iter-lambda () + (unwind-protect + (progn + (iter-yield 1) + (error "test") + (iter-yield 2)) + (incf nr-unwound)))))) + (should (equal (iter-next iter) 1)) + (should-error (iter-next iter)) + (should (equal nr-unwound 1)))) -- cgit v1.2.3 From 8f0f8c166c2c76789acfa0cf3d42eafbbfa95973 Mon Sep 17 00:00:00 2001 From: Daniel Colascione Date: Mon, 2 Mar 2015 16:11:51 -0800 Subject: Fix docstrings, declarations in iter-defun * lisp/emacs-lisp/generator.el (iter-defun): Correctly propagate docstrings and declarations to underlying function. --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/generator.el | 14 ++++++++++---- 2 files changed, 15 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 4ab4406dba1..5018ca4b9de 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-03-03 Daniel Colascione + + * emacs-lisp/generator.el (iter-defun): Correctly propagate + docstrings and declarations to underlying function. + 2015-03-02 Daniel Colascione * emacs-lisp/generator.el: New file. diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index 4e21e792406..bb9fcff1408 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -674,10 +674,16 @@ encapsulates the state of a computation that produces a sequence of values. Callers can retrieve each value using `iter-next'." (declare (indent defun)) (cl-assert lexical-binding) - `(defun ,name ,arglist - ,(cps-generate-evaluator - `(cl-macrolet ((iter-yield (value) `(cps-internal-yield ,value))) - ,@body)))) + (let (preamble) + (when (stringp (car body)) + (push (pop body) preamble)) + (when (eq (car-safe (car body)) 'declare) + (push (pop body) preamble)) + `(defun ,name ,arglist + ,@(nreverse preamble) + ,(cps-generate-evaluator + `(cl-macrolet ((iter-yield (value) `(cps-internal-yield ,value))) + ,@body))))) (defmacro iter-lambda (arglist &rest body) "Return a lambda generator. -- cgit v1.2.3 From 8af3e1848cbdc570b6c173480c2988a552f3f74d Mon Sep 17 00:00:00 2001 From: Daniel Colascione Date: Mon, 2 Mar 2015 16:41:59 -0800 Subject: Add cl-iter-defun * lisp/emacs-lisp/cl-macs.el (cl-iter-defun): Add cl-iter-defun. --- doc/misc/cl.texi | 7 +++++++ lisp/ChangeLog | 2 ++ lisp/emacs-lisp/cl-macs.el | 21 +++++++++++++++++++++ 3 files changed, 30 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index 052ca6bd786..c6076babacd 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -296,6 +296,13 @@ list. Also, the function body is enclosed in an implicit block called @var{name}; @pxref{Blocks and Exits}. @end defmac +@defmac cl-iter-defun name arglist body@dots{} +This form is identical to the regular @code{iter-defun} form, except +that @var{arglist} is allowed to be a full Common Lisp argument +list. Also, the function body is enclosed in an implicit block +called @var{name}; @pxref{Blocks and Exits}. +@end defmac + @defmac cl-defsubst name arglist body@dots{} This is just like @code{cl-defun}, except that the function that is defined is automatically proclaimed @code{inline}, i.e., diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 5018ca4b9de..aae09fda38f 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,7 @@ 2015-03-03 Daniel Colascione + * emacs-lisp/cl-macs.el (cl-iter-defun): Add cl-iter-defun. + * emacs-lisp/generator.el (iter-defun): Correctly propagate docstrings and declarations to underlying function. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c3da091fb00..36f263cd20a 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -301,6 +301,27 @@ and BODY is implicitly surrounded by (cl-block NAME ...). (form `(defun ,name ,@(cdr res)))) (if (car res) `(progn ,(car res) ,form) form))) +;;;###autoload +(defmacro cl-iter-defun (name args &rest body) + "Define NAME as a generator function. +Like normal `iter-defun', except ARGLIST allows full Common Lisp conventions, +and BODY is implicitly surrounded by (cl-block NAME ...). + +\(fn NAME ARGLIST [DOCSTRING] BODY...)" + (declare (debug + ;; Same as iter-defun but use cl-lambda-list. + (&define [&or name ("setf" :name setf name)] + cl-lambda-list + cl-declarations-or-string + [&optional ("interactive" interactive)] + def-body)) + (doc-string 3) + (indent 2)) + (require 'generator) + (let* ((res (cl--transform-lambda (cons args body) name)) + (form `(iter-defun ,name ,@(cdr res)))) + (if (car res) `(progn ,(car res) ,form) form))) + ;; The lambda list for macros is different from that of normal lambdas. ;; Note that &environment is only allowed as first or last items in the ;; top level list. -- cgit v1.2.3 From bfbcec128a64c8d7d480140874c7bfa50ae803f7 Mon Sep 17 00:00:00 2001 From: Artur Malabarba Date: Tue, 3 Mar 2015 15:15:26 +0000 Subject: emacs-lisp/package.el (package-autoremove): Fix if logic. --- lisp/ChangeLog | 4 ++++ lisp/emacs-lisp/package.el | 4 ++-- 2 files changed, 6 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 16206e2b6e1..af7d0d81323 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2015-03-03 Artur Malabarba + + * emacs-lisp/package.el (package-autoremove): Fix if logic. + 2015-03-03 Martin Rudalics * window.el (window--dump-frame): For pixel height return total diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index de1158d96a7..885fb00ce75 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1611,8 +1611,8 @@ will be deleted." (mapconcat #'symbol-name removable ", "))) (mapc (lambda (p) (package-delete (cadr (assq p package-alist)) t)) - removable) - (message "Nothing to autoremove")))))) + removable)) + (message "Nothing to autoremove"))))) (defun package-archive-base (desc) "Return the archive containing the package NAME." -- cgit v1.2.3 From a0b78cb64f295f52c67916362ec1eaf75b1259c4 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Tue, 3 Mar 2015 08:56:24 -0800 Subject: # Standardize copyright and license notices for recently added files --- lisp/emacs-lisp/generator.el | 2 +- test/automated/finalizer-tests.el | 8 +++++--- test/automated/generator-tests.el | 8 +++++--- 3 files changed, 11 insertions(+), 7 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index bb9fcff1408..a3759a27fdd 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -6,7 +6,7 @@ ;; Keywords: extensions, elisp ;; Package: emacs -;; Copyright (C) Daniel Colascione +;; 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 diff --git a/test/automated/finalizer-tests.el b/test/automated/finalizer-tests.el index 4746dbea9b7..4bf8bb1a318 100644 --- a/test/automated/finalizer-tests.el +++ b/test/automated/finalizer-tests.el @@ -5,18 +5,20 @@ ;; Author: Daniel Colascione ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . +;; along with GNU Emacs. If not, see . ;;; Commentary: diff --git a/test/automated/generator-tests.el b/test/automated/generator-tests.el index 2c5de31b40b..875255ff11a 100644 --- a/test/automated/generator-tests.el +++ b/test/automated/generator-tests.el @@ -5,18 +5,20 @@ ;; Author: Daniel Colascione ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . +;; along with GNU Emacs. If not, see . ;;; Commentary: -- cgit v1.2.3 From 02eb227e8163c6212e814b5b7e191b4d34306872 Mon Sep 17 00:00:00 2001 From: Daniel Colascione Date: Tue, 3 Mar 2015 10:32:21 -0800 Subject: Rename globals in generator.el * lisp/emacs-lisp/generator.el: Make globals conform to elisp style throughout. --- lisp/ChangeLog | 5 ++ lisp/emacs-lisp/generator.el | 156 +++++++++++++++++++++---------------------- 2 files changed, 83 insertions(+), 78 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index af7d0d81323..e08263d4ab7 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-03-03 Daniel Colascione + + * emacs-lisp/generator.el: Make globals conform to elisp + style throughout. + 2015-03-03 Artur Malabarba * emacs-lisp/package.el (package-autoremove): Fix if logic. diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index a3759a27fdd..d41f13e29ca 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -79,14 +79,14 @@ (require 'cl-lib) (require 'pcase) -(defvar *cps-bindings* nil) -(defvar *cps-states* nil) -(defvar *cps-value-symbol* nil) -(defvar *cps-state-symbol* nil) -(defvar *cps-cleanup-table-symbol* nil) -(defvar *cps-cleanup-function* nil) - -(defvar *cps-dynamic-wrappers* '(identity) +(defvar cps--bindings nil) +(defvar cps--states nil) +(defvar cps--value-symbol nil) +(defvar cps--state-symbol nil) +(defvar cps--cleanup-table-symbol nil) +(defvar cps--cleanup-function nil) + +(defvar cps--dynamic-wrappers '(identity) "List of transformer functions to apply to atomic forms we evaluate in CPS context.") @@ -128,10 +128,10 @@ control flow non-locally in goo that diverts this control flow to the CPS state machinery. " (declare (indent 1)) - `(let ((*cps-dynamic-wrappers* + `(let ((cps--dynamic-wrappers (cons ,wrapper - *cps-dynamic-wrappers*))) + cps--dynamic-wrappers))) ,@body)) (defun cps--make-dynamic-binding-wrapper (dynamic-var static-var) @@ -155,13 +155,13 @@ DYNAMIC-VAR bound to STATIC-VAR." "Create a new CPS state with body BODY and return the state's name." (declare (indent 1)) (let* ((state (cl-gensym (format "cps-state-%s-" kind)))) - (push (list state body *cps-cleanup-function*) *cps-states*) - (push state *cps-bindings*) + (push (list state body cps--cleanup-function) cps--states) + (push state cps--bindings) state)) (defun cps--add-binding (original-name) (car (push (cl-gensym (format "cps-binding-%s-" original-name)) - *cps-bindings*))) + cps--bindings))) (defun cps--find-special-form-handler (form) (let* ((handler-name (format "cps--transform-%s" (car-safe form))) @@ -187,17 +187,17 @@ don't yield.") (not cps--yield-seen)))) (defun cps--make-atomic-state (form next-state) - (let ((tform `(prog1 ,form (setf ,*cps-state-symbol* ,next-state)))) - (cl-loop for wrapper in *cps-dynamic-wrappers* + (let ((tform `(prog1 ,form (setf ,cps--state-symbol ,next-state)))) + (cl-loop for wrapper in cps--dynamic-wrappers do (setf tform (funcall wrapper tform))) - ;; Bind *cps-cleanup-function* to nil here because the wrapper + ;; Bind cps--cleanup-function to nil here because the wrapper ;; function mechanism is responsible for cleanup here, not the ;; generic cleanup mechanism. If we didn't make this binding, ;; we'd run cleanup handlers twice on anything that made it out ;; to toplevel. - (let ((*cps-cleanup-function* nil)) + (let ((cps--cleanup-function nil)) (cps--add-state "atom" - `(setf ,*cps-value-symbol* ,tform))))) + `(setf ,cps--value-symbol ,tform))))) (defun cps--transform-1 (form next-state) (pcase form @@ -221,8 +221,8 @@ don't yield.") (cps--transform-1 condition (cps--add-state "and" - `(setf ,*cps-state-symbol* - (if ,*cps-value-symbol* + `(setf ,cps--state-symbol + (if ,cps--value-symbol ,(cps--transform-1 `(and ,@rest) next-state) ,next-state))))) @@ -233,8 +233,8 @@ don't yield.") (let ((tag-binding (cps--add-binding "catch-tag"))) (cps--transform-1 tag (cps--add-state "cps-update-tag" - `(setf ,tag-binding ,*cps-value-symbol* - ,*cps-state-symbol* + `(setf ,tag-binding ,cps--value-symbol + ,cps--state-symbol ,(cps--with-value-wrapper (cps--make-catch-wrapper tag-binding next-state) @@ -269,8 +269,8 @@ don't yield.") (`(if ,cond ,then . ,else) (cps--transform-1 cond (cps--add-state "if" - `(setf ,*cps-state-symbol* - (if ,*cps-value-symbol* + `(setf ,cps--state-symbol + (if ,cps--value-symbol ,(cps--transform-1 then next-state) ,(cps--transform-1 `(progn ,@else) @@ -328,8 +328,8 @@ don't yield.") (cps--transform-1 value-form (cps--add-state "let*" - `(setf ,new-var ,*cps-value-symbol* - ,*cps-state-symbol* + `(setf ,new-var ,cps--value-symbol + ,cps--state-symbol ,(if (or (not lexical-binding) (special-variable-p var)) (cps--with-dynamic-binding var new-var (cps--transform-1 @@ -349,8 +349,8 @@ don't yield.") (cps--transform-1 condition (cps--add-state "or" - `(setf ,*cps-state-symbol* - (if ,*cps-value-symbol* + `(setf ,cps--state-symbol + (if ,cps--value-symbol ,next-state ,(cps--transform-1 `(or ,@rest) next-state)))))) @@ -364,13 +364,13 @@ don't yield.") (let ((temp-var-symbol (cps--add-binding "prog1-temp"))) (cps--add-state "prog1" `(setf ,temp-var-symbol - ,*cps-value-symbol* - ,*cps-state-symbol* + ,cps--value-symbol + ,cps--state-symbol ,(cps--transform-1 `(progn ,@body) (cps--add-state "prog1inner" - `(setf ,*cps-value-symbol* ,temp-var-symbol - ,*cps-state-symbol* ,next-state)))))))) + `(setf ,cps--value-symbol ,temp-var-symbol + ,cps--state-symbol ,next-state)))))))) ;; Process `prog2'. @@ -402,8 +402,8 @@ don't yield.") (`(unwind-protect ,bodyform . ,unwindforms) ;; Signal the evaluator-generator that it needs to generate code ;; to handle cleanup forms. - (unless *cps-cleanup-table-symbol* - (setf *cps-cleanup-table-symbol* (cl-gensym "cps-cleanup-table-"))) + (unless cps--cleanup-table-symbol + (setf cps--cleanup-table-symbol (cl-gensym "cps-cleanup-table-"))) (let* ((unwind-state (cps--add-state "unwind" @@ -412,10 +412,10 @@ don't yield.") ;; references inside it with lifted equivalents. `(progn ,@unwindforms - (setf ,*cps-state-symbol* ,next-state)))) - (old-cleanup *cps-cleanup-function*) - (*cps-cleanup-function* - (let ((*cps-cleanup-function* nil)) + (setf ,cps--state-symbol ,next-state)))) + (old-cleanup cps--cleanup-function) + (cps--cleanup-function + (let ((cps--cleanup-function nil)) (cps--add-state "cleanup" `(progn ,(when old-cleanup `(funcall ,old-cleanup)) @@ -436,25 +436,25 @@ don't yield.") (cps--transform-1 test loop-state)) (loop-state-body `(progn - (setf ,*cps-state-symbol* - (if ,*cps-value-symbol* + (setf ,cps--state-symbol + (if ,cps--value-symbol ,(cps--transform-1 `(progn ,@body) eval-loop-condition-state) ,next-state))))) - (push (list loop-state loop-state-body *cps-cleanup-function*) - *cps-states*) - (push loop-state *cps-bindings*) + (push (list loop-state loop-state-body cps--cleanup-function) + cps--states) + (push loop-state cps--bindings) eval-loop-condition-state)) ;; Process various kinds of `quote'. (`(quote ,arg) (cps--add-state "quote" - `(setf ,*cps-value-symbol* (quote ,arg) - ,*cps-state-symbol* ,next-state))) + `(setf ,cps--value-symbol (quote ,arg) + ,cps--state-symbol ,next-state))) (`(function ,arg) (cps--add-state "function" - `(setf ,*cps-value-symbol* (function ,arg) - ,*cps-state-symbol* ,next-state))) + `(setf ,cps--value-symbol (function ,arg) + ,cps--state-symbol ,next-state))) ;; Deal with `iter-yield'. @@ -463,12 +463,12 @@ don't yield.") value (cps--add-state "iter-yield" `(progn - (setf ,*cps-state-symbol* - ,(if *cps-cleanup-function* + (setf ,cps--state-symbol + ,(if cps--cleanup-function (cps--add-state "after-yield" - `(setf ,*cps-state-symbol* ,next-state)) + `(setf ,cps--state-symbol ,next-state)) next-state)) - (throw 'cps--yield ,*cps-value-symbol*))))) + (throw 'cps--yield ,cps--value-symbol))))) ;; Catch any unhandled special forms. @@ -513,7 +513,7 @@ don't yield.") ,form (setf ,normal-exit-symbol t))) (unless ,normal-exit-symbol - (setf ,*cps-state-symbol* ,next-state))))))) + (setf ,cps--state-symbol ,next-state))))))) (defun cps--make-condition-wrapper (var next-state handlers) ;; Each handler is both one of the transformers with which we wrap @@ -541,7 +541,7 @@ don't yield.") `(,condition (setf ,error-symbol ,lexical-error-symbol - ,*cps-state-symbol* + ,cps--state-symbol ,error-state))))))) (defun cps--replace-variable-references (var new-var form) @@ -568,47 +568,47 @@ modified copy." (put 'iter-end-of-sequence 'error-message "iteration terminated") (defun cps--make-close-iterator-form (terminal-state) - (if *cps-cleanup-table-symbol* - `(let ((cleanup (cdr (assq ,*cps-state-symbol* ,*cps-cleanup-table-symbol*)))) - (setf ,*cps-state-symbol* ,terminal-state - ,*cps-value-symbol* nil) + (if cps--cleanup-table-symbol + `(let ((cleanup (cdr (assq ,cps--state-symbol ,cps--cleanup-table-symbol)))) + (setf ,cps--state-symbol ,terminal-state + ,cps--value-symbol nil) (when cleanup (funcall cleanup))) - `(setf ,*cps-state-symbol* ,terminal-state - ,*cps-value-symbol* nil))) + `(setf ,cps--state-symbol ,terminal-state + ,cps--value-symbol nil))) (defun cps-generate-evaluator (form) - (let* (*cps-states* - *cps-bindings* - *cps-cleanup-function* - (*cps-value-symbol* (cl-gensym "cps-current-value-")) - (*cps-state-symbol* (cl-gensym "cps-current-state-")) + (let* (cps--states + cps--bindings + cps--cleanup-function + (cps--value-symbol (cl-gensym "cps-current-value-")) + (cps--state-symbol (cl-gensym "cps-current-state-")) ;; We make *cps-cleanup-table-symbol** non-nil when we notice ;; that we have cleanup processing to perform. - (*cps-cleanup-table-symbol* nil) + (cps--cleanup-table-symbol nil) (terminal-state (cps--add-state "terminal" `(signal 'iter-end-of-sequence - ,*cps-value-symbol*))) + ,cps--value-symbol))) (initial-state (cps--transform-1 (macroexpand-all form) terminal-state)) (finalizer-symbol - (when *cps-cleanup-table-symbol* - (when *cps-cleanup-table-symbol* + (when cps--cleanup-table-symbol + (when cps--cleanup-table-symbol (cl-gensym "cps-iterator-finalizer-"))))) - `(let ,(append (list *cps-state-symbol* *cps-value-symbol*) - (when *cps-cleanup-table-symbol* - (list *cps-cleanup-table-symbol*)) + `(let ,(append (list cps--state-symbol cps--value-symbol) + (when cps--cleanup-table-symbol + (list cps--cleanup-table-symbol)) (when finalizer-symbol (list finalizer-symbol)) - (nreverse *cps-bindings*)) + (nreverse cps--bindings)) ;; Order state list so that cleanup states are always defined ;; before they're referenced. - ,@(cl-loop for (state body cleanup) in (nreverse *cps-states*) + ,@(cl-loop for (state body cleanup) in (nreverse cps--states) collect `(setf ,state (lambda () ,body)) when cleanup - do (cl-assert *cps-cleanup-table-symbol*) - and collect `(push (cons ,state ,cleanup) ,*cps-cleanup-table-symbol*)) - (setf ,*cps-state-symbol* ,initial-state) + do (cl-assert cps--cleanup-table-symbol) + and collect `(push (cons ,state ,cleanup) ,cps--cleanup-table-symbol)) + (setf ,cps--state-symbol ,initial-state) (let ((iterator (lambda (op value) @@ -621,13 +621,13 @@ modified copy." ((eq op :close) ,(cps--make-close-iterator-form terminal-state)) ((eq op :next) - (setf ,*cps-value-symbol* value) + (setf ,cps--value-symbol value) (let ((yielded nil)) (unwind-protect (prog1 (catch 'cps--yield (while t - (funcall ,*cps-state-symbol*))) + (funcall ,cps--state-symbol))) (setf yielded t)) (unless yielded ;; If we're exiting non-locally (error, quit, -- cgit v1.2.3 From cecf4afebb394351a78c48d05e81a1e55af6da32 Mon Sep 17 00:00:00 2001 From: Daniel Colascione Date: Tue, 3 Mar 2015 10:56:24 -0800 Subject: Address generator feedback * doc/lispref/control.texi (Generators): Correct missing word. Clarify which forms are legal in which parts of `unwind-protect'. Fix orphaned close parenthesis. * lisp/emacs-lisp/generator.el: Make globals conform to elisp style throughout. Use more efficient font-lock patterns. (cps-inhibit-atomic-optimization): Rename from `cps-disable-atomic-optimization'. (cps--gensym): New macro; replaces `cl-gensym' throughout. (cps-generate-evaluator): Move the `iter-yield' local macro definition here (iter-defun, iter-lambda): from here. * test/automated/generator-tests.el (cps-test-iter-close-finalizer): Rename `gc-precise-p' to `gc-precise'. * test/automated/generator-tests.el (cps-testcase): Use `cps-inhibit-atomic-optimization' instead of `cps-disable-atomic-optimization'. --- doc/lispref/ChangeLog | 4 ++ doc/lispref/control.texi | 14 ++++--- lisp/ChangeLog | 8 +++- lisp/emacs-lisp/generator.el | 77 ++++++++++++++++++++------------------- test/ChangeLog | 4 ++ test/automated/generator-tests.el | 2 +- 6 files changed, 64 insertions(+), 45 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog index c27805b3d6e..f96cb26a5e1 100644 --- a/doc/lispref/ChangeLog +++ b/doc/lispref/ChangeLog @@ -1,5 +1,9 @@ 2015-03-03 Daniel Colascione + * control.texi (Generators): Correct missing word. Clarify which + forms are legal in which parts of `unwind-protect'. Fix orphaned + close parenthesis. + * objects.texi (Finalizer Type): New section for finalizer objects. (Type Predicates): Mention finalizers in `type-of' documentation. * elisp.texi (Top): Link to finalizer type. diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index bec2bc92ac4..f512ad990bd 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -661,7 +661,7 @@ indicates that the current iterator should pause and return @code{iter-yield-from} yields all the values that @var{iterator} produces and evaluates to the value that @var{iterator}'s generator function returns normally. While it has control, @var{iterator} -receives sent to the iterator using @code{iter-next}. +receives values sent to the iterator using @code{iter-next}. @end defmac To use a generator function, first call it normally, producing a @@ -693,9 +693,11 @@ evaluating any @code{iter-yield} form. @end defun @defun iter-close iterator -If @var{iterator} is suspended inside a @code{unwind-protect} and -becomes unreachable, Emacs will eventually run unwind handlers after a -garbage collection pass. To ensure that these handlers are run before +If @var{iterator} is suspended inside an @code{unwind-protect}'s +@code{bodyform} and becomes unreachable, Emacs will eventually run +unwind handlers after a garbage collection pass. (Note that +@code{iter-yield} is illegal inside an @code{unwind-protect}'s +@code{unwindforms}.) To ensure that these handlers are run before then, use @code{iter-close}. @end defun @@ -716,8 +718,8 @@ working with iterators. @example (iter-defun my-iter (x) (iter-yield (1+ (iter-yield (1+ x)))) - -1 ;; Return normally - ) + ;; Return normally + -1) (let* ((iter (my-iter 5)) (iter2 (my-iter 0))) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index e08263d4ab7..63071734cf8 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,7 +1,13 @@ 2015-03-03 Daniel Colascione * emacs-lisp/generator.el: Make globals conform to elisp - style throughout. + style throughout. Use more efficient font-lock patterns. + (cps-inhibit-atomic-optimization): Rename from + `cps-disable-atomic-optimization'. + (cps--gensym): New macro; replaces `cl-gensym' throughout. + (cps-generate-evaluator): Move the `iter-yield' local macro + definition here + (iter-defun, iter-lambda): from here. 2015-03-03 Artur Malabarba diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index d41f13e29ca..77b1fab9b09 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -86,6 +86,12 @@ (defvar cps--cleanup-table-symbol nil) (defvar cps--cleanup-function nil) +(defmacro cps--gensym (fmt &rest args) + ;; Change this function to use `cl-gensym' if you want the generated + ;; code to be easier to read and debug. + ;; (cl-gensym (apply #'format fmt args)) + `(make-symbol ,fmt)) + (defvar cps--dynamic-wrappers '(identity) "List of transformer functions to apply to atomic forms we evaluate in CPS context.") @@ -154,13 +160,13 @@ DYNAMIC-VAR bound to STATIC-VAR." (defun cps--add-state (kind body) "Create a new CPS state with body BODY and return the state's name." (declare (indent 1)) - (let* ((state (cl-gensym (format "cps-state-%s-" kind)))) + (let* ((state (cps--gensym "cps-state-%s-" kind))) (push (list state body cps--cleanup-function) cps--states) (push state cps--bindings) state)) (defun cps--add-binding (original-name) - (car (push (cl-gensym (format "cps-binding-%s-" original-name)) + (car (push (cps--gensym (format "cps-binding-%s-" original-name)) cps--bindings))) (defun cps--find-special-form-handler (form) @@ -168,7 +174,7 @@ DYNAMIC-VAR bound to STATIC-VAR." (handler (intern-soft handler-name))) (and (fboundp handler) handler))) -(defvar cps-disable-atomic-optimization nil +(defvar cps-inhibit-atomic-optimization nil "When t, always rewrite forms into cps even when they don't yield.") @@ -177,13 +183,14 @@ don't yield.") (defun cps--atomic-p (form) "Return whether the given form never yields." - (and (not cps-disable-atomic-optimization) + (and (not cps-inhibit-atomic-optimization) (let* ((cps--yield-seen)) (ignore (macroexpand-all `(cl-macrolet ((cps-internal-yield (_val) (setf cps--yield-seen t))) - ,form))) + ,form) + macroexpand-all-environment)) (not cps--yield-seen)))) (defun cps--make-atomic-state (form next-state) @@ -403,7 +410,7 @@ don't yield.") ;; Signal the evaluator-generator that it needs to generate code ;; to handle cleanup forms. (unless cps--cleanup-table-symbol - (setf cps--cleanup-table-symbol (cl-gensym "cps-cleanup-table-"))) + (setf cps--cleanup-table-symbol (cps--gensym "cps-cleanup-table-"))) (let* ((unwind-state (cps--add-state "unwind" @@ -431,7 +438,7 @@ don't yield.") ;; need our states to be self-referential. (That's what makes the ;; state a loop.) (let* ((loop-state - (cl-gensym "cps-state-while-")) + (cps--gensym "cps-state-while-")) (eval-loop-condition-state (cps--transform-1 test loop-state)) (loop-state-body @@ -489,7 +496,7 @@ don't yield.") (cl-loop for argument in arguments collect (if (atom argument) argument - (cl-gensym "cps-argument-"))))) + (cps--gensym "cps-argument-"))))) (cps--transform-1 `(let* ,(cl-loop for argument in arguments @@ -505,7 +512,7 @@ don't yield.") (defun cps--make-catch-wrapper (tag-binding next-state) (lambda (form) (let ((normal-exit-symbol - (cl-gensym "cps-normal-exit-from-catch-"))) + (cps--gensym "cps-normal-exit-from-catch-"))) `(let (,normal-exit-symbol) (prog1 (catch ,tag-binding @@ -521,7 +528,7 @@ don't yield.") ;; encounter the given error. (let* ((error-symbol (cps--add-binding "condition-case-error")) - (lexical-error-symbol (cl-gensym "cps-lexical-error-")) + (lexical-error-symbol (cps--gensym "cps-lexical-error-")) (processed-handlers (cl-loop for (condition . body) in handlers collect (cons condition @@ -549,13 +556,14 @@ don't yield.") This routine does not modify FORM. Instead, it returns a modified copy." (macroexpand-all - `(cl-symbol-macrolet ((,var ,new-var)) ,form))) + `(cl-symbol-macrolet ((,var ,new-var)) ,form) + macroexpand-all-environment)) (defun cps--make-unwind-wrapper (unwind-forms) (cl-assert lexical-binding) (lambda (form) (let ((normal-exit-symbol - (cl-gensym "cps-normal-exit-from-unwind-"))) + (cps--gensym "cps-normal-exit-from-unwind-"))) `(let (,normal-exit-symbol) (unwind-protect (prog1 @@ -576,12 +584,12 @@ modified copy." `(setf ,cps--state-symbol ,terminal-state ,cps--value-symbol nil))) -(defun cps-generate-evaluator (form) +(defun cps-generate-evaluator (body) (let* (cps--states cps--bindings cps--cleanup-function - (cps--value-symbol (cl-gensym "cps-current-value-")) - (cps--state-symbol (cl-gensym "cps-current-state-")) + (cps--value-symbol (cps--gensym "cps-current-value-")) + (cps--state-symbol (cps--gensym "cps-current-state-")) ;; We make *cps-cleanup-table-symbol** non-nil when we notice ;; that we have cleanup processing to perform. (cps--cleanup-table-symbol nil) @@ -589,12 +597,17 @@ modified copy." `(signal 'iter-end-of-sequence ,cps--value-symbol))) (initial-state (cps--transform-1 - (macroexpand-all form) + (macroexpand-all + `(cl-macrolet + ((iter-yield (value) + `(cps-internal-yield ,value))) + ,@body) + macroexpand-all-environment) terminal-state)) (finalizer-symbol (when cps--cleanup-table-symbol (when cps--cleanup-table-symbol - (cl-gensym "cps-iterator-finalizer-"))))) + (cps--gensym "cps-iterator-finalizer-"))))) `(let ,(append (list cps--state-symbol cps--value-symbol) (when cps--cleanup-table-symbol (list cps--cleanup-table-symbol)) @@ -656,8 +669,8 @@ The values that the sub-iterator yields are passed directly to the caller, and values supplied to `iter-next' are sent to the sub-iterator. `iter-yield-from' evaluates to the value that the sub-iterator function returns via `iter-end-of-sequence'." - (let ((errsym (cl-gensym "yield-from-result")) - (valsym (cl-gensym "yield-from-value"))) + (let ((errsym (cps--gensym "yield-from-result")) + (valsym (cps--gensym "yield-from-value"))) `(let ((,valsym ,value)) (unwind-protect (condition-case ,errsym @@ -681,9 +694,7 @@ of values. Callers can retrieve each value using `iter-next'." (push (pop body) preamble)) `(defun ,name ,arglist ,@(nreverse preamble) - ,(cps-generate-evaluator - `(cl-macrolet ((iter-yield (value) `(cps-internal-yield ,value))) - ,@body))))) + ,(cps-generate-evaluator body)))) (defmacro iter-lambda (arglist &rest body) "Return a lambda generator. @@ -691,9 +702,7 @@ of values. Callers can retrieve each value using `iter-next'." (declare (indent defun)) (cl-assert lexical-binding) `(lambda ,arglist - ,(cps-generate-evaluator - `(cl-macrolet ((iter-yield (value) `(cps-internal-yield ,value))) - ,@body)))) + ,(cps-generate-evaluator body))) (defun iter-next (iterator &optional yield-result) "Extract a value from an iterator. @@ -715,10 +724,10 @@ is blocked." Evaluate BODY with VAR bound to each value from ITERATOR. Return the value with which ITERATOR finished iteration." (declare (indent 1)) - (let ((done-symbol (cl-gensym "iter-do-iterator-done")) - (condition-symbol (cl-gensym "iter-do-condition")) - (it-symbol (cl-gensym "iter-do-iterator")) - (result-symbol (cl-gensym "iter-do-result"))) + (let ((done-symbol (cps--gensym "iter-do-iterator-done")) + (condition-symbol (cps--gensym "iter-do-condition")) + (it-symbol (cps--gensym "iter-do-iterator")) + (result-symbol (cps--gensym "iter-do-result"))) `(let (,var ,result-symbol (,done-symbol nil) @@ -745,7 +754,7 @@ Return the value with which ITERATOR finished iteration." (defmacro cps--initialize-for (iterator) ;; See cps--handle-loop-for - (let ((cs (cl-gensym "cps--loop-temp"))) + (let ((cs (cps--gensym "cps--loop-temp"))) `(let ((,cs (cons nil ,iterator))) (cps--advance-for ,cs)))) @@ -781,13 +790,7 @@ Return the value with which ITERATOR finished iteration." '(("(\\(iter-defun\\)\\_>\\s *\\(\\(?:\\sw\\|\\s_\\)+\\)?" (1 font-lock-keyword-face nil t) (2 font-lock-function-name-face nil t)) - ("(\\(iter-next\\)\\_>" - (1 font-lock-keyword-face nil t)) - ("(\\(iter-lambda\\)\\_>" - (1 font-lock-keyword-face nil t)) - ("(\\(iter-yield\\)\\_>" - (1 font-lock-keyword-face nil t)) - ("(\\(iter-yield-from\\)\\_>" + ("(\\(iter-\\(?:next\\|lambda\\|yield\\|yield-from\\)\\)\\_>" (1 font-lock-keyword-face nil t)))))) (provide 'generator) diff --git a/test/ChangeLog b/test/ChangeLog index ea2e0eef179..55f8c6c8eb8 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,5 +1,9 @@ 2015-03-03 Daniel Colascione + * automated/generator-tests.el (cps-testcase): Use + `cps-inhibit-atomic-optimization' instead of + `cps-disable-atomic-optimization'. + * automated/finalizer-tests.el (finalizer-basic) (finalizer-circular-reference, finalizer-cross-reference) (finalizer-error): Rename `gc-precise-p' to `gc-precise'. diff --git a/test/automated/generator-tests.el b/test/automated/generator-tests.el index 893c0d2e724..3ee65105597 100644 --- a/test/automated/generator-tests.el +++ b/test/automated/generator-tests.el @@ -54,7 +54,7 @@ identical output. (funcall (lambda () ,@body)) (iter-next (funcall - (let ((cps-disable-atomic-optimization t)) + (let ((cps-inhibit-atomic-optimization t)) (iter-lambda () (iter-yield (progn ,@body))))))))))) (put 'cps-testcase 'lisp-indent-function 1) -- cgit v1.2.3 From 7133f262bbd818509825a3317c91e91e62bd56fb Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 3 Mar 2015 14:23:49 -0500 Subject: * lisp/progmodes/gud.el: Use lexical-binding. Fixes: debbugs:19966 * lisp/emacs-lisp/gv.el (gv-ref): Warn about likely problematic cases. --- lisp/ChangeLog | 10 ++++++++-- lisp/emacs-lisp/gv.el | 17 ++++++++++++++--- lisp/progmodes/gud.el | 2 +- 3 files changed, 23 insertions(+), 6 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 63071734cf8..0cfe8eed02a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2015-03-03 Stefan Monnier + + * progmodes/gud.el: Use lexical-binding (bug#19966). + + * emacs-lisp/gv.el (gv-ref): Warn about likely problematic cases. + 2015-03-03 Daniel Colascione * emacs-lisp/generator.el: Make globals conform to elisp @@ -6,8 +12,8 @@ `cps-disable-atomic-optimization'. (cps--gensym): New macro; replaces `cl-gensym' throughout. (cps-generate-evaluator): Move the `iter-yield' local macro - definition here - (iter-defun, iter-lambda): from here. + definition here... + (iter-defun, iter-lambda): ...from here. 2015-03-03 Artur Malabarba diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 5d6e6e1b372..fae3bcb86f6 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -493,9 +493,20 @@ This is like the `&' operator of the C language. Note: this only works reliably with lexical binding mode, except for very simple PLACEs such as (function-symbol 'foo) which will also work in dynamic binding mode." - (gv-letplace (getter setter) place - `(cons (lambda () ,getter) - (lambda (gv--val) ,(funcall setter 'gv--val))))) + (let ((code + (gv-letplace (getter setter) place + `(cons (lambda () ,getter) + (lambda (gv--val) ,(funcall setter 'gv--val)))))) + (if (or lexical-binding + ;; If `code' still starts with `cons' then presumably gv-letplace + ;; did not add any new let-bindings, so the `lambda's don't capture + ;; any new variables. As a consequence, the code probably works in + ;; dynamic binding mode as well. + (eq (car-safe code) 'cons)) + code + (macroexp--warn-and-return + "Use of gv-ref probably requires lexical-binding" + code)))) (defsubst gv-deref (ref) "Dereference REF, returning the referenced value. diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index 42c5b20a7b8..29a6dc63a68 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -1,4 +1,4 @@ -;;; gud.el --- Grand Unified Debugger mode for running GDB and other debuggers +;;; gud.el --- Grand Unified Debugger mode for running GDB and other debuggers -*- lexical-binding:t -*- ;; Copyright (C) 1992-1996, 1998, 2000-2015 Free Software Foundation, ;; Inc. -- cgit v1.2.3 From 8b38d30e1b02809c34cfba9c7f15ca46f9d45f80 Mon Sep 17 00:00:00 2001 From: Daniel Colascione Date: Tue, 3 Mar 2015 13:18:00 -0800 Subject: Use `macroexp-parse-body' * lisp/emacs-lisp/generator.el: (iter-defun): Use `macroexp-parse-body'. * test/automated/generator-tests.el (cps-testcase): Use (cps-test-declarations-preserved): New test. --- lisp/ChangeLog | 15 +++++++++++++++ lisp/emacs-lisp/generator.el | 12 +++++------- test/ChangeLog | 1 + test/automated/generator-tests.el | 9 +++++++++ 4 files changed, 30 insertions(+), 7 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 0cfe8eed02a..3bc9b8c85ce 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,18 @@ +2015-03-03 Daniel Colascione + + * emacs-lisp/generator.el: Make globals conform to elisp + style throughout. Use more efficient font-lock patterns. + (cps-inhibit-atomic-optimization): Rename from + `cps-disable-atomic-optimization'. + (cps--gensym): New macro; replaces `cl-gensym' throughout. + (cps-generate-evaluator): Move the `iter-yield' local macro + definition here + (iter-defun, iter-lambda): from here. + + (iter-defun): Use `macroexp-parse-body'. + +2015-03-03 Daniel Colascione + 2015-03-03 Stefan Monnier * progmodes/gud.el: Use lexical-binding (bug#19966). diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index 77b1fab9b09..284de410580 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -687,14 +687,12 @@ encapsulates the state of a computation that produces a sequence of values. Callers can retrieve each value using `iter-next'." (declare (indent defun)) (cl-assert lexical-binding) - (let (preamble) - (when (stringp (car body)) - (push (pop body) preamble)) - (when (eq (car-safe (car body)) 'declare) - (push (pop body) preamble)) + (let* ((parsed-body (macroexp-parse-body body)) + (declarations (car parsed-body)) + (exps (cdr parsed-body))) `(defun ,name ,arglist - ,@(nreverse preamble) - ,(cps-generate-evaluator body)))) + ,@declarations + ,(cps-generate-evaluator exps)))) (defmacro iter-lambda (arglist &rest body) "Return a lambda generator. diff --git a/test/ChangeLog b/test/ChangeLog index 55f8c6c8eb8..4488aab701f 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -3,6 +3,7 @@ * automated/generator-tests.el (cps-testcase): Use `cps-inhibit-atomic-optimization' instead of `cps-disable-atomic-optimization'. + (cps-test-declarations-preserved): New test. * automated/finalizer-tests.el (finalizer-basic) (finalizer-circular-reference, finalizer-cross-reference) diff --git a/test/automated/generator-tests.el b/test/automated/generator-tests.el index 3ee65105597..d9c81b59a23 100644 --- a/test/automated/generator-tests.el +++ b/test/automated/generator-tests.el @@ -287,3 +287,12 @@ identical output. (should (equal (iter-next iter) 1)) (should-error (iter-next iter)) (should (equal nr-unwound 1)))) + +(iter-defun generator-with-docstring () + "Documentation!" + (declare (indent 5)) + nil) + +(ert-deftest cps-test-declarations-preserved () + (should (equal (documentation 'generator-with-docstring) "Documentation!")) + (should (equal (get 'generator-with-docstring 'lisp-indent-function) 5))) -- cgit v1.2.3 From 5d9b1e100aa4ddb79471f7ec2347fdb65d6a9a70 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Tue, 3 Mar 2015 15:10:05 -0800 Subject: Spelling fixes --- lisp/emacs-lisp/check-declare.el | 2 +- lisp/emacs-lisp/generator.el | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index c2639729fa9..8fc299d7e93 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -130,7 +130,7 @@ With optional argument FULL, sums the number of elements in each element." :group 'tools) (defcustom check-declare-ext-errors nil - "When non-nil, warn abount functions not found in :ext." + "When non-nil, warn about functions not found in :ext." :type 'boolean) (defun check-declare-verify (fnfile fnlist) diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index 284de410580..8251682590e 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -25,7 +25,7 @@ ;; This package implements generators for Emacs Lisp through a ;; continuation-passing transformation. It provides essentially the -;; same generator API and iterator facilties that Python and +;; same generator API and iterator facilities that Python and ;; JavaScript ES6 provide. ;; ;; `iter-lambda' and `iter-defun' work like `lambda' and `defun', @@ -57,7 +57,7 @@ ;; and each iterator maintains its own internal state. ;; ;; This raw form of iteration is general, but a bit awkward to use, so -;; this library also provides soem convenience functions: +;; this library also provides some convenience functions: ;; ;; `iter-do' is like `cl-do', except that instead of walking a list, ;; it walks an iterator. `cl-loop' is also extended with a new -- cgit v1.2.3 From 21c547863d5950a9d623d62ab743e92c0e1fd95f Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 4 Mar 2015 20:04:57 -0500 Subject: Replace *-function vars with generic functions in cl-generic. * lisp/emacs-lisp/cl-generic.el (cl--generic-generalizer): New struct. (cl-generic-tagcode-function, cl-generic-tag-types-function): Remove. (cl--generic-t-generalizer): New const. (cl--generic-make-method): Rename from `cl--generic-method-make'. (cl--generic-make): Change calling convention. (cl--generic): Add `options' field. (cl-generic-function-options): New function. (cl-defgeneric): Rewrite handling of options. Add support for :method options and allow the use of a default body. (cl-generic-define): Save options in the corresponding new field. (cl-defmethod): Fix ordering of qualifiers. (cl-generic-define-method): Use cl-generic-generalizers. (cl--generic-get-dispatcher): Change calling convention, and change calling convention of the returned function as well so as to take the list of methods separately from the generic function object, so that it can receive the original generic function object. (cl--generic-make-next-function): New function, extracted from cl--generic-make-function. (cl--generic-make-function): Use it. (cl-generic-method-combination-function): Remove. (cl--generic-cyclic-definition): New error. (cl-generic-call-method): Take a generic function object rather than its name. (cl-method-qualifiers): New alias. (cl--generic-build-combined-method): Use cl-generic-combine-methods, don't segregate by qualifiers here any more. (cl--generic-standard-method-combination): Segregate by qualifiers here instead. Add support for the `:extra' qualifier. (cl--generic-cache-miss): Move earlier, adjust to new calling convention. (cl-generic-generalizers, cl-generic-combine-methods): New generic functions. (cl-no-next-method, cl-no-applicable-method, cl-no-primary-method): Use the new "default method in defgeneric" functionality, change calling convention to receive a generic function object. (cl--generic-head-used): New var. (cl--generic-head-generalizer, cl--generic-eql-generalizer) (cl--generic-struct-generalizer, cl--generic-typeof-generalizer): New consts. * lisp/emacs-lisp/eieio-core.el (eieio--generic-generalizer) (eieio--generic-subclass-generalizer): New consts. (cl-generic-generalizers): New methods. * lisp/emacs-lisp/eieio-compat.el (eieio--generic-static-symbol-generalizer) (eieio--generic-static-object-generalizer): New consts. (cl-generic-generalizers) <(head eieio--static)>: New method. * lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Unfold closures like lambdas. --- lisp/ChangeLog | 74 ++++- lisp/emacs-lisp/byte-opt.el | 2 +- lisp/emacs-lisp/cl-generic.el | 625 ++++++++++++++++++++++++---------------- lisp/emacs-lisp/eieio-compat.el | 56 ++-- lisp/emacs-lisp/eieio-core.el | 54 ++-- 5 files changed, 504 insertions(+), 307 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index cdd4bf8557f..d4bc0af3eff 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,53 @@ +2015-03-05 Stefan Monnier + + Replace *-function vars with generic functions in cl-generic. + * emacs-lisp/cl-generic.el (cl--generic-generalizer): New struct. + (cl-generic-tagcode-function, cl-generic-tag-types-function): Remove. + (cl--generic-t-generalizer): New const. + (cl--generic-make-method): Rename from `cl--generic-method-make'. + (cl--generic-make): Change calling convention. + (cl--generic): Add `options' field. + (cl-generic-function-options): New function. + (cl-defgeneric): Rewrite handling of options. Add support for :method + options and allow the use of a default body. + (cl-generic-define): Save options in the corresponding new field. + (cl-defmethod): Fix ordering of qualifiers. + (cl-generic-define-method): Use cl-generic-generalizers. + (cl--generic-get-dispatcher): Change calling convention, and change + calling convention of the returned function as well so as to take the + list of methods separately from the generic function object, so that it + can receive the original generic function object. + (cl--generic-make-next-function): New function, extracted from + cl--generic-make-function. + (cl--generic-make-function): Use it. + (cl-generic-method-combination-function): Remove. + (cl--generic-cyclic-definition): New error. + (cl-generic-call-method): Take a generic function object rather than + its name. + (cl-method-qualifiers): New alias. + (cl--generic-build-combined-method): Use cl-generic-combine-methods, + don't segregate by qualifiers here any more. + (cl--generic-standard-method-combination): Segregate by qualifiers + here instead. Add support for the `:extra' qualifier. + (cl--generic-cache-miss): Move earlier, adjust to new calling convention. + (cl-generic-generalizers, cl-generic-combine-methods): + New generic functions. + (cl-no-next-method, cl-no-applicable-method, cl-no-primary-method): + Use the new "default method in defgeneric" functionality, change + calling convention to receive a generic function object. + (cl--generic-head-used): New var. + (cl--generic-head-generalizer, cl--generic-eql-generalizer) + (cl--generic-struct-generalizer, cl--generic-typeof-generalizer): + New consts. + * emacs-lisp/eieio-core.el (eieio--generic-generalizer) + (eieio--generic-subclass-generalizer): New consts. + (cl-generic-generalizers): New methods. + * emacs-lisp/eieio-compat.el (eieio--generic-static-symbol-generalizer) + (eieio--generic-static-object-generalizer): New consts. + (cl-generic-generalizers) <(head eieio--static)>: New method. + * emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): + Unfold closures like lambdas. + 2015-03-04 Filipp Gunbin * autorevert.el (auto-revert-notify-add-watch): @@ -142,8 +192,8 @@ 2015-03-03 Eli Zaretskii * frame.el (frame-notice-user-settings): Refresh the value of - frame parameters after calling tty-handle-reverse-video. Call - face-set-after-frame-default with the actual parameters, to avoid + frame parameters after calling tty-handle-reverse-video. + Call face-set-after-frame-default with the actual parameters, to avoid resetting colors back to unspecified. (set-background-color, set-foreground-color): Pass the foreground and background colors to face-set-after-frame-default. (Bug#19802) @@ -176,8 +226,8 @@ 2015-03-03 Eli Zaretskii - * textmodes/artist.el (artist-ellipse-compute-fill-info): Use - mapcar, not mapc, to create the other half of fill-info. + * textmodes/artist.el (artist-ellipse-compute-fill-info): + Use mapcar, not mapc, to create the other half of fill-info. (Bug#19763) 2015-03-03 Nicolas Petton @@ -323,8 +373,8 @@ Handle "#" operator properly inside macro. Fix coding bug. - * progmodes/cc-mode.el (c-neutralize-syntax-in-and-mark-CPP): On - finding a "#" which looks like the start of a macro, check it + * progmodes/cc-mode.el (c-neutralize-syntax-in-and-mark-CPP): + On finding a "#" which looks like the start of a macro, check it isn't already inside a macro. * progmodes/cc-engine.el (c-state-safe-place): Don't record a new @@ -364,15 +414,15 @@ 2015-02-25 Oleh Krehel - * emacs-lisp/check-declare.el (check-declare-warn): Use - compilation-style warnings. + * emacs-lisp/check-declare.el (check-declare-warn): + Use compilation-style warnings. (check-declare-files): Make sure that `check-declare-warning-buffer' is in `compilation-mode'. 2015-02-25 Oleh Krehel - * emacs-lisp/check-declare.el (check-declare-ext-errors): New - defcustom. + * emacs-lisp/check-declare.el (check-declare-ext-errors): + New defcustom. (check-declare): New defgroup. (check-declare-verify): When `check-declare-ext-errors' is non-nil, warn about an unfound function, instead of saying @@ -380,8 +430,8 @@ 2015-02-25 Tassilo Horn - * textmodes/reftex-vars.el (reftex-include-file-commands): Call - reftex-set-dirty on changes. + * textmodes/reftex-vars.el (reftex-include-file-commands): + Call reftex-set-dirty on changes. 2015-02-25 Stefan Monnier diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 149c4723199..e149f80db8e 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -390,7 +390,7 @@ (and (nth 1 form) (not for-effect) form)) - ((eq 'lambda (car-safe fn)) + ((memq (car-safe fn) '(lambda closure)) (let ((newform (byte-compile-unfold-lambda form))) (if (eq newform form) ;; Some error occurred, avoid infinite recursion diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 99924ba288f..a8483ea1355 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -31,37 +31,51 @@ ;; from a significant problem: the method-combination code returns a sexp ;; that needs to be `eval'uated or compiled. IOW it requires run-time ;; code generation. Given how rarely method-combinations are used, -;; I just provided a cl-generic-method-combination-function, which -;; people can use if they are really desperate for such functionality. +;; I just provided a cl-generic-combine-methods generic function, to which +;; people can add methods if they are really desperate for such functionality. ;; - In defgeneric we don't support the options: -;; declare, :method-combination, :generic-function-class, :method-class, -;; :method. +;; declare, :method-combination, :generic-function-class, :method-class. ;; Added elements: ;; - We support aliases to generic functions. -;; - The kind of thing on which to dispatch can be extended. -;; There is support in this file for dispatch on: +;; - cl-generic-generalizers. This generic function lets you extend the kind +;; of thing on which to dispatch. There is support in this file for +;; dispatch on: ;; - (eql ) +;; - (head ) which checks that the arg is a cons with as its head. ;; - plain old types ;; - type of CL structs ;; eieio-core adds dispatch on: ;; - class of eieio objects ;; - actual class argument, using the syntax (subclass ). -;; - cl-generic-method-combination-function (i.s.o define-method-combination). +;; - cl-generic-combine-methods (i.s.o define-method-combination and +;; compute-effective-method). ;; - cl-generic-call-method (which replaces make-method and call-method). +;; - The standard method combination supports ":extra STRING" qualifiers +;; which simply allows adding more methods for the same +;; specializers&qualifiers. ;; Efficiency considerations: overall, I've made an effort to make this fairly ;; efficient for the expected case (e.g. no constant redefinition of methods). ;; - Generic functions which do not dispatch on any argument are implemented ;; optimally (just as efficient as plain old functions). ;; - Generic functions which only dispatch on one argument are fairly efficient -;; (not a lot of room for improvement, I think). +;; (not a lot of room for improvement without changes to the byte-compiler, +;; I think). ;; - Multiple dispatch is implemented rather naively. There's an extra `apply' ;; function call for every dispatch; we don't optimize each dispatch ;; based on the set of candidate methods remaining; we don't optimize the -;; order in which we performs the dispatches either; If/when this -;; becomes a problem, we can try and optimize it. +;; order in which we performs the dispatches either; +;; If/when this becomes a problem, we can try and optimize it. ;; - call-next-method could be made more efficient, but isn't too terrible. +;; TODO: +;; +;; - A generic "filter" generalizer (e.g. could be used to cleanly adds methods +;; to cl-generic-combine-methods with a specializer that says it applies only +;; when some particular qualifier is used). +;; - A way to dispatch on the context (e.g. the major-mode, some global +;; variable, you name it). + ;;; Code: ;; Note: For generic functions that dispatch on several arguments (i.e. those @@ -70,40 +84,24 @@ ;; often suboptimal since after one dispatch, the remaining dispatches can ;; usually be simplified, or even completely skipped. -;; TODO/FIXME: -;; - WIBNI we could use something like -;; (add-function :before (cl-method-function (cl-find-method ...)) ...) - (eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'pcase)) -(defvar cl-generic-tagcode-function - (lambda (type _name) - (if (eq type t) '(0 . 'cl--generic-type) - (error "Unknown specializer %S" type))) - "Function to get the Elisp code to extract the tag on which we dispatch. -Takes a \"parameter-specializer-name\" and a variable name, and returns -a pair (PRIORITY . CODE) where CODE is an Elisp expression that should be -used to extract the \"tag\" (from the object held in the named variable) -that should uniquely determine if we have a match -\(i.e. the \"tag\" is the value that will be used to dispatch to the proper -method(s)). -Such \"tagcodes\" will be or'd together. -PRIORITY is an integer from 0 to 100 which is used to sort the tagcodes -in the `or'. The higher the priority, the more specific the tag should be. -More specifically, if PRIORITY is N and we have two objects X and Y -whose tag (according to TAGCODE) is `eql', then it should be the case -that for all other (PRIORITY . TAGCODE) where PRIORITY ≤ N, then -\(eval TAGCODE) for X is `eql' to (eval TAGCODE) for Y.") - -(defvar cl-generic-tag-types-function - (lambda (tag) (if (eq tag 'cl--generic-type) '(t))) - "Function to get the list of types that a given \"tag\" matches. -They should be sorted from most specific to least specific.") +(cl-defstruct (cl--generic-generalizer + (:constructor nil) + (:constructor cl-generic-make-generalizer + (priority tagcode-function specializers-function))) + (priority nil :type integer) + tagcode-function + specializers-function) + +(defconst cl--generic-t-generalizer + (cl-generic-make-generalizer + 0 (lambda (_name) nil) (lambda (_tag) '(t)))) (cl-defstruct (cl--generic-method (:constructor nil) - (:constructor cl--generic-method-make + (:constructor cl--generic-make-method (specializers qualifiers uses-cnm function)) (:predicate nil)) (specializers nil :read-only t :type list) @@ -115,8 +113,7 @@ They should be sorted from most specific to least specific.") (cl-defstruct (cl--generic (:constructor nil) - (:constructor cl--generic-make - (name &optional dispatches method-table)) + (:constructor cl--generic-make (name)) (:predicate nil)) (name nil :type symbol :read-only t) ;Pointer back to the symbol. ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index @@ -125,8 +122,13 @@ They should be sorted from most specific to least specific.") ;; on which to dispatch and PRIORITY is the priority of each expression to ;; decide in which order to sort them. ;; The most important dispatch is last in the list (and the least is first). - (dispatches nil :type (list-of (cons natnum (list-of tagcode)))) - (method-table nil :type (list-of cl--generic-method))) + (dispatches nil :type (list-of (cons natnum (list-of generalizers)))) + (method-table nil :type (list-of cl--generic-method)) + (options nil :type list)) + +(defun cl-generic-function-options (generic) + "Return the options of the generic function GENERIC." + (cl--generic-options generic)) (defmacro cl--generic (name) `(get ,name 'cl--generic)) @@ -170,20 +172,34 @@ is appropriate to use. Specific methods are defined with `cl-defmethod'. With this implementation the ARGS are currently ignored. OPTIONS-AND-METHODS currently understands: - (:documentation DOCSTRING) -- (declare DECLARATIONS)" +- (declare DECLARATIONS) +- (:argument-precedence-order &rest ARGS) +- (:method [QUALIFIERS...] ARGS &rest BODY) +BODY, if present, is used as the body of a default method. + +\(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest BODY)" (declare (indent 2) (doc-string 3)) - (let* ((docprop (assq :documentation options-and-methods)) - (doc (cond ((stringp (car-safe options-and-methods)) - (pop options-and-methods)) - (docprop - (prog1 - (cadr docprop) - (setq options-and-methods - (delq docprop options-and-methods)))))) - (declarations (assq 'declare options-and-methods))) - (when declarations - (setq options-and-methods - (delq declarations options-and-methods))) + (let* ((doc (if (stringp (car-safe options-and-methods)) + (pop options-and-methods))) + (declarations nil) + (methods ()) + (options ()) + next-head) + (while (progn (setq next-head (car-safe (car options-and-methods))) + (or (keywordp next-head) + (eq next-head 'declare))) + (pcase next-head + (`:documentation + (when doc (error "Multiple doc strings for %S" name)) + (setq doc (cadr (pop options-and-methods)))) + (`declare + (when declarations (error "Multiple `declare' for %S" name)) + (setq declarations (pop options-and-methods))) + (`:method (push (cdr (pop options-and-methods)) methods)) + (_ (push (pop options-and-methods) options)))) + (when options-and-methods + ;; Anything remaining is assumed to be a default method body. + (push `(,args ,@options-and-methods) methods)) `(progn ,(when (eq 'setf (car-safe name)) (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite @@ -200,8 +216,10 @@ OPTIONS-AND-METHODS currently understands: nil)))) (cdr declarations)) (defalias ',name - (cl-generic-define ',name ',args ',options-and-methods) - ,(help-add-fundoc-usage doc args))))) + (cl-generic-define ',name ',args ',(nreverse options)) + ,(help-add-fundoc-usage doc args)) + ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method)) + (nreverse methods))))) (defun cl--generic-mandatory-args (args) (let ((res ())) @@ -210,10 +228,10 @@ OPTIONS-AND-METHODS currently understands: (nreverse res))) ;;;###autoload -(defun cl-generic-define (name args options-and-methods) +(defun cl-generic-define (name args options) (let ((generic (cl-generic-ensure-function name)) (mandatory (cl--generic-mandatory-args args)) - (apo (assq :argument-precedence-order options-and-methods))) + (apo (assq :argument-precedence-order options))) (setf (cl--generic-dispatches generic) nil) (when apo (dolist (arg (cdr apo)) @@ -222,6 +240,7 @@ OPTIONS-AND-METHODS currently understands: (push (list (- (length mandatory) (length pos))) (cl--generic-dispatches generic))))) (setf (cl--generic-method-table generic) nil) + (setf (cl--generic-options generic) options) (cl--generic-make-function generic))) (defmacro cl-generic-current-method-specializers () @@ -341,7 +360,7 @@ which case this method will be invoked when the argument is `eql' to VAL. ;; But in practice, it's common to use `cl-defmethod' ;; without a previous `cl-defgeneric'. (declare-function ,name "") - (cl-generic-define-method ',name ',qualifiers ',args + (cl-generic-define-method ',name ',(nreverse qualifiers) ',args ,uses-cnm ,fun))))) (defun cl--generic-member-method (specializers qualifiers methods) @@ -359,28 +378,33 @@ which case this method will be invoked when the argument is `eql' to VAL. (mandatory (cl--generic-mandatory-args args)) (specializers (mapcar (lambda (arg) (if (consp arg) (cadr arg) t)) mandatory)) - (method (cl--generic-method-make + (method (cl--generic-make-method specializers qualifiers uses-cnm function)) (mt (cl--generic-method-table generic)) (me (cl--generic-member-method specializers qualifiers mt)) (dispatches (cl--generic-dispatches generic)) (i 0)) (dolist (specializer specializers) - (let* ((tagcode (funcall cl-generic-tagcode-function specializer 'arg)) + (let* ((generalizers (cl-generic-generalizers specializer)) (x (assq i dispatches))) (unless x - (setq x (list i (funcall cl-generic-tagcode-function t 'arg))) + (setq x (cons i (cl-generic-generalizers t))) (setf (cl--generic-dispatches generic) (setq dispatches (cons x dispatches)))) - (unless (member tagcode (cdr x)) - (setf (cdr x) - (nreverse (sort (cons tagcode (cdr x)) - #'car-less-than-car)))) + (dolist (generalizer generalizers) + (unless (member generalizer (cdr x)) + (setf (cdr x) + (sort (cons generalizer (cdr x)) + (lambda (x y) + (> (cl--generic-generalizer-priority x) + (cl--generic-generalizer-priority y))))))) (setq i (1+ i)))) (if me (setcar me method) (setf (cl--generic-method-table generic) (cons method mt))) (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers)) current-load-list :test #'equal) + ;; FIXME: Try to avoid re-constructing a new function if the old one + ;; is still valid (e.g. still empty method cache)? (let ((gfun (cl--generic-make-function generic)) ;; Prevent `defalias' from recording this as the definition site of ;; the generic function. @@ -399,62 +423,73 @@ which case this method will be invoked when the argument is `eql' to VAL. (defvar cl--generic-dispatchers (make-hash-table :test #'equal)) -(defun cl--generic-get-dispatcher (tagcodes dispatch-arg) +(defun cl--generic-get-dispatcher (dispatch) (cl--generic-with-memoization - (gethash (cons dispatch-arg tagcodes) cl--generic-dispatchers) - (let ((lexical-binding t) - (tag-exp `(or ,@(mapcar #'cdr - ;; Minor optimization: since this tag-exp is - ;; only used to lookup the method-cache, it - ;; doesn't matter if the default value is some - ;; constant or nil. - (if (macroexp-const-p (car (last tagcodes))) - (butlast tagcodes) - tagcodes)))) - (extraargs ())) + (gethash dispatch cl--generic-dispatchers) + (let* ((dispatch-arg (car dispatch)) + (generalizers (cdr dispatch)) + (lexical-binding t) + (tagcodes + (mapcar (lambda (generalizer) + (funcall (cl--generic-generalizer-tagcode-function + generalizer) + 'arg)) + generalizers)) + (typescodes + (mapcar (lambda (generalizer) + `(funcall ',(cl--generic-generalizer-specializers-function + generalizer) + ,(funcall (cl--generic-generalizer-tagcode-function + generalizer) + 'arg))) + generalizers)) + (tag-exp + ;; Minor optimization: since this tag-exp is + ;; only used to lookup the method-cache, it + ;; doesn't matter if the default value is some + ;; constant or nil. + `(or ,@(if (macroexp-const-p (car (last tagcodes))) + (butlast tagcodes) + tagcodes))) + (extraargs ())) (dotimes (_ dispatch-arg) (push (make-symbol "arg") extraargs)) + ;; FIXME: For generic functions with a single method (or with 2 methods, + ;; one of which always matches), using a tagcode + hash-table is + ;; overkill: better just use a `cl-typep' test. (byte-compile - `(lambda (generic dispatches-left) + `(lambda (generic dispatches-left methods) (let ((method-cache (make-hash-table :test #'eql))) (lambda (,@extraargs arg &rest args) (apply (cl--generic-with-memoization (gethash ,tag-exp method-cache) (cl--generic-cache-miss - generic ',dispatch-arg dispatches-left - (list ,@(mapcar #'cdr tagcodes)))) + generic ',dispatch-arg dispatches-left methods + ,(if (cdr typescodes) + `(append ,@typescodes) (car typescodes)))) ,@extraargs arg args)))))))) (defun cl--generic-make-function (generic) - (let* ((dispatches (cl--generic-dispatches generic)) - (dispatch + (cl--generic-make-next-function generic + (cl--generic-dispatches generic) + (cl--generic-method-table generic))) + +(defun cl--generic-make-next-function (generic dispatches methods) + (let* ((dispatch (progn (while (and dispatches - (member (cdar dispatches) - '(nil ((0 . 'cl--generic-type))))) + (let ((x (nth 1 (car dispatches)))) + ;; No need to dispatch for `t' specializers. + (or (null x) (equal x cl--generic-t-generalizer)))) (setq dispatches (cdr dispatches))) (pop dispatches)))) - (if (null dispatch) - (cl--generic-build-combined-method - (cl--generic-name generic) - (cl--generic-method-table generic)) - (let ((dispatcher (cl--generic-get-dispatcher - (cdr dispatch) (car dispatch)))) - (funcall dispatcher generic dispatches))))) - -(defvar cl-generic-method-combination-function - #'cl--generic-standard-method-combination - "Function to build the effective method. -Called with 2 arguments: NAME and METHOD-ALIST. -It should return an effective method, i.e. a function that expects the same -arguments as the methods, and calls those methods in some appropriate order. -NAME is the name (a symbol) of the corresponding generic function. -METHOD-ALIST is a list of elements (QUALIFIERS . METHODS) where -QUALIFIERS is a list of qualifiers, and METHODS is a list of the selected -methods for that qualifier list. -The METHODS lists are sorted from most generic first to most specific last. -The function can use `cl-generic-call-method' to create functions that call those -methods.") + (if (not (and dispatch + ;; If there's no method left, there's no point checking + ;; further arguments. + methods)) + (cl--generic-build-combined-method generic methods) + (let ((dispatcher (cl--generic-get-dispatcher dispatch))) + (funcall dispatcher generic dispatches methods))))) (defvar cl--generic-combined-method-memoization (make-hash-table :test #'equal :weakness 'value) @@ -463,27 +498,37 @@ This is particularly useful when many different tags select the same set of methods, since this table then allows us to share a single combined-method for all those different tags in the method-cache.") -(defun cl--generic-build-combined-method (generic-name methods) - (cl--generic-with-memoization - (gethash (cons generic-name methods) - cl--generic-combined-method-memoization) - (let ((mets-by-qual ())) - (dolist (method methods) - (let* ((qualifiers (cl--generic-method-qualifiers method)) - (x (assoc qualifiers mets-by-qual))) - ;; FIXME: sadly, alist-get only uses `assq' and we need `assoc'. - ;;(push (cdr qm) (alist-get qualifiers mets-by-qual))) - (if x - (push method (cdr x)) - (push (list qualifiers method) mets-by-qual)))) - (funcall cl-generic-method-combination-function - generic-name mets-by-qual)))) +(define-error 'cl--generic-cyclic-definition "Cyclic definition: %S") + +(defun cl--generic-build-combined-method (generic methods) + (if (null methods) + ;; Special case needed to fix a circularity during bootstrap. + (cl--generic-standard-method-combination generic methods) + (let ((f + (cl--generic-with-memoization + ;; FIXME: Since the fields of `generic' are modified, this + ;; hash-table won't work right, because the hashes will change! + ;; It's not terribly serious, but reduces the effectiveness of + ;; the table. + (gethash (cons generic methods) + cl--generic-combined-method-memoization) + (puthash (cons generic methods) :cl--generic--under-construction + cl--generic-combined-method-memoization) + (condition-case nil + (cl-generic-combine-methods generic methods) + ;; Special case needed to fix a circularity during bootstrap. + (cl--generic-cyclic-definition + (cl--generic-standard-method-combination generic methods)))))) + (if (eq f :cl--generic--under-construction) + (signal 'cl--generic-cyclic-definition + (list (cl--generic-name generic))) + f)))) (defun cl--generic-no-next-method-function (generic method) (lambda (&rest args) (apply #'cl-no-next-method generic method args))) -(defun cl-generic-call-method (generic-name method &optional fun) +(defun cl-generic-call-method (generic method &optional fun) "Return a function that calls METHOD. FUN is the function that should be called when METHOD calls `call-next-method'." @@ -491,7 +536,7 @@ FUN is the function that should be called when METHOD calls (cl--generic-method-function method) (let ((met-fun (cl--generic-method-function method)) (next (or fun (cl--generic-no-next-method-function - generic-name method)))) + generic method)))) (lambda (&rest args) (apply met-fun ;; FIXME: This sucks: passing just `next' would @@ -503,42 +548,122 @@ FUN is the function that should be called when METHOD calls (apply next (or cnm-args args))) args))))) -(defun cl--generic-standard-method-combination (generic-name mets-by-qual) - (dolist (x mets-by-qual) - (unless (member (car x) '(() (:after) (:before) (:around))) - (error "Unsupported qualifiers in function %S: %S" generic-name (car x)))) - (cond - ((null mets-by-qual) - (lambda (&rest args) - (apply #'cl-no-applicable-method generic-name args))) - ((null (alist-get nil mets-by-qual)) - (lambda (&rest args) - (apply #'cl-no-primary-method generic-name args))) - (t - (let* ((fun nil) - (ab-call (lambda (m) (cl-generic-call-method generic-name m))) - (before - (mapcar ab-call (reverse (cdr (assoc '(:before) mets-by-qual))))) - (after (mapcar ab-call (cdr (assoc '(:after) mets-by-qual))))) - (dolist (method (cdr (assoc nil mets-by-qual))) - (setq fun (cl-generic-call-method generic-name method fun))) - (when (or after before) - (let ((next fun)) - (setq fun (lambda (&rest args) - (dolist (bf before) - (apply bf args)) - (prog1 - (apply next args) - (dolist (af after) - (apply af args))))))) - (dolist (method (cdr (assoc '(:around) mets-by-qual))) - (setq fun (cl-generic-call-method generic-name method fun))) - fun)))) +;; Standard CLOS name. +(defalias 'cl-method-qualifiers #'cl--generic-method-qualifiers) + +(defun cl--generic-standard-method-combination (generic methods) + (let ((mets-by-qual ())) + (dolist (method methods) + (let ((qualifiers (cl-method-qualifiers method))) + (if (eq (car qualifiers) :extra) (setq qualifiers (cddr qualifiers))) + (unless (member qualifiers '(() (:after) (:before) (:around))) + (error "Unsupported qualifiers in function %S: %S" + (cl--generic-name generic) qualifiers)) + (push method (alist-get (car qualifiers) mets-by-qual)))) + (cond + ((null mets-by-qual) + (lambda (&rest args) + (apply #'cl-no-applicable-method generic args))) + ((null (alist-get nil mets-by-qual)) + (lambda (&rest args) + (apply #'cl-no-primary-method generic args))) + (t + (let* ((fun nil) + (ab-call (lambda (m) (cl-generic-call-method generic m))) + (before + (mapcar ab-call (reverse (cdr (assoc :before mets-by-qual))))) + (after (mapcar ab-call (cdr (assoc :after mets-by-qual))))) + (dolist (method (cdr (assoc nil mets-by-qual))) + (setq fun (cl-generic-call-method generic method fun))) + (when (or after before) + (let ((next fun)) + (setq fun (lambda (&rest args) + (dolist (bf before) + (apply bf args)) + (prog1 + (apply next args) + (dolist (af after) + (apply af args))))))) + (dolist (method (cdr (assoc :around mets-by-qual))) + (setq fun (cl-generic-call-method generic method fun))) + fun))))) + +(defun cl--generic-cache-miss (generic + dispatch-arg dispatches-left methods-left types) + (let ((methods '())) + (dolist (method methods-left) + (let* ((specializer (or (nth dispatch-arg + (cl--generic-method-specializers method)) + t)) + (m (member specializer types))) + (when m + (push (cons (length m) method) methods)))) + ;; Sort the methods, most specific first. + ;; It would be tempting to sort them once and for all in the method-table + ;; rather than here, but the order might depend on the actual argument + ;; (e.g. for multiple inheritance with defclass). + (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car)))) + (cl--generic-make-next-function generic dispatches-left methods))) + +(cl-defgeneric cl-generic-generalizers (specializer) + "Return a list of generalizers for a given SPECIALIZER. +To each kind of `specializer', corresponds a `generalizer' which describes +how to extract a \"tag\" from an object which will then let us check if this +object matches the specializer. A typical example of a \"tag\" would be the +type of an object. It's called a `generalizer' because it +takes a specific object and returns a more general approximation, +denoting a set of objects to which it belongs. +A generalizer gives us the chunk of code which the +dispatch function needs to use to extract the \"tag\" of an object, as well +as a function which turns this tag into an ordered list of +`specializers' that this object matches. +The code which extracts the tag should be as fast as possible. +The tags should be chosen according to the following rules: +- The tags should not be too specific: similar objects which match the + same list of specializers should ideally use the same (`eql') tag. + This insures that the cached computation of the applicable + methods for one object can be reused for other objects. +- Corollary: objects which don't match any of the relevant specializers + should ideally all use the same tag (typically nil). + This insures that this cache does not grow unnecessarily large. +- Two different generalizers G1 and G2 should not use the same tag + unless they use it for the same set of objects. IOW, if G1.tag(X1) = + G2.tag(X2) then G1.tag(X1) = G2.tag(X1) = G1.tag(X2) = G2.tag(X2). +- If G1.priority > G2.priority and G1.tag(X1) = G1.tag(X2) and this tag is + non-nil, then you have to make sure that the G2.tag(X1) = G2.tag(X2). + This is because the method-cache is only indexed with the first non-nil + tag (by order of decreasing priority).") + + +(cl-defgeneric cl-generic-combine-methods (generic methods) + "Build the effective method made of METHODS. +It should return a function that expects the same arguments as the methods, and + calls those methods in some appropriate order. +GENERIC is the generic function (mostly used for its name). +METHODS is the list of the selected methods. +The METHODS list is sorted from most specific first to most generic last. +The function can use `cl-generic-call-method' to create functions that call those +methods.") + +;; Temporary definition to let the next defmethod succeed. +(fset 'cl-generic-generalizers + (lambda (_specializer) (list cl--generic-t-generalizer))) +(fset 'cl-generic-combine-methods + #'cl--generic-standard-method-combination) + +(cl-defmethod cl-generic-generalizers (specializer) + "Support for the catch-all `t' specializer." + (if (eq specializer t) (list cl--generic-t-generalizer) + (error "Unknown specializer %S" specializer))) + +(cl-defmethod cl-generic-combine-methods (generic methods) + "Standard support for :after, :before, :around, and `:extra NAME' qualifiers." + (cl--generic-standard-method-combination generic methods)) (defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t)) (defconst cl--generic-cnm-sample (funcall (cl--generic-build-combined-method - nil (list (cl--generic-method-make () () t #'identity))))) + nil (list (cl--generic-make-method () () t #'identity))))) (defun cl--generic-isnot-nnm-p (cnm) "Return non-nil if CNM is the function that calls `cl-no-next-method'." @@ -566,24 +691,6 @@ FUN is the function that should be called when METHOD calls (setq cnm-env (cdr cnm-env))))) (error "Haven't found no-next-method-sample in cnm-sample"))) -(defun cl--generic-cache-miss (generic dispatch-arg dispatches-left tags) - (let ((types (apply #'append (mapcar cl-generic-tag-types-function tags))) - (methods '())) - (dolist (method (cl--generic-method-table generic)) - (let* ((specializer (or (nth dispatch-arg - (cl--generic-method-specializers method)) - t)) - (m (member specializer types))) - (when m - (push (cons (length m) method) methods)))) - ;; Sort the methods, most specific first. - ;; It would be tempting to sort them once and for all in the method-table - ;; rather than here, but the order might depend on the actual argument - ;; (e.g. for multiple inheritance with defclass). - (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car)))) - (cl--generic-make-function (cl--generic-make (cl--generic-name generic) - dispatches-left methods)))) - ;;; Define some pre-defined generic functions, used internally. (define-error 'cl-no-method "No method for %S") @@ -593,19 +700,16 @@ FUN is the function that should be called when METHOD calls 'cl-no-method) (cl-defgeneric cl-no-next-method (generic method &rest args) - "Function called when `cl-call-next-method' finds no next method.") -(cl-defmethod cl-no-next-method (generic method &rest args) - (signal 'cl-no-next-method `(,generic ,method ,@args))) + "Function called when `cl-call-next-method' finds no next method." + (signal 'cl-no-next-method `(,(cl--generic-name generic) ,method ,@args))) (cl-defgeneric cl-no-applicable-method (generic &rest args) - "Function called when a method call finds no applicable method.") -(cl-defmethod cl-no-applicable-method (generic &rest args) - (signal 'cl-no-applicable-method `(,generic ,@args))) + "Function called when a method call finds no applicable method." + (signal 'cl-no-applicable-method `(,(cl--generic-name generic) ,@args))) (cl-defgeneric cl-no-primary-method (generic &rest args) - "Function called when a method call finds no primary method.") -(cl-defmethod cl-no-primary-method (generic &rest args) - (signal 'cl-no-primary-method `(,generic ,@args))) + "Function called when a method call finds no primary method." + (signal 'cl-no-primary-method `(,(cl--generic-name generic) ,@args))) (defun cl-call-next-method (&rest _args) "Function to call the next applicable method. @@ -700,27 +804,57 @@ Can only be used from within the lexical body of a primary or around method." (insert "'.\n"))) (insert "\n" (or (nth 2 info) "Undocumented") "\n\n"))))))) +;;; Support for (head ) specializers. + +;; For both the `eql' and the `head' specializers, the dispatch +;; is unsatisfactory. Basically, in the "common&fast case", we end up doing +;; +;; (let ((tag (gethash value ))) +;; (funcall (gethash tag ))) +;; +;; whereas we'd like to just do +;; +;; (funcall (gethash value ))) +;; +;; but the problem is that the method-cache is normally "open ended", so +;; a nil means "not computed yet" and if we bump into it, we dutifully fill the +;; corresponding entry, whereas we'd want to just fallback on some default +;; effective method (so as not to fill the cache with lots of redundant +;; entries). + +(defvar cl--generic-head-used (make-hash-table :test #'eql)) + +(defconst cl--generic-head-generalizer + (cl-generic-make-generalizer + 80 (lambda (name) `(gethash (car-safe ,name) cl--generic-head-used)) + (lambda (tag) (if (eq (car-safe tag) 'head) (list tag))))) + +(cl-defmethod cl-generic-generalizers :extra "head" (specializer) + "Support for the `(head VAL)' specializers." + ;; We have to implement `head' here using the :extra qualifier, + ;; since we can't use the `head' specializer to implement itself. + (if (not (eq (car-safe specializer) 'head)) + (cl-call-next-method) + (cl--generic-with-memoization + (gethash (cadr specializer) cl--generic-head-used) specializer) + (list cl--generic-head-generalizer))) + ;;; Support for (eql ) specializers. (defvar cl--generic-eql-used (make-hash-table :test #'eql)) -(add-function :before-until cl-generic-tagcode-function - #'cl--generic-eql-tagcode) -(defun cl--generic-eql-tagcode (type name) - (when (eq (car-safe type) 'eql) - (puthash (cadr type) type cl--generic-eql-used) - `(100 . (gethash ,name cl--generic-eql-used)))) +(defconst cl--generic-eql-generalizer + (cl-generic-make-generalizer + 100 (lambda (name) `(gethash ,name cl--generic-eql-used)) + (lambda (tag) (if (eq (car-safe tag) 'eql) (list tag))))) -(add-function :before-until cl-generic-tag-types-function - #'cl--generic-eql-tag-types) -(defun cl--generic-eql-tag-types (tag) - (if (eq (car-safe tag) 'eql) (list tag))) +(cl-defmethod cl-generic-generalizers ((specializer (head eql))) + "Support for the `(eql VAL)' specializers." + (puthash (cadr specializer) specializer cl--generic-eql-used) + (list cl--generic-eql-generalizer)) ;;; Support for cl-defstructs specializers. -(add-function :before-until cl-generic-tagcode-function - #'cl--generic-struct-tagcode) - (defun cl--generic-struct-tag (name) `(and (vectorp ,name) (> (length ,name) 0) @@ -728,41 +862,46 @@ Can only be used from within the lexical body of a primary or around method." (if (eq (symbol-function tag) :quick-object-witness-check) tag)))) -(defun cl--generic-struct-tagcode (type name) - (and (symbolp type) - (get type 'cl-struct-type) - (or (null (car (get type 'cl-struct-type))) - (error "Can't dispatch on cl-struct %S: type is %S" - type (car (get type 'cl-struct-type)))) - (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots))) - (error "Can't dispatch on cl-struct %S: no tag in slot 0" - type)) - ;; It's tempting to use (and (vectorp ,name) (aref ,name 0)) - ;; but that would suffer from some problems: - ;; - the vector may have size 0. - ;; - when called on an actual vector (rather than an object), we'd - ;; end up returning an arbitrary value, possibly colliding with - ;; other tagcode's values. - ;; - it can also result in returning all kinds of irrelevant - ;; values which would end up filling up the method-cache with - ;; lots of irrelevant/redundant entries. - ;; FIXME: We could speed this up by introducing a dedicated - ;; vector type at the C level, so we could do something like - ;; (and (vector-objectp ,name) (aref ,name 0)) - `(50 . ,(cl--generic-struct-tag name)))) - -(add-function :before-until cl-generic-tag-types-function - #'cl--generic-struct-tag-types) -(defun cl--generic-struct-tag-types (tag) - ;; FIXME: cl-defstruct doesn't make it easy for us. +(defun cl--generic-struct-specializers (tag) (and (symbolp tag) ;; A method call shouldn't itself mess with the match-data. (string-match-p "\\`cl-struct-\\(.*\\)" (symbol-name tag)) (let ((types (list (intern (substring (symbol-name tag) 10))))) - (while (get (car types) 'cl-struct-include) - (push (get (car types) 'cl-struct-include) types)) - (push 'cl-structure-object types) ;The "parent type" of all cl-structs. - (nreverse types)))) + (while (get (car types) 'cl-struct-include) + (push (get (car types) 'cl-struct-include) types)) + (push 'cl-structure-object types) ;The "parent type" of all cl-structs. + (nreverse types)))) + +(defconst cl--generic-struct-generalizer + (cl-generic-make-generalizer + 50 #'cl--generic-struct-tag + #'cl--generic-struct-specializers)) + +(cl-defmethod cl-generic-generalizers :extra "cl-struct" (type) + "Support for dispatch on cl-struct types." + (or + (and (symbolp type) + (get type 'cl-struct-type) + (or (null (car (get type 'cl-struct-type))) + (error "Can't dispatch on cl-struct %S: type is %S" + type (car (get type 'cl-struct-type)))) + (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots))) + (error "Can't dispatch on cl-struct %S: no tag in slot 0" + type)) + ;; It's tempting to use (and (vectorp ,name) (aref ,name 0)) + ;; but that would suffer from some problems: + ;; - the vector may have size 0. + ;; - when called on an actual vector (rather than an object), we'd + ;; end up returning an arbitrary value, possibly colliding with + ;; other tagcode's values. + ;; - it can also result in returning all kinds of irrelevant + ;; values which would end up filling up the method-cache with + ;; lots of irrelevant/redundant entries. + ;; FIXME: We could speed this up by introducing a dedicated + ;; vector type at the C level, so we could do something like + ;; (and (vector-objectp ,name) (aref ,name 0)) + (list cl--generic-struct-generalizer)) + (cl-call-next-method))) ;;; Dispatch on "system types". @@ -784,23 +923,23 @@ Can only be used from within the lexical body of a primary or around method." (sequence) (number))) -(add-function :before-until cl-generic-tagcode-function - #'cl--generic-typeof-tagcode) -(defun cl--generic-typeof-tagcode (type name) +(defconst cl--generic-typeof-generalizer + (cl-generic-make-generalizer + ;; FIXME: We could also change `type-of' to return `null' for nil. + 10 (lambda (name) `(if ,name (type-of ,name) 'null)) + (lambda (tag) (and (symbolp tag) (assq tag cl--generic-typeof-types))))) + +(cl-defmethod cl-generic-generalizers :extra "typeof" (type) + "Support for dispatch on builtin types." ;; FIXME: Add support for other types accepted by `cl-typep' such ;; as `character', `atom', `face', `function', ... - (and (assq type cl--generic-typeof-types) - (progn - (if (memq type '(vector array sequence)) - (message "`%S' also matches CL structs and EIEIO classes" type)) - ;; FIXME: We could also change `type-of' to return `null' for nil. - `(10 . (if ,name (type-of ,name) 'null))))) - -(add-function :before-until cl-generic-tag-types-function - #'cl--generic-typeof-types) -(defun cl--generic-typeof-types (tag) - (and (symbolp tag) - (assq tag cl--generic-typeof-types))) + (or + (and (assq type cl--generic-typeof-types) + (progn + (if (memq type '(vector array sequence)) + (message "`%S' also matches CL structs and EIEIO classes" type)) + (list cl--generic-typeof-generalizer))) + (cl-call-next-method))) ;;; Just for kicks: dispatch on major-mode ;; @@ -814,7 +953,7 @@ Can only be used from within the lexical body of a primary or around method." ;; (defvar cl--generic-major-modes (make-hash-table :test #'eq)) ;; -;; (add-function :before-until cl-generic-tagcode-function +;; (add-function :before-until cl-generic-generalizer-function ;; #'cl--generic-major-mode-tagcode) ;; (defun cl--generic-major-mode-tagcode (type name) ;; (if (eq 'major-mode (car-safe type)) diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index 7468c040e10..ee8e731b043 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el @@ -124,30 +124,38 @@ Summary: (defgeneric ,method ,args) (eieio--defmethod ',method ',key ',class #',code)))) -(add-function :before-until cl-generic-tagcode-function - #'eieio--generic-static-tagcode) -(defun eieio--generic-static-tagcode (type name) - (and (eq 'eieio--static (car-safe type)) - `(40 . (cond - ((symbolp ,name) (eieio--class-v ,name)) - ((vectorp ,name) (aref ,name 0)))))) - -(add-function :around cl-generic-tag-types-function - #'eieio--generic-static-tag-types) -(defun eieio--generic-static-tag-types (orig-fun tag) - (cond - ((or (eieio--class-p tag) - (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag)))) - (let ((superclasses (funcall orig-fun tag)) - (types ())) - ;; Interleave: (subclass ) (eieio--static ) ) .. - (dolist (superclass superclasses) - (push superclass types) - (push `(eieio--static - ,(if (consp superclass) (cadr superclass) superclass)) - types)) - (nreverse types))) - (t (funcall orig-fun tag)))) +(defconst eieio--generic-static-symbol-generalizer + (cl-generic-make-generalizer + ;; Give it a slightly higher priority than `subclass' so that the + ;; interleaved list comes before subclass's non-interleaved list. + 61 (lambda (name) `(and (symbolp ,name) (eieio--class-v ,name))) + (lambda (tag) + (when (eieio--class-p tag) + (let ((superclasses (eieio--generic-subclass-specializers tag)) + (specializers ())) + (dolist (superclass superclasses) + (push superclass specializers) + (push `(eieio--static ,(cadr superclass)) specializers)) + (nreverse specializers)))))) +(defconst eieio--generic-static-object-generalizer + (cl-generic-make-generalizer + ;; Give it a slightly higher priority than `class' so that the + ;; interleaved list comes before the class's non-interleaved list. + 51 #'cl--generic-struct-tag + (lambda (tag) + (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag)) + (eieio--class-p tag) + (let ((superclasses (eieio--class-precedence-list tag)) + (specializers ())) + (dolist (superclass superclasses) + (setq superclass (eieio--class-symbol superclass)) + (push superclass specializers) + (push `(eieio--static ,superclass) specializers)) + (nreverse specializers)))))) + +(cl-defmethod cl-generic-generalizers ((_specializer (head eieio--static))) + (list eieio--generic-static-symbol-generalizer + eieio--generic-static-object-generalizer)) ;;;###autoload (defun eieio--defgeneric-init-form (method doc-string) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 408922a2daa..1e226c154e2 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -1203,25 +1203,26 @@ method invocation orders of the involved classes." ;;;; General support to dispatch based on the type of the argument. -(add-function :before-until cl-generic-tagcode-function - #'eieio--generic-tagcode) -(defun eieio--generic-tagcode (type name) +(defconst eieio--generic-generalizer + (cl-generic-make-generalizer + ;; Use the exact same tagcode as for cl-struct, so that methods + ;; that dispatch on both kinds of objects get to share this + ;; part of the dispatch code. + 50 #'cl--generic-struct-tag + (lambda (tag) + (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag)) + (mapcar #'eieio--class-symbol + (eieio--class-precedence-list (symbol-value tag))))))) + +(cl-defmethod cl-generic-generalizers :extra "class" (specializer) ;; CLHS says: ;; A class must be defined before it can be used as a parameter ;; specializer in a defmethod form. ;; So we can ignore types that are not known to denote classes. - (and (eieio--class-p (eieio--class-object type)) - ;; Use the exact same code as for cl-struct, so that methods - ;; that dispatch on both kinds of objects get to share this - ;; part of the dispatch code. - `(50 . ,(cl--generic-struct-tag name)))) - -(add-function :before-until cl-generic-tag-types-function - #'eieio--generic-tag-types) -(defun eieio--generic-tag-types (tag) - (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag)) - (mapcar #'eieio--class-symbol - (eieio--class-precedence-list (symbol-value tag))))) + (or + (and (eieio--class-p (eieio--class-object specializer)) + (list eieio--generic-generalizer)) + (cl-call-next-method))) ;;;; Dispatch for arguments which are classes. @@ -1231,23 +1232,22 @@ method invocation orders of the involved classes." ;; would not make much sense (e.g. to which argument should it apply?). ;; Instead, we add a new "subclass" specializer. -(add-function :before-until cl-generic-tagcode-function - #'eieio--generic-subclass-tagcode) -(defun eieio--generic-subclass-tagcode (type name) - (when (eq 'subclass (car-safe type)) - `(60 . (and (symbolp ,name) (eieio--class-v ,name))))) - -(add-function :before-until cl-generic-tag-types-function - #'eieio--generic-subclass-tag-types) -(defun eieio--generic-subclass-tag-types (tag) +(defun eieio--generic-subclass-specializers (tag) (when (eieio--class-p tag) (mapcar (lambda (class) - `(subclass - ,(if (symbolp class) class (eieio--class-symbol class)))) + `(subclass ,(eieio--class-symbol class))) (eieio--class-precedence-list tag)))) +(defconst eieio--generic-subclass-generalizer + (cl-generic-make-generalizer + 60 (lambda (name) `(and (symbolp ,name) (eieio--class-v ,name))) + #'eieio--generic-subclass-specializers)) + +(cl-defmethod cl-generic-generalizers ((_specializer (head subclass))) + (list eieio--generic-subclass-generalizer)) + -;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "5b04c9a8fff2bd3f3d3ac54aba0f65b7") +;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "25a66814a400e7dea16bf0f3bfe245ed") ;;; Generated autoloads from eieio-compat.el (autoload 'eieio--defalias "eieio-compat" "\ -- cgit v1.2.3 From 17ecfea3b904c4676a52dd9d2ea33c8c3e13b870 Mon Sep 17 00:00:00 2001 From: Artur Malabarba Date: Thu, 5 Mar 2015 13:25:53 +0000 Subject: package.el (package-refresh-contents): Update doc. --- lisp/ChangeLog | 4 ++++ lisp/emacs-lisp/package.el | 7 ++++--- 2 files changed, 8 insertions(+), 3 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 3486c3806fd..1f54617b4d4 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2015-03-05 Artur Malabarba + + * emacs-lisp/package.el (package-refresh-contents): Update doc. + 2015-03-05 Dmitry Gutov * progmodes/js.el (js-mode-syntax-table): Add an entry for `. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 885fb00ce75..00608f3d2c7 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1695,9 +1695,10 @@ similar to an entry in `package-alist'. Save the cached copy to ;;;###autoload (defun package-refresh-contents () - "Download the ELPA archive description if needed. -This informs Emacs about the latest versions of all packages, and -makes them available for download." + "Download the description of all configured ELPAs. +For each archive configured in the variable `package-archives', +this informs Emacs about the latest versions of all packages it +offers, and makes them available for download." (interactive) ;; FIXME: Do it asynchronously. (unless (file-exists-p package-user-dir) -- cgit v1.2.3 From 25058c3ab82cff0105c31de0c1934da6602c6bee Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 6 Mar 2015 23:35:04 -0500 Subject: * lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Don't try to unfold `closure's since byte-compile-unfold-lambda doesn't know how to do it. --- lisp/ChangeLog | 6 +++ lisp/emacs-lisp/byte-opt.el | 121 ++++++++++++++++++++++---------------------- 2 files changed, 67 insertions(+), 60 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index c81ab9b6d22..1bd45c07c3e 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2015-03-07 Stefan Monnier + + * emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Don't try to + unfold `closure's since byte-compile-unfold-lambda doesn't know how to + do it. + 2015-03-06 Oscar Fuentes * net/browse-url.el (browse-url-firefox): Removed outdated diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index e149f80db8e..06a11063025 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -302,65 +302,65 @@ ;; doesn't matter here, because function's behavior is underspecified so it ;; can safely be turned into a `let', even though the reverse is not true. (or name (setq name "anonymous lambda")) - (let ((lambda (car form)) - (values (cdr form))) - (let ((arglist (nth 1 lambda)) - (body (cdr (cdr lambda))) - optionalp restp - bindings) - (if (and (stringp (car body)) (cdr body)) - (setq body (cdr body))) - (if (and (consp (car body)) (eq 'interactive (car (car body)))) - (setq body (cdr body))) - ;; FIXME: The checks below do not belong in an optimization phase. - (while arglist - (cond ((eq (car arglist) '&optional) - ;; ok, I'll let this slide because funcall_lambda() does... - ;; (if optionalp (error "multiple &optional keywords in %s" name)) - (if restp (error "&optional found after &rest in %s" name)) - (if (null (cdr arglist)) - (error "nothing after &optional in %s" name)) - (setq optionalp t)) - ((eq (car arglist) '&rest) - ;; ...but it is by no stretch of the imagination a reasonable - ;; thing that funcall_lambda() allows (&rest x y) and - ;; (&rest x &optional y) in arglists. - (if (null (cdr arglist)) - (error "nothing after &rest in %s" name)) - (if (cdr (cdr arglist)) - (error "multiple vars after &rest in %s" name)) - (setq restp t)) - (restp - (setq bindings (cons (list (car arglist) - (and values (cons 'list values))) - bindings) - values nil)) - ((and (not optionalp) (null values)) - (byte-compile-warn "attempt to open-code `%s' with too few arguments" name) - (setq arglist nil values 'too-few)) - (t - (setq bindings (cons (list (car arglist) (car values)) - bindings) - values (cdr values)))) - (setq arglist (cdr arglist))) - (if values - (progn - (or (eq values 'too-few) - (byte-compile-warn - "attempt to open-code `%s' with too many arguments" name)) - form) - - ;; The following leads to infinite recursion when loading a - ;; file containing `(defsubst f () (f))', and then trying to - ;; byte-compile that file. - ;(setq body (mapcar 'byte-optimize-form body))) - - (let ((newform - (if bindings - (cons 'let (cons (nreverse bindings) body)) - (cons 'progn body)))) - (byte-compile-log " %s\t==>\t%s" form newform) - newform))))) + (let* ((lambda (car form)) + (values (cdr form)) + (arglist (nth 1 lambda)) + (body (cdr (cdr lambda))) + optionalp restp + bindings) + (if (and (stringp (car body)) (cdr body)) + (setq body (cdr body))) + (if (and (consp (car body)) (eq 'interactive (car (car body)))) + (setq body (cdr body))) + ;; FIXME: The checks below do not belong in an optimization phase. + (while arglist + (cond ((eq (car arglist) '&optional) + ;; ok, I'll let this slide because funcall_lambda() does... + ;; (if optionalp (error "multiple &optional keywords in %s" name)) + (if restp (error "&optional found after &rest in %s" name)) + (if (null (cdr arglist)) + (error "nothing after &optional in %s" name)) + (setq optionalp t)) + ((eq (car arglist) '&rest) + ;; ...but it is by no stretch of the imagination a reasonable + ;; thing that funcall_lambda() allows (&rest x y) and + ;; (&rest x &optional y) in arglists. + (if (null (cdr arglist)) + (error "nothing after &rest in %s" name)) + (if (cdr (cdr arglist)) + (error "multiple vars after &rest in %s" name)) + (setq restp t)) + (restp + (setq bindings (cons (list (car arglist) + (and values (cons 'list values))) + bindings) + values nil)) + ((and (not optionalp) (null values)) + (byte-compile-warn "attempt to open-code `%s' with too few arguments" name) + (setq arglist nil values 'too-few)) + (t + (setq bindings (cons (list (car arglist) (car values)) + bindings) + values (cdr values)))) + (setq arglist (cdr arglist))) + (if values + (progn + (or (eq values 'too-few) + (byte-compile-warn + "attempt to open-code `%s' with too many arguments" name)) + form) + + ;; The following leads to infinite recursion when loading a + ;; file containing `(defsubst f () (f))', and then trying to + ;; byte-compile that file. + ;(setq body (mapcar 'byte-optimize-form body))) + + (let ((newform + (if bindings + (cons 'let (cons (nreverse bindings) body)) + (cons 'progn body)))) + (byte-compile-log " %s\t==>\t%s" form newform) + newform)))) ;;; implementing source-level optimizers @@ -390,12 +390,13 @@ (and (nth 1 form) (not for-effect) form)) - ((memq (car-safe fn) '(lambda closure)) + ((eq (car-safe fn) 'lambda) (let ((newform (byte-compile-unfold-lambda form))) (if (eq newform form) ;; Some error occurred, avoid infinite recursion form (byte-optimize-form-code-walker newform for-effect)))) + ((eq (car-safe fn) 'closure) form) ((memq fn '(let let*)) ;; recursively enter the optimizer for the bindings and body ;; of a let or let*. This for depth-firstness: forms that -- cgit v1.2.3 From b7ed48c3ce8e77acc08d4948684333bef3238d2d Mon Sep 17 00:00:00 2001 From: Nicolas Petton Date: Mon, 9 Mar 2015 12:46:29 +0100 Subject: Add seq-into as a public function * lisp/emacs-lisp/seq.el: Make seq-into a public function (replacing seq--into) * test/automated/seq-tests.el: Add tests for seq-into * doc/lispref/sequences.texi: Add documentation for seq-into --- doc/lispref/ChangeLog | 5 +++++ doc/lispref/sequences.texi | 22 ++++++++++++++++++++++ lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/seq.el | 12 +++++++----- test/ChangeLog | 4 ++++ test/automated/seq-tests.el | 22 ++++++++++++++++++++++ 6 files changed, 65 insertions(+), 5 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog index 42bff7c865a..260656c6cf7 100644 --- a/doc/lispref/ChangeLog +++ b/doc/lispref/ChangeLog @@ -1,3 +1,8 @@ +2015-03-09 Nicolas Petton + + * sequences.texi (seq-into): Add documentation for the new + seq-into function. + 2015-03-03 Eli Zaretskii * processes.texi (Synchronous Processes): Update documentation of diff --git a/doc/lispref/sequences.texi b/doc/lispref/sequences.texi index 04404f886e0..1af353590cf 100644 --- a/doc/lispref/sequences.texi +++ b/doc/lispref/sequences.texi @@ -740,6 +740,28 @@ of @var{sequence}. Keys are compared using @code{equal}. @end example @end defun +@defun seq-into sequence type + This function converts the sequence @var{sequence} into a sequence +of type @var{type}. @var{type} can be one of the following symbols: +@code{vector}, @code{string} or @code{list}. + +@example +@group +(seq-into [1 2 3] 'list) +@result{} (1 2 3) +@end group +@group +(seq-into nil 'vector) +@result{} [] +@end group +@group +(seq-into "hello" 'vector) +@result{} [104 101 108 108 111] +@end group +@end example +@end defun + + @defmac seq-doseq (var sequence [result]) body@dots{} @cindex sequence iteration This macro is like @code{dolist}, except that @var{sequence} can be a list, diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b284ef16eaf..d8330a46c89 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-03-09 Nicolas Petton + + * emacs-lisp/seq.el (seq-into): New function. + Bump seq.el version to 1.3. + 2015-03-09 Dmitry Gutov * progmodes/ruby-mode.el (ruby-font-lock-keywords): Don't consider diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index ad4c3536b44..59b91408d09 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -4,7 +4,8 @@ ;; Author: Nicolas Petton ;; Keywords: sequences -;; Version: 1.2 +;; Version: 1.3 +;; Package: seq ;; Maintainer: emacs-devel@gnu.org @@ -171,7 +172,7 @@ The result is a sequence of the same type as SEQ." (if (listp seq) (sort (seq-copy seq) pred) (let ((result (seq-sort pred (append seq nil)))) - (seq--into result (type-of seq))))) + (seq-into result (type-of seq))))) (defun seq-contains-p (seq elt &optional testfn) "Return the first element in SEQ that equals to ELT. @@ -265,10 +266,11 @@ See also the function `nreverse', which is used more often." seq) (if (listp seq) result - (seq--into result (type-of seq))))))) + (seq-into result (type-of seq))))))) -(defun seq--into (seq type) - "Convert the sequence SEQ into a sequence of type TYPE." +(defun seq-into (seq type) + "Convert the sequence SEQ into a sequence of type TYPE. +TYPE can be one of the following symbols: vector, string or list." (pcase type (`vector (vconcat seq)) (`string (concat seq)) diff --git a/test/ChangeLog b/test/ChangeLog index 301cc4046e5..876b9462611 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,7 @@ +2015-03-09 Nicolas Petton + + * automated/seq-tests.el (test-seq-into): Add a test for seq-into. + 2015-03-08 Dmitry Gutov * indent/ruby.rb: Add an example for bug#20026. diff --git a/test/automated/seq-tests.el b/test/automated/seq-tests.el index badb3267f43..d3536b6f9a6 100644 --- a/test/automated/seq-tests.el +++ b/test/automated/seq-tests.el @@ -228,5 +228,27 @@ Evaluate BODY for each created sequence. (should (equal (type-of (seq-reverse seq)) (type-of seq))))) +(ert-deftest test-seq-into () + (let* ((vector [1 2 3]) + (list (seq-into vector 'list))) + (should (same-contents-p vector list)) + (should (listp list))) + (let* ((list '(hello world)) + (vector (seq-into list 'vector))) + (should (same-contents-p vector list)) + (should (vectorp vector))) + (let* ((string "hello") + (list (seq-into string 'list))) + (should (same-contents-p string list)) + (should (stringp string))) + (let* ((string "hello") + (vector (seq-into string 'vector))) + (should (same-contents-p string vector)) + (should (stringp string))) + (let* ((list nil) + (vector (seq-into list 'vector))) + (should (same-contents-p list vector)) + (should (vectorp vector)))) + (provide 'seq-tests) ;;; seq-tests.el ends here -- cgit v1.2.3 From 33d9869b5f7a5acaca838e2b57e5ae713df9603d Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Tue, 10 Mar 2015 00:49:20 -0700 Subject: Spelling and minor grammar fixes --- lisp/ChangeLog | 4 ++-- lisp/emacs-lisp/package.el | 6 +++--- lisp/net/tramp-adb.el | 2 +- lisp/net/tramp-sh.el | 4 ++-- 4 files changed, 8 insertions(+), 8 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index df45ec49632..c25f4efcdd0 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -173,7 +173,7 @@ Use `with-temp-file'. * net/tramp-sh.el (tramp-perl-file-attributes) - (tramp-perl-directory-files-and-attributes): Escape apostrophs in + (tramp-perl-directory-files-and-attributes): Escape apostrophes in file names. (tramp-do-file-attributes-with-stat): Quote file name. (tramp-sh-handle-directory-files-and-attributes): Fall back to @@ -185,7 +185,7 @@ Normalize use of "cd". (tramp-do-directory-files-and-attributes-with-stat): Use the `quoting-style' arg of `ls' if possible. Make it also working for - file names with apostrophs. + file names with apostrophes. (tramp-sh-handle-file-name-all-completions): Use arguments of `ls' in proper order. (tramp-do-copy-or-rename-file-via-buffer) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 00608f3d2c7..0d001bff4cf 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1695,10 +1695,10 @@ similar to an entry in `package-alist'. Save the cached copy to ;;;###autoload (defun package-refresh-contents () - "Download the description of all configured ELPAs. + "Download descriptions of all configured ELPA packages. For each archive configured in the variable `package-archives', -this informs Emacs about the latest versions of all packages it -offers, and makes them available for download." +inform Emacs about the latest versions of all packages it offers, +and make them available for download." (interactive) ;; FIXME: Do it asynchronously. (unless (file-exists-p package-user-dir) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index fae54520102..6696dcf1505 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -1013,7 +1013,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (tramp-set-connection-property v "process-buffer" nil)))))) (defun tramp-adb-get-device (vec) - "Return full host name from VEC to be used in shell exceution. + "Return full host name from VEC to be used in shell execution. E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" a host name \"R38273882DE\" returns \"R38273882DE\"." ;; Sometimes this is called before there is a connection process diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 580c5d08ecd..76d2b014917 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1695,7 +1695,7 @@ be non-negative integers." ;; "-"; this would confuse xargs. "ls -aQ" might be a solution, ;; but it does not work on all remote systems. Therefore, we ;; use \000 as file separator. - ;; Apostrophs in the stat output are masked as \037 character, in + ;; Apostrophes in the stat output are masked as \037 characters, in ;; order to make a proper shell escape of them in file names. "cd %s && echo \"(\"; (%s %s -a | " "xargs %s -c " @@ -1703,7 +1703,7 @@ be non-negative integers." " -- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/\037/\"/g'); echo \")\"") (tramp-shell-quote-argument localname) (tramp-get-ls-command vec) - ;; On systems which have no quotings style, file names with + ;; On systems which have no quoting style, file names with ;; special characters could fail. (if (tramp-get-ls-command-with-quoting-style vec) "--quoting-style=shell" "") -- cgit v1.2.3 From 994168240aa3d81cb42cef2f049fec5739f9d850 Mon Sep 17 00:00:00 2001 From: Daniel Colascione Date: Sun, 15 Mar 2015 00:17:05 -0700 Subject: Support indenting backquote substitutions in cl-indent * lisp/emacs-lisp/cl-indent.el (lisp-indent-backquote-substitution-mode): New user option. (common-lisp-indent-function-1, common-lisp-loop-part-indentation) (common-lisp-indent-function): Support normally indenting backquote substitutions. (extended-loop-p): Rename to `lisp-extended-loop-p'. --- lisp/ChangeLog | 9 +++++++ lisp/emacs-lisp/cl-indent.el | 62 ++++++++++++++++++++++++++++++++++++-------- 2 files changed, 60 insertions(+), 11 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index a9cf1b0f88f..fb2291c534c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,12 @@ +2015-03-15 Daniel Colascione + + * emacs-lisp/cl-indent.el + (lisp-indent-backquote-substitution-mode): New user option. + (common-lisp-indent-function-1, common-lisp-loop-part-indentation) + (common-lisp-indent-function): Support normally indenting + backquote substitutions. + (extended-loop-p): Rename to `lisp-extended-loop-p'. + 2015-03-14 Michael R. Mauger * progmodes/sql.el: Version 3.5 diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index 1bcfb6df2cf..5e75406cf22 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -138,6 +138,19 @@ If non-nil, alignment is done with the first parameter :type 'boolean :group 'lisp-indent) +(defcustom lisp-indent-backquote-substitution-mode t + "How to indent substitutions in backquotes. +If `t', the default, indent substituted forms normally. +If `nil', do not apply special indentation rule to substituted +forms. If `corrected', subtract the `,' or `,@' from the form +column, indenting as if this character sequence were not present. +In any case, do not backtrack beyond a backquote substitution. + +Until Emacs 25.1, the `nil' behavior was hard-wired." + :version "25.1" + :type '(choice (const corrected) (const nil) (const t)) + :group 'lisp-indent) + (defvar lisp-indent-defun-method '(4 &lambda &body) "Defun-like indentation method. @@ -145,7 +158,7 @@ This applies when the value of the `common-lisp-indent-function' property is set to `defun'.") -(defun extended-loop-p (loop-start) +(defun lisp-extended-loop-p (loop-start) "True if an extended loop form starts at LOOP-START." (condition-case () (save-excursion @@ -170,11 +183,22 @@ the standard lisp indent package." "Compute the indentation of loop form constituents." (let* ((loop-indentation (save-excursion (goto-char (elt state 1)) - (current-column)))) + (current-column)))) + (when (and (eq lisp-indent-backquote-substitution-mode 'corrected)) + (save-excursion + (goto-char (elt state 1)) + (incf loop-indentation + (cond ((eq (char-before) ?,) -1) + ((and (eq (char-before) ?@) + (progn (backward-char) + (eq (char-before) ?,))) + -2) + (t 0))))) + (goto-char indent-point) (beginning-of-line) (list - (cond ((not (extended-loop-p (elt state 1))) + (cond ((not (lisp-extended-loop-p (elt state 1))) (+ loop-indentation lisp-simple-loop-indentation)) ((looking-at "^\\s-*\\(:?\\sw+\\|;\\)") (+ loop-indentation lisp-loop-keyword-indentation)) @@ -264,9 +288,15 @@ at `common-lisp-indent-function' and, if set, use its value instead." ;; FIXME: why do we need to special-case loop? (if (save-excursion (goto-char (elt state 1)) - (looking-at (if (derived-mode-p 'emacs-lisp-mode) - "(\\(cl-\\)?[Ll][Oo][Oo][Pp]" - "([Ll][Oo][Oo][Pp]"))) + (and (looking-at (if (derived-mode-p 'emacs-lisp-mode) + "(\\(cl-\\)?loop" + "([Ll][Oo][Oo][Pp]")) + (or lisp-indent-backquote-substitution-mode + (not + (or (and (eq (char-before) ?@) + (progn (backward-char) + (eq (char-before) ?,))) + (eq (char-before) ?,)))))) (common-lisp-loop-part-indentation indent-point state) (common-lisp-indent-function-1 indent-point state))) @@ -373,11 +403,21 @@ instead." (not (eq (char-after (- containing-sexp 2)) ?\#))) ;; No indentation for "'(...)" elements (setq calculated (1+ sexp-column))) - ((or (eq (char-after (1- containing-sexp)) ?\,) - (and (eq (char-after (1- containing-sexp)) ?\@) - (eq (char-after (- containing-sexp 2)) ?\,))) - ;; ",(...)" or ",@(...)" - (setq calculated normal-indent)) + ((when + (or (eq (char-after (1- containing-sexp)) ?\,) + (and (eq (char-after (1- containing-sexp)) ?\@) + (eq (char-after (- containing-sexp 2)) ?\,))) + ;; ",(...)" or ",@(...)" + (when (eq lisp-indent-backquote-substitution-mode + 'corrected) + (incf sexp-column -1) + (when (eq (char-after (1- containing-sexp)) ?\@) + (incf sexp-column -1))) + (cond (lisp-indent-backquote-substitution-mode + (setf tentative-calculated normal-indent) + (setq depth lisp-indent-maximum-backtracking) + nil) + (t (setq calculated normal-indent))))) ((eq (char-after (1- containing-sexp)) ?\#) ;; "#(...)" (setq calculated (1+ sexp-column))) -- cgit v1.2.3 From 51e7e463e93708a0e40688f91200e9e9869ec662 Mon Sep 17 00:00:00 2001 From: Tassilo Horn Date: Sat, 14 Mar 2015 09:27:31 +0100 Subject: Font-lock elisp macros/special forms dynamically * emacs-lisp/lisp-mode.el (lisp--el-macro-regexp): New defconst. (lisp--el-update-macro-regexp, lisp--el-update-after-load) (lisp--el-match-macro): New functions. (lisp-mode-variables): Update lisp--el-macro-regexp and add lisp--el-update-after-load to after-load-functions. --- lisp/ChangeLog | 8 ++++++++ lisp/emacs-lisp/lisp-mode.el | 36 ++++++++++++++++++++++++++++++++++-- 2 files changed, 42 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index fb2291c534c..73ba0353d9d 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,11 @@ +2015-03-15 Tassilo Horn + + * emacs-lisp/lisp-mode.el (lisp--el-macro-regexp): New defconst. + (lisp--el-update-macro-regexp, lisp--el-update-after-load) + (lisp--el-match-macro): New functions. + (lisp-mode-variables): Update lisp--el-macro-regexp and add + lisp--el-update-after-load to after-load-functions. + 2015-03-15 Daniel Colascione * emacs-lisp/cl-indent.el diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 5d912097838..b4f87fdac66 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -181,6 +181,33 @@ nil))) res)) +(defconst lisp--el-macro-regexp nil + "A regular expression matching all loaded elisp macros. +Can be updated using `lisp--el-update-macro-regexp' after new +macros were defined.") + +(defun lisp--el-update-macro-regexp () + "Update `lisp--el-update-macro-regexp' from `obarray'. +Return non-nil only if the old and new value are different." + (let ((old-regex lisp--el-macro-regexp) + (elisp-macros nil)) + (mapatoms (lambda (a) + (when (or (macrop a) (special-form-p a)) + (push (symbol-name a) elisp-macros)))) + (setq lisp--el-macro-regexp + (concat "(" (regexp-opt elisp-macros t) "\\_>")) + (not (string= old-regex lisp--el-macro-regexp)))) + +(defun lisp--el-update-after-load (_file) + "Update `lisp--el-macro-regexp' and adjust font-lock in existing buffers." + (when (lisp--el-update-macro-regexp) + (dolist (buf (buffer-list)) + (when (derived-mode-p 'emacs-lisp-mode) + (font-lock-flush))))) + +(defun lisp--el-match-macro (limit) + (re-search-forward lisp--el-macro-regexp limit t)) + (pcase-let ((`(,vdefs ,tdefs ,el-defs-re ,cl-defs-re @@ -194,7 +221,9 @@ "when" "unless" "with-output-to-string" "ignore-errors" "dotimes" "dolist" "declare")) (lisp-errs '("warn" "error" "signal")) - ;; Elisp constructs. FIXME: update dynamically from obarray. + ;; Elisp constructs. Now they are update dynamically + ;; from obarray but they are also used for setting up + ;; the keywords for Common Lisp. (el-fdefs '("define-advice" "defadvice" "defalias" "define-derived-mode" "define-minor-mode" "define-generic-mode" "define-global-minor-mode" @@ -333,7 +362,7 @@ `( ;; Regexp negated char group. ("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend) ;; Control structures. Common Lisp forms. - (,(concat "(" el-kws-re "\\_>") . 1) + (lisp--el-match-macro . 1) ;; Exit/Feature symbols as constants. (,(concat "(\\(catch\\|throw\\|featurep\\|provide\\|require\\)\\_>" "[ \t']*\\(\\(?:\\sw\\|\\s_\\)+\\)?") @@ -514,6 +543,9 @@ font-lock keywords will not be case sensitive." . lisp-font-lock-syntactic-face-function))) (setq-local prettify-symbols-alist lisp--prettify-symbols-alist) (when elisp + (unless lisp--el-macro-regexp + (lisp--el-update-macro-regexp)) + (add-hook 'after-load-functions #'lisp--el-update-after-load) (setq-local electric-pair-text-pairs (cons '(?\` . ?\') electric-pair-text-pairs))) (setq-local electric-pair-skip-whitespace 'chomp) -- cgit v1.2.3 From 3eb4d23a7cdee6f763b5be4947f70a1040c25424 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Mon, 16 Mar 2015 14:48:09 +0000 Subject: Make Edebug work with Follow Mode. * emacs-lisp/edebug.el (edebug--display-1): Remove call to edebug-adjust-window. (edebug--recursive-edit): Don't bind pre/post-command-hooks to nil over the recursive edit. (edebug-adjust-window): Remove. --- lisp/ChangeLog | 10 ++++++++++ lisp/emacs-lisp/edebug.el | 34 ---------------------------------- 2 files changed, 10 insertions(+), 34 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 747a1d6c650..c6fab7fba3d 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,13 @@ +2015-03-16 Alan Mackenzie + + Make Edebug work with Follow Mode. + + * emacs-lisp/edebug.el (edebug--display-1): Remove call to + edebug-adjust-window. + (edebug--recursive-edit): Don't bind pre/post-command-hooks to nil + over the recursive edit. + (edebug-adjust-window): Remove. + 2015-03-15 Michael Albinus * net/tramp-adb.el: diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 10918775f49..333f02842f7 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -2446,9 +2446,6 @@ MSG is printed after `::::} '." edebug-function) )) - (setcdr edebug-window-data - (edebug-adjust-window (cdr edebug-window-data))) - ;; Test if there is input, not including keyboard macros. (if (input-pending-p) (progn @@ -2677,12 +2674,6 @@ MSG is printed after `::::} '." (defining-kbd-macro (if edebug-continue-kbd-macro defining-kbd-macro)) - ;; Disable command hooks. This is essential when - ;; a hook function is instrumented - to avoid infinite loop. - ;; This may be more than we need, however. - (pre-command-hook nil) - (post-command-hook nil) - ;; others?? ) @@ -2722,31 +2713,6 @@ MSG is printed after `::::} '." ;;; Display related functions -(defun edebug-adjust-window (old-start) - ;; If pos is not visible, adjust current window to fit following context. - ;; (message "window: %s old-start: %s window-start: %s pos: %s" - ;; (selected-window) old-start (window-start) (point)) (sit-for 5) - (if (not (pos-visible-in-window-p)) - (progn - ;; First try old-start - (if old-start - (set-window-start (selected-window) old-start)) - (if (not (pos-visible-in-window-p)) - (progn - ;; (message "resetting window start") (sit-for 2) - (set-window-start - (selected-window) - (save-excursion - (forward-line - (if (< (point) (window-start)) -1 ; one line before if in back - (- (/ (window-height) 2)) ; center the line moving forward - )) - (beginning-of-line) - (point))))))) - (window-start)) - - - (defconst edebug-arrow-alist '((Continue-fast . "=") (Trace-fast . "-") -- cgit v1.2.3 From 801eda8a2a00b3f28a69ffe51b05a649fffc5c58 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 16 Mar 2015 16:11:38 -0400 Subject: * lisp/emacs-lisp/cl-macs.el (cl--transform-lambda): Optimize &aux. Rework to avoid cl--do-arglist in more cases; add comments to explain what's going on. (cl--do-&aux): New function extracted from cl--do-arglist. (cl--do-arglist): Use it. * lisp/emacs-lisp/cl-generic.el: Add Version: header, for ELPA purposes. --- lisp/ChangeLog | 7 ++ lisp/emacs-lisp/cl-generic.el | 1 + lisp/emacs-lisp/cl-macs.el | 148 +++++++++++++++++++++++++++-------------- test/automated/cl-lib-tests.el | 17 +++++ 4 files changed, 124 insertions(+), 49 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index e9e910a8857..41898bee686 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,12 @@ 2015-03-16 Stefan Monnier + * emacs-lisp/cl-macs.el (cl--transform-lambda): Rework to avoid + cl--do-arglist in more cases; add comments to explain what's going on. + (cl--do-&aux): New function extracted from cl--do-arglist. + (cl--do-arglist): Use it. + + * emacs-lisp/cl-generic.el: Add Version: header, for ELPA purposes. + * obsolete/iswitchb.el (iswitchb-read-buffer): Add `predicate' arg. * isearchb.el (isearchb-iswitchb): Adjust accordingly. * ido.el (ido-read-buffer): Add `predicate' argument. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index a8483ea1355..41c760e960e 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -3,6 +3,7 @@ ;; Copyright (C) 2015 Free Software Foundation, Inc. ;; Author: Stefan Monnier +;; Version: 1.0 ;; This file is part of GNU Emacs. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 36f263cd20a..712a7485167 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -220,7 +220,20 @@ The name is made by appending a number to PREFIX, default \"G\"." (defconst cl--lambda-list-keywords '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) -(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote) +;; Internal hacks used in formal arg lists: +;; - &cl-quote: Added to formal-arglists to mean that any default value +;; mentioned in the formal arglist should be considered as implicitly +;; quoted rather than evaluated. This is used in `cl-defsubst' when +;; performing compiler-macro-expansion, since at that time the +;; arguments hold expressions rather than values. +;; - &cl-defs (DEF . DEFS): Gives the default value to use for missing +;; optional arguments which don't have an explicit default value. +;; DEFS is an alist mapping vars to their default default value. +;; and DEF is the default default to use for all other vars. + +(defvar cl--bind-block) ;Name of surrounding block, only use for `signal' data. +(defvar cl--bind-defs) ;(DEF . DEFS) giving the "default default" for optargs. +(defvar cl--bind-enquote) ;Non-nil if &cl-quote was in the formal arglist! (defvar cl--bind-lets) (defvar cl--bind-forms) (defun cl--transform-lambda (form bind-block) @@ -229,19 +242,26 @@ BIND-BLOCK is the name of the symbol to which the function will be bound, and which will be used for the name of the `cl-block' surrounding the function's body. FORM is of the form (ARGS . BODY)." - ;; FIXME: (lambda (a &aux b) 1) expands to (lambda (a &rest --cl-rest--) ...) - ;; where the --cl-rest-- is clearly undesired. (let* ((args (car form)) (body (cdr form)) (orig-args args) (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil) - (cl--bind-lets nil) (cl--bind-forms nil) (parsed-body (macroexp-parse-body body)) (header (car parsed-body)) (simple-args nil)) (setq body (cdr parsed-body)) + ;; "(. X) to (&rest X)" conversion already done in cl--do-arglist, but we + ;; do it here as well, so as to be able to see if we can avoid + ;; cl--do-arglist. (setq args (if (listp args) (cl-copy-list args) (list '&rest args))) (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) - (if (setq cl--bind-defs (cadr (memq '&cl-defs args))) - (setq args (delq '&cl-defs (delq cl--bind-defs args)) - cl--bind-defs (cadr cl--bind-defs))) + (let ((cl-defs (memq '&cl-defs args))) + (when cl-defs + (setq cl--bind-defs (cadr cl-defs)) + ;; Remove "&cl-defs DEFS" from args. + (setcdr cl-defs (cddr cl-defs)) + (setq args (delq '&cl-defs args)) + ;; Optimize away trivial &cl-defs. + (if (and (null (car cl--bind-defs)) + (cl-every (lambda (x) (null (cadr x))) (cdr cl--bind-defs))) + (setq cl--bind-defs nil)))) (if (setq cl--bind-enquote (memq '&cl-quote args)) (setq args (delq '&cl-quote args))) (if (memq '&whole args) (error "&whole not currently implemented")) @@ -249,6 +269,9 @@ FORM is of the form (ARGS . BODY)." (v (cadr p))) (if p (setq args (nconc (delq (car p) (delq v args)) `(&aux (,v macroexpand-all-environment)))))) + ;; Take away all the simple args whose parsing can be handled more + ;; efficiently by a plain old `lambda' than the manual parsing generated + ;; by `cl--do-arglist'. (while (and args (symbolp (car args)) (not (memq (car args) '(nil &rest &body &key &aux))) (not (and (eq (car args) '&optional) @@ -256,30 +279,50 @@ FORM is of the form (ARGS . BODY)." (push (pop args) simple-args)) (or (eq cl--bind-block 'cl-none) (setq body (list `(cl-block ,cl--bind-block ,@body)))) - (if (null args) - (cl-list* nil (nreverse simple-args) (nconc header body)) - (if (memq '&optional simple-args) (push '&optional args)) - (cl--do-arglist args nil (- (length simple-args) - (if (memq '&optional simple-args) 1 0))) - (setq cl--bind-lets (nreverse cl--bind-lets)) - (cl-list* nil - (nconc (nreverse simple-args) - (list '&rest (car (pop cl--bind-lets)))) - (nconc (save-match-data ;; Macro expansion can take place in the - ;; middle of apparently harmless computation, so it - ;; should not touch the match-data. - (require 'help-fns) - (cons (help-add-fundoc-usage - (if (stringp (car header)) (pop header)) - ;; Be careful with make-symbol and (back)quote, - ;; see bug#12884. - (let ((print-gensym nil) (print-quoted t)) - (format "%S" (cons 'fn (cl--make-usage-args - orig-args))))) - header)) - (list `(let* ,cl--bind-lets - ,@(nreverse cl--bind-forms) - ,@body))))))) + (let* ((cl--bind-lets nil) (cl--bind-forms nil) + (rest-args + (cond + ((null args) nil) + ((eq (car args) '&aux) + (cl--do-&aux args) + (setq cl--bind-lets (nreverse cl--bind-lets)) + nil) + (t ;; `simple-args' doesn't handle all the parsing that we need, + ;; so we pass the rest to cl--do-arglist which will do + ;; "manual" parsing. + (let ((slen (length simple-args))) + (when (memq '&optional simple-args) + (push '&optional args) (cl-decf slen)) + (setq header + ;; Macro expansion can take place in the middle of + ;; apparently harmless computation, so it should not + ;; touch the match-data. + (save-match-data + (require 'help-fns) + (cons (help-add-fundoc-usage + (if (stringp (car header)) (pop header)) + ;; Be careful with make-symbol and (back)quote, + ;; see bug#12884. + (let ((print-gensym nil) (print-quoted t)) + (format "%S" (cons 'fn (cl--make-usage-args + orig-args))))) + header))) + ;; FIXME: we'd want to choose an arg name for the &rest param + ;; and pass that as `expr' to cl--do-arglist, but that ends up + ;; generating code with a redundant let-binding, so we instead + ;; pass a dummy and then look in cl--bind-lets to find what var + ;; this was bound to. + (cl--do-arglist args :dummy slen) + (setq cl--bind-lets (nreverse cl--bind-lets)) + ;; (cl-assert (eq :dummy (nth 1 (car cl--bind-lets)))) + (list '&rest (car (pop cl--bind-lets)))))))) + `(nil + (,@(nreverse simple-args) ,@rest-args) + ,@header + ,(macroexp-let* cl--bind-lets + (macroexp-progn + `(,@(nreverse cl--bind-forms) + ,@body))))))) ;;;###autoload (defmacro cl-defun (name args &rest body) @@ -422,8 +465,7 @@ its argument list allows full Common Lisp conventions." (setcdr last nil) (nconc (cl--make-usage-args arglist) (cl--make-usage-var tail))) (setcdr last tail))) - ;; `orig-args' can contain &cl-defs (an internal - ;; CL thingy I don't understand), so remove it. + ;; `orig-args' can contain &cl-defs. (let ((x (memq '&cl-defs arglist))) (when x (setq arglist (delq (car x) (remq (cadr x) arglist))))) (let ((state nil)) @@ -450,6 +492,17 @@ its argument list allows full Common Lisp conventions." )))) arglist)))) +(defun cl--do-&aux (args) + (while (and (eq (car args) '&aux) (pop args)) + (while (and args (not (memq (car args) cl--lambda-list-keywords))) + (if (consp (car args)) + (if (and cl--bind-enquote (cl-cadar args)) + (cl--do-arglist (caar args) + `',(cadr (pop args))) + (cl--do-arglist (caar args) (cadr (pop args)))) + (cl--do-arglist (pop args) nil)))) + (if args (error "Malformed argument list ends with: %S" args))) + (defun cl--do-arglist (args expr &optional num) ; uses cl--bind-* (if (nlistp args) (if (or (memq args cl--lambda-list-keywords) (not (symbolp args))) @@ -459,8 +512,7 @@ its argument list allows full Common Lisp conventions." (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) (let ((p (memq '&body args))) (if p (setcar p '&rest))) (if (memq '&environment args) (error "&environment used incorrectly")) - (let ((save-args args) - (restarg (memq '&rest args)) + (let ((restarg (memq '&rest args)) (safety (if (cl--compiling-file) cl--optimize-safety 3)) (keys nil) (laterarg nil) (exactarg nil) minarg) @@ -530,7 +582,12 @@ its argument list allows full Common Lisp conventions." (intern (format ":%s" name))))) (varg (if (consp (car arg)) (cl-cadar arg) (car arg))) (def (if (cdr arg) (cadr arg) - (or (car cl--bind-defs) (cadr (assq varg cl--bind-defs))))) + ;; The ordering between those two or clauses is + ;; irrelevant, since in practice only one of the two + ;; is ever non-nil (the car is only used for + ;; cl-deftype which doesn't use the cdr). + (or (car cl--bind-defs) + (cadr (assq varg cl--bind-defs))))) (look `(plist-member ,restarg ',karg))) (and def cl--bind-enquote (setq def `',def)) (if (cddr arg) @@ -567,15 +624,8 @@ its argument list allows full Common Lisp conventions." keys) (car ,var))))))) (push `(let ((,var ,restarg)) ,check) cl--bind-forms))) - (while (and (eq (car args) '&aux) (pop args)) - (while (and args (not (memq (car args) cl--lambda-list-keywords))) - (if (consp (car args)) - (if (and cl--bind-enquote (cl-cadar args)) - (cl--do-arglist (caar args) - `',(cadr (pop args))) - (cl--do-arglist (caar args) (cadr (pop args)))) - (cl--do-arglist (pop args) nil)))) - (if args (error "Malformed argument list %s" save-args))))) + (cl--do-&aux args) + nil))) (defun cl--arglist-args (args) (if (nlistp args) (list args) @@ -2608,7 +2658,7 @@ non-nil value, that slot cannot be set via `setf'. (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) slots defaults))) (push `(cl-defsubst ,name - (&cl-defs '(nil ,@descs) ,@args) + (&cl-defs (nil ,@descs) ,@args) ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) '((declare (side-effect-free t)))) (,(or type #'vector) ,@make)) @@ -2716,8 +2766,8 @@ Of course, we really can't know that for sure, so it's just a heuristic." (t (inline-quote (or (cl-typep ,val ',head) (cl-typep ,val ',rest))))))))) - (`(member . ,args) - (inline-quote (and (memql ,val ',args) t))) + (`(eql ,v) (inline-quote (and (eql ,val ',v) t))) + (`(member . ,args) (inline-quote (and (memql ,val ',args) t))) (`(satisfies ,pred) (inline-quote (funcall #',pred ,val))) ((and (pred symbolp) type (guard (get type 'cl-deftype-handler))) (inline-quote @@ -2977,7 +3027,7 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (declare (debug cl-defmacro) (doc-string 3) (indent 2)) `(cl-eval-when (compile load eval) (put ',name 'cl-deftype-handler - (cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body))))) + (cl-function (lambda (&cl-defs ('*) ,@arglist) ,@body))))) (cl-deftype extended-char () `(and character (not base-char))) diff --git a/test/automated/cl-lib-tests.el b/test/automated/cl-lib-tests.el index 1c36e7d7abf..2c188a40059 100644 --- a/test/automated/cl-lib-tests.el +++ b/test/automated/cl-lib-tests.el @@ -427,4 +427,21 @@ (ert-deftest cl-flet-test () (should (equal (cl-flet ((f1 (x) x)) (let ((x #'f1)) (funcall x 5))) 5))) +(ert-deftest cl-lib-test-typep () + (cl-deftype cl-lib-test-type (&optional x) `(member ,x)) + ;; Make sure we correctly implement the rule that deftype's optional args + ;; default to `*' rather than to nil. + (should (cl-typep '* 'cl-lib-test-type)) + (should-not (cl-typep 1 'cl-lib-test-type))) + +(ert-deftest cl-lib-arglist-performance () + ;; An `&aux' should not cause lambda's arglist to be turned into an &rest + ;; that's parsed by hand. + (should (eq () (nth 1 (nth 1 (macroexpand + '(cl-function (lambda (&aux (x 1)) x))))))) + (cl-defstruct (cl-lib--s (:constructor cl-lib--s-make (&optional a))) a) + ;; Similarly the &cl-defs thingy shouldn't cause fallback to manual parsing + ;; of args if the default for optional args is nil. + (should (equal '(&optional a) (help-function-arglist 'cl-lib--s-make)))) + ;;; cl-lib.el ends here -- cgit v1.2.3 From b0743354e5502395f9a64b534a5ff5579c64ed42 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Mon, 16 Mar 2015 22:10:00 +0000 Subject: Edebug: Allow "S" to work during trace mode. Fixes debbugs #20074. Also display the overlay arrow in go and go-nonstop modes. * emacs-lisp/edebug.el (edebug--display-1): Move the `input-pending' test to after trace mode's `sit-for'. (edebug--recursive-edit): Insert "(sit-for 0)" after "(edebug-overlay-arrow)". --- lisp/ChangeLog | 10 ++++++++++ lisp/emacs-lisp/edebug.el | 28 ++++++++++++---------------- 2 files changed, 22 insertions(+), 16 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 41898bee686..cbd1bce25e8 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,13 @@ +2015-03-16 Alan Mackenzie + + Edebug: Allow "S" to work during trace mode. Fixes debbugs #20074. + Also display the overlay arrow in go and go-nonstop modes. + + * emacs-lisp/edebug.el (edebug--display-1): Move the + `input-pending' test to after trace mode's `sit-for'. + (edebug--recursive-edit): Insert "(sit-for 0)" after + "(edebug-overlay-arrow)". + 2015-03-16 Stefan Monnier * emacs-lisp/cl-macs.el (cl--transform-lambda): Rework to avoid diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 333f02842f7..aa7cdf96337 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -2446,15 +2446,6 @@ MSG is printed after `::::} '." edebug-function) )) - ;; Test if there is input, not including keyboard macros. - (if (input-pending-p) - (progn - (setq edebug-execution-mode 'step - edebug-stop t) - (edebug-stop) - ;; (discard-input) ; is this unfriendly?? - )) - ;; Make sure we bind those in the right buffer (bug#16410). (let ((overlay-arrow-position overlay-arrow-position) (overlay-arrow-string overlay-arrow-string)) @@ -2507,14 +2498,18 @@ MSG is printed after `::::} '." ((eq edebug-execution-mode 'Trace-fast) (sit-for 0))) ; Force update and continue. + (when (input-pending-p) + (setq edebug-stop t) + (setq edebug-execution-mode 'step) ; for `edebug-overlay-arrow' + (edebug-stop)) + + (edebug-overlay-arrow) + (unwind-protect (if (or edebug-stop (memq edebug-execution-mode '(step next)) (eq arg-mode 'error)) - (progn - ;; (setq edebug-execution-mode 'step) - ;; (edebug-overlay-arrow) ; This doesn't always show up. - (edebug--recursive-edit arg-mode))) ; <--- Recursive edit + (edebug--recursive-edit arg-mode)) ; <--- Recursive edit ;; Reset the edebug-window-data to whatever it is now. (let ((window (if (eq (window-buffer) edebug-buffer) @@ -2702,8 +2697,9 @@ MSG is printed after `::::} '." (if (buffer-name edebug-buffer) ; if it still exists (progn (set-buffer edebug-buffer) - (if (memq edebug-execution-mode '(go Go-nonstop)) - (edebug-overlay-arrow)) + (when (memq edebug-execution-mode '(go Go-nonstop)) + (edebug-overlay-arrow) + (sit-for 0)) (edebug-mode -1)) ;; gotta have a buffer to let its buffer local variables be set (get-buffer-create " bogus edebug buffer")) @@ -2721,7 +2717,7 @@ MSG is printed after `::::} '." (step . "=>") (next . "=>") (go . "<>") - (Go-nonstop . "..") ; not used + (Go-nonstop . "..") ) "Association list of arrows for each edebug mode.") -- cgit v1.2.3 From 6f73c465a8990560fedb1c9897c893056b4b04ef Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 17 Mar 2015 14:30:42 -0400 Subject: * cl-macs.el (cl--transform-lambda): Refine last change. Fixes: debbugs:20125 * test/automated/cl-lib-tests.el: Use lexical-binding. (cl-lib-arglist-performance): Refine test to the case where one of the fields has a non-nil default value. Use existing `mystruct' defstruct. (cl-lib-struct-accessors): Use `pcase' to be a bit more flexible in the accepted outputs. --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/cl-macs.el | 26 +++++++++++++++----------- test/ChangeLog | 20 ++++++++++++++------ test/automated/cl-lib-tests.el | 30 ++++++++++++++++-------------- 4 files changed, 50 insertions(+), 31 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 96478223d49..b7062bb5c66 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-03-17 Stefan Monnier + + * emacs-lisp/cl-macs.el (cl--transform-lambda): Refine last change + (bug#20125). + 2015-03-17 Michael Albinus * net/tramp-sh.el (tramp-ssh-controlmaster-options): Change test diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 712a7485167..56fbcf0b2fd 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -257,11 +257,7 @@ FORM is of the form (ARGS . BODY)." (setq cl--bind-defs (cadr cl-defs)) ;; Remove "&cl-defs DEFS" from args. (setcdr cl-defs (cddr cl-defs)) - (setq args (delq '&cl-defs args)) - ;; Optimize away trivial &cl-defs. - (if (and (null (car cl--bind-defs)) - (cl-every (lambda (x) (null (cadr x))) (cdr cl--bind-defs))) - (setq cl--bind-defs nil)))) + (setq args (delq '&cl-defs args)))) (if (setq cl--bind-enquote (memq '&cl-quote args)) (setq args (delq '&cl-quote args))) (if (memq '&whole args) (error "&whole not currently implemented")) @@ -272,11 +268,19 @@ FORM is of the form (ARGS . BODY)." ;; Take away all the simple args whose parsing can be handled more ;; efficiently by a plain old `lambda' than the manual parsing generated ;; by `cl--do-arglist'. - (while (and args (symbolp (car args)) - (not (memq (car args) '(nil &rest &body &key &aux))) - (not (and (eq (car args) '&optional) - (or cl--bind-defs (consp (cadr args)))))) - (push (pop args) simple-args)) + (let ((optional nil)) + (while (and args (symbolp (car args)) + (not (memq (car args) '(nil &rest &body &key &aux))) + (or (not optional) + ;; Optional args whose default is nil are simple. + (null (nth 1 (assq (car args) (cdr cl--bind-defs))))) + (not (and (eq (car args) '&optional) (setq optional t) + (car cl--bind-defs)))) + (push (pop args) simple-args)) + (when optional + (if args (push '&optional args)) + ;; Don't keep a dummy trailing &optional without actual optional args. + (if (eq '&optional (car simple-args)) (pop simple-args)))) (or (eq cl--bind-block 'cl-none) (setq body (list `(cl-block ,cl--bind-block ,@body)))) (let* ((cl--bind-lets nil) (cl--bind-forms nil) @@ -292,7 +296,7 @@ FORM is of the form (ARGS . BODY)." ;; "manual" parsing. (let ((slen (length simple-args))) (when (memq '&optional simple-args) - (push '&optional args) (cl-decf slen)) + (cl-decf slen)) (setq header ;; Macro expansion can take place in the middle of ;; apparently harmless computation, so it should not diff --git a/test/ChangeLog b/test/ChangeLog index a7d1dfdceae..e150aba2874 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,7 +1,15 @@ +2015-03-17 Stefan Monnier + + * automated/cl-lib-tests.el: Use lexical-binding. + (cl-lib-arglist-performance): Refine test to the case where one of the + fields has a non-nil default value. Use existing `mystruct' defstruct. + (cl-lib-struct-accessors): Use `pcase' to be a bit more flexible in the + accepted outputs. + 2015-03-16 Ken Brown - * automated/tramp-tests.el (tramp--test-special-characters): Don't - test "\t" in file names on Cygwin. (Bug#20119) + * automated/tramp-tests.el (tramp--test-special-characters): + Don't test "\t" in file names on Cygwin. (Bug#20119) 2015-03-10 Jackson Ray Hamilton @@ -78,8 +86,8 @@ 2015-03-03 Daniel Colascione - * automated/generator-tests.el (cps-testcase): Use - `cps-inhibit-atomic-optimization' instead of + * automated/generator-tests.el (cps-testcase): + Use `cps-inhibit-atomic-optimization' instead of `cps-disable-atomic-optimization'. (cps-test-declarations-preserved): New test. @@ -184,8 +192,8 @@ 2015-02-07 Dmitry Gutov - * automated/vc-tests.el (vc-test--working-revision): Fix - `vc-working-revision' checks to be compared against nil, which is + * automated/vc-tests.el (vc-test--working-revision): + Fix `vc-working-revision' checks to be compared against nil, which is what is should return for unregistered files. 2015-02-06 Nicolas Petton diff --git a/test/automated/cl-lib-tests.el b/test/automated/cl-lib-tests.el index 2c188a40059..ce0e5918653 100644 --- a/test/automated/cl-lib-tests.el +++ b/test/automated/cl-lib-tests.el @@ -1,4 +1,4 @@ -;;; cl-lib.el --- tests for emacs-lisp/cl-lib.el +;;; cl-lib.el --- tests for emacs-lisp/cl-lib.el -*- lexical-binding:t -*- ;; Copyright (C) 2013-2015 Free Software Foundation, Inc. @@ -204,7 +204,10 @@ :b :a :a 42) '(42 :a)))) -(cl-defstruct mystruct (abc :readonly t) def) +(cl-defstruct (mystruct + (:constructor cl-lib--con-1 (&aux (abc 1))) + (:constructor cl-lib--con-2 (&optional def))) + (abc 5 :readonly t) (def nil)) (ert-deftest cl-lib-struct-accessors () (let ((x (make-mystruct :abc 1 :def 2))) (should (eql (cl-struct-slot-value 'mystruct 'abc x) 1)) @@ -213,8 +216,17 @@ (should (eql (cl-struct-slot-value 'mystruct 'def x) -1)) (should (eql (cl-struct-slot-offset 'mystruct 'abc) 1)) (should-error (cl-struct-slot-offset 'mystruct 'marypoppins)) - (should (equal (cl-struct-slot-info 'mystruct) - '((cl-tag-slot) (abc :readonly t) (def)))))) + (should (pcase (cl-struct-slot-info 'mystruct) + (`((cl-tag-slot) (abc 5 :readonly t) + (def . ,(or `nil `(nil)))) + t))))) + +(ert-deftest cl-lib-arglist-performance () + ;; An `&aux' should not cause lambda's arglist to be turned into an &rest + ;; that's parsed by hand. + (should (equal () (help-function-arglist 'cl-lib--con-1))) + (should (pcase (help-function-arglist 'cl-lib--con-2) + (`(&optional ,_) t)))) (ert-deftest cl-the () (should (eql (cl-the integer 42) 42)) @@ -434,14 +446,4 @@ (should (cl-typep '* 'cl-lib-test-type)) (should-not (cl-typep 1 'cl-lib-test-type))) -(ert-deftest cl-lib-arglist-performance () - ;; An `&aux' should not cause lambda's arglist to be turned into an &rest - ;; that's parsed by hand. - (should (eq () (nth 1 (nth 1 (macroexpand - '(cl-function (lambda (&aux (x 1)) x))))))) - (cl-defstruct (cl-lib--s (:constructor cl-lib--s-make (&optional a))) a) - ;; Similarly the &cl-defs thingy shouldn't cause fallback to manual parsing - ;; of args if the default for optional args is nil. - (should (equal '(&optional a) (help-function-arglist 'cl-lib--s-make)))) - ;;; cl-lib.el ends here -- cgit v1.2.3 From 9fdc166ee0ca212f7d5bf1cd9e1177932b0cd9aa Mon Sep 17 00:00:00 2001 From: Tassilo Horn Date: Mon, 16 Mar 2015 10:25:14 +0100 Subject: Improve dynamic elisp keyword font-locking * emacs-lisp/byte-run.el (macro-declarations-alist): New declaration no-font-lock-keyword. (defmacro): Flush font-lock in existing elisp buffers. * emacs-lisp/lisp-mode.el (lisp--el-update-after-load) (lisp--el-update-macro-regexp, lisp--el-macro-regexp): Delete functions and defconst. (lisp--el-match-keyword): Rename from lisp--el-match-macro. (lisp--el-font-lock-flush-elisp-buffers): New function. (lisp-mode-variables): Remove code for updating lisp--el-macro-regexp, and add lisp--el-font-lock-flush-elisp-buffers to after-load-functions. --- lisp/ChangeLog | 15 ++++++++++++++ lisp/emacs-lisp/byte-run.el | 28 ++++++++++++++++++++----- lisp/emacs-lisp/lisp-mode.el | 49 ++++++++++++++++++-------------------------- 3 files changed, 58 insertions(+), 34 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 25571bab9c5..e365346c972 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,18 @@ +2015-03-17 Tassilo Horn + + * emacs-lisp/byte-run.el (macro-declarations-alist): New + declaration no-font-lock-keyword. + (defmacro): Flush font-lock in existing elisp buffers. + + * emacs-lisp/lisp-mode.el (lisp--el-update-after-load) + (lisp--el-update-macro-regexp, lisp--el-macro-regexp): Delete + functions and defconst. + (lisp--el-match-keyword): Rename from lisp--el-match-macro. + (lisp--el-font-lock-flush-elisp-buffers): New function. + (lisp-mode-variables): Remove code for updating + lisp--el-macro-regexp, and add + lisp--el-font-lock-flush-elisp-buffers to after-load-functions. + 2015-03-17 Simen Heggestøyl * textmodes/css-mode.el (css--font-lock-keywords): Discriminate diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index caa7e3dad33..e0d6c3e7829 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -147,11 +147,16 @@ This is used by `declare'.") (defvar macro-declarations-alist (cons (list 'debug - #'(lambda (name _args spec) - (list 'progn :autoload-end - (list 'put (list 'quote name) - ''edebug-form-spec (list 'quote spec))))) - defun-declarations-alist) + #'(lambda (name _args spec) + (list 'progn :autoload-end + (list 'put (list 'quote name) + ''edebug-form-spec (list 'quote spec))))) + (cons + (list 'no-font-lock-keyword + #'(lambda (name _args val) + (list 'function-put (list 'quote name) + ''no-font-lock-keyword (list 'quote val)))) + defun-declarations-alist)) "List associating properties of macros to their macro expansion. Each element of the list takes the form (PROP FUN) where FUN is a function. For each (PROP . VALUES) in a macro's declaration, the FUN corresponding @@ -201,6 +206,19 @@ The return value is undefined. (message "Warning: Unknown macro property %S in %S" (car x) name)))) decls))) + ;; Refresh font-lock if this is a new macro, or it is an + ;; existing macro whose 'no-font-lock-keyword declaration + ;; has changed. + (if (and + ;; If lisp-mode hasn't been loaded, there's no reason + ;; to flush. + (fboundp 'lisp--el-font-lock-flush-elisp-buffers) + (or (not (fboundp name)) ;; new macro + (and (fboundp name) ;; existing macro + (member `(function-put ',name 'no-font-lock-keyword + ',(get name 'no-font-lock-keyword)) + declarations)))) + (lisp--el-font-lock-flush-elisp-buffers)) (if declarations (cons 'prog1 (cons def declarations)) def)))))) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index b4f87fdac66..6b3077302ed 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -181,32 +181,25 @@ nil))) res)) -(defconst lisp--el-macro-regexp nil - "A regular expression matching all loaded elisp macros. -Can be updated using `lisp--el-update-macro-regexp' after new -macros were defined.") - -(defun lisp--el-update-macro-regexp () - "Update `lisp--el-update-macro-regexp' from `obarray'. -Return non-nil only if the old and new value are different." - (let ((old-regex lisp--el-macro-regexp) - (elisp-macros nil)) - (mapatoms (lambda (a) - (when (or (macrop a) (special-form-p a)) - (push (symbol-name a) elisp-macros)))) - (setq lisp--el-macro-regexp - (concat "(" (regexp-opt elisp-macros t) "\\_>")) - (not (string= old-regex lisp--el-macro-regexp)))) - -(defun lisp--el-update-after-load (_file) - "Update `lisp--el-macro-regexp' and adjust font-lock in existing buffers." - (when (lisp--el-update-macro-regexp) +(defun lisp--el-match-keyword (limit) + (catch 'found + (while (re-search-forward "(\\(\\(?:\\sw\\|\\s_\\)+\\)\\_>" limit t) + (let ((sym (intern-soft (match-string 1)))) + (when (or (special-form-p sym) + (and (macrop sym) + (not (get sym 'no-font-lock-keyword)))) + (throw 'found t)))))) + +(defun lisp--el-font-lock-flush-elisp-buffers (&optional file) + ;; Don't flush during load unless called from after-load-functions. + ;; In that case, FILE is non-nil. It's somehow strange that + ;; load-in-progress is t when an after-load-function is called since + ;; that should run *after* the load... + (when (or (not load-in-progress) file) (dolist (buf (buffer-list)) - (when (derived-mode-p 'emacs-lisp-mode) - (font-lock-flush))))) - -(defun lisp--el-match-macro (limit) - (re-search-forward lisp--el-macro-regexp limit t)) + (with-current-buffer buf + (when (derived-mode-p 'emacs-lisp-mode) + (font-lock-flush)))))) (pcase-let ((`(,vdefs ,tdefs @@ -362,7 +355,7 @@ Return non-nil only if the old and new value are different." `( ;; Regexp negated char group. ("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend) ;; Control structures. Common Lisp forms. - (lisp--el-match-macro . 1) + (lisp--el-match-keyword . 1) ;; Exit/Feature symbols as constants. (,(concat "(\\(catch\\|throw\\|featurep\\|provide\\|require\\)\\_>" "[ \t']*\\(\\(?:\\sw\\|\\s_\\)+\\)?") @@ -543,9 +536,7 @@ font-lock keywords will not be case sensitive." . lisp-font-lock-syntactic-face-function))) (setq-local prettify-symbols-alist lisp--prettify-symbols-alist) (when elisp - (unless lisp--el-macro-regexp - (lisp--el-update-macro-regexp)) - (add-hook 'after-load-functions #'lisp--el-update-after-load) + (add-hook 'after-load-functions #'lisp--el-font-lock-flush-elisp-buffers) (setq-local electric-pair-text-pairs (cons '(?\` . ?\') electric-pair-text-pairs))) (setq-local electric-pair-skip-whitespace 'chomp) -- cgit v1.2.3 From 872481d9e26d7569145c897fd319b1104e028878 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 18 Mar 2015 10:31:07 -0400 Subject: Add classes as run-time descriptors of cl-structs. * lisp/emacs-lisp/cl-preloaded.el (cl--struct-get-class): New function. (cl--make-slot-desc): New constructor. (cl--plist-remove, cl--struct-register-child): New functions. (cl-struct-define): Rewrite. (cl-structure-class, cl-structure-object, cl-slot-descriptor) (cl--class): New structs. (cl--struct-default-parent): Initialize it here. * lisp/emacs-lisp/cl-macs.el (cl--find-class): New macro. (cl-defsubst, cl--defsubst-expand, cl--sublis): Move before first use. (cl--struct-default-parent): New var. (cl-defstruct): Adjust to new representation of classes; add default parent. In accessors, signal `wrong-type-argument' rather than a generic error. (cl-struct-sequence-type, cl-struct-slot-info) (cl-struct-slot-offset): Rewrite. * lisp/emacs-lisp/cl-generic.el (cl--generic-struct-specializers) (cl-generic-generalizers): Rewrite. * src/alloc.c (purecopy): Handle hash-tables. * lisp/emacs-lisp/debug.el (debug--implement-debug-on-entry): Bind inhibit-debug-on-entry here... (debug): Instead of here. * lisp/emacs-lisp/macroexp.el (macroexp--debug-eager): New var. (internal-macroexpand-for-load): Use it. * lwlib/xlwmenu.c (pop_up_menu): Remove debugging code. --- lisp/ChangeLog | 62 +++++++---- lisp/emacs-lisp/cl-generic.el | 64 ++++++----- lisp/emacs-lisp/cl-macs.el | 198 +++++++++++++++++++--------------- lisp/emacs-lisp/cl-preloaded.el | 231 +++++++++++++++++++++++++++++++++++----- lisp/emacs-lisp/debug.el | 8 +- lisp/emacs-lisp/macroexp.el | 8 +- lwlib/ChangeLog | 4 + lwlib/xlwmenu.c | 58 +++++----- src/ChangeLog | 18 ++-- src/alloc.c | 43 ++++---- 10 files changed, 468 insertions(+), 226 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d61a0a67673..2db0f9a349a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,31 @@ +2015-03-18 Stefan Monnier + + Add classes as run-time descriptors of cl-structs. + * emacs-lisp/cl-preloaded.el (cl--struct-get-class): New function. + (cl--make-slot-desc): New constructor. + (cl--plist-remove, cl--struct-register-child): New functions. + (cl-struct-define): Rewrite. + (cl-structure-class, cl-structure-object, cl-slot-descriptor) + (cl--class): New structs. + (cl--struct-default-parent): Initialize it here. + * emacs-lisp/cl-macs.el (cl--find-class): New macro. + (cl-defsubst, cl--defsubst-expand, cl--sublis): Move before first use. + (cl--struct-default-parent): New var. + (cl-defstruct): Adjust to new representation of classes; add + default parent. In accessors, signal `wrong-type-argument' rather than + a generic error. + (cl-struct-sequence-type, cl-struct-slot-info) + (cl-struct-slot-offset): Rewrite. + * emacs-lisp/cl-generic.el (cl--generic-struct-specializers) + (cl-generic-generalizers): Rewrite. + + * emacs-lisp/macroexp.el (macroexp--debug-eager): New var. + (internal-macroexpand-for-load): Use it. + + * emacs-lisp/debug.el (debug--implement-debug-on-entry): + Bind inhibit-debug-on-entry here... + (debug): Instead of here. + 2015-03-18 Dima Kogan Have gud-display-line not display source buffer in gud window. @@ -6,13 +34,13 @@ 2015-03-17 Tassilo Horn - * emacs-lisp/byte-run.el (macro-declarations-alist): New - declaration no-font-lock-keyword. + * emacs-lisp/byte-run.el (macro-declarations-alist): + New declaration no-font-lock-keyword. (defmacro): Flush font-lock in existing elisp buffers. * emacs-lisp/lisp-mode.el (lisp--el-update-after-load) - (lisp--el-update-macro-regexp, lisp--el-macro-regexp): Delete - functions and defconst. + (lisp--el-update-macro-regexp, lisp--el-macro-regexp): + Delete functions and defconst. (lisp--el-match-keyword): Rename from lisp--el-match-macro. (lisp--el-font-lock-flush-elisp-buffers): New function. (lisp-mode-variables): Remove code for updating @@ -21,23 +49,17 @@ 2015-03-17 Simen Heggestøyl - * textmodes/css-mode.el (css--font-lock-keywords): Discriminate - between pseudo-classes and pseudo-elements. + * textmodes/css-mode.el (css--font-lock-keywords): + Discriminate between pseudo-classes and pseudo-elements. (css-pseudo-ids): Remove. - (css-pseudo-class-ids): New variable. - (css-pseudo-element-ids): New variable. - (css--complete-property): New function for completing CSS - properties. - (css--complete-pseudo-element-or-class): New function for + (css-pseudo-class-ids, css-pseudo-element-ids): New variables. + (css--complete-property): New function for completing CSS properties. + (css--complete-pseudo-element-or-class): New function completing CSS pseudo-elements and pseudo-classes. (css--complete-at-rule): New function for completing CSS at-rules. - (css-completion-at-point): New function providing completion for - `css-mode'. + (css-completion-at-point): New function. (css-mode): Add support for completion. - (css-extract-keyword-list): Remove function in favor of manual - extraction. - (css-extract-parse-val-grammar): Remove function in favor of - manual extraction. + (css-extract-keyword-list, css-extract-parse-val-grammar) (css-extract-props-and-vals): Remove function in favor of manual extraction. (css-at-ids): Update list of CSS at-rule ids. @@ -163,7 +185,7 @@ * progmodes/sql.el: Version 3.5 (sql-starts-with-prompt-re, sql-ends-with-prompt-re): Match password prompts. - (sql-interactive-remove-continuation-prompt): Fixed regression. (Bug#6686) + (sql-interactive-remove-continuation-prompt): Fix regression. (Bug#6686) 2015-03-14 Daniel Colascione @@ -178,8 +200,8 @@ info-look fixes for Texinfo 5 * info-look.el (c-mode, bison-mode, makefile-mode) (makefile-automake-mode, texinfo-mode, autoconf-mode, awk-mode) - (latex-mode, emacs-lisp-mode, sh-mode, cfengine-mode): Match - `foo' and 'foo' and ‘foo’ for @item and similar. + (latex-mode, emacs-lisp-mode, sh-mode, cfengine-mode): + Match `foo' and 'foo' and ‘foo’ for @item and similar. (latex-mode): Match multi-arg \frac{num}{den} or \sqrt[root]{n} in suffix regexp. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 41c760e960e..c9ca92d7c09 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -857,6 +857,18 @@ Can only be used from within the lexical body of a primary or around method." ;;; Support for cl-defstructs specializers. (defun cl--generic-struct-tag (name) + ;; It's tempting to use (and (vectorp ,name) (aref ,name 0)) + ;; but that would suffer from some problems: + ;; - the vector may have size 0. + ;; - when called on an actual vector (rather than an object), we'd + ;; end up returning an arbitrary value, possibly colliding with + ;; other tagcode's values. + ;; - it can also result in returning all kinds of irrelevant + ;; values which would end up filling up the method-cache with + ;; lots of irrelevant/redundant entries. + ;; FIXME: We could speed this up by introducing a dedicated + ;; vector type at the C level, so we could do something like + ;; (and (vector-objectp ,name) (aref ,name 0)) `(and (vectorp ,name) (> (length ,name) 0) (let ((tag (aref ,name 0))) @@ -864,14 +876,18 @@ Can only be used from within the lexical body of a primary or around method." tag)))) (defun cl--generic-struct-specializers (tag) - (and (symbolp tag) - ;; A method call shouldn't itself mess with the match-data. - (string-match-p "\\`cl-struct-\\(.*\\)" (symbol-name tag)) - (let ((types (list (intern (substring (symbol-name tag) 10))))) - (while (get (car types) 'cl-struct-include) - (push (get (car types) 'cl-struct-include) types)) - (push 'cl-structure-object types) ;The "parent type" of all cl-structs. - (nreverse types)))) + (and (symbolp tag) (boundp tag) + (let ((class (symbol-value tag))) + (when (cl-typep class 'cl-structure-class) + (let ((types ()) + (classes (list class))) + ;; BFS precedence. + (while (let ((class (pop classes))) + (push (cl--class-name class) types) + (setq classes + (append classes + (cl--class-parents class))))) + (nreverse types)))))) (defconst cl--generic-struct-generalizer (cl-generic-make-generalizer @@ -881,27 +897,17 @@ Can only be used from within the lexical body of a primary or around method." (cl-defmethod cl-generic-generalizers :extra "cl-struct" (type) "Support for dispatch on cl-struct types." (or - (and (symbolp type) - (get type 'cl-struct-type) - (or (null (car (get type 'cl-struct-type))) - (error "Can't dispatch on cl-struct %S: type is %S" - type (car (get type 'cl-struct-type)))) - (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots))) - (error "Can't dispatch on cl-struct %S: no tag in slot 0" - type)) - ;; It's tempting to use (and (vectorp ,name) (aref ,name 0)) - ;; but that would suffer from some problems: - ;; - the vector may have size 0. - ;; - when called on an actual vector (rather than an object), we'd - ;; end up returning an arbitrary value, possibly colliding with - ;; other tagcode's values. - ;; - it can also result in returning all kinds of irrelevant - ;; values which would end up filling up the method-cache with - ;; lots of irrelevant/redundant entries. - ;; FIXME: We could speed this up by introducing a dedicated - ;; vector type at the C level, so we could do something like - ;; (and (vector-objectp ,name) (aref ,name 0)) - (list cl--generic-struct-generalizer)) + (when (symbolp type) + ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than + ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can + ;; take place without requiring cl-lib. + (let ((class (cl--find-class type))) + (and (cl-typep class 'cl-structure-class) + (when (cl--struct-class-type class) + (error "Can't dispatch on cl-struct %S: type is %S" + type (cl--struct-class-type class))) + (progn (cl-assert (null (cl--struct-class-named class))) t) + (list cl--generic-struct-generalizer)))) (cl-call-next-method))) ;;; Dispatch on "system types". diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 56fbcf0b2fd..d3866783447 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2434,8 +2434,79 @@ Like `cl-callf', but PLACE is the second argument of FUNC, not the first. (if (symbolp func) (cons func rargs) `(funcall #',func ,@rargs)))))))) +;;;###autoload +(defmacro cl-defsubst (name args &rest body) + "Define NAME as a function. +Like `defun', except the function is automatically declared `inline' and +the arguments are immutable. +ARGLIST allows full Common Lisp conventions, and BODY is implicitly +surrounded by (cl-block NAME ...). +The function's arguments should be treated as immutable. + +\(fn NAME ARGLIST [DOCSTRING] BODY...)" + (declare (debug cl-defun) (indent 2)) + (let* ((argns (cl--arglist-args args)) + (p argns) + ;; (pbody (cons 'progn body)) + ) + (while (and p (eq (cl--expr-contains args (car p)) 1)) (pop p)) + `(progn + ,(if p nil ; give up if defaults refer to earlier args + `(cl-define-compiler-macro ,name + ,(if (memq '&key args) + `(&whole cl-whole &cl-quote ,@args) + (cons '&cl-quote args)) + (cl--defsubst-expand + ',argns '(cl-block ,name ,@body) + ;; We used to pass `simple' as + ;; (not (or unsafe (cl-expr-access-order pbody argns))) + ;; But this is much too simplistic since it + ;; does not pay attention to the argvs (and + ;; cl-expr-access-order itself is also too naive). + nil + ,(and (memq '&key args) 'cl-whole) nil ,@argns))) + (cl-defun ,name ,args ,@body)))) + +(defun cl--defsubst-expand (argns body simple whole _unsafe &rest argvs) + (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole + (if (cl--simple-exprs-p argvs) (setq simple t)) + (let* ((substs ()) + (lets (delq nil + (cl-mapcar (lambda (argn argv) + (if (or simple (macroexp-const-p argv)) + (progn (push (cons argn argv) substs) + nil) + (list argn argv))) + argns argvs)))) + ;; FIXME: `sublis/subst' will happily substitute the symbol + ;; `argn' in places where it's not used as a reference + ;; to a variable. + ;; FIXME: `sublis/subst' will happily copy `argv' to a different + ;; scope, leading to name capture. + (setq body (cond ((null substs) body) + ((null (cdr substs)) + (cl-subst (cdar substs) (caar substs) body)) + (t (cl--sublis substs body)))) + (if lets `(let ,lets ,body) body)))) + +(defun cl--sublis (alist tree) + "Perform substitutions indicated by ALIST in TREE (non-destructively)." + (let ((x (assq tree alist))) + (cond + (x (cdr x)) + ((consp tree) + (cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree)))) + (t tree)))) + ;;; Structures. +(defmacro cl--find-class (type) + `(get ,type 'cl--class)) + +;; Rather than hard code cl-structure-object, we indirect through this variable +;; for bootstrapping reasons. +(defvar cl--struct-default-parent nil) + ;;;###autoload (defmacro cl-defstruct (struct &rest descs) "Define a struct type. @@ -2491,6 +2562,7 @@ non-nil value, that slot cannot be set via `setf'. (tag (intern (format "cl-struct-%s" name))) (tag-symbol (intern (format "cl-struct-%s-tags" name))) (include-descs nil) + (include-name nil) (type nil) (named nil) (forms nil) @@ -2520,12 +2592,14 @@ non-nil value, that slot cannot be set via `setf'. ((eq opt :predicate) (if args (setq predicate (car args)))) ((eq opt :include) - (when include (error "Can't :include more than once")) - (setq include (car args) - include-descs (mapcar (function - (lambda (x) - (if (consp x) x (list x)))) - (cdr args)))) + ;; FIXME: Actually, we can include more than once as long as + ;; we include EIEIO classes rather than cl-structs! + (when include-name (error "Can't :include more than once")) + (setq include-name (car args)) + (setq include-descs (mapcar (function + (lambda (x) + (if (consp x) x (list x)))) + (cdr args)))) ((eq opt :print-function) (setq print-func (car args))) ((eq opt :type) @@ -2537,19 +2611,21 @@ non-nil value, that slot cannot be set via `setf'. descs))) (t (error "Slot option %s unrecognized" opt))))) + (unless (or include-name type) + (setq include-name cl--struct-default-parent)) + (when include-name (setq include (cl--struct-get-class include-name))) (if print-func (setq print-func `(progn (funcall #',print-func cl-x cl-s cl-n) t)) - (or type (and include (not (get include 'cl-struct-print))) + (or type (and include (not (cl--struct-class-print include))) (setq print-auto t print-func (and (or (not (or include type)) (null print-func)) `(progn (princ ,(format "#S(%s" name) cl-s)))))) (if include - (let ((inc-type (get include 'cl-struct-type)) - (old-descs (get include 'cl-struct-slots))) - (or inc-type (error "%s is not a struct name" include)) - (and type (not (eq (car inc-type) type)) + (let* ((inc-type (cl--struct-class-type include)) + (old-descs (cl-struct-slot-info include))) + (and type (not (eq inc-type type)) (error ":type disagrees with :include for %s" name)) (while include-descs (setcar (memq (or (assq (caar include-descs) old-descs) @@ -2558,9 +2634,9 @@ non-nil value, that slot cannot be set via `setf'. old-descs) (pop include-descs))) (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs)) - type (car inc-type) - named (assq 'cl-tag-slot descs)) - (if (cadr inc-type) (setq tag name named t))) + type inc-type + named (if type (assq 'cl-tag-slot descs) 'true)) + (if (cl--struct-class-named include) (setq tag name named t))) (if type (progn (or (memq type '(vector list)) @@ -2605,8 +2681,8 @@ non-nil value, that slot cannot be set via `setf'. (declare (side-effect-free t)) ,@(and pred-check (list `(or ,pred-check - (error "%s accessing a non-%s" - ',accessor ',name)))) + (signal 'wrong-type-argument + (list ',name cl-x))))) ,(if (memq type '(nil vector)) `(aref cl-x ,pos) (if (= pos 0) '(car cl-x) `(nth ,pos cl-x)))) @@ -2682,8 +2758,11 @@ non-nil value, that slot cannot be set via `setf'. `(progn (defvar ,tag-symbol) ,@(nreverse forms) + ;; Call cl-struct-define during compilation as well, so that + ;; a subsequent cl-defstruct in the same file can correctly include this + ;; struct as a parent. (eval-and-compile - (cl-struct-define ',name ,docstring ',include + (cl-struct-define ',name ,docstring ',include-name ',type ,(eq named t) ',descs ',tag-symbol ',tag ',print-auto)) ',name))) @@ -2693,7 +2772,7 @@ non-nil value, that slot cannot be set via `setf'. STRUCT-TYPE is a symbol naming a struct type. Return 'vector or 'list, or nil if STRUCT-TYPE is not a struct type. " (declare (side-effect-free t) (pure t)) - (car (get struct-type 'cl-struct-type))) + (cl--struct-class-type (cl--struct-get-class struct-type))) (defun cl-struct-slot-info (struct-type) "Return a list of slot names of struct STRUCT-TYPE. @@ -2702,7 +2781,19 @@ slot name symbol and OPTS is a list of slot options given to `cl-defstruct'. Dummy slots that represent the struct name and slots skipped by :initial-offset may appear in the list." (declare (side-effect-free t) (pure t)) - (get struct-type 'cl-struct-slots)) + (let* ((class (cl--struct-get-class struct-type)) + (slots (cl--struct-class-slots class)) + (type (cl--struct-class-type class)) + (descs (if type () (list '(cl-tag-slot))))) + (dotimes (i (length slots)) + (let ((slot (aref slots i))) + (push `(,(cl--slot-descriptor-name slot) + ,(cl--slot-descriptor-initform slot) + ,@(if (not (eq (cl--slot-descriptor-type slot) t)) + `(:type ,(cl--slot-descriptor-type slot))) + ,@(cl--slot-descriptor-props slot)) + descs))) + (nreverse descs))) (defun cl-struct-slot-offset (struct-type slot-name) "Return the offset of slot SLOT-NAME in STRUCT-TYPE. @@ -2711,9 +2802,8 @@ the structure data type and is adjusted for any structure name and :initial-offset slots. Signal error if struct STRUCT-TYPE does not contain SLOT-NAME." (declare (side-effect-free t) (pure t)) - (or (cl-position slot-name - (cl-struct-slot-info struct-type) - :key #'car :test #'eq) + (or (gethash slot-name + (cl--class-index-table (cl--struct-get-class struct-type))) (error "struct %s has no slot %s" struct-type slot-name))) (defvar byte-compile-function-environment) @@ -2898,70 +2988,6 @@ macro that returns its `&whole' argument." (if cl-found (setcdr cl-found t))) `(throw ,cl-tag ,cl-value)) -;;;###autoload -(defmacro cl-defsubst (name args &rest body) - "Define NAME as a function. -Like `defun', except the function is automatically declared `inline' and -the arguments are immutable. -ARGLIST allows full Common Lisp conventions, and BODY is implicitly -surrounded by (cl-block NAME ...). -The function's arguments should be treated as immutable. - -\(fn NAME ARGLIST [DOCSTRING] BODY...)" - (declare (debug cl-defun) (indent 2)) - (let* ((argns (cl--arglist-args args)) - (p argns) - ;; (pbody (cons 'progn body)) - ) - (while (and p (eq (cl--expr-contains args (car p)) 1)) (pop p)) - `(progn - ,(if p nil ; give up if defaults refer to earlier args - `(cl-define-compiler-macro ,name - ,(if (memq '&key args) - `(&whole cl-whole &cl-quote ,@args) - (cons '&cl-quote args)) - (cl--defsubst-expand - ',argns '(cl-block ,name ,@body) - ;; We used to pass `simple' as - ;; (not (or unsafe (cl-expr-access-order pbody argns))) - ;; But this is much too simplistic since it - ;; does not pay attention to the argvs (and - ;; cl-expr-access-order itself is also too naive). - nil - ,(and (memq '&key args) 'cl-whole) nil ,@argns))) - (cl-defun ,name ,args ,@body)))) - -(defun cl--defsubst-expand (argns body simple whole _unsafe &rest argvs) - (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole - (if (cl--simple-exprs-p argvs) (setq simple t)) - (let* ((substs ()) - (lets (delq nil - (cl-mapcar (lambda (argn argv) - (if (or simple (macroexp-const-p argv)) - (progn (push (cons argn argv) substs) - nil) - (list argn argv))) - argns argvs)))) - ;; FIXME: `sublis/subst' will happily substitute the symbol - ;; `argn' in places where it's not used as a reference - ;; to a variable. - ;; FIXME: `sublis/subst' will happily copy `argv' to a different - ;; scope, leading to name capture. - (setq body (cond ((null substs) body) - ((null (cdr substs)) - (cl-subst (cdar substs) (caar substs) body)) - (t (cl--sublis substs body)))) - (if lets `(let ,lets ,body) body)))) - -(defun cl--sublis (alist tree) - "Perform substitutions indicated by ALIST in TREE (non-destructively)." - (let ((x (assq tree alist))) - (cond - (x (cdr x)) - ((consp tree) - (cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree)))) - (t tree)))) - ;; Compile-time optimizations for some functions defined in this package. (defun cl--compiler-macro-member (form a list &rest keys) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 401d34b449e..a18e0e57b05 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -21,36 +21,22 @@ ;;; Commentary: -;; The expectation is that structs defined with cl-defstruct do not -;; need cl-lib at run-time, but we'd like to hide the details of the -;; cl-struct metadata behind the cl-struct-define function, so we put -;; it in this pre-loaded file. +;; The cl-defstruct macro is full of circularities, since it uses the +;; cl-structure-class type (and its accessors) which is defined with itself, +;; and it setups a default parent (cl-structure-object) which is also defined +;; with cl-defstruct, and to make things more interesting, the class of +;; cl-structure-object is of course an object of type cl-structure-class while +;; cl-structure-class's parent is cl-structure-object. +;; Furthermore, the code generated by cl-defstruct generally assumes that the +;; parent will be loaded when the child is loaded. But at the same time, the +;; expectation is that structs defined with cl-defstruct do not need cl-lib at +;; run-time, which means that the `cl-structure-object' parent can't be in +;; cl-lib but should be preloaded. So here's this preloaded circular setup. ;;; Code: (eval-when-compile (require 'cl-lib)) - -(defun cl-struct-define (name docstring parent type named slots children-sym - tag print-auto) - (cl-assert (or type (equal '(cl-tag-slot) (car slots)))) - (cl-assert (or type (not named))) - (if (boundp children-sym) - (add-to-list children-sym tag) - (set children-sym (list tag))) - (let* ((parent-class parent)) - (while parent-class - (add-to-list (intern (format "cl-struct-%s-tags" parent-class)) tag) - (setq parent-class (get parent-class 'cl-struct-include)))) - ;; If the cl-generic support, we need to be able to check - ;; if a vector is a cl-struct object, without knowing its particular type. - ;; So we use the (otherwise) unused function slots of the tag symbol - ;; to put a special witness value, to make the check easy and reliable. - (unless named (fset tag :quick-object-witness-check)) - (put name 'cl-struct-slots slots) - (put name 'cl-struct-type (list type named)) - (if parent (put name 'cl-struct-include parent)) - (if print-auto (put name 'cl-struct-print print-auto)) - (if docstring (put name 'structure-documentation docstring))) +(eval-when-compile (require 'cl-macs)) ;For cl--struct-class. ;; The `assert' macro from the cl package signals ;; `cl-assertion-failed' at runtime so always define it. @@ -63,6 +49,199 @@ (apply #'error string (append sargs args)) (signal 'cl-assertion-failed `(,form ,@sargs))))) +;; When we load this (compiled) file during pre-loading, the cl--struct-class +;; code below will need to access the `cl-struct' info, since it's considered +;; already as its parent (because `cl-struct' was defined while the file was +;; compiled). So let's temporarily setup a fake. +(defvar cl-struct-cl-structure-object-tags nil) +(unless (cl--find-class 'cl-structure-object) + (setf (cl--find-class 'cl-structure-object) 'dummy)) + +(fset 'cl--make-slot-desc + ;; To break circularity, we pre-define the slot constructor by hand. + ;; It's redefined a bit further down as part of the cl-defstruct of + ;; cl--slot-descriptor. + ;; BEWARE: Obviously, it's important to keep the two in sync! + (lambda (name &optional initform type props) + (vector 'cl-struct-cl-slot-descriptor + name initform type props))) + +(defun cl--struct-get-class (name) + (or (if (not (symbolp name)) name) + (cl--find-class name) + (if (not (get name 'cl-struct-type)) + ;; FIXME: Add a conversion for `eieio--class' so we can + ;; create a cl-defstruct that inherits from an eieio class? + (error "%S is not a struct name" name) + ;; Backward compatibility with a defstruct compiled with a version + ;; cl-defstruct from Emacs<25. Convert to new format. + (let ((tag (intern (format "cl-struct-%s" name))) + (type-and-named (get name 'cl-struct-type)) + (descs (get name 'cl-struct-slots))) + (cl-struct-define name nil (get name 'cl-struct-include) + (unless (and (eq (car type-and-named) 'vector) + (null (cadr type-and-named)) + (assq 'cl-tag-slot descs)) + (car type-and-named)) + (cadr type-and-named) + descs + (intern (format "cl-struct-%s-tags" name)) + tag + (get name 'cl-struct-print)) + (cl--find-class name))))) + +(defun cl--plist-remove (plist member) + (cond + ((null plist) nil) + ((null member) plist) + ((eq plist member) (cddr plist)) + (t `(,(car plist) ,(cadr plist) ,@(cl--plist-remove (cddr plist) member))))) + +(defun cl--struct-register-child (parent tag) + ;; Can't use (cl-typep parent 'cl-structure-class) at this stage + ;; because `cl-structure-class' is defined later. + (while (vectorp parent) + (add-to-list (cl--struct-class-children-sym parent) tag) + ;; Only register ourselves as a child of the leftmost parent since structs + ;; can only only have one parent. + (setq parent (car (cl--struct-class-parents parent))))) + +;;;###autoload +(defun cl-struct-define (name docstring parent type named slots children-sym + tag print) + (cl-assert (or type (not named))) + (if (boundp children-sym) + (add-to-list children-sym tag) + (set children-sym (list tag))) + (and (null type) (eq (caar slots) 'cl-tag-slot) + ;; Hide the tag slot from "standard" (i.e. non-`type'd) structs. + (setq slots (cdr slots))) + (let* ((parent-class (when parent (cl--struct-get-class parent))) + (n (length slots)) + (index-table (make-hash-table :test 'eq :size n)) + (vslots (let ((v (make-vector n nil)) + (i 0) + (offset (if type 0 1))) + (dolist (slot slots) + (let* ((props (cddr slot)) + (typep (plist-member props :type)) + (type (if typep (cadr typep) t))) + (aset v i (cl--make-slot-desc + (car slot) (nth 1 slot) + type (cl--plist-remove props typep)))) + (puthash (car slot) (+ i offset) index-table) + (cl-incf i)) + v)) + (class (cl--struct-new-class + name docstring + (unless (symbolp parent-class) (list parent-class)) + type named vslots index-table children-sym tag print))) + (unless (symbolp parent-class) + (let ((pslots (cl--struct-class-slots parent-class))) + (or (>= n (length pslots)) + (let ((ok t)) + (dotimes (i (length pslots)) + (unless (eq (cl--slot-descriptor-name (aref pslots i)) + (cl--slot-descriptor-name (aref vslots i))) + (setq ok nil))) + ok) + (error "Included struct %S has changed since compilation of %S" + parent name)))) + (cl--struct-register-child parent-class tag) + (unless (eq named t) + (eval `(defconst ,tag ',class) t) + ;; In the cl-generic support, we need to be able to check + ;; if a vector is a cl-struct object, without knowing its particular type. + ;; So we use the (otherwise) unused function slots of the tag symbol + ;; to put a special witness value, to make the check easy and reliable. + (fset tag :quick-object-witness-check)) + (setf (cl--find-class name) class))) + +(cl-defstruct (cl-structure-class + (:conc-name cl--struct-class-) + (:predicate cl--struct-class-p) + (:constructor nil) + (:constructor cl--struct-new-class + (name docstring parents type named slots index-table + children-sym tag print)) + (:copier nil)) + "The type of CL structs descriptors." + ;; The first few fields here are actually inherited from cl--class, but we + ;; have to define this one before, to break the circularity, so we manually + ;; list the fields here and later "backpatch" cl--class as the parent. + ;; BEWARE: Obviously, it's indispensable to keep these two structs in sync! + (name nil :type symbol) ;The type name. + (docstring nil :type string) + (parents nil :type (list-of cl--class)) ;The included struct. + (slots nil :type (vector cl--slot-descriptor)) + (index-table nil :type hash-table) + (tag nil :type symbol) ;Placed in cl-tag-slot. Holds the struct-class object. + (type nil :type (memq (vector list))) + (named nil :type bool) + (print nil :type bool) + (children-sym nil :type symbol) ;This sym's value holds the tags of children. + ) + +(cl-defstruct (cl-structure-object + (:predicate cl-struct-p) + (:constructor nil) + (:copier nil)) + "The root parent of all \"normal\" CL structs") + +(setq cl--struct-default-parent 'cl-structure-object) + +(cl-defstruct (cl-slot-descriptor + (:conc-name cl--slot-descriptor-) + (:constructor nil) + (:constructor cl--make-slot-descriptor + (name &optional initform type props)) + (:copier cl--copy-slot-descriptor)) + ;; FIXME: This is actually not used yet, for circularity reasons! + "Descriptor of structure slot." + name ;Attribute name (symbol). + initform + type + ;; Extra properties, kept in an alist, can include: + ;; :documentation, :protection, :custom, :label, :group, :printer. + (props nil :type alist)) + +(cl-defstruct (cl--class + (:constructor nil) + (:copier nil)) + "Type of descriptors for any kind of structure-like data." + ;; Intended to be shared between defstruct and defclass. + (name nil :type symbol) ;The type name. + (docstring nil :type string) + (parents nil :type (or cl--class (list-of cl--class))) + (slots nil :type (vector cl-slot-descriptor)) + (index-table nil :type hash-table)) + +(cl-assert + (let ((sc-slots (cl--struct-class-slots (cl--find-class 'cl-structure-class))) + (c-slots (cl--struct-class-slots (cl--find-class 'cl--class))) + (eq t)) + (dotimes (i (length c-slots)) + (let ((sc-slot (aref sc-slots i)) + (c-slot (aref c-slots i))) + (unless (eq (cl--slot-descriptor-name sc-slot) + (cl--slot-descriptor-name c-slot)) + (setq eq nil)))) + eq)) + +;; Close the recursion between cl-structure-object and cl-structure-class. +(setf (cl--struct-class-parents (cl--find-class 'cl-structure-class)) + (list (cl--find-class 'cl--class))) +(cl--struct-register-child + (cl--find-class 'cl--class) + (cl--struct-class-tag (cl--find-class 'cl-structure-class))) + +(cl-assert (cl--find-class 'cl-structure-class)) +(cl-assert (cl--find-class 'cl-structure-object)) +(cl-assert (cl-struct-p (cl--find-class 'cl-structure-class))) +(cl-assert (cl-struct-p (cl--find-class 'cl-structure-object))) +(cl-assert (cl--class-p (cl--find-class 'cl-structure-class))) +(cl-assert (cl--class-p (cl--find-class 'cl-structure-object))) + ;; Make sure functions defined with cl-defsubst can be inlined even in ;; packages which do not require CL. We don't put an autoload cookie ;; directly on that function, since those cookies only go to cl-loaddefs. diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 8c1440d02f3..83213285d4e 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -106,10 +106,10 @@ This is to optimize `debugger-make-xrefs'.") "Non-nil if we expect to get back in the debugger soon.") (defvar inhibit-debug-on-entry nil - "Non-nil means that debug-on-entry is disabled.") + "Non-nil means that `debug-on-entry' is disabled.") (defvar debugger-jumping-flag nil - "Non-nil means that debug-on-entry is disabled. + "Non-nil means that `debug-on-entry' is disabled. This variable is used by `debugger-jump', `debugger-step-through', and `debugger-reenable' to temporarily disable debug-on-entry.") @@ -165,7 +165,6 @@ first will be printed into the backtrace buffer." ;; Don't let these magic variables affect the debugger itself. (let ((last-command nil) this-command track-mouse (inhibit-trace t) - (inhibit-debug-on-entry t) unread-command-events unread-post-input-method-events last-input-event last-command-event last-nonmenu-event @@ -763,7 +762,8 @@ A call to this function is inserted by `debug-on-entry' to cause functions to break on entry." (if (or inhibit-debug-on-entry debugger-jumping-flag) nil - (funcall debugger 'debug))) + (let ((inhibit-debug-on-entry t)) + (funcall debugger 'debug)))) ;;;###autoload (defun debug-on-entry (function) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 68bf4f62c34..f0410f87447 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -465,6 +465,8 @@ itself or not." (defvar macroexp--pending-eager-loads nil "Stack of files currently undergoing eager macro-expansion.") +(defvar macroexp--debug-eager nil) + (defun internal-macroexpand-for-load (form full-p) ;; Called from the eager-macroexpansion in readevalloop. (cond @@ -480,8 +482,10 @@ itself or not." (tail (member elem (cdr (member elem bt))))) (if tail (setcdr tail (list '…))) (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) - (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" - (mapconcat #'prin1-to-string (nreverse bt) " => ")) + (if macroexp--debug-eager + (debug 'eager-macroexp-cycle) + (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" + (mapconcat #'prin1-to-string (nreverse bt) " => "))) (push 'skip macroexp--pending-eager-loads) form)) (t diff --git a/lwlib/ChangeLog b/lwlib/ChangeLog index c98d72575a8..e5dfed2342a 100644 --- a/lwlib/ChangeLog +++ b/lwlib/ChangeLog @@ -1,3 +1,7 @@ +2015-03-18 Stefan Monnier + + * xlwmenu.c (pop_up_menu): Remove debugging code. + 2015-02-28 Jan Djärv * xlwmenu.c (remap_menubar): Re-realize menu to force move under diff --git a/lwlib/xlwmenu.c b/lwlib/xlwmenu.c index f781b7ee54c..9317dea02b0 100644 --- a/lwlib/xlwmenu.c +++ b/lwlib/xlwmenu.c @@ -1719,7 +1719,7 @@ make_shadow_gcs (XlwMenuWidget mw) 1.2, 0x8000)) #else XQueryColor (dpy, cmap, &topc); - /* don't overflow/wrap! */ + /* Don't overflow/wrap! */ topc.red = MINL (65535, topc.red * 1.2); topc.green = MINL (65535, topc.green * 1.2); topc.blue = MINL (65535, topc.blue * 1.2); @@ -1780,8 +1780,8 @@ make_shadow_gcs (XlwMenuWidget mw) } } - if (!mw->menu.top_shadow_pixmap && - mw->menu.top_shadow_color == mw->core.background_pixel) + if (!mw->menu.top_shadow_pixmap + && mw->menu.top_shadow_color == mw->core.background_pixel) { mw->menu.top_shadow_pixmap = mw->menu.gray_pixmap; if (mw->menu.free_top_shadow_color_p) @@ -1791,8 +1791,8 @@ make_shadow_gcs (XlwMenuWidget mw) } mw->menu.top_shadow_color = mw->menu.foreground; } - if (!mw->menu.bottom_shadow_pixmap && - mw->menu.bottom_shadow_color == mw->core.background_pixel) + if (!mw->menu.bottom_shadow_pixmap + && mw->menu.bottom_shadow_color == mw->core.background_pixel) { mw->menu.bottom_shadow_pixmap = mw->menu.gray_pixmap; if (mw->menu.free_bottom_shadow_color_p) @@ -1856,7 +1856,7 @@ openXftFont (XlwMenuWidget mw) if (fname && strcmp (fname, "none") != 0) { int screen = XScreenNumberOfScreen (mw->core.screen); - int len = strlen (fname), i = len-1; + int len = strlen (fname), i = len - 1; /* Try to convert Gtk-syntax (Sans 9) to Xft syntax Sans-9. */ while (i > 0 && '0' <= fname[i] && fname[i] <= '9') --i; @@ -1880,7 +1880,7 @@ openXftFont (XlwMenuWidget mw) static void XlwMenuInitialize (Widget request, Widget w, ArgList args, Cardinal *num_args) { - /* Get the GCs and the widget size */ + /* Get the GCs and the widget size. */ XlwMenuWidget mw = (XlwMenuWidget) w; Window window = RootWindowOfScreen (DefaultScreenOfDisplay (XtDisplay (mw))); Display* display = XtDisplay (mw); @@ -2014,7 +2014,7 @@ XlwMenuRealize (Widget w, Mask *valueMask, XSetWindowAttributes *attributes) /* Only the toplevel menubar/popup is a widget so it's the only one that receives expose events through Xt. So we repaint all the other panes - when receiving an Expose event. */ + when receiving an Expose event. */ static void XlwMenuRedisplay (Widget w, XEvent *ev, Region region) { @@ -2056,14 +2056,14 @@ XlwMenuDestroy (Widget w) release_drawing_gcs (mw); release_shadow_gcs (mw); - /* this doesn't come from the resource db but is created explicitly - so we must free it ourselves. */ + /* This doesn't come from the resource db but is created explicitly + so we must free it ourselves. */ XFreePixmap (XtDisplay (mw), mw->menu.gray_pixmap); mw->menu.gray_pixmap = (Pixmap) -1; /* Don't free mw->menu.contents because that comes from our creator. The `*_stack' elements are just pointers into `contents' so leave - that alone too. But free the stacks themselves. */ + that alone too. But free the stacks themselves. */ if (mw->menu.old_stack) XtFree ((char *) mw->menu.old_stack); if (mw->menu.new_stack) XtFree ((char *) mw->menu.new_stack); @@ -2093,7 +2093,7 @@ XlwMenuDestroy (Widget w) if (mw->menu.windows [0].pixmap != None) XFreePixmap (XtDisplay (mw), mw->menu.windows [0].pixmap); - /* start from 1 because the one in slot 0 is w->core.window */ + /* Start from 1 because the one in slot 0 is w->core.window. */ for (i = 1; i < mw->menu.windows_length; i++) { if (mw->menu.windows [i].pixmap != None) @@ -2170,7 +2170,7 @@ XlwMenuSetValues (Widget current, Widget request, Widget new, XSetWindowBackground (XtDisplay (oldmw), oldmw->menu.windows [i].window, newmw->core.background_pixel); - /* clear windows and generate expose events */ + /* Clear windows and generate expose events. */ XClearArea (XtDisplay (oldmw), oldmw->menu.windows[i].window, 0, 0, 0, 0, True); } @@ -2244,7 +2244,7 @@ handle_single_motion_event (XlwMenuWidget mw, XMotionEvent *ev) set_new_state (mw, val, level); remap_menubar (mw); - /* Sync with the display. Makes it feel better on X terms. */ + /* Sync with the display. Makes it feel better on X terms. */ XSync (XtDisplay (mw), False); } @@ -2256,7 +2256,7 @@ handle_motion_event (XlwMenuWidget mw, XMotionEvent *ev) int state = ev->state; XMotionEvent oldev = *ev; - /* allow motion events to be generated again */ + /* Allow motion events to be generated again. */ if (ev->is_hint && XQueryPointer (XtDisplay (mw), ev->window, &ev->root, &ev->subwindow, @@ -2293,11 +2293,11 @@ Start (Widget w, XEvent *ev, String *params, Cardinal *num_params) releasing the button should always pop the menu down. */ next_release_must_exit = 1; - /* notes the absolute position of the menubar window */ + /* Notes the absolute position of the menubar window. */ mw->menu.windows [0].x = ev->xmotion.x_root - ev->xmotion.x; mw->menu.windows [0].y = ev->xmotion.y_root - ev->xmotion.y; - /* handles the down like a move, slots are compatible */ + /* Handles the down like a move, slots are compatible. */ ev->xmotion.is_hint = 0; handle_motion_event (mw, &ev->xmotion); } @@ -2327,7 +2327,7 @@ find_first_selectable (XlwMenuWidget mw, widget_value *item, int skip_titles) while (lw_separator_p (current->name, &separator, 0) || !current->enabled || (skip_titles && !current->call_data && !current->contents)) if (current->next) - current=current->next; + current = current->next; else return NULL; @@ -2340,9 +2340,9 @@ find_next_selectable (XlwMenuWidget mw, widget_value *item, int skip_titles) widget_value *current = item; enum menu_separator separator; - while (current->next && (current=current->next) && - (lw_separator_p (current->name, &separator, 0) || !current->enabled - || (skip_titles && !current->call_data && !current->contents))) + while (current->next && (current = current->next) + && (lw_separator_p (current->name, &separator, 0) || !current->enabled + || (skip_titles && !current->call_data && !current->contents))) ; if (current == item) @@ -2357,7 +2357,7 @@ find_next_selectable (XlwMenuWidget mw, widget_value *item, int skip_titles) && !current->contents)) { if (current->next) - current=current->next; + current = current->next; if (current == item) break; @@ -2374,12 +2374,12 @@ find_prev_selectable (XlwMenuWidget mw, widget_value *item, int skip_titles) widget_value *current = item; widget_value *prev = item; - while ((current=find_next_selectable (mw, current, skip_titles)) + while ((current = find_next_selectable (mw, current, skip_titles)) != item) { if (prev == current) break; - prev=current; + prev = current; } return prev; @@ -2560,7 +2560,7 @@ Select (Widget w, XEvent *ev, String *params, Cardinal *num_params) < XtGetMultiClickTime (XtDisplay (w)))) return; - /* pop down everything. */ + /* Pop down everything. */ mw->menu.new_depth = 1; remap_menubar (mw); @@ -2582,7 +2582,7 @@ Select (Widget w, XEvent *ev, String *params, Cardinal *num_params) } - /* Special code to pop-up a menu */ + /* Special code to pop-up a menu. */ static void pop_up_menu (XlwMenuWidget mw, XButtonPressedEvent *event) { @@ -2619,14 +2619,14 @@ pop_up_menu (XlwMenuWidget mw, XButtonPressedEvent *event) mw->menu.popped_up = True; if (XtIsShell (XtParent ((Widget)mw))) { - fprintf(stderr, "Config %d %d\n", x, y); + /* fprintf (stderr, "Config %d %d\n", x, y); */ XtConfigureWidget (XtParent ((Widget)mw), x, y, w, h, XtParent ((Widget)mw)->core.border_width); XtPopup (XtParent ((Widget)mw), XtGrabExclusive); display_menu (mw, 0, False, NULL, NULL, NULL); mw->menu.windows [0].x = x + borderwidth; mw->menu.windows [0].y = y + borderwidth; - mw->menu.top_depth = 1; /* Popup menus don't have a bar so top is 1 */ + mw->menu.top_depth = 1; /* Popup menus don't have a bar so top is 1. */ } else { @@ -2634,7 +2634,7 @@ pop_up_menu (XlwMenuWidget mw, XButtonPressedEvent *event) XtAddGrab ((Widget) mw, True, True); - /* notes the absolute position of the menubar window */ + /* Notes the absolute position of the menubar window. */ mw->menu.windows [0].x = ev->xmotion.x_root - ev->xmotion.x; mw->menu.windows [0].y = ev->xmotion.y_root - ev->xmotion.y; mw->menu.top_depth = 2; diff --git a/src/ChangeLog b/src/ChangeLog index fbf8fb452fc..1b1a9c59033 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,7 @@ +2015-03-18 Stefan Monnier + + * alloc.c (purecopy): Handle hash-tables. + 2015-03-16 Stefan Monnier * minibuf.c (Fread_buffer): Add `predicate' argument. @@ -6,13 +10,11 @@ 2015-03-15 Eli Zaretskii * xdisp.c (handle_invisible_prop): Fix up it->position even when - we are going to load overlays at the beginning of the invisible - text. + we are going to load overlays at the beginning of the invisible text. (setup_for_ellipsis): Reset the ignore_overlay_strings_at_pos_p flag also here. (next_overlay_string): Set the overlay_strings_at_end_processed_p - flag only if the overlays just processed were actually loaded at - EOB. + flag only if the overlays just processed were actually loaded at EOB. 2015-03-14 Daniel Colascione @@ -183,8 +185,8 @@ 2015-02-28 Martin Rudalics - * frame.c (make_initial_frame, Fmake_terminal_frame): Set - can_x_set_window_size and after_make_frame (Bug#19962). + * frame.c (make_initial_frame, Fmake_terminal_frame): + Set can_x_set_window_size and after_make_frame (Bug#19962). 2015-02-28 Eli Zaretskii @@ -454,8 +456,8 @@ * indent.c (Fvertical_motion): Accept an additional argument CUR-COL and use it as the starting screen coordinate. - * window.c (window_scroll_line_based, Fmove_to_window_line): All - callers of vertical-motion changed. + * window.c (window_scroll_line_based, Fmove_to_window_line): + All callers of vertical-motion changed. 2015-02-09 Dima Kogan diff --git a/src/alloc.c b/src/alloc.c index 022782504f1..1f4b1a4694e 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3423,7 +3423,7 @@ union aligned_Lisp_Misc }; /* Allocation of markers and other objects that share that structure. - Works like allocation of conses. */ + Works like allocation of conses. */ #define MARKER_BLOCK_SIZE \ ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc)) @@ -4744,7 +4744,7 @@ mark_maybe_pointer (void *p) #endif /* Mark Lisp objects referenced from the address range START+OFFSET..END - or END+OFFSET..START. */ + or END+OFFSET..START. */ static void ATTRIBUTE_NO_SANITIZE_ADDRESS mark_memory (void *start, void *end) @@ -5356,7 +5356,6 @@ make_pure_vector (ptrdiff_t len) return new; } - DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0, doc: /* Make a copy of object OBJ in pure storage. Recursively copies contents of vectors and cons cells. @@ -5391,28 +5390,26 @@ purecopy (Lisp_Object obj) else if (FLOATP (obj)) obj = make_pure_float (XFLOAT_DATA (obj)); else if (STRINGP (obj)) - obj = make_pure_string (SSDATA (obj), SCHARS (obj), - SBYTES (obj), - STRING_MULTIBYTE (obj)); - else if (COMPILEDP (obj) || VECTORP (obj)) { - register struct Lisp_Vector *vec; + if (XSTRING (obj)->intervals) + message ("Dropping text-properties when making string pure"); + obj = make_pure_string (SSDATA (obj), SCHARS (obj), + SBYTES (obj), + STRING_MULTIBYTE (obj)); + } + else if (COMPILEDP (obj) || VECTORP (obj) || HASH_TABLE_P (obj)) + { + struct Lisp_Vector *objp = XVECTOR (obj); + ptrdiff_t nbytes = vector_nbytes (objp); + struct Lisp_Vector *vec = pure_alloc (nbytes, Lisp_Vectorlike); register ptrdiff_t i; - ptrdiff_t size; - - size = ASIZE (obj); + ptrdiff_t size = ASIZE (obj); if (size & PSEUDOVECTOR_FLAG) size &= PSEUDOVECTOR_SIZE_MASK; - vec = XVECTOR (make_pure_vector (size)); + memcpy (vec, objp, nbytes); for (i = 0; i < size; i++) - vec->contents[i] = purecopy (AREF (obj, i)); - if (COMPILEDP (obj)) - { - XSETPVECTYPE (vec, PVEC_COMPILED); - XSETCOMPILED (obj, vec); - } - else - XSETVECTOR (obj, vec); + vec->contents[i] = purecopy (vec->contents[i]); + XSETVECTOR (obj, vec); } else if (SYMBOLP (obj)) { @@ -5422,6 +5419,7 @@ purecopy (Lisp_Object obj) XSYMBOL (obj)->pinned = true; symbol_block_pinned = symbol_block; } + /* Don't hash-cons it. */ return obj; } else @@ -6229,13 +6227,14 @@ mark_discard_killed_buffers (Lisp_Object list) void mark_object (Lisp_Object arg) { - register Lisp_Object obj = arg; + register Lisp_Object obj; void *po; #ifdef GC_CHECK_MARKED_OBJECTS struct mem_node *m; #endif ptrdiff_t cdr_count = 0; + obj = arg; loop: po = XPNTR (obj); @@ -6870,7 +6869,7 @@ sweep_symbols (void) total_free_symbols = num_free; } -NO_INLINE /* For better stack traces */ +NO_INLINE /* For better stack traces. */ static void sweep_misc (void) { -- cgit v1.2.3 From 8dfff871bdf0e420c6f5570e72afc80471d40d51 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 18 Mar 2015 10:49:55 -0400 Subject: * cl-generic.el (cl-generic-generalizers): Clean up after braindamage --- lisp/emacs-lisp/cl-generic.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index c9ca92d7c09..fb11a3e25a1 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -903,8 +903,8 @@ Can only be used from within the lexical body of a primary or around method." ;; take place without requiring cl-lib. (let ((class (cl--find-class type))) (and (cl-typep class 'cl-structure-class) - (when (cl--struct-class-type class) - (error "Can't dispatch on cl-struct %S: type is %S" + (or (null (cl--struct-class-type class)) + (error "Can't dispatch on cl-struct %S: type is %S" type (cl--struct-class-type class))) (progn (cl-assert (null (cl--struct-class-named class))) t) (list cl--generic-struct-generalizer)))) -- cgit v1.2.3 From 50c117fe86d94719807cbe08353c032779b3b910 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 18 Mar 2015 23:02:26 -0400 Subject: EIEIO: Change class's representation to unify instance & class slots * lisp/emacs-lisp/eieio-core.el (eieio--class): Change field names and order to match those of cl--class; use cl--slot for both instance slots and class slots. (eieio--object-num-slots): Use cl-struct-slot-info. (eieio--object-class): Rename from eieio--object-class-object. (eieio--object-class-name): Remove. (eieio-defclass-internal): Adjust to new slot representation. Store doc in class rather than in `variable-documentation'. (eieio--perform-slot-validation-for-default): Change API to take a slot object. (eieio--slot-override): New function. (eieio--add-new-slot): Rewrite. (eieio-copy-parents-into-subclass): Rewrite. (eieio--validate-slot-value, eieio--validate-class-slot-value) (eieio-oref-default, eieio-oset-default) (eieio--class-slot-name-index, eieio-set-defaults): Adjust to new slot representation. (eieio--c3-merge-lists): Simplify. (eieio--class/struct-parents): New function. (eieio--class-precedence-bfs): Use it. * lisp/emacs-lisp/eieio.el (with-slots): Use macroexp-let2. (object-class-fast): Change recommend replacement. (eieio-object-class): Rewrite. (slot-exists-p): Adjust to new slot representation. (initialize-instance): Adjust to new slot representation. (object-write): Adjust to new slot representation. * lisp/emacs-lisp/eieio-base.el (eieio-persistent-convert-list-to-object): Manually map initargs to slot names. (eieio-persistent-validate/fix-slot-value): Adjust to new slot representation. * lisp/emacs-lisp/eieio-compat.el (eieio--generic-static-symbol-specializers): Extract from eieio--generic-static-symbol-generalizer. (eieio--generic-static-symbol-generalizer): Use it. * lisp/emacs-lisp/eieio-custom.el (eieio-object-value-create) (eieio-object-value-get): Adjust to new slot representation. * lisp/emacs-lisp/eieio-datadebug.el (data-debug/eieio-insert-slots): Declare to silence warnings. (data-debug-insert-object-button): Avoid `object-slots'. (data-debug/eieio-insert-slots): Adjust to new slot representation. * lisp/emacs-lisp/eieio-opt.el (eieio--help-print-slot): New function extracted from eieio-help-class-slots. (eieio-help-class-slots): Use it. Adjust to new slot representation. * test/automated/eieio-test-methodinvoke.el (make-instance): Use new-style `subclass' specializer for a change. * test/automated/eieio-test-persist.el (persist-test-save-and-compare): Adjust to new slot representation. * test/automated/eieio-tests.el (eieio-test-17-virtual-slot): Don't use initarg in `oset'. (eieio-test-32-slot-attribute-override-2): Adjust to new slot representation. * lisp/emacs-lisp/cl-preloaded.el (cl--class): Fix type of `parents'. --- lisp/ChangeLog | 54 +++ lisp/emacs-lisp/cl-preloaded.el | 4 +- lisp/emacs-lisp/eieio-base.el | 36 +- lisp/emacs-lisp/eieio-compat.el | 21 +- lisp/emacs-lisp/eieio-core.el | 632 ++++++++++++------------------ lisp/emacs-lisp/eieio-custom.el | 161 ++++---- lisp/emacs-lisp/eieio-datadebug.el | 68 ++-- lisp/emacs-lisp/eieio-opt.el | 90 ++--- lisp/emacs-lisp/eieio.el | 132 ++++--- test/ChangeLog | 13 + test/automated/eieio-test-methodinvoke.el | 2 +- test/automated/eieio-test-persist.el | 17 +- test/automated/eieio-tests.el | 57 ++- 13 files changed, 583 insertions(+), 704 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index e75f81ba75a..7c751f4e8e8 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,57 @@ +2015-03-19 Stefan Monnier + + * emacs-lisp/eieio.el (with-slots): Use macroexp-let2. + (object-class-fast): Change recommend replacement. + (eieio-object-class): Rewrite. + (slot-exists-p): Adjust to new slot representation. + (initialize-instance): Adjust to new slot representation. + (object-write): Adjust to new slot representation. + + * emacs-lisp/eieio-opt.el (eieio--help-print-slot): New function + extracted from eieio-help-class-slots. + (eieio-help-class-slots): Use it. Adjust to new slot representation. + + * emacs-lisp/eieio-datadebug.el (data-debug/eieio-insert-slots): + Declare to silence warnings. + (data-debug-insert-object-button): Avoid `object-slots'. + (data-debug/eieio-insert-slots): Adjust to new slot representation. + + * emacs-lisp/eieio-custom.el (eieio-object-value-create) + (eieio-object-value-get): Adjust to new slot representation. + + EIEIO: Change class's representation to unify instance and class slots + * emacs-lisp/eieio-core.el (eieio--class): Change field names and order + to match those of cl--class; use cl--slot for both instance slots and + class slots. + (eieio--object-num-slots): Use cl-struct-slot-info. + (eieio--object-class): Rename from eieio--object-class-object. + (eieio--object-class-name): Remove. + (eieio-defclass-internal): Adjust to new slot representation. + Store doc in class rather than in `variable-documentation'. + (eieio--perform-slot-validation-for-default): Change API to take + a slot object. + (eieio--slot-override): New function. + (eieio--add-new-slot): Rewrite. + (eieio-copy-parents-into-subclass): Rewrite. + (eieio--validate-slot-value, eieio--validate-class-slot-value) + (eieio-oref-default, eieio-oset-default) + (eieio--class-slot-name-index, eieio-set-defaults): Adjust to new + slot representation. + (eieio--c3-merge-lists): Simplify. + (eieio--class/struct-parents): New function. + (eieio--class-precedence-bfs): Use it. + + * emacs-lisp/eieio-compat.el (eieio--generic-static-symbol-specializers): + Extract from eieio--generic-static-symbol-generalizer. + (eieio--generic-static-symbol-generalizer): Use it. + + * emacs-lisp/eieio-base.el (eieio-persistent-convert-list-to-object): + Manually map initargs to slot names. + (eieio-persistent-validate/fix-slot-value): Adjust to new + slot representation. + + * emacs-lisp/cl-preloaded.el (cl--class): Fix type of `parents'. + 2015-03-19 Vibhav Pant * lisp/leim/quail/hangul.el diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index a18e0e57b05..ed0639b63ab 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -212,7 +212,9 @@ ;; Intended to be shared between defstruct and defclass. (name nil :type symbol) ;The type name. (docstring nil :type string) - (parents nil :type (or cl--class (list-of cl--class))) + ;; For structs there can only be one parent, but when EIEIO classes inherit + ;; from cl--class, we'll need this to hold a list. + (parents nil :type (list-of cl--class)) (slots nil :type (vector cl-slot-descriptor)) (index-table nil :type hash-table)) diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 1cc9f895f8a..5b3d9029c53 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -254,25 +254,28 @@ malicious code. Note: This function recurses when a slot of :type of some object is identified, and needing more object creation." - (let ((objclass (nth 0 inputlist)) - ;; (objname (nth 1 inputlist)) - (slots (nthcdr 2 inputlist)) - (createslots nil)) - - ;; If OBJCLASS is an eieio autoload object, then we need to load it. - (eieio-class-un-autoload objclass) + (let* ((objclass (nth 0 inputlist)) + ;; (objname (nth 1 inputlist)) + (slots (nthcdr 2 inputlist)) + (createslots nil) + (class + (progn + ;; If OBJCLASS is an eieio autoload object, then we need to + ;; load it. + (eieio-class-un-autoload objclass) + (eieio--class-object objclass)))) (while slots - (let ((name (car slots)) + (let ((initarg (car slots)) (value (car (cdr slots)))) ;; Make sure that the value proposed for SLOT is valid. ;; In addition, strip out quotes, list functions, and update ;; object constructors as needed. (setq value (eieio-persistent-validate/fix-slot-value - (eieio--class-v objclass) name value)) + class (eieio--initarg-to-attribute class initarg) value)) - (push name createslots) + (push initarg createslots) (push value createslots) ) @@ -290,16 +293,11 @@ constructor functions are considered valid. Second, any text properties will be stripped from strings." (cond ((consp proposed-value) ;; Lists with something in them need special treatment. - (let ((slot-idx (eieio--slot-name-index class slot)) - (type nil) - (classtype nil)) - (setq slot-idx (- slot-idx + (let* ((slot-idx (- (eieio--slot-name-index class slot) (eval-when-compile eieio--object-num-slots))) - (setq type (aref (eieio--class-public-type class) - slot-idx)) - - (setq classtype (eieio-persistent-slot-type-is-class-p - type)) + (type (cl--slot-descriptor-type (aref (eieio--class-slots class) + slot-idx))) + (classtype (eieio-persistent-slot-type-is-class-p type))) (cond ((eq (car proposed-value) 'quote) (car (cdr proposed-value))) diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index ee8e731b043..0283704e033 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el @@ -124,19 +124,22 @@ Summary: (defgeneric ,method ,args) (eieio--defmethod ',method ',key ',class #',code)))) +(defun eieio--generic-static-symbol-specializers (tag) + (cl-assert (or (null tag) (eieio--class-p tag))) + (when (eieio--class-p tag) + (let ((superclasses (eieio--generic-subclass-specializers tag)) + (specializers ())) + (dolist (superclass superclasses) + (push superclass specializers) + (push `(eieio--static ,(cadr superclass)) specializers)) + (nreverse specializers)))) + (defconst eieio--generic-static-symbol-generalizer (cl-generic-make-generalizer ;; Give it a slightly higher priority than `subclass' so that the ;; interleaved list comes before subclass's non-interleaved list. 61 (lambda (name) `(and (symbolp ,name) (eieio--class-v ,name))) - (lambda (tag) - (when (eieio--class-p tag) - (let ((superclasses (eieio--generic-subclass-specializers tag)) - (specializers ())) - (dolist (superclass superclasses) - (push superclass specializers) - (push `(eieio--static ,(cadr superclass)) specializers)) - (nreverse specializers)))))) + #'eieio--generic-static-symbol-specializers)) (defconst eieio--generic-static-object-generalizer (cl-generic-make-generalizer ;; Give it a slightly higher priority than `class' so that the @@ -148,7 +151,7 @@ Summary: (let ((superclasses (eieio--class-precedence-list tag)) (specializers ())) (dolist (superclass superclasses) - (setq superclass (eieio--class-symbol superclass)) + (setq superclass (eieio--class-name superclass)) (push superclass specializers) (push `(eieio--static ,superclass) specializers)) (nreverse specializers)))))) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 1e226c154e2..6fd9c14088e 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -85,9 +85,10 @@ Currently under control of this var: ;; Arrange for field access not to bother checking if the access is indeed ;; made to an eieio--class object. (cl-declaim (optimize (safety 0))) + (cl-defstruct (eieio--class (:constructor nil) - (:constructor eieio--class-make (symbol &aux (tag 'defclass))) + (:constructor eieio--class-make (name &aux (tag 'defclass))) (:type vector) (:copier nil)) ;; We use an untagged cl-struct, with our own hand-made tag as first field @@ -96,30 +97,16 @@ Currently under control of this var: ;; predicate for us), but that breaks compatibility with .elc files compiled ;; against older versions of EIEIO. tag - symbol ;; symbol (self-referencing) - parent children - symbol-hashtable ;; hashtable permitting fast access to variable position indexes - ;; @todo - ;; the word "public" here is leftovers from the very first version. - ;; Get rid of it! - public-a ;; class attribute index - public-d ;; class attribute defaults index - public-doc ;; class documentation strings for attributes - public-type ;; class type for a slot - public-custom ;; class custom type for a slot - public-custom-label ;; class custom group for a slot - public-custom-group ;; class custom group for a slot - public-printer ;; printer for a slot - protection ;; protection for a slot + ;; Fields we could inherit from cl--class (if we used a tagged cl-struct): + (name nil :type symbol) ;The type name. + (docstring nil :type string) + (parents nil :type (or eieio--class (list-of eieio--class))) + (slots nil :type (vector cl-slot-descriptor)) + (index-table nil :type hash-table) + ;; Fields specific to EIEIO classes: + children initarg-tuples ;; initarg tuples list - class-allocation-a ;; class allocated attributes - class-allocation-doc ;; class allocated documentation - class-allocation-type ;; class allocated value type - class-allocation-custom ;; class allocated custom descriptor - class-allocation-custom-label ;; class allocated custom descriptor - class-allocation-custom-group ;; class allocated custom group - class-allocation-printer ;; class allocated printer for a slot - class-allocation-protection ;; class allocated protection list + (class-slots nil :type eieio--slot) class-allocation-values ;; class allocated value vector default-object-cache ;; what a newly created object would look like. ; This will speed up instantiation time as @@ -142,18 +129,13 @@ Currently under control of this var: ;; object/struct in its `symbol-value' slot. class-tag) -(eval-and-compile +(eval-when-compile (defconst eieio--object-num-slots - (length (get 'eieio--object 'cl-struct-slots)))) + (length (cl-struct-slot-info 'eieio--object)))) -(defsubst eieio--object-class-object (obj) +(defsubst eieio--object-class (obj) (symbol-value (eieio--object-class-tag obj))) -(defsubst eieio--object-class-name (obj) - ;; FIXME: Most uses of this function should be changed to use - ;; eieio--object-class-object instead! - (eieio--class-symbol (eieio--object-class-object obj))) - ;;; Important macros used internally in eieio. @@ -189,7 +171,7 @@ CLASS is a symbol." ;FIXME: Is it a vector or a symbol? "Return a Lisp like symbol name for CLASS." (setq class (eieio--class-object class)) (cl-check-type class eieio--class) - (eieio--class-symbol class)) + (eieio--class-name class)) (define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") (defalias 'eieio--class-constructor #'identity @@ -354,10 +336,10 @@ See `defclass' for more information." (mapc (lambda (g) (cl-pushnew g groups :test #'equal)) (eieio--class-option c :custom-groups)) ;; Save parent in child. - (push c (eieio--class-parent newc)))))) + (push c (eieio--class-parents newc)))))) ;; Reverse the list of our parents so that they are prioritized in ;; the same order as specified in the code. - (cl-callf nreverse (eieio--class-parent newc))) + (cl-callf nreverse (eieio--class-parents newc))) ;; If there is nothing to loop over, then inherit from the ;; default superclass. (unless (eq cname 'eieio-default-superclass) @@ -366,7 +348,7 @@ See `defclass' for more information." ;; save new child in parent (cl-pushnew cname (eieio--class-children eieio-default-superclass)) ;; save parent in child - (setf (eieio--class-parent newc) (list eieio-default-superclass)))) + (setf (eieio--class-parents newc) (list eieio-default-superclass)))) ;; turn this into a usable self-pointing symbol; FIXME: Why? (when eieio-backward-compatibility @@ -442,62 +424,70 @@ See `defclass' for more information." (make-obsolete-variable initarg (format "use '%s instead" initarg) "25.1")))) - ;; The customgroup should be a list of symbols - (cond ((null customg) + ;; The customgroup should be a list of symbols. + (cond ((and (null customg) custom) (setq customg '(default))) ((not (listp customg)) (setq customg (list customg)))) - ;; The customgroup better be a symbol, or list of symbols. - (mapc (lambda (cg) - (if (not (symbolp cg)) - (signal 'invalid-slot-type (list :group cg)))) - customg) + ;; The customgroup better be a list of symbols. + (dolist (cg customg) + (unless (symbolp cg) + (signal 'invalid-slot-type (list :group cg)))) ;; First up, add this slot into our new class. - (eieio--add-new-slot newc name init docstr type custom label customg printer - prot initarg alloc 'defaultoverride skip-nil) + (eieio--add-new-slot + newc (cl--make-slot-descriptor + name init type + `(,@(if docstr `((:documentation . ,docstr))) + ,@(if custom `((:custom . ,custom))) + ,@(if label `((:label . ,label))) + ,@(if customg `((:group . ,customg))) + ,@(if printer `((:printer . ,printer))) + ,@(if prot `((:protection . ,prot))))) + initarg alloc 'defaultoverride skip-nil) ;; We need to id the group, and store them in a group list attribute. (dolist (cg customg) - (cl-pushnew cg groups :test 'equal)) + (cl-pushnew cg groups :test #'equal)) )) ;; Now that everything has been loaded up, all our lists are backwards! - ;; Fix that up now. - (cl-callf nreverse (eieio--class-public-a newc)) - (cl-callf nreverse (eieio--class-public-d newc)) - (cl-callf nreverse (eieio--class-public-doc newc)) - (cl-callf (lambda (types) (apply #'vector (nreverse types))) - (eieio--class-public-type newc)) - (cl-callf nreverse (eieio--class-public-custom newc)) - (cl-callf nreverse (eieio--class-public-custom-label newc)) - (cl-callf nreverse (eieio--class-public-custom-group newc)) - (cl-callf nreverse (eieio--class-public-printer newc)) - (cl-callf nreverse (eieio--class-protection newc)) + ;; Fix that up now and then them into vectors. + (cl-callf (lambda (slots) (apply #'vector (nreverse slots))) + (eieio--class-slots newc)) (cl-callf nreverse (eieio--class-initarg-tuples newc)) ;; The storage for class-class-allocation-type needs to be turned into ;; a vector now. - (cl-callf (lambda (cat) (apply #'vector cat)) - (eieio--class-class-allocation-type newc)) - - ;; Also, take class allocated values, and vectorize them for speed. - (cl-callf (lambda (cavs) (apply #'vector cavs)) - (eieio--class-class-allocation-values newc)) + (cl-callf (lambda (slots) (apply #'vector slots)) + (eieio--class-class-slots newc)) + + ;; Also, setup the class allocated values. + (let* ((slots (eieio--class-class-slots newc)) + (n (length slots)) + (v (make-vector n nil))) + (dotimes (i n) + (setf (aref v i) (eieio-default-eval-maybe + (cl--slot-descriptor-initform (aref slots i))))) + (setf (eieio--class-class-allocation-values newc) v)) ;; Attach slot symbols into a hashtable, and store the index of ;; this slot as the value this table. - (let* ((cnt 0) + (let* ((slots (eieio--class-slots newc)) + ;; (cslots (eieio--class-class-slots newc)) (oa (make-hash-table :test #'eq))) - (dolist (pubsym (eieio--class-public-a newc)) - (setf (gethash pubsym oa) cnt) - (setq cnt (1+ cnt))) - (setf (eieio--class-symbol-hashtable newc) oa)) + ;; (dotimes (cnt (length cslots)) + ;; (setf (gethash (cl--slot-descriptor-name (aref cslots cnt)) oa) (- -1 cnt))) + (dotimes (cnt (length slots)) + (setf (gethash (cl--slot-descriptor-name (aref slots cnt)) oa) cnt)) + (setf (eieio--class-index-table newc) oa)) ;; Set up a specialized doc string. ;; Use stored value since it is calculated in a non-trivial way - (put cname 'variable-documentation - (eieio--class-option-assoc options :documentation)) + (let ((docstring (eieio--class-option-assoc options :documentation))) + (setf (eieio--class-docstring newc) docstring) + (when eieio-backward-compatibility + (put cname 'variable-documentation docstring))) ;; Save the file location where this class is defined. (add-to-list 'current-load-list `(eieio-defclass . ,cname)) @@ -514,10 +504,10 @@ See `defclass' for more information." ;; if this is a superclass, clear out parent (which was set to the ;; default superclass eieio-default-superclass) - (if clearparent (setf (eieio--class-parent newc) nil)) + (if clearparent (setf (eieio--class-parents newc) nil)) ;; Create the cached default object. - (let ((cache (make-vector (+ (length (eieio--class-public-a newc)) + (let ((cache (make-vector (+ (length (eieio--class-slots newc)) (eval-when-compile eieio--object-num-slots)) nil)) ;; We don't strictly speaking need to use a symbol, but the old @@ -544,239 +534,133 @@ See `defclass' for more information." "Whether the default value VAL should be evaluated for use." (and (consp val) (symbolp (car val)) (fboundp (car val)))) -(defun eieio--perform-slot-validation-for-default (slot spec value skipnil) - "For SLOT, signal if SPEC does not match VALUE. -If SKIPNIL is non-nil, then if VALUE is nil return t instead." - (if (not (or (eieio-eval-default-p value) ;FIXME: Why? - eieio-skip-typecheck - (and skipnil (null value)) - (eieio--perform-slot-validation spec value))) - (signal 'invalid-slot-type (list slot spec value)))) - -(defun eieio--add-new-slot (newc a d doc type cust label custg print prot init alloc +(defun eieio--perform-slot-validation-for-default (slot skipnil) + "For SLOT, signal if its type does not match its default value. +If SKIPNIL is non-nil, then if default value is nil return t instead." + (let ((value (cl--slot-descriptor-initform slot)) + (spec (cl--slot-descriptor-type slot))) + (if (not (or (eieio-eval-default-p value) ;FIXME: Why? + eieio-skip-typecheck + (and skipnil (null value)) + (eieio--perform-slot-validation spec value))) + (signal 'invalid-slot-type (list (cl--slot-descriptor-name slot) spec value))))) + +(defun eieio--slot-override (old new skipnil) + (cl-assert (eq (cl--slot-descriptor-name old) (cl--slot-descriptor-name new))) + ;; There is a match, and we must override the old value. + (let* ((a (cl--slot-descriptor-name old)) + (tp (cl--slot-descriptor-type old)) + (d (cl--slot-descriptor-initform new)) + (type (cl--slot-descriptor-type new)) + (oprops (cl--slot-descriptor-props old)) + (nprops (cl--slot-descriptor-props new)) + (custg (alist-get :group nprops))) + ;; If type is passed in, is it the same? + (if (not (eq type t)) + (if (not (equal type tp)) + (error + "Child slot type `%s' does not match inherited type `%s' for `%s'" + type tp a)) + (setf (cl--slot-descriptor-type new) tp)) + ;; If we have a repeat, only update the initarg... + (unless (eq d eieio-unbound) + (eieio--perform-slot-validation-for-default new skipnil) + (setf (cl--slot-descriptor-initform old) d)) + + ;; PLN Tue Jun 26 11:57:06 2007 : The protection is + ;; checked and SHOULD match the superclass + ;; protection. Otherwise an error is thrown. However + ;; I wonder if a more flexible schedule might be + ;; implemented. + ;; + ;; EML - We used to have (if prot... here, + ;; but a prot of 'nil means public. + ;; + (let ((super-prot (alist-get :protection oprops)) + (prot (alist-get :protection nprops))) + (if (not (eq prot super-prot)) + (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" + prot super-prot a))) + ;; End original PLN + + ;; PLN Tue Jun 26 11:57:06 2007 : + ;; Do a non redundant combination of ancient custom + ;; groups and new ones. + (when custg + (let* ((list1 (alist-get :group oprops))) + (dolist (elt custg) + (unless (memq elt list1) + (push elt list1))) + (setf (alist-get :group (cl--slot-descriptor-props old)) list1))) + ;; End PLN + + ;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is + ;; set, simply replaces the old one. + (dolist (prop '(:custom :label :documentation :printer)) + (when (alist-get prop (cl--slot-descriptor-props new)) + (setf (alist-get prop (cl--slot-descriptor-props old)) + (alist-get prop (cl--slot-descriptor-props new)))) + + ) )) + +(defun eieio--add-new-slot (newc slot init alloc &optional defaultoverride skipnil) - "Add into NEWC attribute A. -If A already exists in NEWC, then do nothing. If it doesn't exist, -then also add in D (default), DOC, TYPE, CUST, LABEL, CUSTG, PRINT, PROT, and INIT arg. + "Add into NEWC attribute SLOT. +If a slot of that name already exists in NEWC, then do nothing. If it doesn't exist, +INIT is the initarg, if any. Argument ALLOC specifies if the slot is allocated per instance, or per class. If optional DEFAULTOVERRIDE is non-nil, then if A exists in NEWC, we must override its value for a default. Optional argument SKIPNIL indicates if type checking should be skipped if default value is nil." ;; Make sure we duplicate those items that are sequences. + (let* ((a (cl--slot-descriptor-name slot)) + (d (cl--slot-descriptor-initform slot)) + (old (car (cl-member a (eieio--class-slots newc) + :key #'cl--slot-descriptor-name))) + (cold (car (cl-member a (eieio--class-class-slots newc) + :key #'cl--slot-descriptor-name)))) (condition-case nil (if (sequencep d) (setq d (copy-sequence d))) - ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's skip it if it doesn't work. + ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's + ;; skip it if it doesn't work. (error nil)) - (if (sequencep type) (setq type (copy-sequence type))) - (if (sequencep cust) (setq cust (copy-sequence cust))) - (if (sequencep custg) (setq custg (copy-sequence custg))) + ;; (if (sequencep type) (setq type (copy-sequence type))) + ;; (if (sequencep cust) (setq cust (copy-sequence cust))) + ;; (if (sequencep custg) (setq custg (copy-sequence custg))) ;; To prevent override information w/out specification of storage, ;; we need to do this little hack. - (if (member a (eieio--class-class-allocation-a newc)) (setq alloc :class)) + (if cold (setq alloc :class)) - (if (or (not alloc) (and (symbolp alloc) (eq alloc :instance))) + (if (memq alloc '(nil :instance)) ;; In this case, we modify the INSTANCE version of a given slot. - (progn - - ;; Only add this element if it is so-far unique - (if (not (member a (eieio--class-public-a newc))) - (progn - (eieio--perform-slot-validation-for-default a type d skipnil) - (push a (eieio--class-public-a newc)) - (push d (eieio--class-public-d newc)) - (push doc (eieio--class-public-doc newc)) - (push type (eieio--class-public-type newc)) - (push cust (eieio--class-public-custom newc)) - (push label (eieio--class-public-custom-label newc)) - (push custg (eieio--class-public-custom-group newc)) - (push print (eieio--class-public-printer newc)) - (push prot (eieio--class-protection newc)) - (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc))) - ) - ;; When defaultoverride is true, we are usually adding new local - ;; attributes which must override the default value of any slot - ;; passed in by one of the parent classes. - (when defaultoverride - ;; There is a match, and we must override the old value. - (let* ((ca (eieio--class-public-a newc)) - (np (member a ca)) - (num (- (length ca) (length np))) - (dp (if np (nthcdr num (eieio--class-public-d newc)) - nil)) - (tp (if np (nth num (eieio--class-public-type newc)))) - ) - (if (not np) - (error "EIEIO internal error overriding default value for %s" - a) - ;; If type is passed in, is it the same? - (if (not (eq type t)) - (if (not (equal type tp)) - (error - "Child slot type `%s' does not match inherited type `%s' for `%s'" - type tp a))) - ;; If we have a repeat, only update the initarg... - (unless (eq d eieio-unbound) - (eieio--perform-slot-validation-for-default a tp d skipnil) - (setcar dp d)) - ;; If we have a new initarg, check for it. - (when init - (let* ((inits (eieio--class-initarg-tuples newc)) - (inita (rassq a inits))) - ;; Replace the CAR of the associate INITA. - ;;(message "Initarg: %S replace %s" inita init) - (setcar inita init) - )) - - ;; PLN Tue Jun 26 11:57:06 2007 : The protection is - ;; checked and SHOULD match the superclass - ;; protection. Otherwise an error is thrown. However - ;; I wonder if a more flexible schedule might be - ;; implemented. - ;; - ;; EML - We used to have (if prot... here, - ;; but a prot of 'nil means public. - ;; - (let ((super-prot (nth num (eieio--class-protection newc))) - ) - (if (not (eq prot super-prot)) - (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" - prot super-prot a))) - ;; End original PLN - - ;; PLN Tue Jun 26 11:57:06 2007 : - ;; Do a non redundant combination of ancient custom - ;; groups and new ones. - (when custg - (let* ((groups - (nthcdr num (eieio--class-public-custom-group newc))) - (list1 (car groups)) - (list2 (if (listp custg) custg (list custg)))) - (if (< (length list1) (length list2)) - (setq list1 (prog1 list2 (setq list2 list1)))) - (dolist (elt list2) - (unless (memq elt list1) - (push elt list1))) - (setcar groups list1))) - ;; End PLN - - ;; PLN Mon Jun 25 22:44:34 2007 : If a new cust is - ;; set, simply replaces the old one. - (when cust - ;; (message "Custom type redefined to %s" cust) - (setcar (nthcdr num (eieio--class-public-custom newc)) cust)) - - ;; If a new label is specified, it simply replaces - ;; the old one. - (when label - ;; (message "Custom label redefined to %s" label) - (setcar (nthcdr num (eieio--class-public-custom-label newc)) label)) - ;; End PLN - - ;; PLN Sat Jun 30 17:24:42 2007 : when a new - ;; doc is specified, simply replaces the old one. - (when doc - ;;(message "Documentation redefined to %s" doc) - (setcar (nthcdr num (eieio--class-public-doc newc)) - doc)) - ;; End PLN - - ;; If a new printer is specified, it simply replaces - ;; the old one. - (when print - ;; (message "printer redefined to %s" print) - (setcar (nthcdr num (eieio--class-public-printer newc)) print)) - - ))) - )) + ;; Only add this element if it is so-far unique + (if (not old) + (progn + (eieio--perform-slot-validation-for-default slot skipnil) + (push slot (eieio--class-slots newc)) + ) + ;; When defaultoverride is true, we are usually adding new local + ;; attributes which must override the default value of any slot + ;; passed in by one of the parent classes. + (when defaultoverride + (eieio--slot-override old slot skipnil))) + (when init + (cl-pushnew (cons init a) (eieio--class-initarg-tuples newc) + :test #'equal))) ;; CLASS ALLOCATED SLOTS - (let ((value (eieio-default-eval-maybe d))) - (if (not (member a (eieio--class-class-allocation-a newc))) - (progn - (eieio--perform-slot-validation-for-default a type value skipnil) - ;; Here we have found a :class version of a slot. This - ;; requires a very different approach. - (push a (eieio--class-class-allocation-a newc)) - (push doc (eieio--class-class-allocation-doc newc)) - (push type (eieio--class-class-allocation-type newc)) - (push cust (eieio--class-class-allocation-custom newc)) - (push label (eieio--class-class-allocation-custom-label newc)) - (push custg (eieio--class-class-allocation-custom-group newc)) - (push prot (eieio--class-class-allocation-protection newc)) - ;; Default value is stored in the 'values section, since new objects - ;; can't initialize from this element. - (push value (eieio--class-class-allocation-values newc))) - (when defaultoverride - ;; There is a match, and we must override the old value. - (let* ((ca (eieio--class-class-allocation-a newc)) - (np (member a ca)) - (num (- (length ca) (length np))) - (dp (if np - (nthcdr num - (eieio--class-class-allocation-values newc)) - nil)) - (tp (if np (nth num (eieio--class-class-allocation-type newc)) - nil))) - (if (not np) - (error "EIEIO internal error overriding default value for %s" - a) - ;; If type is passed in, is it the same? - (if (not (eq type t)) - (if (not (equal type tp)) - (error - "Child slot type `%s' does not match inherited type `%s' for `%s'" - type tp a))) - ;; EML - Note: the only reason to override a class bound slot - ;; is to change the default, so allow unbound in. - - ;; If we have a repeat, only update the value... - (eieio--perform-slot-validation-for-default a tp value skipnil) - (setcar dp value)) - - ;; PLN Tue Jun 26 11:57:06 2007 : The protection is - ;; checked and SHOULD match the superclass - ;; protection. Otherwise an error is thrown. However - ;; I wonder if a more flexible schedule might be - ;; implemented. - (let ((super-prot - (car (nthcdr num (eieio--class-class-allocation-protection newc))))) - (if (not (eq prot super-prot)) - (error "Child slot protection `%s' does not match inherited protection `%s' for `%s'" - prot super-prot a))) - ;; Do a non redundant combination of ancient custom groups - ;; and new ones. - (when custg - (let* ((groups - (nthcdr num (eieio--class-class-allocation-custom-group newc))) - (list1 (car groups)) - (list2 (if (listp custg) custg (list custg)))) - (if (< (length list1) (length list2)) - (setq list1 (prog1 list2 (setq list2 list1)))) - (dolist (elt list2) - (unless (memq elt list1) - (push elt list1))) - (setcar groups list1))) - - ;; PLN Sat Jun 30 17:24:42 2007 : when a new - ;; doc is specified, simply replaces the old one. - (when doc - ;;(message "Documentation redefined to %s" doc) - (setcar (nthcdr num (eieio--class-class-allocation-doc newc)) - doc)) - ;; End PLN - - ;; If a new printer is specified, it simply replaces - ;; the old one. - (when print - ;; (message "printer redefined to %s" print) - (setcar (nthcdr num (eieio--class-class-allocation-printer newc)) print)) - - )) - )) - )) + (if (not cold) + (progn + (eieio--perform-slot-validation-for-default slot skipnil) + ;; Here we have found a :class version of a slot. This + ;; requires a very different approach. + (push slot (eieio--class-class-slots newc))) + (when defaultoverride + ;; There is a match, and we must override the old value. + (eieio--slot-override cold slot skipnil)))))) (defun eieio-copy-parents-into-subclass (newc) "Copy into NEWC the slots of PARENTS. @@ -784,63 +668,22 @@ Follow the rules of not overwriting early parents when applying to the new child class." (let ((sn (eieio--class-option-assoc (eieio--class-options newc) :allow-nil-initform))) - (dolist (pcv (eieio--class-parent newc)) + (dolist (pcv (eieio--class-parents newc)) ;; First, duplicate all the slots of the parent. - (let ((pa (eieio--class-public-a pcv)) - (pd (eieio--class-public-d pcv)) - (pdoc (eieio--class-public-doc pcv)) - (ptype (eieio--class-public-type pcv)) - (pcust (eieio--class-public-custom pcv)) - (plabel (eieio--class-public-custom-label pcv)) - (pcustg (eieio--class-public-custom-group pcv)) - (printer (eieio--class-public-printer pcv)) - (pprot (eieio--class-protection pcv)) - (pinit (eieio--class-initarg-tuples pcv)) - (i 0)) - (while pa - (eieio--add-new-slot newc - (car pa) (car pd) (car pdoc) (aref ptype i) - (car pcust) (car plabel) (car pcustg) - (car printer) - (car pprot) (car-safe (car pinit)) nil nil sn) + (let ((pslots (eieio--class-slots pcv)) + (pinit (eieio--class-initarg-tuples pcv))) + (dotimes (i (length pslots)) + (eieio--add-new-slot newc (cl--copy-slot-descriptor (aref pslots i)) + (car-safe (car pinit)) nil nil sn) ;; Increment each value. - (setq pa (cdr pa) - pd (cdr pd) - pdoc (cdr pdoc) - i (1+ i) - pcust (cdr pcust) - plabel (cdr plabel) - pcustg (cdr pcustg) - printer (cdr printer) - pprot (cdr pprot) - pinit (cdr pinit)) + (setq pinit (cdr pinit)) )) ;; while/let ;; Now duplicate all the class alloc slots. - (let ((pa (eieio--class-class-allocation-a pcv)) - (pdoc (eieio--class-class-allocation-doc pcv)) - (ptype (eieio--class-class-allocation-type pcv)) - (pcust (eieio--class-class-allocation-custom pcv)) - (plabel (eieio--class-class-allocation-custom-label pcv)) - (pcustg (eieio--class-class-allocation-custom-group pcv)) - (printer (eieio--class-class-allocation-printer pcv)) - (pprot (eieio--class-class-allocation-protection pcv)) - (pval (eieio--class-class-allocation-values pcv)) - (i 0)) - (while pa - (eieio--add-new-slot newc - (car pa) (aref pval i) (car pdoc) (aref ptype i) - (car pcust) (car plabel) (car pcustg) - (car printer) - (car pprot) nil :class sn) - ;; Increment each value. - (setq pa (cdr pa) - pdoc (cdr pdoc) - pcust (cdr pcust) - plabel (cdr plabel) - pcustg (cdr pcustg) - printer (cdr printer) - pprot (cdr pprot) - i (1+ i)) + (let ((pcslots (eieio--class-class-slots pcv))) + (dotimes (i (length pcslots)) + (eieio--add-new-slot newc (cl--copy-slot-descriptor + (aref pcslots i)) + nil :class sn) ))))) @@ -865,10 +708,11 @@ an error." nil ;; Trim off object IDX junk added in for the object index. (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots))) - (let ((st (aref (eieio--class-public-type class) slot-idx))) + (let ((st (cl--slot-descriptor-type (aref (eieio--class-slots class) + slot-idx)))) (if (not (eieio--perform-slot-validation st value)) (signal 'invalid-slot-type - (list (eieio--class-symbol class) slot st value)))))) + (list (eieio--class-name class) slot st value)))))) (defun eieio--validate-class-slot-value (class slot-idx value slot) "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. @@ -877,11 +721,11 @@ SLOT is the slot that is being checked, and is only used when throwing an error." (if eieio-skip-typecheck nil - (let ((st (aref (eieio--class-class-allocation-type class) - slot-idx))) + (let ((st (cl--slot-descriptor-type (aref (eieio--class-class-slots class) + slot-idx)))) (if (not (eieio--perform-slot-validation st value)) (signal 'invalid-slot-type - (list (eieio--class-symbol class) slot st value)))))) + (list (eieio--class-name class) slot st value)))))) (defun eieio-barf-if-slot-unbound (value instance slotname fn) "Throw a signal if VALUE is a representation of an UNBOUND slot. @@ -889,7 +733,7 @@ INSTANCE is the object being referenced. SLOTNAME is the offending slot. If the slot is ok, return VALUE. Argument FN is the function calling this verifier." (if (and (eq value eieio-unbound) (not eieio-skip-typecheck)) - (slot-unbound instance (eieio--object-class-object instance) slotname fn) + (slot-unbound instance (eieio--object-class instance) slotname fn) value)) @@ -904,7 +748,7 @@ Argument FN is the function calling this verifier." (let ((c (eieio--class-v obj))) (if (eieio--class-p c) (eieio-class-un-autoload obj)) c)) - (t (eieio--object-class-object obj)))) + (t (eieio--object-class obj)))) (c (eieio--slot-name-index class slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. @@ -928,7 +772,7 @@ Fills in OBJ's SLOT with its default value." (cl-check-type obj (or eieio-object class)) (cl-check-type slot symbol) (let* ((cl (cond ((symbolp obj) (eieio--class-v obj)) - (t (eieio--object-class-object obj)))) + (t (eieio--object-class obj)))) (c (eieio--slot-name-index cl slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. @@ -942,10 +786,11 @@ Fills in OBJ's SLOT with its default value." ;;(signal 'invalid-slot-name (list (class-name cl) slot)) ) (eieio-barf-if-slot-unbound - (let ((val (nth (- c (eval-when-compile eieio--object-num-slots)) - (eieio--class-public-d cl)))) + (let ((val (cl--slot-descriptor-initform + (aref (eieio--class-slots cl) + (- c (eval-when-compile eieio--object-num-slots)))))) (eieio-default-eval-maybe val)) - obj (eieio--class-symbol cl) 'oref-default)))) + obj (eieio--class-name cl) 'oref-default)))) (defun eieio-default-eval-maybe (val) "Check VAL, and return what `oref-default' would provide." @@ -966,7 +811,7 @@ Fills in OBJ's SLOT with its default value." Fills in OBJ's SLOT with VALUE." (cl-check-type obj eieio-object) (cl-check-type slot symbol) - (let* ((class (eieio--object-class-object obj)) + (let* ((class (eieio--object-class obj)) (c (eieio--slot-name-index class slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. @@ -1001,13 +846,24 @@ Fills in the default value in CLASS' in SLOT with VALUE." (eieio--validate-class-slot-value class c value slot) (aset (eieio--class-class-allocation-values class) c value)) - (signal 'invalid-slot-name (list (eieio--class-symbol class) slot))) + (signal 'invalid-slot-name (list (eieio--class-name class) slot))) + ;; `oset-default' on an instance-allocated slot is allowed by EIEIO but + ;; not by CLOS and is mildly inconsistent with the :initform thingy, so + ;; it'd be nice to get of it. This said, it is/was used at one place by + ;; gnus/registry.el, so it might be used elsewhere as well, so let's + ;; keep it for now. + ;; FIXME: Generate a compile-time warning for it! + ;; (error "Can't `oset-default' an instance-allocated slot: %S of %S" + ;; slot class) (eieio--validate-slot-value class c value slot) ;; Set this into the storage for defaults. (if (eieio-eval-default-p value) (error "Can't set default to a sexp that gets evaluated again")) - (setcar (nthcdr (- c (eval-when-compile eieio--object-num-slots)) - (eieio--class-public-d class)) + (setf (cl--slot-descriptor-initform + ;; FIXME: Apparently we set it both in `slots' and in + ;; `object-cache', which seems redundant. + (aref (eieio--class-slots class) + (- c (eval-when-compile eieio--object-num-slots)))) value) ;; Take the value, and put it into our cache object. (eieio-oset (eieio--class-default-object-cache class) @@ -1023,11 +879,16 @@ The slot is a symbol which is installed in CLASS by the `defclass' call. If SLOT is the value created with :initarg instead, reverse-lookup that name, and recurse with the associated slot value." ;; Removed checks to outside this call - (let* ((fsi (gethash slot (eieio--class-symbol-hashtable class)))) + (let* ((fsi (gethash slot (eieio--class-index-table class)))) (if (integerp fsi) (+ (eval-when-compile eieio--object-num-slots) fsi) (let ((fn (eieio--initarg-to-attribute class slot))) - (if fn (eieio--slot-name-index class fn) nil))))) + (if fn + ;; Accessing a slot via its :initarg is accepted by EIEIO + ;; (but not CLOS) but is a bad idea (for one: it's slower). + ;; FIXME: We should emit a compile-time warning when this happens! + (eieio--slot-name-index class fn) + nil))))) (defun eieio--class-slot-name-index (class slot) "In CLASS find the index of the named SLOT. @@ -1036,13 +897,12 @@ call. If SLOT is the value created with :initarg instead, reverse-lookup that name, and recurse with the associated slot value." ;; This will happen less often, and with fewer slots. Do this the ;; storage cheap way. - (let* ((a (eieio--class-class-allocation-a class)) - (l1 (length a)) - (af (memq slot a)) - (l2 (length af))) - ;; Slot # is length of the total list, minus the remaining list of - ;; the found slot. - (if af (- l1 l2)))) + (let ((index nil) + (slots (eieio--class-class-slots class))) + (dotimes (i (length slots)) + (if (eq slot (cl--slot-descriptor-name (aref slots i))) + (setq index i))) + index)) ;;; ;; Way to assign slots based on a list. Used for constructors, or @@ -1053,12 +913,12 @@ reverse-lookup that name, and recurse with the associated slot value." If SET-ALL is non-nil, then when a default is nil, that value is reset. If SET-ALL is nil, the slots are only reset if the default is not nil." - (let ((pub (eieio--class-public-a (eieio--object-class-object obj)))) - (while pub - (let ((df (eieio-oref-default obj (car pub)))) + (let ((slots (eieio--class-slots (eieio--object-class obj)))) + (dotimes (i (length slots)) + (let* ((name (cl--slot-descriptor-name (aref slots i))) + (df (eieio-oref-default obj name))) (if (or df set-all) - (eieio-oset obj (car pub) df))) - (setq pub (cdr pub))))) + (eieio-oset obj name df)))))) (defun eieio--initarg-to-attribute (class initarg) "For CLASS, convert INITARG to the actual attribute name. @@ -1085,11 +945,8 @@ need be... May remove that later...)" (defun eieio--c3-merge-lists (reversed-partial-result remaining-inputs) "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible. If a consistent order does not exist, signal an error." - (if (let ((tail remaining-inputs) - (found nil)) - (while (and tail (not found)) - (setq found (car tail) tail (cdr tail))) - (not found)) + (setq remaining-inputs (delq nil remaining-inputs)) + (if (null remaining-inputs) ;; If all remaining inputs are empty lists, we are done. (nreverse reversed-partial-result) ;; Otherwise, we try to find the next element of the result. This @@ -1100,9 +957,8 @@ If a consistent order does not exist, signal an error." (tail remaining-inputs) (next (progn (while (and tail (not found)) - (setq found (and (car tail) - (eieio--c3-candidate (caar tail) - remaining-inputs)) + (setq found (eieio--c3-candidate (caar tail) + remaining-inputs) tail (cdr tail))) found))) (if next @@ -1116,9 +972,13 @@ If a consistent order does not exist, signal an error." ;; The graph is inconsistent, give up (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) +(defsubst eieio--class/struct-parents (class) + (or (eieio--class-parents class) + `(,eieio-default-superclass))) + (defun eieio--class-precedence-c3 (class) "Return all parents of CLASS in c3 order." - (let ((parents (eieio--class-parent (eieio--class-v class)))) + (let ((parents (eieio--class-parents (eieio--class-v class)))) (eieio--c3-merge-lists (list class) (append @@ -1132,7 +992,7 @@ If a consistent order does not exist, signal an error." (defun eieio--class-precedence-dfs (class) "Return all parents of CLASS in depth-first order." - (let* ((parents (eieio--class-parent class)) + (let* ((parents (eieio--class-parents class)) (classes (copy-sequence (apply #'append (list class) @@ -1155,15 +1015,13 @@ If a consistent order does not exist, signal an error." (defun eieio--class-precedence-bfs (class) "Return all parents of CLASS in breadth-first order." (let* ((result) - (queue (or (eieio--class-parent class) - `(,eieio-default-superclass)))) + (queue (eieio--class/struct-parents class))) (while queue (let ((head (pop queue))) (unless (member head result) (push head result) (unless (eq head eieio-default-superclass) - (setq queue (append queue (or (eieio--class-parent head) - `(,eieio-default-superclass)))))))) + (setq queue (append queue (eieio--class/struct-parents head))))))) (cons class (nreverse result))) ) @@ -1177,7 +1035,7 @@ method invocation orders of the involved classes." (if (or (null class) (eq class eieio-default-superclass)) nil (unless (eieio--class-default-object-cache class) - (eieio-class-un-autoload (eieio--class-symbol class))) + (eieio-class-un-autoload (eieio--class-name class))) (cl-case (eieio--class-method-invocation-order class) (:depth-first (eieio--class-precedence-dfs class)) @@ -1211,7 +1069,7 @@ method invocation orders of the involved classes." 50 #'cl--generic-struct-tag (lambda (tag) (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag)) - (mapcar #'eieio--class-symbol + (mapcar #'eieio--class-name (eieio--class-precedence-list (symbol-value tag))))))) (cl-defmethod cl-generic-generalizers :extra "class" (specializer) @@ -1235,7 +1093,7 @@ method invocation orders of the involved classes." (defun eieio--generic-subclass-specializers (tag) (when (eieio--class-p tag) (mapcar (lambda (class) - `(subclass ,(eieio--class-symbol class))) + `(subclass ,(eieio--class-name class))) (eieio--class-precedence-list tag)))) (defconst eieio--generic-subclass-generalizer @@ -1247,7 +1105,7 @@ method invocation orders of the involved classes." (list eieio--generic-subclass-generalizer)) -;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "25a66814a400e7dea16bf0f3bfe245ed") +;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "0609a7bdcd6f38876b7f5647047ddca9") ;;; Generated autoloads from eieio-compat.el (autoload 'eieio--defalias "eieio-compat" "\ diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index 0e0b31e4e7e..26fc452f7b1 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -193,12 +193,8 @@ Optional argument IGNORE is an extraneous parameter." (let* ((chil nil) (obj (widget-get widget :value)) (master-group (widget-get widget :eieio-group)) - (cv (eieio--object-class-object obj)) - (slots (eieio--class-public-a cv)) - (flabel (eieio--class-public-custom-label cv)) - (fgroup (eieio--class-public-custom-group cv)) - (fdoc (eieio--class-public-doc cv)) - (fcust (eieio--class-public-custom cv))) + (cv (eieio--object-class obj)) + (slots (eieio--class-slots cv))) ;; First line describes the object, but may not editable. (if (widget-get widget :eieio-show-name) (setq chil (cons (widget-create-child-and-convert @@ -208,7 +204,7 @@ Optional argument IGNORE is an extraneous parameter." chil))) ;; Display information about the group being shown (when master-group - (let ((groups (eieio--class-option (eieio--object-class-object obj) + (let ((groups (eieio--class-option (eieio--object-class obj) :custom-groups))) (widget-insert "Groups:") (while groups @@ -225,63 +221,59 @@ Optional argument IGNORE is an extraneous parameter." (setq groups (cdr groups))) (widget-insert "\n\n"))) ;; Loop over all the slots, creating child widgets. - (while slots - ;; Output this slot if it has a customize flag associated with it. - (when (and (car fcust) - (or (not master-group) (member master-group (car fgroup))) - (slot-boundp obj (car slots))) - ;; In this case, this slot has a custom type. Create its - ;; children widgets. - (let ((type (eieio-filter-slot-type widget (car fcust))) - (stuff nil)) - ;; This next bit is an evil hack to get some EDE functions - ;; working the way I like. - (if (and (listp type) - (setq stuff (member :slotofchoices type))) - (let ((choices (eieio-oref obj (car (cdr stuff)))) - (newtype nil)) - (while (not (eq (car type) :slotofchoices)) - (setq newtype (cons (car type) newtype) - type (cdr type))) - (while choices - (setq newtype (cons (list 'const (car choices)) - newtype) - choices (cdr choices))) - (setq type (nreverse newtype)))) - (setq chil (cons (widget-create-child-and-convert - widget 'object-slot - :childtype type - :sample-face 'eieio-custom-slot-tag-face - :tag - (concat - (make-string - (or (widget-get widget :indent) 0) - ? ) - (if (car flabel) - (car flabel) - (let ((s (symbol-name - (or - (eieio--class-slot-initarg - (eieio--object-class-object obj) - (car slots)) - (car slots))))) - (capitalize - (if (string-match "^:" s) - (substring s (match-end 0)) - s))))) - :value (slot-value obj (car slots)) - :doc (if (car fdoc) (car fdoc) - "Slot not Documented.") - :eieio-custom-visibility 'visible - ) - chil)) - ) - ) - (setq slots (cdr slots) - fdoc (cdr fdoc) - fcust (cdr fcust) - flabel (cdr flabel) - fgroup (cdr fgroup))) + (dotimes (i (length slots)) + (let* ((slot (aref slots i)) + (props (cl--slot-descriptor-props slot))) + ;; Output this slot if it has a customize flag associated with it. + (when (and (alist-get :custom props) + (or (not master-group) + (member master-group (alist-get :group props))) + (slot-boundp obj (cl--slot-descriptor-name slot))) + ;; In this case, this slot has a custom type. Create its + ;; children widgets. + (let ((type (eieio-filter-slot-type widget (alist-get :custom props))) + (stuff nil)) + ;; This next bit is an evil hack to get some EDE functions + ;; working the way I like. + (if (and (listp type) + (setq stuff (member :slotofchoices type))) + (let ((choices (eieio-oref obj (car (cdr stuff)))) + (newtype nil)) + (while (not (eq (car type) :slotofchoices)) + (setq newtype (cons (car type) newtype) + type (cdr type))) + (while choices + (setq newtype (cons (list 'const (car choices)) + newtype) + choices (cdr choices))) + (setq type (nreverse newtype)))) + (setq chil (cons (widget-create-child-and-convert + widget 'object-slot + :childtype type + :sample-face 'eieio-custom-slot-tag-face + :tag + (concat + (make-string + (or (widget-get widget :indent) 0) + ?\s) + (or (alist-get :label props) + (let ((s (symbol-name + (or + (eieio--class-slot-initarg + (eieio--object-class obj) + (car slots)) + (car slots))))) + (capitalize + (if (string-match "^:" s) + (substring s (match-end 0)) + s))))) + :value (slot-value obj (car slots)) + :doc (or (alist-get :documentation props) + "Slot not Documented.") + :eieio-custom-visibility 'visible + ) + chil)) + )))) (widget-put widget :children (nreverse chil)) )) @@ -289,34 +281,33 @@ Optional argument IGNORE is an extraneous parameter." "Get the value of WIDGET." (let* ((obj (widget-get widget :value)) (master-group eieio-cog) - (cv (eieio--object-class-object obj)) - (fgroup (eieio--class-public-custom-group cv)) (wids (widget-get widget :children)) (name (if (widget-get widget :eieio-show-name) (car (widget-apply (car wids) :value-inline)) nil)) (chil (if (widget-get widget :eieio-show-name) (nthcdr 1 wids) wids)) - (cv (eieio--object-class-object obj)) - (slots (eieio--class-public-a cv)) - (fcust (eieio--class-public-custom cv))) + (cv (eieio--object-class obj)) + (i 0) + (slots (eieio--class-slots cv))) ;; If there are any prefix widgets, clear them. ;; -- None yet ;; Create a batch of initargs for each slot. - (while (and slots chil) - (if (and (car fcust) - (or eieio-custom-ignore-eieio-co - (not master-group) (member master-group (car fgroup))) - (slot-boundp obj (car slots))) - (progn - ;; Only customized slots have widgets - (let ((eieio-custom-ignore-eieio-co t)) - (eieio-oset obj (car slots) - (car (widget-apply (car chil) :value-inline)))) - (setq chil (cdr chil)))) - (setq slots (cdr slots) - fgroup (cdr fgroup) - fcust (cdr fcust))) + (while (and (< i (length slots)) chil) + (let* ((slot (aref slots i)) + (props (cl--slot-descriptor-props slot)) + (cust (alist-get :custom props))) + (if (and cust + (or eieio-custom-ignore-eieio-co + (not master-group) + (member master-group (alist-get :group props))) + (slot-boundp obj (cl--slot-descriptor-name slot))) + (progn + ;; Only customized slots have widgets + (let ((eieio-custom-ignore-eieio-co t)) + (eieio-oset obj (cl--slot-descriptor-name slot) + (car (widget-apply (car chil) :value-inline)))) + (setq chil (cdr chil)))))) ;; Set any name updates on it. (if name (eieio-object-set-name-string obj name)) ;; This is the same object we had before. @@ -452,7 +443,7 @@ Must return the created widget." (vector (concat "Group " (symbol-name group)) (list 'customize-object obj (list 'quote group)) t)) - (eieio--class-option (eieio--object-class-object obj) :custom-groups))) + (eieio--class-option (eieio--object-class obj) :custom-groups))) (defvar eieio-read-custom-group-history nil "History for the custom group reader.") @@ -460,7 +451,7 @@ Must return the created widget." (cl-defmethod eieio-read-customization-group ((obj eieio-default-superclass)) "Do a completing read on the name of a customization group in OBJ. Return the symbol for the group, or nil" - (let ((g (eieio--class-option (eieio--object-class-object obj) + (let ((g (eieio--class-option (eieio--object-class obj) :custom-groups))) (if (= (length g) 1) (car g) diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index 82349192e5e..c820180359b 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el @@ -31,6 +31,9 @@ ;;; Code: +(declare-function data-debug/eieio-insert-slots "eieio-datadebug" + (obj eieio-default-superclass)) + (defun data-debug-insert-object-slots (object prefix) "Insert all the slots of OBJECT. PREFIX specifies what to insert at the start of each line." @@ -54,16 +57,17 @@ PREFIX specifies what to insert at the start of each line." "Insert a button representing OBJECT. PREFIX is the text that precedes the button. PREBUTTONTEXT is some text between PREFIX and the object button." - (let ((start (point)) - (end nil) - (str (object-print object)) - (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots" - (eieio-object-name-string object) - (eieio-object-class object) - (eieio-class-parents (eieio-object-class object)) - (length (object-slots object)) - )) - ) + (let* ((start (point)) + (end nil) + (str (object-print object)) + (class (eieio-object-class object)) + (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots" + (eieio-object-name-string object) + class + (eieio-class-parents class) + (length (eieio-class-slots class)) + )) + ) (insert prefix prebuttontext str) (setq end (point)) (put-text-property (- end (length str)) end 'face 'font-lock-keyword-face) @@ -80,41 +84,31 @@ PREBUTTONTEXT is some text between PREFIX and the object button." ;; Each object should have an opportunity to show stuff about itself. (cl-defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass) - prefix) + prefix) "Insert the slots of OBJ into the current DDEBUG buffer." (let ((inhibit-read-only t)) (data-debug-insert-thing (eieio-object-name-string obj) prefix "Name: ") - (let* ((cl (eieio-object-class obj)) - (cv (eieio--class-v cl))) - (data-debug-insert-thing (eieio--class-constructor cl) + (let* ((cv (eieio--object-class obj))) + (data-debug-insert-thing (eieio--class-name cv) prefix "Class: ") ;; Loop over all the public slots - (let ((publa (eieio--class-public-a cv)) - ) - (while publa - (if (slot-boundp obj (car publa)) - (let* ((i (eieio--class-slot-initarg (eieio--class-v cl) - (car publa))) - (v (eieio-oref obj (car publa)))) - (data-debug-insert-thing - v prefix (concat - (if i (symbol-name i) - (symbol-name (car publa))) - " "))) - ;; Unbound case - (let ((i (eieio--class-slot-initarg (eieio--class-v cl) - (car publa)))) - (data-debug-insert-custom - "#unbound" prefix - (concat (if i (symbol-name i) - (symbol-name (car publa))) - " ") - 'font-lock-keyword-face)) - ) - (setq publa (cdr publa))))))) + (let ((slots (eieio--class-slots cv))) + (dotimes (i (length slots)) + (let* ((slot (aref slots i)) + (sname (cl--slot-descriptor-name slot)) + (i (eieio--class-slot-initarg cv sname)) + (sstr (concat (symbol-name (or i sname)) " "))) + (if (slot-boundp obj sname) + (let* ((v (eieio-oref obj sname))) + (data-debug-insert-thing v prefix sstr)) + ;; Unbound case + (data-debug-insert-custom + "#unbound" prefix sstr + 'font-lock-keyword-face) + ))))))) ;;; Augment the Data debug thing display list. (data-debug-add-specialized-thing (lambda (thing) (eieio-object-p thing)) diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index a769ca7b536..7f98730340d 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -99,7 +99,7 @@ If CLASS is actually an object, then also display current values of that object. (when pl (insert " Inherits from ") (while (setq cur (pop pl)) - (setq cur (eieio--class-symbol cur)) + (setq cur (eieio--class-name cur)) (insert "`") (help-insert-xref-button (symbol-name cur) 'help-function cur) @@ -136,74 +136,40 @@ If CLASS is actually an object, then also display current values of that object. (or doc ""))) (insert "\n\n"))))) +(defun eieio--help-print-slot (slot) + (insert + (concat + (propertize "Slot: " 'face 'bold) + (prin1-to-string (cl--slot-descriptor-name slot)) + (unless (eq (cl--slot-descriptor-type slot) t) + (concat " type = " + (prin1-to-string (cl--slot-descriptor-type slot)))) + (unless (eq (cl--slot-descriptor-initform slot) eieio-unbound) + (concat " default = " + (prin1-to-string (cl--slot-descriptor-initform slot)))) + (when (alist-get :printer (cl--slot-descriptor-props slot)) + (concat " printer = " + (prin1-to-string + (alist-get :printer (cl--slot-descriptor-props slot))))) + (when (alist-get :documentation (cl--slot-descriptor-props slot)) + (concat "\n " (alist-get :documentation (cl--slot-descriptor-props slot)) + "\n"))) + "\n")) + (defun eieio-help-class-slots (class) "Print help description for the slots in CLASS. Outputs to the current buffer." (let* ((cv (eieio--class-v class)) - (docs (eieio--class-public-doc cv)) - (names (eieio--class-public-a cv)) - (deflt (eieio--class-public-d cv)) - (types (eieio--class-public-type cv)) - (publp (eieio--class-public-printer cv)) - (i 0) - (prot (eieio--class-protection cv)) - ) + (slots (eieio--class-slots cv)) + (cslots (eieio--class-class-slots cv))) (insert (propertize "Instance Allocated Slots:\n\n" 'face 'bold)) - (while names - (insert - (concat - (when (car prot) - (propertize "Private " 'face 'bold)) - (propertize "Slot: " 'face 'bold) - (prin1-to-string (car names)) - (unless (eq (aref types i) t) - (concat " type = " - (prin1-to-string (aref types i)))) - (unless (eq (car deflt) eieio-unbound) - (concat " default = " - (prin1-to-string (car deflt)))) - (when (car publp) - (concat " printer = " - (prin1-to-string (car publp)))) - (when (car docs) - (concat "\n " (car docs) "\n")) - "\n")) - (setq names (cdr names) - docs (cdr docs) - deflt (cdr deflt) - publp (cdr publp) - prot (cdr prot) - i (1+ i))) - (setq docs (eieio--class-class-allocation-doc cv) - names (eieio--class-class-allocation-a cv) - types (eieio--class-class-allocation-type cv) - i 0 - prot (eieio--class-class-allocation-protection cv)) - (when names + (dotimes (i (length slots)) + (eieio--help-print-slot (aref slots i))) + (when (> (length cslots) 0) (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold))) - (while names - (insert - (concat - (when (car prot) - "Private ") - "Slot: " - (prin1-to-string (car names)) - (unless (eq (aref types i) t) - (concat " type = " - (prin1-to-string (aref types i)))) - (condition-case nil - (let ((value (eieio-oref class (car names)))) - (concat " value = " - (prin1-to-string value))) - (error nil)) - (when (car docs) - (concat "\n\n " (car docs) "\n")) - "\n")) - (setq names (cdr names) - docs (cdr docs) - prot (cdr prot) - i (1+ i))))) + (dotimes (i (length cslots)) + (eieio--help-print-slot (aref cslots i))))) (defun eieio-build-class-alist (&optional class instantiable-only buildlist) "Return an alist of all currently active classes for completion purposes. diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index cdf1992f9a5..4ba67693175 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -320,19 +320,21 @@ variable name of the same name as the slot." (declare (indent 2) (debug (sexp sexp def-body))) (require 'cl-lib) ;; Transform the spec-list into a cl-symbol-macrolet spec-list. - (let ((mappings (mapcar (lambda (entry) - (let ((var (if (listp entry) (car entry) entry)) - (slot (if (listp entry) (cadr entry) entry))) - (list var `(slot-value ,object ',slot)))) - spec-list))) - (append (list 'cl-symbol-macrolet mappings) - body))) + (macroexp-let2 nil object object + `(cl-symbol-macrolet + ,(mapcar (lambda (entry) + (let ((var (if (listp entry) (car entry) entry)) + (slot (if (listp entry) (cadr entry) entry))) + (list var `(slot-value ,object ',slot)))) + spec-list) + ,@body))) ;;; Simple generators, and query functions. None of these would do ;; well embedded into an object. ;; + (define-obsolete-function-alias - 'object-class-fast #'eieio--object-class-name "24.4") + 'object-class-fast #'eieio-object-class "24.4") (cl-defgeneric eieio-object-name-string (obj) "Return a string which is OBJ's name." @@ -342,7 +344,7 @@ variable name of the same name as the slot." "Return a printed representation for object OBJ. If EXTRA, include that in the string returned to represent the symbol." (cl-check-type obj eieio-object) - (format "#<%s %s%s>" (eieio--object-class-name obj) + (format "#<%s %s%s>" (eieio-object-class obj) (eieio-object-name-string obj) (or extra ""))) (define-obsolete-function-alias 'object-name #'eieio-object-name "24.4") @@ -370,7 +372,7 @@ If EXTRA, include that in the string returned to represent the symbol." "Return the class struct defining OBJ." ;; FIXME: We say we return a "struct" but we return a symbol instead! (cl-check-type obj eieio-object) - (eieio--object-class-name obj)) + (eieio--class-name (eieio--object-class obj))) (define-obsolete-function-alias 'object-class #'eieio-object-class "24.4") ;; CLOS name, maybe? (define-obsolete-function-alias 'class-of #'eieio-object-class "24.4") @@ -378,7 +380,7 @@ If EXTRA, include that in the string returned to represent the symbol." (defun eieio-object-class-name (obj) "Return a Lisp like symbol name for OBJ's class." (cl-check-type obj eieio-object) - (eieio-class-name (eieio--object-class-object obj))) + (eieio-class-name (eieio--object-class obj))) (define-obsolete-function-alias 'object-class-name 'eieio-object-class-name "24.4") @@ -386,7 +388,7 @@ If EXTRA, include that in the string returned to represent the symbol." "Return parent classes to CLASS. (overload of variable). The CLOS function `class-direct-superclasses' is aliased to this function." - (eieio--class-parent (eieio--class-object class))) + (eieio--class-parents (eieio--class-object class))) (define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4") @@ -414,13 +416,13 @@ The CLOS function `class-direct-subclasses' is aliased to this function." (setq class (eieio--class-object class)) (cl-check-type class eieio--class) (cl-check-type obj eieio-object) - (eq (eieio--object-class-object obj) class)) + (eq (eieio--object-class obj) class)) (defun object-of-class-p (obj class) "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses." (cl-check-type obj eieio-object) ;; class will be checked one layer down - (child-of-class-p (eieio--object-class-object obj) class)) + (child-of-class-p (eieio--object-class obj) class)) ;; Backwards compatibility (defalias 'obj-of-class-p 'object-of-class-p) @@ -428,36 +430,36 @@ The CLOS function `class-direct-subclasses' is aliased to this function." "Return non-nil if CHILD class is a subclass of CLASS." (setq child (eieio--class-object child)) (cl-check-type child eieio--class) - ;; `eieio-default-superclass' is never mentioned in eieio--class-parent, + ;; `eieio-default-superclass' is never mentioned in eieio--class-parents, ;; so we have to special case it here. (or (eq class 'eieio-default-superclass) (let ((p nil)) (setq class (eieio--class-object class)) (cl-check-type class eieio--class) (while (and child (not (eq child class))) - (setq p (append p (eieio--class-parent child)) + (setq p (append p (eieio--class-parents child)) child (pop p))) (if child t)))) -(defun eieio-slot-descriptor-name (slot) slot) +(defun eieio-slot-descriptor-name (slot) + (cl--slot-descriptor-name slot)) (defun eieio-class-slots (class) "Return list of slots available in instances of CLASS." ;; FIXME: This only gives the instance slots and ignores the ;; class-allocated slots. - ;; FIXME: It only gives the slot's *names* rather than actual - ;; slot descriptors. (setq class (eieio--class-object class)) (cl-check-type class eieio--class) - (eieio--class-public-a class)) + (mapcar #'identity (eieio--class-slots class))) (defun object-slots (obj) "Return list of slots available in OBJ." (declare (obsolete eieio-class-slots "25.1")) (cl-check-type obj eieio-object) - (eieio-class-slots (eieio--object-class-object obj))) + (eieio-class-slots (eieio--object-class obj))) -(defun eieio--class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." +(defun eieio--class-slot-initarg (class slot) + "Fetch from CLASS, SLOT's :initarg." (cl-check-type class eieio--class) (let ((ia (eieio--class-initarg-tuples class)) (f nil)) @@ -507,12 +509,18 @@ OBJECT can be an instance or a class." (defun slot-exists-p (object-or-class slot) "Return non-nil if OBJECT-OR-CLASS has SLOT." (let ((cv (cond ((eieio-object-p object-or-class) - (eieio--object-class-object object-or-class)) + (eieio--object-class object-or-class)) ((eieio--class-p object-or-class) object-or-class) (t (find-class object-or-class 'error))))) - (or (memq slot (eieio--class-public-a cv)) - (memq slot (eieio--class-class-allocation-a cv))) - )) + (or (gethash slot (eieio--class-index-table cv)) + ;; FIXME: We could speed this up by adding class slots into the + ;; index-table (e.g. with a negative index?). + (let ((cs (eieio--class-class-slots cv)) + found) + (dotimes (i (length cs)) + (if (eq slot (cl--slot-descriptor-name (aref cs i))) + (setq found t))) + found)))) (defun find-class (symbol &optional errorp) "Return the class that SYMBOL represents. @@ -671,7 +679,7 @@ Called from the constructor routine.") "Set slots of OBJ with SLOTS which is a list of name/value pairs. Called from the constructor routine." (while slots - (let ((rn (eieio--initarg-to-attribute (eieio--object-class-object obj) + (let ((rn (eieio--initarg-to-attribute (eieio--object-class obj) (car slots)))) (if (not rn) (slot-missing obj (car slots) 'oset (car (cdr slots))) @@ -694,9 +702,9 @@ not taken, then new objects of your class will not have their values dynamically set from SLOTS." ;; First, see if any of our defaults are `lambda', and ;; re-evaluate them and apply the value to our slots. - (let* ((this-class (eieio--object-class-object this)) - (defaults (eieio--class-public-d this-class))) - (dolist (slot (eieio--class-public-a this-class)) + (let* ((this-class (eieio--object-class this)) + (slots (eieio--class-slots this-class))) + (dotimes (i (length slots)) ;; For each slot, see if we need to evaluate it. ;; ;; Paul Landes said in an email: @@ -704,11 +712,12 @@ dynamically set from SLOTS." ;; > the quoted thing as you already have. This is by the ;; > Sonya E. Keene book and other things I've look at on the ;; > web. - (let ((dflt (eieio-default-eval-maybe (car defaults)))) - (when (not (eq dflt (car defaults))) - (eieio-oset this slot dflt) )) - ;; Next. - (setq defaults (cdr defaults)))) + (let* ((slot (aref slots i)) + (initform (cl--slot-descriptor-initform slot)) + (dflt (eieio-default-eval-maybe initform))) + (when (not (eq dflt initform)) + ;; FIXME: We should be able to just do (aset this (+ i ) dflt)! + (eieio-oset this (cl--slot-descriptor-name slot) dflt))))) ;; Shared initialize will parse our slots for us. (shared-initialize this slots)) @@ -825,32 +834,31 @@ this object." (prin1 (eieio-object-name-string this)) (princ "\n") ;; Loop over all the public slots - (let ((publa (eieio--class-public-a cv)) - (publd (eieio--class-public-d cv)) - (publp (eieio--class-public-printer cv)) + (let ((slots (eieio--class-slots cv)) (eieio-print-depth (1+ eieio-print-depth))) - (while publa - (when (slot-boundp this (car publa)) - (let ((i (eieio--class-slot-initarg cv (car publa))) - (v (eieio-oref this (car publa))) - ) - (unless (or (not i) (equal v (car publd))) - (unless (bolp) - (princ "\n")) - (princ (make-string (* eieio-print-depth 2) ? )) - (princ (symbol-name i)) - (if (car publp) - ;; Use our public printer - (progn - (princ " ") - (funcall (car publp) v)) - ;; Use our generic override prin1 function. - (princ (if (or (eieio-object-p v) - (eieio-object-p (car-safe v))) - "\n" " ")) - (eieio-override-prin1 v))))) - (setq publa (cdr publa) publd (cdr publd) - publp (cdr publp)))) + (dotimes (i (length slots)) + (let ((slot (aref slots i))) + (when (slot-boundp this (cl--slot-descriptor-name slot)) + (let ((i (eieio--class-slot-initarg + cv (cl--slot-descriptor-name slot))) + (v (eieio-oref this (cl--slot-descriptor-name slot)))) + (unless (or (not i) (equal v (cl--slot-descriptor-initform slot))) + (unless (bolp) + (princ "\n")) + (princ (make-string (* eieio-print-depth 2) ? )) + (princ (symbol-name i)) + (if (alist-get :printer (cl--slot-descriptor-props slot)) + ;; Use our public printer + (progn + (princ " ") + (funcall (alist-get :printer + (cl--slot-descriptor-props slot)) + v)) + ;; Use our generic override prin1 function. + (princ (if (or (eieio-object-p v) + (eieio-object-p (car-safe v))) + "\n" " ")) + (eieio-override-prin1 v)))))))) (princ ")") (when (= eieio-print-depth 0) (princ "\n")))) @@ -919,7 +927,7 @@ variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to ;;; Start of automatically extracted autoloads. -;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "2ec91e473fcad1ff20cd76edc4aab706") +;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "813d32fbf76d4248fc6b4dc97ebcd720") ;;; Generated autoloads from eieio-custom.el (autoload 'customize-object "eieio-custom" "\ @@ -930,7 +938,7 @@ Optional argument GROUP is the sub-group of slots to display. ;;;*** -;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "d1910eb455f102989fc33bb3f5a9b614") +;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "3005b815c6b30eccbf0642170b3f82a5") ;;; Generated autoloads from eieio-opt.el (autoload 'eieio-browse "eieio-opt" "\ diff --git a/test/ChangeLog b/test/ChangeLog index e150aba2874..15408a3c970 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,16 @@ +2015-03-19 Stefan Monnier + + * automated/eieio-tests.el (eieio-test-17-virtual-slot): Don't use + initarg in `oset'. + (eieio-test-32-slot-attribute-override-2): Adjust to new + slot representation. + + * automated/eieio-test-persist.el (persist-test-save-and-compare): + Adjust to new slot representation. + + * automated/eieio-test-methodinvoke.el (make-instance): Use new-style + `subclass' specializer for a change. + 2015-03-17 Stefan Monnier * automated/cl-lib-tests.el: Use lexical-binding. diff --git a/test/automated/eieio-test-methodinvoke.el b/test/automated/eieio-test-methodinvoke.el index 62f5603d3b6..5263013434e 100644 --- a/test/automated/eieio-test-methodinvoke.el +++ b/test/automated/eieio-test-methodinvoke.el @@ -184,7 +184,7 @@ (if (next-method-p) (call-next-method)) ) -(defmethod make-instance :STATIC ((p C) &rest args) +(cl-defmethod make-instance ((p (subclass C)) &rest args) (eieio-test-method-store :STATIC 'C) (call-next-method) ) diff --git a/test/automated/eieio-test-persist.el b/test/automated/eieio-test-persist.el index 7bb2f1ca779..6710ead2e77 100644 --- a/test/automated/eieio-test-persist.el +++ b/test/automated/eieio-test-persist.el @@ -45,20 +45,20 @@ This is usually a symbol that starts with `:'." (eieio-persistent-save original) - (let* ((file (oref original :file)) + (let* ((file (oref original file)) (class (eieio-object-class original)) (fromdisk (eieio-persistent-read file class)) (cv (eieio--class-v class)) - (slot-names (eieio--class-public-a cv)) - (slot-deflt (eieio--class-public-d cv)) + (slots (eieio--class-slots cv)) ) (unless (object-of-class-p fromdisk class) (error "Persistent class %S != original class %S" (eieio-object-class fromdisk) class)) - (while slot-names - (let* ((oneslot (car slot-names)) + (dotimes (i (length slots)) + (let* ((slot (aref slots i)) + (oneslot (cl--slot-descriptor-name slot)) (origvalue (eieio-oref original oneslot)) (fromdiskvalue (eieio-oref fromdisk oneslot)) (initarg-p (eieio--attribute-to-initarg @@ -70,12 +70,9 @@ This is usually a symbol that starts with `:'." (error "Slot %S Original Val %S != Persistent Val %S" oneslot origvalue fromdiskvalue)) ;; Else !initarg-p - (unless (equal (car slot-deflt) fromdiskvalue) + (unless (equal (cl--slot-descriptor-initform slot) fromdiskvalue) (error "Slot %S Persistent Val %S != Default Value %S" - oneslot fromdiskvalue (car slot-deflt)))) - - (setq slot-names (cdr slot-names) - slot-deflt (cdr slot-deflt)) + oneslot fromdiskvalue (cl--slot-descriptor-initform slot)))) )))) ;;; Simple Case diff --git a/test/automated/eieio-tests.el b/test/automated/eieio-tests.el index 7532609c4c3..01131d886dd 100644 --- a/test/automated/eieio-tests.el +++ b/test/automated/eieio-tests.el @@ -406,21 +406,21 @@ METHOD is the method that was attempting to be called." (ert-deftest eieio-test-17-virtual-slot () (setq eitest-vsca (virtual-slot-class :base-value 1)) ;; Check slot values - (should (= (oref eitest-vsca :base-value) 1)) + (should (= (oref eitest-vsca base-value) 1)) (should (= (oref eitest-vsca :derived-value) 2)) - (oset eitest-vsca :derived-value 3) - (should (= (oref eitest-vsca :base-value) 2)) + (oset eitest-vsca derived-value 3) + (should (= (oref eitest-vsca base-value) 2)) (should (= (oref eitest-vsca :derived-value) 3)) - (oset eitest-vsca :base-value 3) - (should (= (oref eitest-vsca :base-value) 3)) + (oset eitest-vsca base-value 3) + (should (= (oref eitest-vsca base-value) 3)) (should (= (oref eitest-vsca :derived-value) 4)) ;; should also be possible to initialize instance using virtual slot (setq eitest-vscb (virtual-slot-class :derived-value 5)) - (should (= (oref eitest-vscb :base-value) 4)) + (should (= (oref eitest-vscb base-value) 4)) (should (= (oref eitest-vscb :derived-value) 5))) (ert-deftest eieio-test-18-slot-unbound () @@ -560,7 +560,8 @@ METHOD is the method that was attempting to be called." (setq eitest-t1 (class-c)) ;; Slot initialization (should (eq (oref eitest-t1 slot-1) 'moose)) - (should (eq (oref eitest-t1 :moose) 'moose)) + ;; Accessing via the initarg name is deprecated! + ;; (should (eq (oref eitest-t1 :moose) 'moose)) ;; Don't pass reference of private slot ;;PRIVATE (should-error (oref eitest-t1 slot-2) :type 'invalid-slot-name) ;; Check private slot accessor @@ -580,7 +581,8 @@ METHOD is the method that was attempting to be called." ;; See previous test, nor for subclass (setq eitest-t2 (class-subc)) (should (eq (oref eitest-t2 slot-1) 'moose)) - (should (eq (oref eitest-t2 :moose) 'moose)) + ;; Accessing via the initarg name is deprecated! + ;;(should (eq (oref eitest-t2 :moose) 'moose)) (should (string= (get-slot-2 eitest-t2) "linux")) ;;PRIVATE (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name) (should (string= (get-slot-2 eitest-t2) "linux")) @@ -802,30 +804,24 @@ Subclasses to override slot attributes.") (ert-deftest eieio-test-32-slot-attribute-override-2 () (let* ((cv (eieio--class-v 'slotattr-ok)) - (docs (eieio--class-public-doc cv)) - (names (eieio--class-public-a cv)) - (cust (eieio--class-public-custom cv)) - (label (eieio--class-public-custom-label cv)) - (group (eieio--class-public-custom-group cv)) - (types (eieio--class-public-type cv)) - (args (eieio--class-initarg-tuples cv)) - (i 0)) + (slots (eieio--class-slots cv)) + (args (eieio--class-initarg-tuples cv))) ;; :initarg should override for subclass (should (assoc :initblarg args)) - (while (< i (length names)) - (cond - ((eq (nth i names) 'custom) - ;; Custom slot attributes must override - (should (eq (nth i cust) 'string)) - ;; Custom label slot attribute must override - (should (string= (nth i label) "One String")) - (let ((grp (nth i group))) - ;; Custom group slot attribute must combine - (should (and (memq 'moose grp) (memq 'cow grp))))) - (t nil)) - - (setq i (1+ i))))) + (dotimes (i (length slots)) + (let* ((slot (aref slots i)) + (props (cl--slot-descriptor-props slot))) + (cond + ((eq (cl--slot-descriptor-name slot) 'custom) + ;; Custom slot attributes must override + (should (eq (alist-get :custom props) 'string)) + ;; Custom label slot attribute must override + (should (string= (alist-get :label props) "One String")) + (let ((grp (alist-get :group props))) + ;; Custom group slot attribute must combine + (should (and (memq 'moose grp) (memq 'cow grp))))) + (t nil)))))) (defvar eitest-CLONETEST1 nil) (defvar eitest-CLONETEST2 nil) @@ -891,8 +887,7 @@ Subclasses to override slot attributes.") (should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2)) (should (= (length (eieio-build-class-alist 'opt-test1 t)) 1))) -(defclass eieio--testing () - ()) +(defclass eieio--testing () ()) (defmethod constructor :static ((_x eieio--testing) newname &rest _args) (list newname 2)) -- cgit v1.2.3 From 29f7f98b7c3755f8f9e9dcef60bd460794cf2104 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 19 Mar 2015 10:35:52 -0400 Subject: Fixes: debbugs:20141 * lisp/emacs-lisp/eieio.el (object-slots): Return slot names as before. --- lisp/ChangeLog | 42 ++++++++++++++++++++++++------------------ lisp/emacs-lisp/eieio.el | 5 +++-- 2 files changed, 27 insertions(+), 20 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 7c751f4e8e8..74a0988c98f 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,23 +1,9 @@ 2015-03-19 Stefan Monnier - * emacs-lisp/eieio.el (with-slots): Use macroexp-let2. - (object-class-fast): Change recommend replacement. - (eieio-object-class): Rewrite. - (slot-exists-p): Adjust to new slot representation. - (initialize-instance): Adjust to new slot representation. - (object-write): Adjust to new slot representation. - - * emacs-lisp/eieio-opt.el (eieio--help-print-slot): New function - extracted from eieio-help-class-slots. - (eieio-help-class-slots): Use it. Adjust to new slot representation. + * emacs-lisp/eieio.el (object-slots): Return slot names as before + (bug#20141). - * emacs-lisp/eieio-datadebug.el (data-debug/eieio-insert-slots): - Declare to silence warnings. - (data-debug-insert-object-button): Avoid `object-slots'. - (data-debug/eieio-insert-slots): Adjust to new slot representation. - - * emacs-lisp/eieio-custom.el (eieio-object-value-create) - (eieio-object-value-get): Adjust to new slot representation. +2015-03-19 Stefan Monnier EIEIO: Change class's representation to unify instance and class slots * emacs-lisp/eieio-core.el (eieio--class): Change field names and order @@ -41,7 +27,27 @@ (eieio--class/struct-parents): New function. (eieio--class-precedence-bfs): Use it. - * emacs-lisp/eieio-compat.el (eieio--generic-static-symbol-specializers): + * emacs-lisp/eieio.el (with-slots): Use macroexp-let2. + (object-class-fast): Change recommend replacement. + (eieio-object-class): Rewrite. + (slot-exists-p): Adjust to new slot representation. + (initialize-instance): Adjust to new slot representation. + (object-write): Adjust to new slot representation. + + * emacs-lisp/eieio-opt.el (eieio--help-print-slot): New function + extracted from eieio-help-class-slots. + (eieio-help-class-slots): Use it. Adjust to new slot representation. + + * emacs-lisp/eieio-datadebug.el (data-debug/eieio-insert-slots): + Declare to silence warnings. + (data-debug-insert-object-button): Avoid `object-slots'. + (data-debug/eieio-insert-slots): Adjust to new slot representation. + + * emacs-lisp/eieio-custom.el (eieio-object-value-create) + (eieio-object-value-get): Adjust to new slot representation. + + * emacs-lisp/eieio-compat.el + (eieio--generic-static-symbol-specializers): Extract from eieio--generic-static-symbol-generalizer. (eieio--generic-static-symbol-generalizer): Use it. diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 4ba67693175..8d76df874e5 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -453,10 +453,11 @@ The CLOS function `class-direct-subclasses' is aliased to this function." (mapcar #'identity (eieio--class-slots class))) (defun object-slots (obj) - "Return list of slots available in OBJ." + "Return list of slot names available in OBJ." (declare (obsolete eieio-class-slots "25.1")) (cl-check-type obj eieio-object) - (eieio-class-slots (eieio--object-class obj))) + (mapcar #'cl--slot-descriptor-name + (eieio-class-slots (eieio--object-class obj)))) (defun eieio--class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." -- cgit v1.2.3 From 8aa13d07fe72b8a00ded10602f5c5ce773181b40 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 19 Mar 2015 13:46:36 -0400 Subject: * lisp/emacs-lisp/pcase.el (pcase-lambda): Rewrite. --- lisp/ChangeLog | 2 ++ lisp/emacs-lisp/pcase.el | 35 +++++++++++++++++++---------------- 2 files changed, 21 insertions(+), 16 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 74a0988c98f..a2500e3fadc 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,7 @@ 2015-03-19 Stefan Monnier + * emacs-lisp/pcase.el (pcase-lambda): Rewrite. + * emacs-lisp/eieio.el (object-slots): Return slot names as before (bug#20141). diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 4706be5e57c..0e8a969a402 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -166,23 +166,26 @@ like `(,a . ,(pred (< a))) or, with more checks: ;;;###autoload (defmacro pcase-lambda (lambda-list &rest body) - "Like `lambda' but allow each argument to be a pattern. -`&rest' argument is supported." + "Like `lambda' but allow each argument to be a UPattern. +I.e. accepts the usual &optional and &rest keywords, but every +formal argument can be any pattern accepted by `pcase' (a mere +variable name being but a special case of it)." (declare (doc-string 2) (indent defun) - (debug ((&rest pcase-UPAT &optional ["&rest" pcase-UPAT]) body))) - (let ((args (make-symbol "args")) - (pats (mapcar (lambda (u) - (unless (eq u '&rest) - (if (eq (car-safe u) '\`) (cadr u) (list '\, u)))) - lambda-list)) - (body (macroexp-parse-body body))) - ;; Handle &rest - (when (eq nil (car (last pats 2))) - (setq pats (append (butlast pats 2) (car (last pats))))) - `(lambda (&rest ,args) - ,@(car body) - (pcase ,args - (,(list '\` pats) . ,(cdr body)))))) + (debug ((&rest pcase-UPAT) body))) + (let* ((bindings ()) + (parsed-body (macroexp-parse-body body)) + (args (mapcar (lambda (pat) + (if (symbolp pat) + ;; Simple vars and &rest/&optional are just passed + ;; through unchanged. + pat + (let ((arg (make-symbol + (format "arg%s" (length bindings))))) + (push `(,pat ,arg) bindings) + arg))) + lambda-list))) + `(lambda ,args ,@(car parsed-body) + (pcase-let* ,(nreverse bindings) ,@(cdr parsed-body))))) (defun pcase--let* (bindings body) (cond -- cgit v1.2.3 From 4cd31cf01964059ab29f735c7856c65631c46c28 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 20 Mar 2015 16:29:21 -0400 Subject: (cl-defsubst): Ignore false-positive occurrences of args via &cl-defs Fixes: debbugs:20149 * lisp/emacs-lisp/cl-macs.el (cl-defsubst): Ignore false-positive occurrences of args via &cl-defs. --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/cl-macs.el | 3 ++- 2 files changed, 7 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index cecec469ed8..ee4e021b940 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-03-20 Stefan Monnier + + * emacs-lisp/cl-macs.el (cl-defsubst): Ignore false-positive + occurrences of args via &cl-defs (bug#20149). + 2015-03-20 Alan Mackenzie Fix debbugs#20146 diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index d3866783447..75c6a5687c4 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2446,10 +2446,11 @@ The function's arguments should be treated as immutable. \(fn NAME ARGLIST [DOCSTRING] BODY...)" (declare (debug cl-defun) (indent 2)) (let* ((argns (cl--arglist-args args)) + (real-args (if (eq '&cl-defs (car args)) (cddr args) args)) (p argns) ;; (pbody (cons 'progn body)) ) - (while (and p (eq (cl--expr-contains args (car p)) 1)) (pop p)) + (while (and p (eq (cl--expr-contains real-args (car p)) 1)) (pop p)) `(progn ,(if p nil ; give up if defaults refer to earlier args `(cl-define-compiler-macro ,name -- cgit v1.2.3 From c9998fcbf40c533004533dee96f2eb67349d55ae Mon Sep 17 00:00:00 2001 From: Tassilo Horn Date: Fri, 20 Mar 2015 23:09:06 +0100 Subject: Fix elisp function name font-lock bug. * emacs-lisp/lisp-mode.el (lisp-el-font-lock-keywords-1): Fix false positive in function name font-locking. --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/lisp-mode.el | 18 +++++++++++------- 2 files changed, 16 insertions(+), 7 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ee4e021b940..85e62be80c2 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-03-20 Tassilo Horn + + * emacs-lisp/lisp-mode.el (lisp-el-font-lock-keywords-1): Fix + false positive in function name font-locking. + 2015-03-20 Stefan Monnier * emacs-lisp/cl-macs.el (cl-defsubst): Ignore false-positive diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 6b3077302ed..d8901ac017d 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -320,14 +320,18 @@ `( ;; Definitions. (,(concat "(" el-defs-re "\\_>" ;; Any whitespace and defined object. - "[ \t'\(]*" - "\\(\\(?:\\sw\\|\\s_\\)+\\)?") + "[ \t']*" + ;; With cl-defstruct, the name may follow a paren, + ;; e.g. (cl-defstruct (foo-struct opts)...). + "\\(([ \t']*\\)?\\(\\(?:\\sw\\|\\s_\\)+\\)?") (1 font-lock-keyword-face) - (2 (let ((type (get (intern-soft (match-string 1)) 'lisp-define-type))) - (cond ((eq type 'var) font-lock-variable-name-face) - ((eq type 'type) font-lock-type-face) - (t font-lock-function-name-face))) - nil t)) + (3 (let ((type (get (intern-soft (match-string 1)) 'lisp-define-type))) + (cond ((eq type 'var) font-lock-variable-name-face) + ((eq type 'type) font-lock-type-face) + ;; If match-string 2 is non-nil, we encountered a + ;; form like (defalias (intern (concat s "-p"))). + ((not (match-string 2)) font-lock-function-name-face))) + nil t)) ;; Emacs Lisp autoload cookies. Supports the slightly different ;; forms used by mh-e, calendar, etc. ("^;;;###\\([-a-z]*autoload\\)" 1 font-lock-warning-face prepend)) -- cgit v1.2.3 From 73b8237c19200e7d8d3739b99ef1e4dc86f51873 Mon Sep 17 00:00:00 2001 From: Tassilo Horn Date: Fri, 20 Mar 2015 23:35:22 +0100 Subject: Fix CL function name font-lock bug. * emacs-lisp/lisp-mode.el (lisp-cl-font-lock-keywords-1): Fix false positive in function name font-locking. --- lisp/ChangeLog | 1 + lisp/emacs-lisp/lisp-mode.el | 11 +++++++---- 2 files changed, 8 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 85e62be80c2..025941f809c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -2,6 +2,7 @@ * emacs-lisp/lisp-mode.el (lisp-el-font-lock-keywords-1): Fix false positive in function name font-locking. + (lisp-cl-font-lock-keywords-1): Ditto. 2015-03-20 Stefan Monnier diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index d8901ac017d..a3bb1a709f6 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -341,13 +341,16 @@ `( ;; Definitions. (,(concat "(" cl-defs-re "\\_>" ;; Any whitespace and defined object. - "[ \t'\(]*" - "\\(setf[ \t]+\\(?:\\sw\\|\\s_\\)+\\|\\(?:\\sw\\|\\s_\\)+\\)?") + "[ \t']*" + "\\(([ \t']*\\)?" ;; An opening paren. + "\\(\\(setf\\)[ \t]+\\(?:\\sw\\|\\s_\\)+\\|\\(?:\\sw\\|\\s_\\)+\\)?") (1 font-lock-keyword-face) - (2 (let ((type (get (intern-soft (match-string 1)) 'lisp-define-type))) + (3 (let ((type (get (intern-soft (match-string 1)) 'lisp-define-type))) (cond ((eq type 'var) font-lock-variable-name-face) ((eq type 'type) font-lock-type-face) - (t font-lock-function-name-face))) + ((or (not (match-string 2)) ;; Normal defun. + (and (match-string 2) ;; Setf-expander. + (match-string 4))) font-lock-function-name-face))) nil t))) "Subdued level highlighting for Lisp modes.") -- cgit v1.2.3 From fa734d07ab9dd00ad29d68668ed25247c9000aef Mon Sep 17 00:00:00 2001 From: Tassilo Horn Date: Sat, 21 Mar 2015 08:52:34 +0100 Subject: Handle setf methods in elisp font-locking. * emacs-lisp/lisp-mode.el (lisp-el-font-lock-keywords-1): Also recognize (cl-)defmethod with (setf method) name. --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/lisp-mode.el | 17 ++++++++++------- 2 files changed, 15 insertions(+), 7 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 025941f809c..1cfefaa39df 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-03-21 Tassilo Horn + + * emacs-lisp/lisp-mode.el (lisp-el-font-lock-keywords-1): Also + recognize (cl-)defmethod with (setf method) name. + 2015-03-20 Tassilo Horn * emacs-lisp/lisp-mode.el (lisp-el-font-lock-keywords-1): Fix diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index a3bb1a709f6..9c4194557ef 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -249,7 +249,7 @@ (eieio-tdefs '("defclass")) (eieio-kw '("with-slots")) ;; Common-Lisp constructs supported by cl-lib. - (cl-lib-fdefs '("defmacro" "defsubst" "defun")) + (cl-lib-fdefs '("defmacro" "defsubst" "defun" "defmethod")) (cl-lib-tdefs '("defstruct" "deftype")) (cl-lib-kw '("progv" "eval-when" "case" "ecase" "typecase" "etypecase" "ccase" "ctypecase" "loop" "do" "do*" @@ -321,16 +321,19 @@ (,(concat "(" el-defs-re "\\_>" ;; Any whitespace and defined object. "[ \t']*" - ;; With cl-defstruct, the name may follow a paren, - ;; e.g. (cl-defstruct (foo-struct opts)...). - "\\(([ \t']*\\)?\\(\\(?:\\sw\\|\\s_\\)+\\)?") + "\\(([ \t']*\\)?" ;; An opening paren. + "\\(\\(setf\\)[ \t]+\\(?:\\sw\\|\\s_\\)+\\|\\(?:\\sw\\|\\s_\\)+\\)?") (1 font-lock-keyword-face) (3 (let ((type (get (intern-soft (match-string 1)) 'lisp-define-type))) (cond ((eq type 'var) font-lock-variable-name-face) ((eq type 'type) font-lock-type-face) ;; If match-string 2 is non-nil, we encountered a - ;; form like (defalias (intern (concat s "-p"))). - ((not (match-string 2)) font-lock-function-name-face))) + ;; form like (defalias (intern (concat s "-p"))), + ;; unless match-string 4 is also there. Then its a + ;; defmethod with (setf foo) as name. + ((or (not (match-string 2)) ;; Normal defun. + (and (match-string 2) ;; Setf method. + (match-string 4))) font-lock-function-name-face))) nil t)) ;; Emacs Lisp autoload cookies. Supports the slightly different ;; forms used by mh-e, calendar, etc. @@ -349,7 +352,7 @@ (cond ((eq type 'var) font-lock-variable-name-face) ((eq type 'type) font-lock-type-face) ((or (not (match-string 2)) ;; Normal defun. - (and (match-string 2) ;; Setf-expander. + (and (match-string 2) ;; Setf function. (match-string 4))) font-lock-function-name-face))) nil t))) "Subdued level highlighting for Lisp modes.") -- cgit v1.2.3 From 17ad6f839e1c435ea944a0cda0b682687f194c7a Mon Sep 17 00:00:00 2001 From: Mario Lang Date: Fri, 6 Jun 2014 02:39:22 +0200 Subject: Fix problems caused by calling 'recenter' in auto-revert (Bug#20122) lisp/emacs-lisp/tabulated-list.el (tabulated-list-print): Only call `recenter' if `current-buffer' is equal to `window-buffer'. (cherry picked from commit 4a8160204325c4b955647fe9e0a944c1f8c705dd) --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/tabulated-list.el | 3 ++- 2 files changed, 7 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 5c72fbdf291..301c52d410d 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2014-06-06 Mario Lang + + * emacs-lisp/tabulated-list.el (tabulated-list-print): Only call + `recenter' if `current-buffer' is equal to `window-buffer'. + 2015-03-20 Dmitry Gutov * progmodes/ruby-mode.el (ruby-syntax-before-regexp-re): Detect diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 933567db993..15a0914cb17 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -323,7 +323,8 @@ to the entry with the same ID element as the current line." (if saved-pt (progn (goto-char saved-pt) (move-to-column saved-col) - (recenter)) + (when (eq (window-buffer) (current-buffer)) + (recenter))) (goto-char (point-min))))) (defun tabulated-list-print-entry (id cols) -- cgit v1.2.3 From bb7b23c5cbd0659a9e913ea4c4642bffe83541ef Mon Sep 17 00:00:00 2001 From: Martin Rudalics Date: Sun, 22 Mar 2015 12:40:21 +0100 Subject: In `debug' don't try using window on inaccessible frame (Bug#17170). * emacs-lisp/debug.el (debug): Don't try using "previous" window when its not live or on an invisible frame (Bug#17170). --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/debug.el | 6 ++++-- 2 files changed, 9 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b28517f07ed..8f888e37b06 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-03-22 Martin Rudalics + + * emacs-lisp/debug.el (debug): Don't try using "previous" window + when its not live or on an invisible frame (Bug#17170). + 2015-03-21 Mario Lang * emacs-lisp/tabulated-list.el (tabulated-list-print): Only call diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index dc0e666836e..38befeece45 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -193,8 +193,10 @@ first will be printed into the backtrace buffer." debugger-buffer `((display-buffer-reuse-window display-buffer-in-previous-window) - . (,(when debugger-previous-window - `(previous-window . ,debugger-previous-window))))) + . (,(when (and (window-live-p debugger-previous-window) + (frame-visible-p + (window-frame debugger-previous-window))) + `(previous-window . ,debugger-previous-window))))) (setq debugger-window (selected-window)) (if (eq debugger-previous-window debugger-window) (when debugger-jumping-flag -- cgit v1.2.3 From e7f92aa3d3fb7d5cf88eef374eaeba4dc6b8984f Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Sun, 22 Mar 2015 17:33:49 -0700 Subject: authors.el small additions * lisp/emacs-lisp/authors.el (authors-aliases) (authors-obsolete-files-regexps): Additions. --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/authors.el | 2 ++ 2 files changed, 7 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 7c7c66d24d6..40f1e9ff279 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-03-23 Glenn Morris + + * emacs-lisp/authors.el (authors-aliases) + (authors-obsolete-files-regexps): Additions. + 2015-03-22 Jan Djärv * simple.el (deactivate-mark): Only modify PRIMARY if we own diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el index b44f7aa7146..7d6169d9029 100644 --- a/lisp/emacs-lisp/authors.el +++ b/lisp/emacs-lisp/authors.el @@ -85,6 +85,7 @@ files.") ("Jens-Ulrik Holger Petersen" "Jens-Ulrik Petersen") ("Jeremy Bertram Maitin-Shepard" "Jeremy Maitin-Shepard") ("Johan Bockgård" "Johan Bockgard") + ("John F. Carr" "John F Carr") ("John J Foerch" "John Foerch") ("John W. Eaton" "John Eaton") ("Jonathan I. Kamens" "Jonathan Kamens") @@ -242,6 +243,7 @@ If REALNAME is nil, ignore that author.") '(".*loaddefs.el$" ; not obsolete, but auto-generated "\\.\\(bzr\\|cvs\\|git\\)ignore$" ; obsolete or uninteresting "\\.arch-inventory$" + "ChangeLog\\(\\.[0-9]+\\)?\\'" "automated/data/" ; not interesting ;; TODO lib/? Matches other things? "build-aux/" "m4/" "Emacs.xcodeproj" "mapfiles" "\\.map\\'" -- cgit v1.2.3 From d235b1d261ae9f275ac1f412dd8a8ad3f1c45e51 Mon Sep 17 00:00:00 2001 From: Daniel Colascione Date: Mon, 23 Mar 2015 01:38:12 -0700 Subject: Try to avoid fontifying macros in funcall position * lisp/emacs-lisp/lisp-mode.el (lisp--el-non-funcall-position-p): New function. (lisp--el-match-keyword): Use it. --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/lisp-mode.el | 36 +++++++++++++++++++++++++++++++++++- 2 files changed, 40 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 8f1534a3284..630265a0f4c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-03-23 Daniel Colascione + + * emacs-lisp/lisp-mode.el (lisp--el-non-funcall-position-p): New function. + (lisp--el-match-keyword): Use it. + 2015-03-23 Daiki Ueno * subr.el (start-process): New function, ported from the C diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 9c4194557ef..52bc6a5405b 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -181,13 +181,47 @@ nil))) res)) +(defun lisp--el-non-funcall-position-p (&optional pos) + "Heuristically determine whether POS is an evaluated position." + (setf pos (or pos (point))) + (save-match-data + (save-excursion + (goto-char pos) + (or (eql (char-before) ?\') + (let ((parent + (ignore-errors + (up-list -1) + (cond + ((looking-at (rx "(" (* (syntax -)) "(")) + (up-list -1) + (when (looking-at "(\\_") + (goto-char (match-end 0)) + 'let)) + ((looking-at + (rx "(" + (group-n 1 (+ (or (syntax w) (syntax _)))) + symbol-end)) + (prog1 (intern-soft (match-string-no-properties 1)) + (goto-char (match-end 1)))))))) + (or (eq parent 'declare) + (and (eq parent 'let) + (progn + (forward-sexp 1) + (< pos (point)))) + (and (eq parent 'condition-case) + (progn + (forward-sexp 2) + (< (point) pos))))))))) + (defun lisp--el-match-keyword (limit) (catch 'found (while (re-search-forward "(\\(\\(?:\\sw\\|\\s_\\)+\\)\\_>" limit t) (let ((sym (intern-soft (match-string 1)))) (when (or (special-form-p sym) (and (macrop sym) - (not (get sym 'no-font-lock-keyword)))) + (not (get sym 'no-font-lock-keyword)) + (not (lisp--el-non-funcall-position-p + (match-beginning 0))))) (throw 'found t)))))) (defun lisp--el-font-lock-flush-elisp-buffers (&optional file) -- cgit v1.2.3 From b8d7d7e8e6b3f5542b52b57f2514960d7184210a Mon Sep 17 00:00:00 2001 From: Daniel Colascione Date: Mon, 23 Mar 2015 01:42:56 -0700 Subject: Fix previous commit --- lisp/emacs-lisp/lisp-mode.el | 50 ++++++++++++++++++++++---------------------- 1 file changed, 25 insertions(+), 25 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 52bc6a5405b..e96c8ed5cef 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -186,32 +186,32 @@ (setf pos (or pos (point))) (save-match-data (save-excursion - (goto-char pos) - (or (eql (char-before) ?\') - (let ((parent - (ignore-errors + (ignore-errors + (goto-char pos) + (or (eql (char-before) ?\') + (let ((parent (up-list -1) - (cond - ((looking-at (rx "(" (* (syntax -)) "(")) - (up-list -1) - (when (looking-at "(\\_") - (goto-char (match-end 0)) - 'let)) - ((looking-at - (rx "(" - (group-n 1 (+ (or (syntax w) (syntax _)))) - symbol-end)) - (prog1 (intern-soft (match-string-no-properties 1)) - (goto-char (match-end 1)))))))) - (or (eq parent 'declare) - (and (eq parent 'let) - (progn - (forward-sexp 1) - (< pos (point)))) - (and (eq parent 'condition-case) - (progn - (forward-sexp 2) - (< (point) pos))))))))) + (cond + ((looking-at (rx "(" (* (syntax -)) "(")) + (up-list -1) + (when (looking-at "(\\_") + (goto-char (match-end 0)) + 'let)) + ((looking-at + (rx "(" + (group-n 1 (+ (or (syntax w) (syntax _)))) + symbol-end)) + (prog1 (intern-soft (match-string-no-properties 1)) + (goto-char (match-end 1))))))) + (or (eq parent 'declare) + (and (eq parent 'let) + (progn + (forward-sexp 1) + (< pos (point)))) + (and (eq parent 'condition-case) + (progn + (forward-sexp 2) + (< (point) pos)))))))))) (defun lisp--el-match-keyword (limit) (catch 'found -- cgit v1.2.3 From bad7308e0c7bfe0192ac05d7aea72e1f7bea7b08 Mon Sep 17 00:00:00 2001 From: Daniel Colascione Date: Mon, 23 Mar 2015 01:50:42 -0700 Subject: Fix previous commit (again) --- lisp/emacs-lisp/lisp-mode.el | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index e96c8ed5cef..4c9a39fe174 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -190,19 +190,22 @@ (goto-char pos) (or (eql (char-before) ?\') (let ((parent - (up-list -1) - (cond - ((looking-at (rx "(" (* (syntax -)) "(")) - (up-list -1) - (when (looking-at "(\\_") - (goto-char (match-end 0)) - 'let)) - ((looking-at - (rx "(" - (group-n 1 (+ (or (syntax w) (syntax _)))) - symbol-end)) - (prog1 (intern-soft (match-string-no-properties 1)) - (goto-char (match-end 1))))))) + (progn + (up-list -1) + (cond + ((ignore-errors + (and (eql (char-after) ?\() + (progn + (up-list -1) + (looking-at "(\\_")))) + (goto-char (match-end 0)) + 'let) + ((looking-at + (rx "(" + (group-n 1 (+ (or (syntax w) (syntax _)))) + symbol-end)) + (prog1 (intern-soft (match-string-no-properties 1)) + (goto-char (match-end 1)))))))) (or (eq parent 'declare) (and (eq parent 'let) (progn -- cgit v1.2.3 From ae277259b1cf8d913893417e4ca284040f5a543f Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 23 Mar 2015 18:24:30 -0400 Subject: Add new `cl-struct' and `eieio' pcase patterns. * lisp/emacs-lisp/cl-macs.el (cl-struct): New pcase pattern. * lisp/emacs-lisp/eieio.el (eieio-pcase-slot-index-table) (eieio-pcase-slot-index-from-index-table): New functions. (eieio): New pcase pattern. * lisp/emacs-lisp/pcase.el (pcase--make-docstring): New function. (pcase): Use it to build the docstring. (pcase-defmacro): Make sure the macro is lazy-loaded. (\`): Move its docstring from `pcase'. --- etc/NEWS | 2 +- lisp/ChangeLog | 12 +++++++++++ lisp/emacs-lisp/cl-lib.el | 1 - lisp/emacs-lisp/cl-macs.el | 22 ++++++++++++++++++++ lisp/emacs-lisp/eieio.el | 38 +++++++++++++++++++++++++++++++++ lisp/emacs-lisp/pcase.el | 52 ++++++++++++++++++++++++++++++++++------------ 6 files changed, 112 insertions(+), 15 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/etc/NEWS b/etc/NEWS index 3b848dc6539..a8b8c55a50a 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -346,7 +346,7 @@ invalid certificates are marked in red. transformed into multipart/related messages before sending. ** pcase -*** New UPatterns `quote' and `app'. +*** New UPatterns `quote', `app', `cl-struct', and `eieio'. *** New UPatterns can be defined with `pcase-defmacro'. +++ *** New vector QPattern. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 248f24d6490..8670e450e28 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,15 @@ +2015-03-23 Stefan Monnier + + Add new `cl-struct' and `eieio' pcase patterns. + * emacs-lisp/cl-macs.el (cl-struct): New pcase pattern. + * emacs-lisp/eieio.el (eieio-pcase-slot-index-table) + (eieio-pcase-slot-index-from-index-table): New functions. + (eieio): New pcase pattern. + * emacs-lisp/pcase.el (pcase--make-docstring): New function. + (pcase): Use it to build the docstring. + (pcase-defmacro): Make sure the macro is lazy-loaded. + (\`): Move its docstring from `pcase'. + 2015-03-23 Glenn Morris * emacs-lisp/authors.el (authors-aliases) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 4b124951446..10651cc29bd 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -629,7 +629,6 @@ the process stops as soon as KEYS or VALUES run out. If ALIST is non-nil, the new pairs are prepended to it." (nconc (cl-mapcar 'cons keys values) alist)) - ;;; Generalized variables. ;; These used to be in cl-macs.el since all macros that use them (like setf) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 75c6a5687c4..a81d217e4ee 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2768,6 +2768,28 @@ non-nil value, that slot cannot be set via `setf'. ',print-auto)) ',name))) +;;; Add cl-struct support to pcase + +;;;###autoload +(pcase-defmacro cl-struct (type &rest fields) + "Pcase patterns to match cl-structs. +Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of +field NAME is matched against UPAT, or they can be of the form NAME which +is a shorthand for (NAME NAME)." + ;; FIXME: This works well for a destructuring pcase-let, but for straight + ;; pcase, it suffers seriously from a lack of support for cl-typep in + ;; pcase--mutually-exclusive-p. + `(and (pred (pcase--swap cl-typep ',type)) + ,@(mapcar + (lambda (field) + (let* ((name (if (consp field) (car field) field)) + (pat (if (consp field) (cadr field) field))) + `(app ,(if (eq (cl-struct-sequence-type type) 'list) + `(nth ,(cl-struct-slot-offset type name)) + `(pcase--flip aref ,(cl-struct-slot-offset type name))) + ,pat))) + fields))) + (defun cl-struct-sequence-type (struct-type) "Return the sequence used to build STRUCT-TYPE. STRUCT-TYPE is a symbol naming a struct type. Return 'vector or diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 8d76df874e5..27725148ff6 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -328,6 +328,44 @@ variable name of the same name as the slot." (list var `(slot-value ,object ',slot)))) spec-list) ,@body))) + +;; Keep it as a non-inlined function, so the internals of object don't get +;; hard-coded in random .elc files. +(defun eieio-pcase-slot-index-table (obj) + "Return some data structure from which can be extracted the slot offset." + (eieio--class-index-table + (symbol-value (eieio--object-class-tag obj)))) + +(defun eieio-pcase-slot-index-from-index-table (index-table slot) + "Find the index to pass to `aref' to access SLOT." + (let ((index (gethash slot index-table))) + (if index (+ (eval-when-compile + (length (cl-struct-slot-info 'eieio--object))) + index)))) + +(pcase-defmacro eieio (&rest fields) + "Pcase patterns to match EIEIO objects. +Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of +field NAME is matched against UPAT, or they can be of the form NAME which +is a shorthand for (NAME NAME)." + (let ((is (make-symbol "table"))) + ;; FIXME: This generates a horrendous mess of redundant let bindings. + ;; `pcase' needs to be improved somehow to introduce let-bindings more + ;; sparingly, or the byte-compiler needs to be taught to optimize + ;; them away. + ;; FIXME: `pcase' does not do a good job here of sharing tests&code among + ;; various branches. + `(and (pred eieio-object-p) + (app eieio-pcase-slot-index-table ,is) + ,@(mapcar (lambda (field) + (let* ((name (if (consp field) (car field) field)) + (pat (if (consp field) (cadr field) field)) + (i (make-symbol "index"))) + `(and (let (and ,i (pred natnump)) + (eieio-pcase-slot-index-from-index-table + ,is ',name)) + (app (pcase--flip aref ,i) ,pat)))) + fields)))) ;;; Simple generators, and query functions. None of these would do ;; well embedded into an object. diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 0e8a969a402..a9933e46bbd 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -103,7 +103,6 @@ UPatterns can take the following forms: (or UPAT...) matches if any of the patterns matches. (and UPAT...) matches if all the patterns match. 'VAL matches if the object is `equal' to VAL - `QPAT matches if the QPattern QPAT matches. (pred FUN) matches if FUN applied to the object returns non-nil. (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. (let UPAT EXP) matches if EXP matches UPAT. @@ -111,14 +110,6 @@ UPatterns can take the following forms: If a SYMBOL is used twice in the same pattern (i.e. the pattern is \"non-linear\"), then the second occurrence is turned into an `eq'uality test. -QPatterns can take the following forms: - (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr. - [QPAT1 QPAT2..QPATn] matches a vector of length n and QPAT1..QPATn match - its 0..(n-1)th elements, respectively. - ,UPAT matches if the UPattern UPAT matches. - STRING matches if the object is `equal' to STRING. - ATOM matches if the object is `eq' to ATOM. - FUN can take the form SYMBOL or (lambda ARGS BODY) in which case it's called with one argument. (F ARG1 .. ARGn) in which case F gets called with an n+1'th argument @@ -129,7 +120,10 @@ FUN is assumed to be pure, i.e. it can be dropped if its result is not used, and two identical calls can be merged into one. 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))))" +`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a)))) + +Additional patterns can be defined via `pcase-defmacro'. +Currently, the following patterns are provided this way:" (declare (indent 1) (debug (form &rest (pcase-UPAT body)))) ;; We want to use a weak hash table as a cache, but the key will unavoidably ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time @@ -154,6 +148,26 @@ like `(,a . ,(pred (< a))) or, with more checks: ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2) expansion)))) +;; FIXME: Obviously, this will collide with nadvice's use of +;; function-documentation if we happen to advise `pcase'. +(put 'pcase 'function-documentation '(pcase--make-docstring)) +(defun pcase--make-docstring () + (let* ((main (documentation (symbol-function 'pcase) 'raw)) + (ud (help-split-fundoc main 'pcase))) + (with-temp-buffer + (insert (or (cdr ud) main)) + (mapatoms + (lambda (symbol) + (let ((me (get symbol 'pcase-macroexpander))) + (when me + (insert "\n\n-- ") + (let* ((doc (documentation me 'raw))) + (setq doc (help-fns--signature symbol doc me + (indirect-function me))) + (insert "\n" (or doc "Not documented."))))))) + (let ((combined-doc (buffer-string))) + (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))))) + ;;;###autoload (defmacro pcase-exhaustive (exp &rest cases) "The exhaustive version of `pcase' (which see)." @@ -347,9 +361,13 @@ of the form (UPAT EXP)." ;;;###autoload (defmacro pcase-defmacro (name args &rest body) "Define a pcase UPattern macro." - (declare (indent 2) (debug (def-name sexp def-body)) (doc-string 3)) - `(put ',name 'pcase-macroexpander - (lambda ,args ,@body))) + (declare (indent 2) (debug defun) (doc-string 3)) + (let ((fsym (intern (format "%s--pcase-macroexpander" name)))) + ;; Add the function via `fsym', so that an autoload cookie placed + ;; on a pcase-defmacro will cause the macro to be loaded on demand. + `(progn + (defun ,fsym ,args ,@body) + (put ',name 'pcase-macroexpander #',fsym)))) (defun pcase--match (val upat) "Build a MATCH structure, hoisting all `or's and `and's outside." @@ -810,6 +828,14 @@ Otherwise, it defers to REST which is a list of branches of the form (t (error "Incorrect MATCH %S" (car matches))))) (pcase-defmacro \` (qpat) + "Backquote-style pcase patterns. +QPAT can take the following forms: + (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr. + [QPAT1 QPAT2..QPATn] matches a vector of length n and QPAT1..QPATn match + its 0..(n-1)th elements, respectively. + ,UPAT matches if the UPattern UPAT matches. + STRING matches if the object is `equal' to STRING. + ATOM matches if the object is `eq' to ATOM." (cond ((eq (car-safe qpat) '\,) (cadr qpat)) ((vectorp qpat) -- cgit v1.2.3 From d7d72624b29f0eeb2c242e976703e4755c6d7bef Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 23 Mar 2015 23:40:06 -0400 Subject: Add cl-struct specific optimizations to pcase. * lisp/emacs-lisp/cl-macs.el (cl--struct-all-parents) (cl--pcase-mutually-exclusive-p): New functions. (pcase--mutually-exclusive-p): Advise to optimize cl-struct patterns. * lisp/emacs-lisp/pcase.el (pcase--split-pred): Handle quoted string. --- lisp/ChangeLog | 9 ++++++++ lisp/emacs-lisp/cl-macs.el | 52 ++++++++++++++++++++++++++++++++++++++++++---- lisp/emacs-lisp/pcase.el | 1 + 3 files changed, 58 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 8670e450e28..25ac7ae6782 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,12 @@ +2015-03-24 Stefan Monnier + + Add cl-struct specific optimizations to pcase. + * emacs-lisp/cl-macs.el (cl--struct-all-parents) + (cl--pcase-mutually-exclusive-p): New functions. + (pcase--mutually-exclusive-p): Advise to optimize cl-struct patterns. + + * emacs-lisp/pcase.el (pcase--split-pred): Handle quoted string. + 2015-03-23 Stefan Monnier Add new `cl-struct' and `eieio' pcase patterns. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index a81d217e4ee..5d55a1d4579 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2770,16 +2770,25 @@ non-nil value, that slot cannot be set via `setf'. ;;; Add cl-struct support to pcase +(defun cl--struct-all-parents (class) + (when (cl--struct-class-p class) + (let ((res ()) + (classes (list class))) + ;; BFS precedence. + (while (let ((class (pop classes))) + (push class res) + (setq classes + (append classes + (cl--class-parents class))))) + (nreverse res)))) + ;;;###autoload (pcase-defmacro cl-struct (type &rest fields) "Pcase patterns to match cl-structs. Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of field NAME is matched against UPAT, or they can be of the form NAME which is a shorthand for (NAME NAME)." - ;; FIXME: This works well for a destructuring pcase-let, but for straight - ;; pcase, it suffers seriously from a lack of support for cl-typep in - ;; pcase--mutually-exclusive-p. - `(and (pred (pcase--swap cl-typep ',type)) + `(and (pred (pcase--flip cl-typep ',type)) ,@(mapcar (lambda (field) (let* ((name (if (consp field) (car field) field)) @@ -2790,6 +2799,41 @@ is a shorthand for (NAME NAME)." ,pat))) fields))) +(defun cl--pcase-mutually-exclusive-p (orig pred1 pred2) + "Extra special cases for `cl-typep' predicates." + (let* ((x1 pred1) (x2 pred2) + (t1 + (and (eq 'pcase--flip (car-safe x1)) (setq x1 (cdr x1)) + (eq 'cl-typep (car-safe x1)) (setq x1 (cdr x1)) + (null (cdr-safe x1)) (setq x1 (car x1)) + (eq 'quote (car-safe x1)) (cadr x1))) + (t2 + (and (eq 'pcase--flip (car-safe x2)) (setq x2 (cdr x2)) + (eq 'cl-typep (car-safe x2)) (setq x2 (cdr x2)) + (null (cdr-safe x2)) (setq x2 (car x2)) + (eq 'quote (car-safe x2)) (cadr x2)))) + (or + (and (symbolp t1) (symbolp t2) + (let ((c1 (cl--find-class t1)) + (c2 (cl--find-class t2))) + (and c1 c2 + (not (or (memq c1 (cl--struct-all-parents c2)) + (memq c2 (cl--struct-all-parents c1))))))) + (let ((c1 (and (symbolp t1) (cl--find-class t1)))) + (and c1 (cl--struct-class-p c1) + (funcall orig (if (eq 'list (cl-struct-sequence-type t1)) + 'consp 'vectorp) + pred2))) + (let ((c2 (and (symbolp t2) (cl--find-class t2)))) + (and c2 (cl--struct-class-p c2) + (funcall orig pred1 + (if (eq 'list (cl-struct-sequence-type t2)) + 'consp 'vectorp)))) + (funcall orig pred1 pred2)))) +(advice-add 'pcase--mutually-exclusive-p + :around #'cl--pcase-mutually-exclusive-p) + + (defun cl-struct-sequence-type (struct-type) "Return the sequence used to build STRUCT-TYPE. STRUCT-TYPE is a symbol naming a struct type. Return 'vector or diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index a9933e46bbd..3a2fa4fdc81 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -582,6 +582,7 @@ MATCH is the pattern that needs to be matched, of the form: (cond ((eq 'pred (car-safe pat)) (cadr pat)) ((not (eq 'quote (car-safe pat))) nil) ((consp (cadr pat)) #'consp) + ((stringp (cadr pat)) #'stringp) ((vectorp (cadr pat)) #'vectorp) ((byte-code-function-p (cadr pat)) #'byte-code-function-p)))) -- cgit v1.2.3 From d46f31b4b2b0c56f2708e3225eb9fa973441e696 Mon Sep 17 00:00:00 2001 From: Nicolas Petton Date: Wed, 25 Mar 2015 09:21:14 +0100 Subject: * lisp/emacs-lisp/seq.el: Documentation improvements --- lisp/ChangeLog | 4 ++++ lisp/emacs-lisp/seq.el | 4 ++-- 2 files changed, 6 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 72a45d0ca7a..4fb1999e3e9 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2015-03-25 Nicolas Petton + + * emacs-lisp/seq.el: Documentation improvements. + 2015-03-25 Glenn Morris * net/browse-url.el (browse-url-browser-function) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 59b91408d09..c5f5906e7e5 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -33,8 +33,8 @@ ;; ;; All provided functions work on lists, strings and vectors. ;; -;; Functions taking a predicate or a function iterating over the -;; sequence as argument take the function as their first argument and +;; Functions taking a predicate or iterating over a sequence using a +;; function as argument take the function as their first argument and ;; the sequence as their second argument. All other functions take ;; the sequence as their first argument. ;; -- cgit v1.2.3 From eeb515715d50e55477b6bc9c5a64fbb57dfaec94 Mon Sep 17 00:00:00 2001 From: Artur Malabarba Date: Wed, 25 Mar 2015 17:48:15 +0000 Subject: emacs-lisp/checkdoc.el: Don't complain about args starting with _. --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/checkdoc.el | 5 +++-- 2 files changed, 8 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index e74733015c9..2d150ba3dd2 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-03-25 Artur Malabarba + + * emacs-lisp/checkdoc.el (checkdoc-this-string-valid-engine): + Don't complain about args starting with _. + 2015-03-25 Stefan Monnier * international/mule-cmds.el (mule--ucs-names-annotation): New func. diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 288e25e6060..777fed082d9 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -1663,14 +1663,15 @@ function,command,variable,option or symbol." ms1)))))) ;; Addendum: Make sure they appear in the doc in the same ;; order that they are found in the arg list. - (let ((args (cdr (cdr (cdr (cdr fp))))) + (let ((args (nthcdr 4 fp)) (last-pos 0) (found 1) (order (and (nth 3 fp) (car (nth 3 fp)))) (nocheck (append '("&optional" "&rest") (nth 3 fp))) (inopts nil)) (while (and args found (> found last-pos)) - (if (member (car args) nocheck) + (if (or (member (car args) nocheck) + (string-match "\\`_" (car args))) (setq args (cdr args) inopts t) (setq last-pos found -- cgit v1.2.3 From 2b828866c2df5ea558283e4c3f4c79a404918bea Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 25 Mar 2015 14:28:25 -0400 Subject: * etc/TODO: Remove obsolete entries. --- etc/ChangeLog | 4 ++++ etc/TODO | 38 -------------------------------------- lisp/emacs-lisp/byte-run.el | 4 ++-- 3 files changed, 6 insertions(+), 40 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/etc/ChangeLog b/etc/ChangeLog index d6b6e299113..f0da3a57d3d 100644 --- a/etc/ChangeLog +++ b/etc/ChangeLog @@ -1,3 +1,7 @@ +2015-03-25 Stefan Monnier + + * TODO: Remove obsolete entries. + 2015-03-24 Daniel Colascione * NEWS: Mention change to `process-running-child-p`. diff --git a/etc/TODO b/etc/TODO index 79996e28d3f..2235431c606 100644 --- a/etc/TODO +++ b/etc/TODO @@ -416,9 +416,6 @@ http://lists.gnu.org/archive/html/emacs-devel/2009-04/msg00034.html ** Allow frames(terminals) created by emacsclient to inherit their environment from the emacsclient process. -** Remove the default toggling behavior of minor modes when called from elisp -rather than interactively. This a trivial one-liner in easy-mode.el. - ** Give Tar mode all the features of Archive mode. ** Create a category of errors called `process-error' @@ -427,9 +424,6 @@ rather than interactively. This a trivial one-liner in easy-mode.el. ** Maybe reinterpret `parse-error' as a category of errors and put some other errors under it. -** A function to tell you the argument pattern of functions. - See `function-arity' in http://www.loveshack.ukfsn.org/emacs/fx-misc.el. - ** Make byte-compile warn when a doc string is too wide. ** Make byte-optimization warnings issue accurate line numbers. @@ -495,9 +489,6 @@ rather than interactively. This a trivial one-liner in easy-mode.el. ** Give start-process the ability to direct standard-error output to a different filter. -** Make desktop.el save the "frame configuration" of Emacs (in some - useful sense). - ** Give desktop.el a feature to switch between different named desktops. ** Add a cpio mode, more or less like tar mode. @@ -523,23 +514,10 @@ rather than interactively. This a trivial one-liner in easy-mode.el. Check the assignments file for other packages which might go in and have been missed. -** Make keymaps a first-class Lisp object (this means a rewrite of - keymap.c). What should it do apart from being opaque ? - multiple inheritance ? faster where-is ? no more fix_submap_inheritance ? - what else ? - -** Implement popular parts of the rest of the CL functions as compiler - macros in cl-macs. [Is this still relevant now that cl-lib exists?] - ** Make compiler warnings about functions that might be undefined at run time smarter, so that they know which files are required by the file being compiled and don't warn about functions defined in them. -** Highlight rectangles (`mouse-track-rectangle-p' in XEmacs). Already in CUA, - but it's a valuable feature worth making more general. - [Basic support added 2013/10: - http://lists.gnu.org/archive/html/emacs-devel/2013-10/msg00904.html ] - ** Split out parts of lisp.h. ** Update the FAQ. @@ -547,11 +525,6 @@ rather than interactively. This a trivial one-liner in easy-mode.el. ** Allow auto-compression-mode to use zlib calls if zlib is available. [It's required for PNG, so may be linked anyhow.] -** Add a --pristine startup flag which does -q --no-site-file plus - ignoring X resources (Doze equivalents?) and most of the - environment. What should not be ignored needs consideration. - [Do the existing -Q and -D cover this, or is more needed?] - ** Improve the GC (generational, incremental). (We may be able to use the Boehm collector.) [See the Boehm-GC branch in CVS for work on this.] @@ -578,20 +551,9 @@ rather than interactively. This a trivial one-liner in easy-mode.el. (Requires recursing through display properties). Provide some way to simulate mouse-clicks on marginal text without a mouse. -** Implement Lisp functions to determine properly whether a character - is displayable (particularly needed in XFree 4, sigh). Use it to - define useful glyphs that may be displayed as images or unicodes - (with ASCIIfied fallback via latin1-disp). Examples include - box-drawing graphics in Custom buffers, W3 rules and tables, and - tree displays generally, mode-line mail indicator. [See work done - already for Emacs 23 and consult fx.] - ** Extend ps-print to deal with multiple font sizes, images, and extra encodings. -** Make byte-compile avoid binding an expanded defsubst's args - when the body only calls primitives. - ** Use the XIE X extension, if available, for image display. ** Make monochrome images display using the foreground and background diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index e0d6c3e7829..081ea3183b9 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -393,7 +393,7 @@ ACCESS-TYPE if non-nil should specify the kind of access that will trigger This uses `defvaralias' and `make-obsolete-variable' (which see). See the Info node `(elisp)Variable Aliases' for more details. -If CURRENT-NAME is a defcustom (more generally, any variable +If CURRENT-NAME is a defcustom or a defvar (more generally, any variable where OBSOLETE-NAME may be set, e.g. in an init file, before the alias is defined), then the define-obsolete-variable-alias statement should be evaluated before the defcustom, if user @@ -407,7 +407,7 @@ variable (this is due to the way `defvaralias' works). For the benefit of `custom-set-variables', if OBSOLETE-NAME has any of the following properties, they are copied to CURRENT-NAME, if it does not already have them: -'saved-value, 'saved-variable-comment." +`saved-value', `saved-variable-comment'." (declare (doc-string 4) (advertised-calling-convention ;; New code should always provide the `when' argument. -- cgit v1.2.3 From 5e0314f6fabca1af214240177a28d3822d6ef3e5 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 26 Mar 2015 09:36:24 -0400 Subject: * smie.el (smie*ward-sexp-command): Don't pretend the arg is optional Fixes: debbugs:20205 * lisp/emacs-lisp/smie.el (smie-backward-sexp-command) (smie-forward-sexp-command): Don't pretend the arg is optional. --- lisp/ChangeLog | 56 +++++++++++++++++++++++++++---------------------- lisp/emacs-lisp/smie.el | 4 ++-- 2 files changed, 33 insertions(+), 27 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 40f1e9ff279..fd9857e792c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2015-03-26 Stefan Monnier + + * emacs-lisp/smie.el (smie-backward-sexp-command) + (smie-forward-sexp-command): Don't pretend the arg is optional + (bug#20205). + 2015-03-23 Glenn Morris * emacs-lisp/authors.el (authors-aliases) @@ -20,19 +26,19 @@ 2015-03-20 Dmitry Gutov - * progmodes/ruby-mode.el (ruby-syntax-before-regexp-re): Detect - regexps after `!'. (Bug#19285) + * progmodes/ruby-mode.el (ruby-syntax-before-regexp-re): + Detect regexps after `!'. (Bug#19285) 2015-03-20 Dmitry Gutov - * progmodes/ruby-mode.el (ruby-font-lock-keywords): Use - `font-lock-constant-face' for nil, true and false. Highlight - `self' as a keyword. (Bug#17733) + * progmodes/ruby-mode.el (ruby-font-lock-keywords): + Use `font-lock-constant-face' for nil, true and false. + Highlight `self' as a keyword. (Bug#17733) 2015-03-20 Nobuyoshi Nakada - * progmodes/ruby-mode.el (ruby-syntax-before-regexp-re): Expect - beginning of regexp also after open brace or vertical bar. + * progmodes/ruby-mode.el (ruby-syntax-before-regexp-re): + Expect beginning of regexp also after open brace or vertical bar. (Bug#20026) 2015-03-07 Michael Albinus @@ -105,8 +111,8 @@ 2015-02-12 Agustín Martín Domingo Improve string search in `flyspell-word-search-*`. (Bug#16800) - * textmodes/flyspell.el (flyspell-duplicate-distance): Limit - default search distance for duplicated words to 40000. + * textmodes/flyspell.el (flyspell-duplicate-distance): + Limit default search distance for duplicated words to 40000. (flyspell-word-search-backward, flyspell-word-search-forward): Search as full word with defined casechars, not as substring. @@ -122,8 +128,8 @@ 2015-02-08 Eli Zaretskii * frame.el (frame-notice-user-settings): Refresh the value of - frame parameters after calling tty-handle-reverse-video. Call - face-set-after-frame-default with the actual parameters, to avoid + frame parameters after calling tty-handle-reverse-video. + Call face-set-after-frame-default with the actual parameters, to avoid resetting colors back to unspecified. (set-background-color, set-foreground-color): Pass the foreground and background colors to face-set-after-frame-default. (Bug#19802) @@ -156,8 +162,8 @@ 2015-02-04 Eli Zaretskii - * textmodes/artist.el (artist-ellipse-compute-fill-info): Use - mapcar, not mapc, to create the other half of fill-info. + * textmodes/artist.el (artist-ellipse-compute-fill-info): + Use mapcar, not mapc, to create the other half of fill-info. (Bug#19763) 2015-02-04 Nicolas Petton @@ -182,18 +188,18 @@ 2015-02-01 Alan Mackenzie - CC Mode: Stop Font Lock forcing fontification from BOL. Fixes - debbugs#19669. + CC Mode: Stop Font Lock forcing fontification from BOL. + Fixes debbugs#19669. - * progmodes/cc-mode.el (c-font-lock-init): Setq - font-lock-extend-region-functions to nil. + * progmodes/cc-mode.el (c-font-lock-init): + Setq font-lock-extend-region-functions to nil. 2015-01-31 Alan Mackenzie Handle "#" operator properly inside macro. Fix coding bug. - * progmodes/cc-mode.el (c-neutralize-syntax-in-and-mark-CPP): On - finding a "#" which looks like the start of a macro, check it + * progmodes/cc-mode.el (c-neutralize-syntax-in-and-mark-CPP): + On finding a "#" which looks like the start of a macro, check it isn't already inside a macro. * progmodes/cc-engine.el (c-state-safe-place): Don't record a new @@ -236,8 +242,8 @@ python.el: New non-global state dependent indentation engine. (Bug#18319, Bug#19595) - * progmodes/python.el (python-syntax-comment-or-string-p): Accept - PPSS as argument. + * progmodes/python.el (python-syntax-comment-or-string-p): + Accept PPSS as argument. (python-syntax-closing-paren-p): New function. (python-indent-current-level) (python-indent-levels): Mark obsolete. @@ -262,8 +268,8 @@ * subr.el (posnp): Correct docstring of `posnp'. (posn-col-row): Make it work with all mouse position objects. - * textmodes/artist.el (artist-mouse-draw-continously): Cancel - timers if an error occurs during continuous drawing. (Bug#6130) + * textmodes/artist.el (artist-mouse-draw-continously): + Cancel timers if an error occurs during continuous drawing. (Bug#6130) 2015-01-20 Eli Zaretskii @@ -368,8 +374,8 @@ 2014-12-27 Fabián Ezequiel Gallina - * progmodes/python.el (python-shell-buffer-substring): Handle - cornercase when region sent starts at point-min. + * progmodes/python.el (python-shell-buffer-substring): + Handle cornercase when region sent starts at point-min. 2014-12-27 Eli Zaretskii diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 184912d9fc4..4f3f12d5285 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -834,12 +834,12 @@ Possible return values: ;;; Miscellaneous commands using the precedence parser. -(defun smie-backward-sexp-command (&optional n) +(defun smie-backward-sexp-command (n) "Move backward through N logical elements." (interactive "^p") (smie-forward-sexp-command (- n))) -(defun smie-forward-sexp-command (&optional n) +(defun smie-forward-sexp-command (n) "Move forward through N logical elements." (interactive "^p") (let ((forw (> n 0)) -- cgit v1.2.3 From 8fd527eb00a0ec1d8d7cf916204c3be3e79e27da Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 26 Mar 2015 13:32:45 -0400 Subject: * lisp/emacs-lisp/cl|eieio: Minor tweaks * lisp/emacs-lisp/cl-macs.el (cl-dolist, cl-dotimes): Silence byte-compiler. * lisp/emacs-lisp/eieio.el (defclass): Change internal name so as to make sure only EIEIO files should have "eieio--" prefixes in their .elc. --- lisp/ChangeLog | 7 +++++++ lisp/emacs-lisp/cl-macs.el | 4 ++-- lisp/emacs-lisp/eieio.el | 2 +- 3 files changed, 10 insertions(+), 3 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 37ac1c5f3c8..294bcfe7fb6 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,10 @@ +2015-03-26 Stefan Monnier + + * emacs-lisp/eieio.el (defclass): Change internal name so as to make + sure only EIEIO files should have "eieio--" prefixes in their .elc. + + * emacs-lisp/cl-macs.el (cl-dolist, cl-dotimes): Silence byte-compiler. + 2015-03-26 Boruch Baum (tiny change) * bookmark.el (bookmark-show-all-annotations): Sort them (bug#20177). diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 5d55a1d4579..f8ddc00c3bf 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1752,7 +1752,7 @@ An implicit nil block is established around the loop. (declare (debug ((symbolp form &optional form) cl-declarations body)) (indent 1)) (let ((loop `(dolist ,spec ,@body))) - (if (advice-member-p #'cl--wrap-in-nil-block 'dolist) + (if (advice-member-p 'cl--wrap-in-nil-block 'dolist) loop `(cl-block nil ,loop)))) ;;;###autoload @@ -1765,7 +1765,7 @@ nil. \(fn (VAR COUNT [RESULT]) BODY...)" (declare (debug cl-dolist) (indent 1)) (let ((loop `(dotimes ,spec ,@body))) - (if (advice-member-p #'cl--wrap-in-nil-block 'dotimes) + (if (advice-member-p 'cl--wrap-in-nil-block 'dotimes) loop `(cl-block nil ,loop)))) (defvar cl--tagbody-alist nil) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 27725148ff6..bca53c0c892 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -130,7 +130,7 @@ and reference them using the function `class-option'." (error "Method invocation order %s is not allowed" io))) (let ((testsym1 (intern (concat (symbol-name name) "-p"))) - (testsym2 (intern (format "eieio--childp--%s" name))) + (testsym2 (intern (format "%s--eieio-childp" name))) (accessors ())) ;; Collect the accessors we need to define. -- cgit v1.2.3 From 733a9f114cc7219a8380db84b05081f145a163ae Mon Sep 17 00:00:00 2001 From: Jan D Date: Sat, 28 Mar 2015 12:15:18 +0100 Subject: Fixes: debbugs:17879 * lisp/emacs-lisp/package.el (package-refresh-contents): Add a message at the end so it does not appear to have hanged. --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/package.el | 3 ++- 2 files changed, 7 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b2d431c62cf..488abb1b39b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-03-28 Jan Djärv + + * emacs-lisp/package.el (package-refresh-contents): Add a message at + the end so it does not appear to have hanged (Bug#17879). + 2015-03-27 Wolfgang Jenkner * font-lock.el (font-lock--remove-face-from-text-property): New diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 0d001bff4cf..d34dfbc0475 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1717,7 +1717,8 @@ and make them available for download." (error (message "Failed to download `%s' archive." (car archive))))) (package-read-all-archive-contents) - (package--build-compatibility-table)) + (package--build-compatibility-table) + (message "Package refersh done")) (defun package--find-non-dependencies () "Return a list of installed packages which are not dependencies. -- cgit v1.2.3 From e6127d94746e230f95bdf2ad002e4379474e5a8b Mon Sep 17 00:00:00 2001 From: Jan D Date: Sat, 28 Mar 2015 23:05:30 +0100 Subject: * lisp/emacs-lisp/package.el (package-refresh-contents): Fix spelling error --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/package.el | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index dbd092d4d50..c8e84a3c729 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-03-28 Jan Djärv + + * emacs-lisp/package.el (package-refresh-contents): Fix spelling + error in previous change. + 2015-03-28 Tom Willemse (tiny change) * elec-pair.el (electric-pair-local-mode): New command. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index d34dfbc0475..0275da39229 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1718,7 +1718,7 @@ and make them available for download." (car archive))))) (package-read-all-archive-contents) (package--build-compatibility-table) - (message "Package refersh done")) + (message "Package refresh done")) (defun package--find-non-dependencies () "Return a list of installed packages which are not dependencies. -- cgit v1.2.3 From ef37e79aae7a64f3c30f7ff4350c8f3a3c6c7b20 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 30 Mar 2015 17:51:50 -0400 Subject: * eieio-base.el (make-instance) : New instance. --- lisp/ChangeLog | 36 +++++++++++++++++++++--------------- lisp/emacs-lisp/eieio-base.el | 9 +++++++++ 2 files changed, 30 insertions(+), 15 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 649e8849732..e6ecf0fe09a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,14 +1,20 @@ +2015-03-30 Stefan Monnier + + * emacs-lisp/eieio-base.el (make-instance) : New instance + which stores the old-style object name argument into the + object-name field. + 2015-03-30 Alan Mackenzie Correct calculation of CC Mode's font-lock region. - * progmodes/cc-mode.el (c-fl-decl-start): Renamed from + * progmodes/cc-mode.el (c-fl-decl-start): Rename from c-set-fl-decl-start. Change signature such that nil is returned when no declaration is found. - (c-change-expand-fl-region): Renamed from + (c-change-expand-fl-region): Rename from c-change-set-fl-decl-start. This now also handles expanding the font lock region to whole lines. - (c-context-expand-fl-region): Renamed from + (c-context-expand-fl-region): Rename from c-context-set-fl-decl-start. This now also handles expanding the font lock region to whole lines. (c-font-lock-fontify-region): When a change font lock region is @@ -66,15 +72,15 @@ 2015-03-27 Wolfgang Jenkner - * font-lock.el (font-lock--remove-face-from-text-property): New - function. Adapted from the previously commented out + * font-lock.el (font-lock--remove-face-from-text-property): + New function. Adapted from the previously commented out remove-single-text-property. Remove previously unused and commented out auxiliary function remove-text-property and obsolete comment. * comint.el (comint-output-filter): Use it to remove comint-highlight-prompt. - (comint-snapshot-last-prompt, comint-output-filter): Use - font-lock-prepend-text-property for comint-highlight-prompt. + (comint-snapshot-last-prompt, comint-output-filter): + Use font-lock-prepend-text-property for comint-highlight-prompt. (Bug#20084) 2015-03-26 Daniel Colascione @@ -221,15 +227,15 @@ Automatically adjust process window sizes. - * window.el (window-adjust-process-window-size-function): New - customizable variable. + * window.el (window-adjust-process-window-size-function): + New customizable variable. (window-adjust-process-window-size) (window-adjust-process-window-size-smallest) (window-adjust-process-window-size-largest) (window--process-window-list, window--adjust-process-windows): New functions. - (window-configuration-change-hook): Add - `window--adjust-process-windows'. + (window-configuration-change-hook): + Add `window--adjust-process-windows'. * term.el (term-mode): Observe result of `window-adjust-process-window-size-function'. (term-check-size): Delete. @@ -261,13 +267,13 @@ 2015-03-21 Tassilo Horn - * emacs-lisp/lisp-mode.el (lisp-el-font-lock-keywords-1): Also - recognize (cl-)defmethod with (setf method) name. + * emacs-lisp/lisp-mode.el (lisp-el-font-lock-keywords-1): + Also recognize (cl-)defmethod with (setf method) name. 2015-03-20 Tassilo Horn - * emacs-lisp/lisp-mode.el (lisp-el-font-lock-keywords-1): Fix - false positive in function name font-locking. + * emacs-lisp/lisp-mode.el (lisp-el-font-lock-keywords-1): + Fix false positive in function name font-locking. (lisp-cl-font-lock-keywords-1): Ditto. 2015-03-20 Stefan Monnier diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 5b3d9029c53..c2eab202881 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -498,6 +498,15 @@ All slots are unbound, except those initialized with PARAMS." (concat nm "-1"))))) nobj)) +(cl-defmethod make-instance ((class (subclass eieio-named)) &rest args) + (if (not (stringp (car args))) + (cl-call-next-method) + (funcall (if eieio-backward-compatibility #'ignore #'message) + "Obsolete: name passed without :object-name to %S constructor" + class) + (apply #'cl-call-next-method class :object-name args))) + + (provide 'eieio-base) ;;; eieio-base.el ends here -- cgit v1.2.3 From a7270fb20feaedc5dc6c4e0936714bdb167062f7 Mon Sep 17 00:00:00 2001 From: Artur Malabarba Date: Sat, 28 Mar 2015 20:36:14 +0000 Subject: emacs-lisp/package.el: Reorganize package.el Reorganize package.el and divide it with page-breaks and comments --- lisp/ChangeLog | 5 + lisp/emacs-lisp/package.el | 1566 +++++++++++++++++++++++--------------------- 2 files changed, 826 insertions(+), 745 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 649e8849732..da5893f495b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-03-30 Artur Malabarba + + * emacs-lisp/package.el: Reorganize package.el and divide it with + page-breaks and comments. + 2015-03-30 Alan Mackenzie Correct calculation of CC Mode's font-lock region. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 0275da39229..526c0b41a77 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -173,6 +173,8 @@ :group 'applications :version "24.1") + +;;; Customization options ;;;###autoload (defcustom package-enable-at-startup t "Whether to activate installed packages when Emacs starts. @@ -204,12 +206,6 @@ If VERSION is nil, the package is not loaded (it is \"disabled\")." :group 'package :version "24.1") -(defvar Info-directory-list) -(declare-function info-initialize "info" ()) -(declare-function url-http-file-exists-p "url-http" (url)) -(declare-function lm-header "lisp-mnt" (header)) -(declare-function lm-commentary "lisp-mnt" (&optional file)) - (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. @@ -270,17 +266,6 @@ the package will be unavailable." :group 'package :version "24.4") -(defconst package-archive-version 1 - "Version number of the package archive understood by this file. -Lower version numbers than this will probably be understood as well.") - -;; We don't prime the cache since it tends to get out of date. -(defvar package-archive-contents nil - "Cache of the contents of the Emacs Lisp Package Archive. -This is an alist mapping package names (symbols) to -non-empty lists of `package-desc' structures.") -(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. The directory name should be absolute. @@ -348,6 +333,14 @@ a sane initial value." :group 'package :type '(repeat symbol)) + +;;; `package-desc' object definition +;; This is the struct used internally to represent packages. +;; Functions that deal with packages should generally take this object +;; as an argument. In some situations (e.g. commands that query the +;; user) it makes sense to take the package name as a symbol instead, +;; but keep in mind there could be multiple `package-desc's with the +;; same name. (defvar package--default-summary "No description available.") (cl-defstruct (package-desc @@ -419,7 +412,43 @@ Slots: extras signed) +(defun package--from-builtin (bi-desc) + (package-desc-create :name (pop bi-desc) + :version (package--bi-desc-version bi-desc) + :summary (package--bi-desc-summary bi-desc) + :dir 'builtin)) + ;; Pseudo fields. +(defun package-version-join (vlist) + "Return the version string corresponding to the list VLIST. +This is, approximately, the inverse of `version-to-list'. +\(Actually, it returns only one of the possible inverses, since +`version-to-list' is a many-to-one operation.)" + (if (null vlist) + "" + (let ((str-list (list "." (int-to-string (car vlist))))) + (dolist (num (cdr vlist)) + (cond + ((>= num 0) + (push (int-to-string num) str-list) + (push "." str-list)) + ((< num -4) + (error "Invalid version list `%s'" vlist)) + (t + ;; pre, or beta, or alpha + (cond ((equal "." (car str-list)) + (pop str-list)) + ((not (string-match "[0-9]+" (car str-list))) + (error "Invalid version list `%s'" vlist))) + (push (cond ((= num -1) "pre") + ((= num -2) "beta") + ((= num -3) "alpha") + ((= num -4) "snapshot")) + str-list)))) + (if (equal "." (car str-list)) + (pop str-list)) + (apply 'concat (nreverse str-list))))) + (defun package-desc-full-name (pkg-desc) (format "%s-%s" (package-desc-name pkg-desc) @@ -446,6 +475,13 @@ Slots: reqs summary) + +;;; Installed packages +;; The following variables store information about packages present in +;; the system. The most important of these is `package-alist'. The +;; command `package-initialize' is also closely related to this +;; section, but it is left for a later section because it also affects +;; other stuff. (defvar package--builtins nil "Alist of built-in packages. The actual value is initialized by loading the library @@ -467,53 +503,33 @@ called via `package-initialize'. To change which packages are loaded and/or activated, customize `package-load-list'.") (put 'package-alist 'risky-local-variable t) -(defvar package--compatibility-table nil - "Hash table connecting package names to their compatibility. -Each key is a symbol, the name of a package. - -The value is either nil, representing an incompatible package, or -a version list, representing the highest compatible version of -that package which is available. - -A package is considered incompatible if it requires an Emacs -version higher than the one being used. To check for package -\(in)compatibility, don't read this table directly, use -`package--incompatible-p' which also checks dependencies.") - (defvar package-activated-list nil ;; FIXME: This should implicitly include all builtin packages. "List of the names of currently activated packages.") (put 'package-activated-list 'risky-local-variable t) -(defun package-version-join (vlist) - "Return the version string corresponding to the list VLIST. -This is, approximately, the inverse of `version-to-list'. -\(Actually, it returns only one of the possible inverses, since -`version-to-list' is a many-to-one operation.)" - (if (null vlist) - "" - (let ((str-list (list "." (int-to-string (car vlist))))) - (dolist (num (cdr vlist)) - (cond - ((>= num 0) - (push (int-to-string num) str-list) - (push "." str-list)) - ((< num -4) - (error "Invalid version list `%s'" vlist)) - (t - ;; pre, or beta, or alpha - (cond ((equal "." (car str-list)) - (pop str-list)) - ((not (string-match "[0-9]+" (car str-list))) - (error "Invalid version list `%s'" vlist))) - (push (cond ((= num -1) "pre") - ((= num -2) "beta") - ((= num -3) "alpha") - ((= num -4) "snapshot")) - str-list)))) - (if (equal "." (car str-list)) - (pop str-list)) - (apply 'concat (nreverse str-list))))) +;;;; Populating `package-alist'. +;; The following functions are called on each installed package by +;; `package-load-all-descriptors', which ultimately populates the +;; `package-alist' variable. +(defun package-process-define-package (exp) + (when (eq (car-safe exp) 'define-package) + (let* ((new-pkg-desc (apply #'package-desc-from-define (cdr exp))) + (name (package-desc-name new-pkg-desc)) + (version (package-desc-version new-pkg-desc)) + (old-pkgs (assq name package-alist))) + (if (null old-pkgs) + ;; If there's no old package, just add this to `package-alist'. + (push (list name new-pkg-desc) package-alist) + ;; If there is, insert the new package at the right place in the list. + (while + (if (and (cdr old-pkgs) + (version-list-< version + (package-desc-version (cadr old-pkgs)))) + (setq old-pkgs (cdr old-pkgs)) + (push new-pkg-desc (cdr old-pkgs)) + nil))) + new-pkg-desc))) (defun package-load-descriptor (pkg-dir) "Load the description file in directory PKG-DIR." @@ -524,8 +540,9 @@ This is, approximately, the inverse of `version-to-list'. (with-temp-buffer (insert-file-contents pkg-file) (goto-char (point-min)) - (let ((pkg-desc (package-process-define-package - (read (current-buffer)) pkg-file))) + (let ((pkg-desc (or (package-process-define-package + (read (current-buffer))) + (error "Can't find define-package in %s" pkg-file)))) (setf (package-desc-dir pkg-desc) pkg-dir) (if (file-exists-p signed-file) (setf (package-desc-signed pkg-desc) t)) @@ -547,6 +564,24 @@ updates `package-alist'." (when (file-directory-p pkg-dir) (package-load-descriptor pkg-dir))))))) +(defun define-package (_name-string _version-string + &optional _docstring _requirements + &rest _extra-properties) + "Define a new package. +NAME-STRING is the name of the package, as a string. +VERSION-STRING is the version of the package, as a string. +DOCSTRING is a short description of the package, a string. +REQUIREMENTS is a list of dependencies on other packages. + Each requirement is of the form (OTHER-PACKAGE OTHER-VERSION), + where OTHER-VERSION is a string. + +EXTRA-PROPERTIES is currently unused." + ;; FIXME: Placeholder! Should we keep it? + (error "Don't call me!")) + + +;;; Package activation +;; Section for functions used by `package-activate', which see. (defun package-disabled-p (pkg-name version) "Return whether PKG-NAME at VERSION can be activated. The decision is made according to `package-load-list'. @@ -562,6 +597,23 @@ Return the max version (as a string) if the package is held at a lower version." force)) (t (error "Invalid element in `package-load-list'"))))) +(defun package-built-in-p (package &optional min-version) + "Return true if PACKAGE is built-in to Emacs. +Optional arg MIN-VERSION, if non-nil, should be a version list +specifying the minimum acceptable version." + (if (package-desc-p package) ;; was built-in and then was converted + (eq 'builtin (package-desc-dir package)) + (let ((bi (assq package package--builtin-versions))) + (cond + (bi (version-list-<= min-version (cdr bi))) + ((remove 0 min-version) nil) + (t + (require 'finder-inf nil t) ; For `package--builtins'. + (assq package package--builtins)))))) + +(defvar Info-directory-list) +(declare-function info-initialize "info" ()) + (defun package-activate-1 (pkg-desc &optional reload) "Activate package given by PKG-DESC, even if it was already active. If RELOAD is non-nil, also `load' any files inside the package which @@ -606,6 +658,7 @@ correspond to previously loaded files (those returned by t)) (declare-function find-library-name "find-func" (library)) + (defun package--list-loaded-files (dir) "Recursively list all files in DIR which correspond to loaded features. Returns the `file-name-sans-extension' of each file, relative to @@ -640,33 +693,14 @@ DIR, sorted by most recently loaded last." ;; Sort the files by ascending HISTORY-POSITION. (lambda (x y) (< (cdr x) (cdr y)))))))) -(defun package-built-in-p (package &optional min-version) - "Return true if PACKAGE is built-in to Emacs. -Optional arg MIN-VERSION, if non-nil, should be a version list -specifying the minimum acceptable version." - (if (package-desc-p package) ;; was built-in and then was converted - (eq 'builtin (package-desc-dir package)) - (let ((bi (assq package package--builtin-versions))) - (cond - (bi (version-list-<= min-version (cdr bi))) - ((remove 0 min-version) nil) - (t - (require 'finder-inf nil t) ; For `package--builtins'. - (assq package package--builtins)))))) - -(defun package--from-builtin (bi-desc) - (package-desc-create :name (pop bi-desc) - :version (package--bi-desc-version bi-desc) - :summary (package--bi-desc-summary bi-desc) - :dir 'builtin)) - -;; This function goes ahead and activates a newer version of a package -;; if an older one was already activated. This is not ideal; we'd at -;; least need to check to see if the package has actually been loaded, -;; and not merely activated. +;;;; `package-activate' +;; This function activates a newer version of a package if an older +;; one was already activated. It also loads a features of this +;; package which were already loaded. (defun package-activate (package &optional force) "Activate package PACKAGE. -If FORCE is true, (re-)activate it if it's already activated." +If FORCE is true, (re-)activate it if it's already activated. +Newer versions are always activated, regardless of FORCE." (let ((pkg-descs (cdr (assq package package-alist)))) ;; Check if PACKAGE is available in `package-alist'. (while @@ -698,76 +732,14 @@ Required package `%s-%s' is unavailable" ;; If all goes well, activate the package itself. (package-activate-1 pkg-vec force))))))) -(defun define-package (_name-string _version-string - &optional _docstring _requirements - &rest _extra-properties) - "Define a new package. -NAME-STRING is the name of the package, as a string. -VERSION-STRING is the version of the package, as a string. -DOCSTRING is a short description of the package, a string. -REQUIREMENTS is a list of dependencies on other packages. - Each requirement is of the form (OTHER-PACKAGE OTHER-VERSION), - where OTHER-VERSION is a string. - -EXTRA-PROPERTIES is currently unused." - ;; FIXME: Placeholder! Should we keep it? - (error "Don't call me!")) - -(defun package-process-define-package (exp origin) - (unless (eq (car-safe exp) 'define-package) - (error "Can't find define-package in %s" origin)) - (let* ((new-pkg-desc (apply #'package-desc-from-define (cdr exp))) - (name (package-desc-name new-pkg-desc)) - (version (package-desc-version new-pkg-desc)) - (old-pkgs (assq name package-alist))) - (if (null old-pkgs) - ;; If there's no old package, just add this to `package-alist'. - (push (list name new-pkg-desc) package-alist) - ;; If there is, insert the new package at the right place in the list. - (while - (if (and (cdr old-pkgs) - (version-list-< version - (package-desc-version (cadr old-pkgs)))) - (setq old-pkgs (cdr old-pkgs)) - (push new-pkg-desc (cdr old-pkgs)) - nil))) - new-pkg-desc)) - -;; From Emacs 22, but changed so it adds to load-path. -(defun package-autoload-ensure-default-file (file) - "Make sure that the autoload file FILE exists and if not create it." - (unless (file-exists-p file) - (write-region - (concat ";;; " (file-name-nondirectory file) - " --- automatically extracted autoloads\n" - ";;\n" - ";;; Code:\n" - "(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))\n" - " \n;; Local Variables:\n" - ";; version-control: never\n" - ";; no-byte-compile: t\n" - ";; no-update-autoloads: t\n" - ";; End:\n" - ";;; " (file-name-nondirectory file) - " ends here\n") - nil file nil 'silent)) - file) - -(defvar generated-autoload-file) -(defvar version-control) - -(defun package-generate-autoloads (name pkg-dir) - (let* ((auto-name (format "%s-autoloads.el" name)) - ;;(ignore-name (concat name "-pkg.el")) - (generated-autoload-file (expand-file-name auto-name pkg-dir)) - (backup-inhibited t) - (version-control 'never)) - (package-autoload-ensure-default-file generated-autoload-file) - (update-directory-autoloads pkg-dir) - (let ((buf (find-buffer-visiting generated-autoload-file))) - (when buf (kill-buffer buf))) - auto-name)) + +;;; Installation -- Local operations +;; This section contains a variety of features regarding installing a +;; package to/from disk. This includes autoload generation, +;; unpacking, compiling, as well as defining a package from the +;; current buffer. +;;;; Unpacking (defvar tar-parse-info) (declare-function tar-untar-buffer "tar-mode" ()) (declare-function tar-header-name "tar-mode" (tar-header) t) @@ -792,34 +764,6 @@ untar into a directory named DIR; otherwise, signal an error." (error "Package does not untar cleanly into directory %s/" dir))))) (tar-untar-buffer)) -(defun package-generate-description-file (pkg-desc pkg-file) - "Create the foo-pkg.el file for single-file packages." - (let* ((name (package-desc-name pkg-desc))) - (let ((print-level nil) - (print-quoted t) - (print-length nil)) - (write-region - (concat - ";;; -*- no-byte-compile: t -*-\n" - (prin1-to-string - (nconc - (list 'define-package - (symbol-name name) - (package-version-join (package-desc-version pkg-desc)) - (package-desc-summary pkg-desc) - (let ((requires (package-desc-reqs pkg-desc))) - (list 'quote - ;; Turn version lists into string form. - (mapcar - (lambda (elt) - (list (car elt) - (package-version-join (cadr elt)))) - requires)))) - (package--alist-to-plist-args - (package-desc-extras pkg-desc)))) - "\n") - nil pkg-file nil 'silent)))) - (defun package--alist-to-plist-args (alist) (mapcar 'macroexp-quote (apply #'nconc @@ -866,43 +810,227 @@ untar into a directory named DIR; otherwise, signal an error." (package-activate name 'force) pkg-dir)) -(defun package--make-autoloads-and-stuff (pkg-desc pkg-dir) - "Generate autoloads, description file, etc.. for PKG-DESC installed at PKG-DIR." - (package-generate-autoloads (package-desc-name pkg-desc) pkg-dir) - (let ((desc-file (expand-file-name (package--description-file pkg-dir) - pkg-dir))) - (unless (file-exists-p desc-file) - (package-generate-description-file pkg-desc desc-file))) - ;; FIXME: Create foo.info and dir file from foo.texi? - ) - -(defun package--compile (pkg-desc) - "Byte-compile installed package PKG-DESC." - (package-activate-1 pkg-desc) - (byte-recompile-directory (package-desc-dir pkg-desc) 0 t)) - -(defun package--write-file-no-coding (file-name) - (let ((buffer-file-coding-system 'no-conversion)) - (write-region (point-min) (point-max) file-name nil 'silent))) - -(defmacro package--with-work-buffer (location file &rest body) - "Run BODY in a buffer containing the contents of FILE at LOCATION. -LOCATION is the base location of a package archive, and should be -one of the URLs (or file names) specified in `package-archives'. -FILE is the name of a file relative to that base location. - -This macro retrieves FILE from LOCATION into a temporary buffer, -and evaluates BODY while that buffer is current. This work -buffer is killed afterwards. Return the last value in BODY." - (declare (indent 2) (debug t)) - `(with-temp-buffer - (if (string-match-p "\\`https?:" ,location) - (url-insert-file-contents (concat ,location ,file)) - (unless (file-name-absolute-p ,location) - (error "Archive location %s is not an absolute file name" - ,location)) - (insert-file-contents (expand-file-name ,file ,location))) - ,@body)) +(defun package-generate-description-file (pkg-desc pkg-file) + "Create the foo-pkg.el file for single-file packages." + (let* ((name (package-desc-name pkg-desc))) + (let ((print-level nil) + (print-quoted t) + (print-length nil)) + (write-region + (concat + ";;; -*- no-byte-compile: t -*-\n" + (prin1-to-string + (nconc + (list 'define-package + (symbol-name name) + (package-version-join (package-desc-version pkg-desc)) + (package-desc-summary pkg-desc) + (let ((requires (package-desc-reqs pkg-desc))) + (list 'quote + ;; Turn version lists into string form. + (mapcar + (lambda (elt) + (list (car elt) + (package-version-join (cadr elt)))) + requires)))) + (package--alist-to-plist-args + (package-desc-extras pkg-desc)))) + "\n") + nil pkg-file nil 'silent)))) + +;;;; Autoload +;; From Emacs 22, but changed so it adds to load-path. +(defun package-autoload-ensure-default-file (file) + "Make sure that the autoload file FILE exists and if not create it." + (unless (file-exists-p file) + (write-region + (concat ";;; " (file-name-nondirectory file) + " --- automatically extracted autoloads\n" + ";;\n" + ";;; Code:\n" + "(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))\n" + " \n;; Local Variables:\n" + ";; version-control: never\n" + ";; no-byte-compile: t\n" + ";; no-update-autoloads: t\n" + ";; End:\n" + ";;; " (file-name-nondirectory file) + " ends here\n") + nil file nil 'silent)) + file) + +(defvar generated-autoload-file) +(defvar version-control) + +(defun package-generate-autoloads (name pkg-dir) + (let* ((auto-name (format "%s-autoloads.el" name)) + ;;(ignore-name (concat name "-pkg.el")) + (generated-autoload-file (expand-file-name auto-name pkg-dir)) + (backup-inhibited t) + (version-control 'never)) + (package-autoload-ensure-default-file generated-autoload-file) + (update-directory-autoloads pkg-dir) + (let ((buf (find-buffer-visiting generated-autoload-file))) + (when buf (kill-buffer buf))) + auto-name)) + +(defun package--make-autoloads-and-stuff (pkg-desc pkg-dir) + "Generate autoloads, description file, etc.. for PKG-DESC installed at PKG-DIR." + (package-generate-autoloads (package-desc-name pkg-desc) pkg-dir) + (let ((desc-file (expand-file-name (package--description-file pkg-dir) + pkg-dir))) + (unless (file-exists-p desc-file) + (package-generate-description-file pkg-desc desc-file))) + ;; FIXME: Create foo.info and dir file from foo.texi? + ) + +;;;; Compilation +(defun package--compile (pkg-desc) + "Byte-compile installed package PKG-DESC." + (package-activate-1 pkg-desc) + (byte-recompile-directory (package-desc-dir pkg-desc) 0 t)) + +;;;; Inferring package from current buffer +(defun package-read-from-string (str) + "Read a Lisp expression from STR. +Signal an error if the entire string was not used." + (let* ((read-data (read-from-string str)) + (more-left + (condition-case nil + ;; The call to `ignore' suppresses a compiler warning. + (progn (ignore (read-from-string + (substring str (cdr read-data)))) + t) + (end-of-file nil)))) + (if more-left + (error "Can't read whole string") + (car read-data)))) + +(defun package--prepare-dependencies (deps) + "Turn DEPS into an acceptable list of dependencies. + +Any parts missing a version string get a default version string +of \"0\" (meaning any version) and an appropriate level of lists +is wrapped around any parts requiring it." + (cond + ((not (listp deps)) + (error "Invalid requirement specifier: %S" deps)) + (t (mapcar (lambda (dep) + (cond + ((symbolp dep) `(,dep "0")) + ((stringp dep) + (error "Invalid requirement specifier: %S" dep)) + ((and (listp dep) (null (cdr dep))) + (list (car dep) "0")) + (t dep))) + deps)))) + +(declare-function lm-header "lisp-mnt" (header)) +(declare-function lm-homepage "lisp-mnt" ()) + +(defun package-buffer-info () + "Return a `package-desc' describing the package in the current buffer. + +If the buffer does not contain a conforming package, signal an +error. If there is a package, narrow the buffer to the file's +boundaries." + (goto-char (point-min)) + (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$" nil t) + (error "Package lacks a file header")) + (let ((file-name (match-string-no-properties 1)) + (desc (match-string-no-properties 2)) + (start (line-beginning-position))) + (unless (search-forward (concat ";;; " file-name ".el ends here")) + (error "Package lacks a terminating comment")) + ;; Try to include a trailing newline. + (forward-line) + (narrow-to-region start (point)) + (require 'lisp-mnt) + ;; Use some headers we've invented to drive the process. + (let* ((requires-str (lm-header "package-requires")) + ;; Prefer Package-Version; if defined, the package author + ;; probably wants us to use it. Otherwise try Version. + (pkg-version + (or (package-strip-rcs-id (lm-header "package-version")) + (package-strip-rcs-id (lm-header "version")))) + (homepage (lm-homepage))) + (unless pkg-version + (error + "Package lacks a \"Version\" or \"Package-Version\" header")) + (package-desc-from-define + file-name pkg-version desc + (if requires-str + (package--prepare-dependencies + (package-read-from-string requires-str))) + :kind 'single + :url homepage)))) + +(defun package--read-pkg-desc (kind) + "Read a `define-package' form in current buffer. +Return the pkg-desc, with desc-kind set to KIND." + (goto-char (point-min)) + (unwind-protect + (let* ((pkg-def-parsed (read (current-buffer))) + (pkg-desc + (when (eq (car pkg-def-parsed) 'define-package) + (apply #'package-desc-from-define + (append (cdr pkg-def-parsed)))))) + (when pkg-desc + (setf (package-desc-kind pkg-desc) kind) + pkg-desc)))) + +(declare-function tar-get-file-descriptor "tar-mode" (file)) +(declare-function tar--extract "tar-mode" (descriptor)) + +(defun package-tar-file-info () + "Find package information for a tar file. +The return result is a `package-desc'." + (cl-assert (derived-mode-p 'tar-mode)) + (let* ((dir-name (file-name-directory + (tar-header-name (car tar-parse-info)))) + (desc-file (package--description-file dir-name)) + (tar-desc (tar-get-file-descriptor (concat dir-name desc-file)))) + (unless tar-desc + (error "No package descriptor file found")) + (with-current-buffer (tar--extract tar-desc) + (unwind-protect + (or (package--read-pkg-desc 'tar) + (error "Can't find define-package in %s" + (tar-header-name tar-desc))) + (kill-buffer (current-buffer)))))) + +(defun package-dir-info () + "Find package information for a directory. +The return result is a `package-desc'." + (cl-assert (derived-mode-p 'dired-mode)) + (let* ((desc-file (package--description-file default-directory))) + (if (file-readable-p desc-file) + (with-temp-buffer + (insert-file-contents desc-file) + (package--read-pkg-desc 'dir)) + (let ((files (directory-files default-directory t "\\.el\\'" t)) + info) + (while files + (with-temp-buffer + (insert-file-contents (pop files)) + ;; When we find the file with the data, + (when (setq info (ignore-errors (package-buffer-info))) + ;; stop looping, + (setq files nil) + ;; set the 'dir kind, + (setf (package-desc-kind info) 'dir)))) + ;; and return the info. + info)))) + + +;;; Communicating with Archives +;; Set of low-level functions for communicating with archives and +;; signature checking. +(defun package--write-file-no-coding (file-name) + (let ((buffer-file-coding-system 'no-conversion)) + (write-region (point-min) (point-max) file-name nil 'silent))) + +(declare-function url-http-file-exists-p "url-http" (url)) (defun package--archive-file-exists-p (location file) (let ((http (string-match "\\`https?:" location))) @@ -935,6 +1063,25 @@ buffer is killed afterwards. Return the last value in BODY." (insert (format "Error while verifying signature %s:\n" sig-file))) (insert "\nCommand output:\n" (epg-context-error-output context)))))) +(defmacro package--with-work-buffer (location file &rest body) + "Run BODY in a buffer containing the contents of FILE at LOCATION. +LOCATION is the base location of a package archive, and should be +one of the URLs (or file names) specified in `package-archives'. +FILE is the name of a file relative to that base location. + +This macro retrieves FILE from LOCATION into a temporary buffer, +and evaluates BODY while that buffer is current. This work +buffer is killed afterwards. Return the last value in BODY." + (declare (indent 2) (debug t)) + `(with-temp-buffer + (if (string-match-p "\\`https?:" ,location) + (url-insert-file-contents (concat ,location ,file)) + (unless (file-name-absolute-p ,location) + (error "Archive location %s is not an absolute file name" + ,location)) + (insert-file-contents (expand-file-name ,file ,location))) + ,@body)) + (defun package--check-signature (location file) "Check signature of the current buffer. GnuPG keyring is located under \"gnupg\" in `package-user-dir'." @@ -967,65 +1114,256 @@ GnuPG keyring is located under \"gnupg\" in `package-user-dir'." (error "Failed to verify signature %s" sig-file)) good-signatures))) -(defun package-install-from-archive (pkg-desc) - "Download and install a tar package." - ;; This won't happen, unless the archive is doing something wrong. - (when (eq (package-desc-kind pkg-desc) 'dir) - (error "Can't install directory package from archive")) - (let* ((location (package-archive-base pkg-desc)) - (file (concat (package-desc-full-name pkg-desc) - (package-desc-suffix pkg-desc))) - (sig-file (concat file ".sig")) - good-signatures pkg-descs) - (package--with-work-buffer location file + +;;; Packages on Archives +;; The following variables store information about packages available +;; from archives. The most important of these is +;; `package-archive-contents' which is initially populated by the +;; function `package-read-all-archive-contents' from a cache on disk. +;; The `package-initialize' command is also closely related to this +;; section, but it has its own section. +(defconst package-archive-version 1 + "Version number of the package archive understood by this file. +Lower version numbers than this will probably be understood as well.") + +;; We don't prime the cache since it tends to get out of date. +(defvar package-archive-contents nil + "Cache of the contents of the Emacs Lisp Package Archive. +This is an alist mapping package names (symbols) to +non-empty lists of `package-desc' structures.") +(put 'package-archive-contents 'risky-local-variable t) + +(defvar package--compatibility-table nil + "Hash table connecting package names to their compatibility. +Each key is a symbol, the name of a package. + +The value is either nil, representing an incompatible package, or +a version list, representing the highest compatible version of +that package which is available. + +A package is considered incompatible if it requires an Emacs +version higher than the one being used. To check for package +\(in)compatibility, don't read this table directly, use +`package--incompatible-p' which also checks dependencies.") + +(defun package--build-compatibility-table () + "Build `package--compatibility-table' with `package--mapc'." + ;; Build compat table. + (setq package--compatibility-table (make-hash-table :test 'eq)) + (package--mapc #'package--add-to-compatibility-table)) + +(defun package--add-to-compatibility-table (pkg) + "If PKG is compatible (without dependencies), add to the compatibility table. +PKG is a package-desc object. +Only adds if its version is higher than what's already stored in +the table." + (unless (package--incompatible-p pkg 'shallow) + (let* ((name (package-desc-name pkg)) + (version (or (package-desc-version pkg) '(0))) + (table-version (gethash name package--compatibility-table))) + (when (or (not table-version) + (version-list-< table-version version)) + (puthash name version package--compatibility-table))))) + +;; Package descriptor objects used inside the "archive-contents" file. +;; Changing this defstruct implies changing the format of the +;; "archive-contents" files. +(cl-defstruct (package--ac-desc + (:constructor package-make-ac-desc (version reqs summary kind extras)) + (:copier nil) + (:type vector)) + version reqs summary kind extras) + +(defun package--append-to-alist (pkg-desc alist) + "Append an entry for PKG-DESC to the start of ALIST and return it. +This entry takes the form (`package-desc-name' PKG-DESC). + +If ALIST already has an entry with this name, destructively add +PKG-DESC to the cdr of this entry instead, sorted by version +number." + (let* ((name (package-desc-name pkg-desc)) + (priority-version (package-desc-priority-version pkg-desc)) + (existing-packages (assq name alist))) + (if (not existing-packages) + (cons (list name pkg-desc) + alist) + (while (if (and (cdr existing-packages) + (version-list-< priority-version + (package-desc-priority-version + (cadr existing-packages)))) + (setq existing-packages (cdr existing-packages)) + (push pkg-desc (cdr existing-packages)) + nil)) + alist))) + +(defun package--add-to-archive-contents (package archive) + "Add the PACKAGE from the given ARCHIVE if necessary. +PACKAGE should have the form (NAME . PACKAGE--AC-DESC). +Also, add the originating archive to the `package-desc' structure." + (let* ((name (car package)) + (version (package--ac-desc-version (cdr package))) + (pkg-desc + (package-desc-create + :name name + :version version + :reqs (package--ac-desc-reqs (cdr package)) + :summary (package--ac-desc-summary (cdr package)) + :kind (package--ac-desc-kind (cdr package)) + :archive archive + :extras (and (> (length (cdr package)) 4) + ;; Older archive-contents files have only 4 + ;; elements here. + (package--ac-desc-extras (cdr package))))) + (pinned-to-archive (assoc name package-pinned-packages))) + ;; Skip entirely if pinned to another archive. + (when (not (and pinned-to-archive + (not (equal (cdr pinned-to-archive) archive)))) + (setq package-archive-contents + (package--append-to-alist pkg-desc package-archive-contents))))) + +(defun package--read-archive-file (file) + "Re-read archive file FILE, if it exists. +Will return the data from the file, or nil if the file does not exist. +Will throw an error if the archive version is too new." + (let ((filename (expand-file-name file package-user-dir))) + (when (file-exists-p filename) + (with-temp-buffer + (insert-file-contents-literally filename) + (let ((contents (read (current-buffer)))) + (if (> (car contents) package-archive-version) + (error "Package archive version %d is higher than %d" + (car contents) package-archive-version)) + (cdr contents)))))) + +(defun package-read-archive-contents (archive) + "Re-read archive contents for ARCHIVE. +If successful, set the variable `package-archive-contents'. +If the archive version is too new, signal an error." + ;; Version 1 of 'archive-contents' is identical to our internal + ;; representation. + (let* ((contents-file (format "archives/%s/archive-contents" archive)) + (contents (package--read-archive-file contents-file))) + (when contents + (dolist (package contents) + (package--add-to-archive-contents package archive))))) + +(defun package-read-all-archive-contents () + "Re-read `archive-contents', if it exists. +If successful, set `package-archive-contents'." + (setq package-archive-contents nil) + (dolist (archive package-archives) + (package-read-archive-contents (car archive)))) + +;;;; Package Initialize +;; A bit of a milestone. This brings together some of the above +;; sections and populates all relevant lists of packages from contents +;; available on disk. +(defvar package--initialized nil) + +;;;###autoload +(defun package-initialize (&optional no-activate) + "Load Emacs Lisp packages, and activate them. +The variable `package-load-list' controls which packages to load. +If optional arg NO-ACTIVATE is non-nil, don't activate packages." + (interactive) + (setq package-alist nil) + (package-load-all-descriptors) + (package-read-all-archive-contents) + (unless no-activate + (dolist (elt package-alist) + (package-activate (car elt)))) + (setq package--initialized t) + ;; This uses `package--mapc' so it must be called after + ;; `package--initialized' is t. + (package--build-compatibility-table)) + + +;;;; Populating `package-archive-contents' from archives +;; This subsection populates the variables listed above from the +;; actual archives, instead of from a local cache. +(defun package--download-one-archive (archive file) + "Retrieve an archive file FILE from ARCHIVE, and cache it. +ARCHIVE should be a cons cell of the form (NAME . LOCATION), +similar to an entry in `package-alist'. Save the cached copy to +\"archives/NAME/archive-contents\" in `package-user-dir'." + (let ((dir (expand-file-name (format "archives/%s" (car archive)) + package-user-dir)) + (sig-file (concat file ".sig")) + good-signatures) + (package--with-work-buffer (cdr archive) file + ;; Check signature of archive-contents, if desired. (if (and package-check-signature - (not (member (package-desc-archive pkg-desc) - package-unsigned-archives))) - (if (package--archive-file-exists-p location sig-file) - (setq good-signatures (package--check-signature location file)) + (not (member archive package-unsigned-archives))) + (if (package--archive-file-exists-p (cdr archive) sig-file) + (setq good-signatures (package--check-signature (cdr archive) + file)) (unless (eq package-check-signature 'allow-unsigned) - (error "Unsigned package: `%s'" - (package-desc-name pkg-desc))))) - (package-unpack pkg-desc)) - ;; Here the package has been installed successfully, mark it as - ;; signed if appropriate. + (error "Unsigned archive `%s'" + (car archive))))) + ;; Read the retrieved buffer to make sure it is valid (e.g. it + ;; may fetch a URL redirect page). + (when (listp (read (current-buffer))) + (make-directory dir t) + (write-region nil nil (expand-file-name file dir) nil 'silent))) (when good-signatures - ;; Write out good signatures into NAME-VERSION.signed file. + ;; Write out good signatures into archive-contents.signed file. (write-region (mapconcat #'epg-signature-to-string good-signatures "\n") nil - (expand-file-name - (concat (package-desc-full-name pkg-desc) - ".signed") - package-user-dir) - nil 'silent) - ;; Update the old pkg-desc which will be shown on the description buffer. - (setf (package-desc-signed pkg-desc) t) - ;; Update the new (activated) pkg-desc as well. - (setq pkg-descs (cdr (assq (package-desc-name pkg-desc) package-alist))) - (if pkg-descs - (setf (package-desc-signed (car pkg-descs)) t))))) + (expand-file-name (concat file ".signed") dir) + nil 'silent)))) -(defvar package--initialized nil) +(declare-function epg-check-configuration "epg-config" + (config &optional minimum-version)) +(declare-function epg-configuration "epg-config" ()) +(declare-function epg-import-keys-from-file "epg" (context keys)) -(defun package-installed-p (package &optional min-version) - "Return true if PACKAGE, of MIN-VERSION or newer, is installed. -If PACKAGE is a symbol, it is the package name and MIN-VERSION -should be a version list. +;;;###autoload +(defun package-import-keyring (&optional file) + "Import keys from FILE." + (interactive "fFile: ") + (setq file (expand-file-name file)) + (let ((context (epg-make-context 'OpenPGP)) + (homedir (expand-file-name "gnupg" package-user-dir))) + (with-file-modes 448 + (make-directory homedir t)) + (setf (epg-context-home-directory context) homedir) + (message "Importing %s..." (file-name-nondirectory file)) + (epg-import-keys-from-file context file) + (message "Importing %s...done" (file-name-nondirectory file)))) -If PACKAGE is a package-desc object, MIN-VERSION is ignored." - (unless package--initialized (error "package.el is not yet initialized!")) - (if (package-desc-p package) - (let ((dir (package-desc-dir package))) - (and (stringp dir) - (file-exists-p dir))) - (or - (let ((pkg-descs (cdr (assq package package-alist)))) - (and pkg-descs - (version-list-<= min-version - (package-desc-version (car pkg-descs))))) - ;; Also check built-in packages. - (package-built-in-p package min-version)))) +;;;###autoload +(defun package-refresh-contents () + "Download descriptions of all configured ELPA packages. +For each archive configured in the variable `package-archives', +inform Emacs about the latest versions of all packages it offers, +and make them available for download." + (interactive) + ;; FIXME: Do it asynchronously. + (unless (file-exists-p package-user-dir) + (make-directory package-user-dir t)) + (let ((default-keyring (expand-file-name "package-keyring.gpg" + data-directory))) + (when (and package-check-signature (file-exists-p default-keyring)) + (condition-case-unless-debug error + (progn + (epg-check-configuration (epg-configuration)) + (package-import-keyring default-keyring)) + (error (message "Cannot import default keyring: %S" (cdr error)))))) + (dolist (archive package-archives) + (condition-case-unless-debug nil + (package--download-one-archive archive "archive-contents") + (error (message "Failed to download `%s' archive." + (car archive))))) + (package-read-all-archive-contents) + (package--build-compatibility-table) + (message "Package refresh done")) + +;;; Dependency Management +;; Calculating the full transaction necessary for an installation, +;; keeping track of which packages were installed strictly as +;; dependencies, and determining which packages cannot be removed +;; because they are dependencies. (defun package-compute-transaction (packages requirements &optional seen) "Return a list of packages to be installed, including PACKAGES. PACKAGES should be a list of `package-desc'. @@ -1109,120 +1447,178 @@ but version %s required" (cons found seen)))))))) packages) -(defun package-read-from-string (str) - "Read a Lisp expression from STR. -Signal an error if the entire string was not used." - (let* ((read-data (read-from-string str)) - (more-left - (condition-case nil - ;; The call to `ignore' suppresses a compiler warning. - (progn (ignore (read-from-string - (substring str (cdr read-data)))) - t) - (end-of-file nil)))) - (if more-left - (error "Can't read whole string") - (car read-data)))) +(defun package--find-non-dependencies () + "Return a list of installed packages which are not dependencies. +Finds all packages in `package-alist' which are not dependencies +of any other packages. +Used to populate `package-selected-packages'." + (let ((dep-list + (delete-dups + (apply #'append + (mapcar (lambda (p) (mapcar #'car (package-desc-reqs (cadr p)))) + package-alist))))) + (cl-loop for p in package-alist + for name = (car p) + unless (memq name dep-list) + collect name))) -(defun package--read-archive-file (file) - "Re-read archive file FILE, if it exists. -Will return the data from the file, or nil if the file does not exist. -Will throw an error if the archive version is too new." - (let ((filename (expand-file-name file package-user-dir))) - (when (file-exists-p filename) - (with-temp-buffer - (insert-file-contents-literally filename) - (let ((contents (read (current-buffer)))) - (if (> (car contents) package-archive-version) - (error "Package archive version %d is higher than %d" - (car contents) package-archive-version)) - (cdr contents)))))) +(defun package--user-selected-p (pkg) + "Return non-nil if PKG is a package was installed by the user. +PKG is a package name. +This looks into `package-selected-packages', populating it first +if it is still empty." + (unless (consp package-selected-packages) + (customize-save-variable + 'package-selected-packages + (setq package-selected-packages (package--find-non-dependencies)))) + (memq pkg package-selected-packages)) -(defun package-read-all-archive-contents () - "Re-read `archive-contents', if it exists. -If successful, set `package-archive-contents'." - (setq package-archive-contents nil) - (dolist (archive package-archives) - (package-read-archive-contents (car archive)))) +(defun package--get-deps (pkg &optional only) + (let* ((pkg-desc (cadr (assq pkg package-alist))) + (direct-deps (cl-loop for p in (package-desc-reqs pkg-desc) + for name = (car p) + when (assq name package-alist) + collect name)) + (indirect-deps (unless (eq only 'direct) + (delete-dups + (cl-loop for p in direct-deps + append (package--get-deps p)))))) + (cl-case only + (direct direct-deps) + (separate (list direct-deps indirect-deps)) + (indirect indirect-deps) + (t (delete-dups (append direct-deps indirect-deps)))))) -(defun package-read-archive-contents (archive) - "Re-read archive contents for ARCHIVE. -If successful, set the variable `package-archive-contents'. -If the archive version is too new, signal an error." - ;; Version 1 of 'archive-contents' is identical to our internal - ;; representation. - (let* ((contents-file (format "archives/%s/archive-contents" archive)) - (contents (package--read-archive-file contents-file))) - (when contents - (dolist (package contents) - (package--add-to-archive-contents package archive))))) +(defun package--removable-packages () + "Return a list of names of packages no longer needed. +These are packages which are neither contained in +`package-selected-packages' nor a dependency of one that is." + (let ((needed (cl-loop for p in package-selected-packages + if (assq p package-alist) + ;; `p' and its dependencies are needed. + append (cons p (package--get-deps p))))) + (cl-loop for p in (mapcar #'car package-alist) + unless (memq p needed) + collect p))) -;; Package descriptor objects used inside the "archive-contents" file. -;; Changing this defstruct implies changing the format of the -;; "archive-contents" files. -(cl-defstruct (package--ac-desc - (:constructor package-make-ac-desc (version reqs summary kind extras)) - (:copier nil) - (:type vector)) - version reqs summary kind extras) +(defun package--used-elsewhere-p (pkg-desc &optional pkg-list) + "Non-nil if PKG-DESC is a dependency of a package in PKG-LIST. +Return the first package found in PKG-LIST of which PKG is a +dependency. -(defun package--add-to-archive-contents (package archive) - "Add the PACKAGE from the given ARCHIVE if necessary. -PACKAGE should have the form (NAME . PACKAGE--AC-DESC). -Also, add the originating archive to the `package-desc' structure." - (let* ((name (car package)) - (version (package--ac-desc-version (cdr package))) - (pkg-desc - (package-desc-create - :name name - :version version - :reqs (package--ac-desc-reqs (cdr package)) - :summary (package--ac-desc-summary (cdr package)) - :kind (package--ac-desc-kind (cdr package)) - :archive archive - :extras (and (> (length (cdr package)) 4) - ;; Older archive-contents files have only 4 - ;; elements here. - (package--ac-desc-extras (cdr package))))) - (pinned-to-archive (assoc name package-pinned-packages))) - ;; Skip entirely if pinned to another archive. - (when (not (and pinned-to-archive - (not (equal (cdr pinned-to-archive) archive)))) - (setq package-archive-contents - (package--append-to-alist pkg-desc package-archive-contents))))) +When not specified, PKG-LIST defaults to `package-alist' +with PKG-DESC entry removed." + (unless (string= (package-desc-status pkg-desc) "obsolete") + (let ((pkg (package-desc-name pkg-desc))) + (cl-loop with alist = (or pkg-list + (remove (assq pkg package-alist) + package-alist)) + for p in alist thereis + (and (memq pkg (mapcar #'car (package-desc-reqs (cadr p)))) + (car p)))))) + +(defun package--sort-deps-in-alist (package only) + "Return a list of dependencies for PACKAGE sorted by dependency. +PACKAGE is included as the first element of the returned list. +ONLY is an alist associating package names to package objects. +Only these packages will be in the return value an their cdrs are +destructively set to nil in ONLY." + (let ((out)) + (dolist (dep (package-desc-reqs package)) + (when-let ((cell (assq (car dep) only)) + (dep-package (cdr-safe cell))) + (setcdr cell nil) + (setq out (append (package--sort-deps-in-alist dep-package only) + out)))) + (cons package out))) + +(defun package--sort-by-dependence (package-list) + "Return PACKAGE-LIST sorted by dependence. +That is, any element of the returned list is guaranteed to not +directly depend on any elements that come before it. + +PACKAGE-LIST is a list of package-desc objects. +Indirect dependencies are guaranteed to be returned in order only +if all the in-between dependencies are also in PACKAGE-LIST." + (let ((alist (mapcar (lambda (p) (cons (package-desc-name p) p)) package-list)) + out-list) + (dolist (cell alist out-list) + ;; `package--sort-deps-in-alist' destructively changes alist, so + ;; some cells might already be empty. We check this here. + (when-let ((pkg-desc (cdr cell))) + (setcdr cell nil) + (setq out-list + (append (package--sort-deps-in-alist pkg-desc alist) + out-list)))))) -(defun package--append-to-alist (pkg-desc alist) - "Append an entry for PKG-DESC to the start of ALIST and return it. -This entry takes the form (`package-desc-name' PKG-DESC). + +;;; Installation Functions +;; As opposed to the previous section (which listed some underlying +;; functions necessary for installation), this one contains the actual +;; functions that install packages. The package itself can be +;; installed in a variety of ways (archives, buffer, file), but +;; requirements (dependencies) are always satisfied by looking in +;; `package-archive-contents'. +(defun package-archive-base (desc) + "Return the archive containing the package NAME." + (cdr (assoc (package-desc-archive desc) package-archives))) -If ALIST already has an entry with this name, destructively add -PKG-DESC to the cdr of this entry instead, sorted by version -number." - (let* ((name (package-desc-name pkg-desc)) - (priority-version (package-desc-priority-version pkg-desc)) - (existing-packages (assq name alist))) - (if (not existing-packages) - (cons (list name pkg-desc) - alist) - (while (if (and (cdr existing-packages) - (version-list-< priority-version - (package-desc-priority-version - (cadr existing-packages)))) - (setq existing-packages (cdr existing-packages)) - (push pkg-desc (cdr existing-packages)) - nil)) - alist))) +(defun package-install-from-archive (pkg-desc) + "Download and install a tar package." + ;; This won't happen, unless the archive is doing something wrong. + (when (eq (package-desc-kind pkg-desc) 'dir) + (error "Can't install directory package from archive")) + (let* ((location (package-archive-base pkg-desc)) + (file (concat (package-desc-full-name pkg-desc) + (package-desc-suffix pkg-desc))) + (sig-file (concat file ".sig")) + good-signatures pkg-descs) + (package--with-work-buffer location file + (if (and package-check-signature + (not (member (package-desc-archive pkg-desc) + package-unsigned-archives))) + (if (package--archive-file-exists-p location sig-file) + (setq good-signatures (package--check-signature location file)) + (unless (eq package-check-signature 'allow-unsigned) + (error "Unsigned package: `%s'" + (package-desc-name pkg-desc))))) + (package-unpack pkg-desc)) + ;; Here the package has been installed successfully, mark it as + ;; signed if appropriate. + (when good-signatures + ;; Write out good signatures into NAME-VERSION.signed file. + (write-region (mapconcat #'epg-signature-to-string good-signatures "\n") + nil + (expand-file-name + (concat (package-desc-full-name pkg-desc) + ".signed") + package-user-dir) + nil 'silent) + ;; Update the old pkg-desc which will be shown on the description buffer. + (setf (package-desc-signed pkg-desc) t) + ;; Update the new (activated) pkg-desc as well. + (setq pkg-descs (cdr (assq (package-desc-name pkg-desc) package-alist))) + (if pkg-descs + (setf (package-desc-signed (car pkg-descs)) t))))) -(defun package--user-selected-p (pkg) - "Return non-nil if PKG is a package was installed by the user. -PKG is a package name. -This looks into `package-selected-packages', populating it first -if it is still empty." - (unless (consp package-selected-packages) - (customize-save-variable - 'package-selected-packages - (setq package-selected-packages (package--find-non-dependencies)))) - (memq pkg package-selected-packages)) +(defun package-installed-p (package &optional min-version) + "Return true if PACKAGE, of MIN-VERSION or newer, is installed. +If PACKAGE is a symbol, it is the package name and MIN-VERSION +should be a version list. + +If PACKAGE is a package-desc object, MIN-VERSION is ignored." + (unless package--initialized (error "package.el is not yet initialized!")) + (if (package-desc-p package) + (let ((dir (package-desc-dir package))) + (and (stringp dir) + (file-exists-p dir))) + (or + (let ((pkg-descs (cdr (assq package package-alist)))) + (and pkg-descs + (version-list-<= min-version + (package-desc-version (car pkg-descs))))) + ;; Also check built-in packages. + (package-built-in-p package min-version)))) (defun package-download-transaction (packages) "Download and install all the packages in PACKAGES. @@ -1276,20 +1672,6 @@ to install it but still mark it as selected." (package-compute-transaction () (list (list pkg)))))) -;;;###autoload -(defun package-reinstall (pkg) - "Reinstall package PKG. -PKG should be either a symbol, the package name, or a package-desc -object." - (interactive (list (intern (completing-read - "Reinstall package: " - (mapcar #'symbol-name - (mapcar #'car package-alist)))))) - (package-delete - (if (package-desc-p pkg) pkg (cadr (assq pkg package-alist))) - 'force 'nosave) - (package-install pkg 'dont-select)) - (defun package-strip-rcs-id (str) "Strip RCS version ID from the version string STR. If the result looks like a dotted numeric version, return it. @@ -1304,120 +1686,6 @@ Otherwise return nil." (declare-function lm-homepage "lisp-mnt" (&optional file)) -(defun package--prepare-dependencies (deps) - "Turn DEPS into an acceptable list of dependencies. - -Any parts missing a version string get a default version string -of \"0\" (meaning any version) and an appropriate level of lists -is wrapped around any parts requiring it." - (cond - ((not (listp deps)) - (error "Invalid requirement specifier: %S" deps)) - (t (mapcar (lambda (dep) - (cond - ((symbolp dep) `(,dep "0")) - ((stringp dep) - (error "Invalid requirement specifier: %S" dep)) - ((and (listp dep) (null (cdr dep))) - (list (car dep) "0")) - (t dep))) - deps)))) - -(defun package-buffer-info () - "Return a `package-desc' describing the package in the current buffer. - -If the buffer does not contain a conforming package, signal an -error. If there is a package, narrow the buffer to the file's -boundaries." - (goto-char (point-min)) - (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$" nil t) - (error "Package lacks a file header")) - (let ((file-name (match-string-no-properties 1)) - (desc (match-string-no-properties 2)) - (start (line-beginning-position))) - (unless (search-forward (concat ";;; " file-name ".el ends here")) - (error "Package lacks a terminating comment")) - ;; Try to include a trailing newline. - (forward-line) - (narrow-to-region start (point)) - (require 'lisp-mnt) - ;; Use some headers we've invented to drive the process. - (let* ((requires-str (lm-header "package-requires")) - ;; Prefer Package-Version; if defined, the package author - ;; probably wants us to use it. Otherwise try Version. - (pkg-version - (or (package-strip-rcs-id (lm-header "package-version")) - (package-strip-rcs-id (lm-header "version")))) - (homepage (lm-homepage))) - (unless pkg-version - (error - "Package lacks a \"Version\" or \"Package-Version\" header")) - (package-desc-from-define - file-name pkg-version desc - (if requires-str - (package--prepare-dependencies - (package-read-from-string requires-str))) - :kind 'single - :url homepage)))) - -(declare-function tar-get-file-descriptor "tar-mode" (file)) -(declare-function tar--extract "tar-mode" (descriptor)) - -(defun package-tar-file-info () - "Find package information for a tar file. -The return result is a `package-desc'." - (cl-assert (derived-mode-p 'tar-mode)) - (let* ((dir-name (file-name-directory - (tar-header-name (car tar-parse-info)))) - (desc-file (package--description-file dir-name)) - (tar-desc (tar-get-file-descriptor (concat dir-name desc-file)))) - (unless tar-desc - (error "No package descriptor file found")) - (with-current-buffer (tar--extract tar-desc) - (unwind-protect - (or (package--read-pkg-desc 'tar) - (error "Can't find define-package in %s" - (tar-header-name tar-desc))) - (kill-buffer (current-buffer)))))) - -(defun package-dir-info () - "Find package information for a directory. -The return result is a `package-desc'." - (cl-assert (derived-mode-p 'dired-mode)) - (let* ((desc-file (package--description-file default-directory))) - (if (file-readable-p desc-file) - (with-temp-buffer - (insert-file-contents desc-file) - (package--read-pkg-desc 'dir)) - (let ((files (directory-files default-directory t "\\.el\\'" t)) - info) - (while files - (with-temp-buffer - (insert-file-contents (pop files)) - ;; When we find the file with the data, - (when (setq info (ignore-errors (package-buffer-info))) - ;; stop looping, - (setq files nil) - ;; set the 'dir kind, - (setf (package-desc-kind info) 'dir)))) - ;; and return the info. - info)))) - -(defun package--read-pkg-desc (kind) - "Read a `define-package' form in current buffer. -Return the pkg-desc, with desc-kind set to KIND." - (goto-char (point-min)) - (unwind-protect - (let* ((pkg-def-parsed (read (current-buffer))) - (pkg-desc - (when (eq (car pkg-def-parsed) 'define-package) - (apply #'package-desc-from-define - (append (cdr pkg-def-parsed)))))) - (when pkg-desc - (setf (package-desc-kind pkg-desc) kind) - pkg-desc)))) - - ;;;###autoload (defun package-install-from-buffer () "Install a package from the current buffer. @@ -1455,35 +1723,19 @@ Downloads and installs required packages as needed." (cons name package-selected-packages))) pkg-desc)) -;;;###autoload -(defun package-install-file (file) - "Install a package from a file. -The file can either be a tar file or an Emacs Lisp file." - (interactive "fPackage file name: ") - (with-temp-buffer - (if (file-directory-p file) - (progn - (setq default-directory file) - (dired-mode)) - (insert-file-contents-literally file) - (when (string-match "\\.tar\\'" file) (tar-mode))) - (package-install-from-buffer))) - -(defun package--get-deps (pkg &optional only) - (let* ((pkg-desc (cadr (assq pkg package-alist))) - (direct-deps (cl-loop for p in (package-desc-reqs pkg-desc) - for name = (car p) - when (assq name package-alist) - collect name)) - (indirect-deps (unless (eq only 'direct) - (delete-dups - (cl-loop for p in direct-deps - append (package--get-deps p)))))) - (cl-case only - (direct direct-deps) - (separate (list direct-deps indirect-deps)) - (indirect indirect-deps) - (t (delete-dups (append direct-deps indirect-deps)))))) +;;;###autoload +(defun package-install-file (file) + "Install a package from a file. +The file can either be a tar file or an Emacs Lisp file." + (interactive "fPackage file name: ") + (with-temp-buffer + (if (file-directory-p file) + (progn + (setq default-directory file) + (dired-mode)) + (insert-file-contents-literally file) + (when (string-match "\\.tar\\'" file) (tar-mode))) + (package-install-from-buffer))) ;;;###autoload (defun package-install-user-selected-packages () @@ -1507,22 +1759,8 @@ If some packages are not installed propose to install them." (mapc #'package-install lst)) (message "All your packages are already installed"))))) -(defun package--used-elsewhere-p (pkg-desc &optional pkg-list) - "Non-nil if PKG-DESC is a dependency of a package in PKG-LIST. -Return the first package found in PKG-LIST of which PKG is a -dependency. - -When not specified, PKG-LIST defaults to `package-alist' -with PKG-DESC entry removed." - (unless (string= (package-desc-status pkg-desc) "obsolete") - (let ((pkg (package-desc-name pkg-desc))) - (cl-loop with alist = (or pkg-list - (remove (assq pkg package-alist) - package-alist)) - for p in alist thereis - (and (memq pkg (mapcar #'car (package-desc-reqs (cadr p)))) - (car p)))))) - + +;;; Package Deletion (defun package--newest-p (pkg) "Return t if PKG is the newest package with its name." (equal (cadr (assq (package-desc-name pkg) package-alist)) @@ -1577,17 +1815,19 @@ If NOSAVE is non-nil, the package is not removed from (setq package-alist (delq pkgs package-alist)))) (message "Package `%s' deleted." (package-desc-full-name pkg-desc)))))) -(defun package--removable-packages () - "Return a list of names of packages no longer needed. -These are packages which are neither contained in -`package-selected-packages' nor a dependency of one that is." - (let ((needed (cl-loop for p in package-selected-packages - if (assq p package-alist) - ;; `p' and its dependencies are needed. - append (cons p (package--get-deps p))))) - (cl-loop for p in (mapcar #'car package-alist) - unless (memq p needed) - collect p))) +;;;###autoload +(defun package-reinstall (pkg) + "Reinstall package PKG. +PKG should be either a symbol, the package name, or a package-desc +object." + (interactive (list (intern (completing-read + "Reinstall package: " + (mapcar #'symbol-name + (mapcar #'car package-alist)))))) + (package-delete + (if (package-desc-p pkg) pkg (cadr (assq pkg package-alist))) + 'force 'nosave) + (package-install pkg 'dont-select)) ;;;###autoload (defun package-autoremove () @@ -1614,157 +1854,6 @@ will be deleted." removable)) (message "Nothing to autoremove"))))) -(defun package-archive-base (desc) - "Return the archive containing the package NAME." - (cdr (assoc (package-desc-archive desc) package-archives))) - -(defun package-archive-priority (archive) - "Return the priority of ARCHIVE. - -The archive priorities are specified in -`package-archive-priorities'. If not given there, the priority -defaults to 0." - (or (cdr (assoc archive package-archive-priorities)) - 0)) - -(defun package-desc-priority-version (pkg-desc) - "Return the version PKG-DESC with the archive priority prepended. - -This allows for easy comparison of package versions from -different archives if archive priorities are meant to be taken in -consideration." - (cons (package-archive-priority - (package-desc-archive pkg-desc)) - (package-desc-version pkg-desc))) - -(defun package--download-one-archive (archive file) - "Retrieve an archive file FILE from ARCHIVE, and cache it. -ARCHIVE should be a cons cell of the form (NAME . LOCATION), -similar to an entry in `package-alist'. Save the cached copy to -\"archives/NAME/archive-contents\" in `package-user-dir'." - (let ((dir (expand-file-name (format "archives/%s" (car archive)) - package-user-dir)) - (sig-file (concat file ".sig")) - good-signatures) - (package--with-work-buffer (cdr archive) file - ;; Check signature of archive-contents, if desired. - (if (and package-check-signature - (not (member archive package-unsigned-archives))) - (if (package--archive-file-exists-p (cdr archive) sig-file) - (setq good-signatures (package--check-signature (cdr archive) - file)) - (unless (eq package-check-signature 'allow-unsigned) - (error "Unsigned archive `%s'" - (car archive))))) - ;; Read the retrieved buffer to make sure it is valid (e.g. it - ;; may fetch a URL redirect page). - (when (listp (read (current-buffer))) - (make-directory dir t) - (write-region nil nil (expand-file-name file dir) nil 'silent))) - (when good-signatures - ;; Write out good signatures into archive-contents.signed file. - (write-region (mapconcat #'epg-signature-to-string good-signatures "\n") - nil - (expand-file-name (concat file ".signed") dir) - nil 'silent)))) - -(declare-function epg-check-configuration "epg-config" - (config &optional minimum-version)) -(declare-function epg-configuration "epg-config" ()) -(declare-function epg-import-keys-from-file "epg" (context keys)) - -;;;###autoload -(defun package-import-keyring (&optional file) - "Import keys from FILE." - (interactive "fFile: ") - (setq file (expand-file-name file)) - (let ((context (epg-make-context 'OpenPGP)) - (homedir (expand-file-name "gnupg" package-user-dir))) - (with-file-modes 448 - (make-directory homedir t)) - (setf (epg-context-home-directory context) homedir) - (message "Importing %s..." (file-name-nondirectory file)) - (epg-import-keys-from-file context file) - (message "Importing %s...done" (file-name-nondirectory file)))) - -(defun package--build-compatibility-table () - "Build `package--compatibility-table' with `package--mapc'." - ;; Build compat table. - (setq package--compatibility-table (make-hash-table :test 'eq)) - (package--mapc #'package--add-to-compatibility-table)) - -;;;###autoload -(defun package-refresh-contents () - "Download descriptions of all configured ELPA packages. -For each archive configured in the variable `package-archives', -inform Emacs about the latest versions of all packages it offers, -and make them available for download." - (interactive) - ;; FIXME: Do it asynchronously. - (unless (file-exists-p package-user-dir) - (make-directory package-user-dir t)) - (let ((default-keyring (expand-file-name "package-keyring.gpg" - data-directory))) - (when (and package-check-signature (file-exists-p default-keyring)) - (condition-case-unless-debug error - (progn - (epg-check-configuration (epg-configuration)) - (package-import-keyring default-keyring)) - (error (message "Cannot import default keyring: %S" (cdr error)))))) - (dolist (archive package-archives) - (condition-case-unless-debug nil - (package--download-one-archive archive "archive-contents") - (error (message "Failed to download `%s' archive." - (car archive))))) - (package-read-all-archive-contents) - (package--build-compatibility-table) - (message "Package refresh done")) - -(defun package--find-non-dependencies () - "Return a list of installed packages which are not dependencies. -Finds all packages in `package-alist' which are not dependencies -of any other packages. -Used to populate `package-selected-packages'." - (let ((dep-list - (delete-dups - (apply #'append - (mapcar (lambda (p) (mapcar #'car (package-desc-reqs (cadr p)))) - package-alist))))) - (cl-loop for p in package-alist - for name = (car p) - unless (memq name dep-list) - collect name))) - -;;;###autoload -(defun package-initialize (&optional no-activate) - "Load Emacs Lisp packages, and activate them. -The variable `package-load-list' controls which packages to load. -If optional arg NO-ACTIVATE is non-nil, don't activate packages." - (interactive) - (setq package-alist nil) - (package-load-all-descriptors) - (package-read-all-archive-contents) - (unless no-activate - (dolist (elt package-alist) - (package-activate (car elt)))) - (setq package--initialized t) - ;; This uses `package--mapc' so it must be called after - ;; `package--initialized' is t. - (package--build-compatibility-table)) - -(defun package--add-to-compatibility-table (pkg) - "If PKG is compatible (without dependencies), add to the compatibility table. -PKG is a package-desc object. -Only adds if its version is higher than what's already stored in -the table." - (unless (package--incompatible-p pkg 'shallow) - (let* ((name (package-desc-name pkg)) - (version (or (package-desc-version pkg) '(0))) - (table-version (gethash name package--compatibility-table))) - (when (or (not table-version) - (version-list-< table-version version)) - (puthash name version package--compatibility-table))))) - ;;;; Package description buffer. @@ -1798,6 +1887,8 @@ the table." (with-current-buffer standard-output (describe-package-1 package))))) +(declare-function lm-commentary "lisp-mnt" (&optional file)) + (defun describe-package-1 (pkg) (require 'lisp-mnt) (let* ((desc (or @@ -2392,6 +2483,25 @@ If optional arg BUTTON is non-nil, describe its associated package." (aref (cadr entry) 2) ""))) +(defun package-archive-priority (archive) + "Return the priority of ARCHIVE. + +The archive priorities are specified in +`package-archive-priorities'. If not given there, the priority +defaults to 0." + (or (cdr (assoc archive package-archive-priorities)) + 0)) + +(defun package-desc-priority-version (pkg-desc) + "Return the version PKG-DESC with the archive priority prepended. + +This allows for easy comparison of package versions from +different archives if archive priorities are meant to be taken in +consideration." + (cons (package-archive-priority + (package-desc-archive pkg-desc)) + (package-desc-version pkg-desc))) + (defun package-menu--find-upgrades () (let (installed available upgrades) ;; Build list of installed/available packages in this buffer. @@ -2441,40 +2551,6 @@ call will upgrade the package." (length upgrades) (if (= (length upgrades) 1) "" "s"))))) -(defun package--sort-deps-in-alist (package only) - "Return a list of dependencies for PACKAGE sorted by dependency. -PACKAGE is included as the first element of the returned list. -ONLY is an alist associating package names to package objects. -Only these packages will be in the return value an their cdrs are -destructively set to nil in ONLY." - (let ((out)) - (dolist (dep (package-desc-reqs package)) - (when-let ((cell (assq (car dep) only)) - (dep-package (cdr-safe cell))) - (setcdr cell nil) - (setq out (append (package--sort-deps-in-alist dep-package only) - out)))) - (cons package out))) - -(defun package--sort-by-dependence (package-list) - "Return PACKAGE-LIST sorted by dependence. -That is, any element of the returned list is guaranteed to not -directly depend on any elements that come before it. - -PACKAGE-LIST is a list of package-desc objects. -Indirect dependencies are guaranteed to be returned in order only -if all the in-between dependencies are also in PACKAGE-LIST." - (let ((alist (mapcar (lambda (p) (cons (package-desc-name p) p)) package-list)) - out-list) - (dolist (cell alist out-list) - ;; `package--sort-deps-in-alist' destructively changes alist, so - ;; some cells might already be empty. We check this here. - (when-let ((pkg-desc (cdr cell))) - (setcdr cell nil) - (setq out-list - (append (package--sort-deps-in-alist pkg-desc alist) - out-list)))))) - (defun package-menu-execute (&optional noquery) "Perform marked Package Menu actions. Packages marked for installation are downloaded and installed; -- cgit v1.2.3 From bc9a6fcd29cd2e35a34e42f6e8b9492c98c1560f Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 30 Mar 2015 21:33:20 -0400 Subject: Let jit-lock know the result of font-lock-extend-region-functions. * lisp/jit-lock.el (jit-lock--run-functions): New function. (jit-lock-fontify-now): Use it. Handle fontification bounds more precisely in case the backend functions fontify more than requested. Don't round up to whole lines since that shouldn't be needed any more. * lisp/font-lock.el (font-lock-fontify-region-function): Adjust docstring. (font-lock-inhibit-thing-lock): Make obsolete. (font-lock-default-fontify-region): Return the bounds actually used. * lisp/emacs-lisp/eieio-base.el (eieio-persistent-validate/fix-slot-value): Fix compilation error. --- lisp/ChangeLog | 15 ++++++ lisp/emacs-lisp/eieio-base.el | 3 +- lisp/font-lock.el | 13 +++-- lisp/jit-lock.el | 109 +++++++++++++++++++++++++----------------- 4 files changed, 91 insertions(+), 49 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index cad239d7dee..e50c69b8af4 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,18 @@ +2015-03-31 Stefan Monnier + + Let jit-lock know the result of font-lock-extend-region-functions. + * jit-lock.el (jit-lock--run-functions): New function. + (jit-lock-fontify-now): Use it. Handle fontification bounds more + precisely in case the backend functions fontify more than requested. + Don't round up to whole lines since that shouldn't be needed + any more. + * font-lock.el (font-lock-fontify-region-function): Adjust docstring. + (font-lock-inhibit-thing-lock): Make obsolete. + (font-lock-default-fontify-region): Return the bounds actually used. + + * emacs-lisp/eieio-base.el (eieio-persistent-validate/fix-slot-value): + Fix compilation error. + 2015-03-30 Artur Malabarba * emacs-lisp/package.el: Reorganize package.el and divide it with diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index c2eab202881..2e280365a7a 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -294,7 +294,8 @@ Second, any text properties will be stripped from strings." (cond ((consp proposed-value) ;; Lists with something in them need special treatment. (let* ((slot-idx (- (eieio--slot-name-index class slot) - (eval-when-compile eieio--object-num-slots))) + (eval-when-compile + (length (cl-struct-slot-info 'eieio--object))))) (type (cl--slot-descriptor-type (aref (eieio--class-slots class) slot-idx))) (classtype (eieio-persistent-slot-type-is-class-p type))) diff --git a/lisp/font-lock.el b/lisp/font-lock.el index 6c8392bc090..96b290e34f4 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -585,11 +585,14 @@ This is normally set via `font-lock-defaults'.") This is used when turning off Font Lock mode. This is normally set via `font-lock-defaults'.") -(defvar font-lock-fontify-region-function 'font-lock-default-fontify-region +(defvar font-lock-fontify-region-function #'font-lock-default-fontify-region "Function to use for fontifying a region. It should take two args, the beginning and end of the region, and an optional third arg VERBOSE. If VERBOSE is non-nil, the function should print status -messages. This is normally set via `font-lock-defaults'.") +messages. This is normally set via `font-lock-defaults'. +If it fontifies a larger region, it should ideally return a list of the form +\(jit-lock-bounds BEG . END) indicating the bounds of the region actually +fontified.") (defvar font-lock-unfontify-region-function 'font-lock-default-unfontify-region "Function to use for unfontifying a region. @@ -600,6 +603,7 @@ This is normally set via `font-lock-defaults'.") "List of Font Lock mode related modes that should not be turned on. Currently, valid mode names are `fast-lock-mode', `jit-lock-mode' and `lazy-lock-mode'. This is normally set via `font-lock-defaults'.") +(make-obsolete-variable 'font-lock-inhibit-thing-lock nil "25.1") (defvar-local font-lock-multiline nil "Whether font-lock should cater to multiline keywords. @@ -935,7 +939,7 @@ The value of this variable is used when Font Lock mode is turned on." ;; Don't fontify eagerly (and don't abort if the buffer is large). (set (make-local-variable 'font-lock-fontified) t) ;; Use jit-lock. - (jit-lock-register 'font-lock-fontify-region + (jit-lock-register #'font-lock-fontify-region (not font-lock-keywords-only)) ;; Tell jit-lock how we extend the region to refontify. (add-hook 'jit-lock-after-change-extend-region-functions @@ -1220,7 +1224,8 @@ This function is the default `font-lock-fontify-region-function'." (font-lock-fontify-syntactic-keywords-region start end))) (unless font-lock-keywords-only (font-lock-fontify-syntactically-region beg end loudly)) - (font-lock-fontify-keywords-region beg end loudly))))) + (font-lock-fontify-keywords-region beg end loudly) + `(jit-lock-bounds ,beg . ,end))))) ;; The following must be rethought, since keywords can override fontification. ;; ;; Now scan for keywords, but not if we are inside a comment now. diff --git a/lisp/jit-lock.el b/lisp/jit-lock.el index 788646c97be..d271a447756 100644 --- a/lisp/jit-lock.el +++ b/lisp/jit-lock.el @@ -351,6 +351,24 @@ is active." (min (point-max) (+ start jit-lock-chunk-size))) 'fontified 'defer))))) +(defun jit-lock--run-functions (beg end) + (let ((tight-beg nil) (tight-end nil) + (loose-beg beg) (loose-end end)) + (run-hook-wrapped + 'jit-lock-functions + (lambda (fun) + (pcase-let* + ((res (funcall fun beg end)) + (`(,this-beg . ,this-end) + (if (eq (car-safe res) 'jit-lock-bounds) + (cdr res) (cons beg end)))) + (setq tight-beg (max tight-beg (or this-beg (point-min)))) + (setq tight-end (max tight-end (or this-end (point-max)))) + (setq loose-beg (max loose-beg this-beg)) + (setq loose-end (max loose-end this-end)) + nil))) + `(,(min tight-beg beg) ,(max tight-end end) ,loose-beg ,loose-end))) + (defun jit-lock-fontify-now (&optional start end) "Fontify current buffer from START to END. Defaults to the whole buffer. END can be out of bounds." @@ -376,54 +394,57 @@ Defaults to the whole buffer. END can be out of bounds." (setq next (or (text-property-any start end 'fontified t) end)) - ;; Decide which range of text should be fontified. - ;; The problem is that START and NEXT may be in the - ;; middle of something matched by a font-lock regexp. - ;; Until someone has a better idea, let's start - ;; at the start of the line containing START and - ;; stop at the start of the line following NEXT. - (goto-char next) (setq next (line-beginning-position 2)) - (goto-char start) (setq start (line-beginning-position)) - - ;; Make sure the contextual refontification doesn't re-refontify - ;; what's already been refontified. - (when (and jit-lock-context-unfontify-pos - (< jit-lock-context-unfontify-pos next) - (>= jit-lock-context-unfontify-pos start) - ;; Don't move boundary forward if we have to - ;; refontify previous text. Otherwise, we risk moving - ;; it past the end of the multiline property and thus - ;; forget about this multiline region altogether. - (not (get-text-property start 'jit-lock-defer-multiline))) - (setq jit-lock-context-unfontify-pos next)) - ;; Fontify the chunk, and mark it as fontified. ;; We mark it first, to make sure that we don't indefinitely ;; re-execute this fontification if an error occurs. (put-text-property start next 'fontified t) - (condition-case err - (run-hook-with-args 'jit-lock-functions start next) - ;; If the user quits (which shouldn't happen in normal on-the-fly - ;; jit-locking), make sure the fontification will be performed - ;; before displaying the block again. - (quit (put-text-property start next 'fontified nil) - (funcall 'signal (car err) (cdr err)))) - - ;; The redisplay engine has already rendered the buffer up-to - ;; `orig-start' and won't notice if the above jit-lock-functions - ;; changed the appearance of any part of the buffer prior - ;; to that. So if `start' is before `orig-start', we need to - ;; cause a new redisplay cycle after this one so that any changes - ;; are properly reflected on screen. - ;; To make such repeated redisplay happen less often, we can - ;; eagerly extend the refontified region with - ;; jit-lock-after-change-extend-region-functions. - (when (< start orig-start) - (run-with-timer 0 nil #'jit-lock-force-redisplay - (copy-marker start) (copy-marker orig-start))) - - ;; Find the start of the next chunk, if any. - (setq start (text-property-any next end 'fontified nil)))))))) + (pcase-let + ;; `tight' is the part we've fully refontified, and `loose' + ;; is the part we've partly refontified (some of the + ;; functions have refontified it but maybe not all). + ((`(,tight-beg ,tight-end ,loose-beg ,loose-end) + (condition-case err + (jit-lock--run-functions start next) + ;; If the user quits (which shouldn't happen in normal + ;; on-the-fly jit-locking), make sure the fontification + ;; will be performed before displaying the block again. + (quit (put-text-property start next 'fontified nil) + (signal (car err) (cdr err)))))) + + ;; In case we fontified more than requested, take note. + (when (or (< tight-beg start) (> tight-end next)) + (put-text-property tight-beg tight-end 'fontified t)) + + ;; Make sure the contextual refontification doesn't re-refontify + ;; what's already been refontified. + (when (and jit-lock-context-unfontify-pos + (< jit-lock-context-unfontify-pos tight-end) + (>= jit-lock-context-unfontify-pos tight-beg) + ;; Don't move boundary forward if we have to + ;; refontify previous text. Otherwise, we risk moving + ;; it past the end of the multiline property and thus + ;; forget about this multiline region altogether. + (not (get-text-property tight-beg + 'jit-lock-defer-multiline))) + (setq jit-lock-context-unfontify-pos tight-end)) + + ;; The redisplay engine has already rendered the buffer up-to + ;; `orig-start' and won't notice if the above jit-lock-functions + ;; changed the appearance of any part of the buffer prior + ;; to that. So if `loose-beg' is before `orig-start', we need to + ;; cause a new redisplay cycle after this one so that the changes + ;; are properly reflected on screen. + ;; To make such repeated redisplay happen less often, we can + ;; eagerly extend the refontified region with + ;; jit-lock-after-change-extend-region-functions. + (when (< loose-beg orig-start) + (run-with-timer 0 nil #'jit-lock-force-redisplay + (copy-marker loose-beg) + (copy-marker orig-start))) + + ;; Find the start of the next chunk, if any. + (setq start + (text-property-any tight-end end 'fontified nil))))))))) (defun jit-lock-force-redisplay (start end) "Force the display engine to re-render START's buffer from START to END. -- cgit v1.2.3 From ba7a1a7a4eb64dd391d2e866c82cadfcc00d364d Mon Sep 17 00:00:00 2001 From: Artur Malabarba Date: Wed, 1 Apr 2015 11:03:43 +0100 Subject: * emacs-lisp/package.el: Implement asynchronous refreshing. (package--with-work-buffer-async) (package--check-signature-content) (package--update-downloads-in-progress): New functions. (package--check-signature, package--download-one-archive) (package--download-and-read-archives, package-refresh-contents): Optional arguments for async usage. (package--post-download-archives-hook): New variable. Hook run after every refresh. --- lisp/ChangeLog | 12 +++ lisp/emacs-lisp/package.el | 183 ++++++++++++++++++++++++++++++++------------- 2 files changed, 144 insertions(+), 51 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 621121e0f06..da3cd513ca2 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,15 @@ +2015-04-01 Artur Malabarba + + * emacs-lisp/package.el: Implement asynchronous refreshing. + (package--with-work-buffer-async) + (package--check-signature-content) + (package--update-downloads-in-progress): New functions. + (package--check-signature, package--download-one-archive) + (package--download-and-read-archives, package-refresh-contents): + Optional arguments for async usage. + (package--post-download-archives-hook): New variable. Hook run + after every refresh. + 2015-03-31 Simen Heggestøyl * textmodes/css-mode.el (css-mode): Derive from `prog-mode'. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 526c0b41a77..89d92464119 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1082,20 +1082,43 @@ buffer is killed afterwards. Return the last value in BODY." (insert-file-contents (expand-file-name ,file ,location))) ,@body)) -(defun package--check-signature (location file) - "Check signature of the current buffer. -GnuPG keyring is located under \"gnupg\" in `package-user-dir'." +(defmacro package--with-work-buffer-async (location file async &rest body) + "Run BODY in a buffer containing the contents of FILE at LOCATION. +If ASYNC is non-nil, and if it is possible, the operation is run +asynchronously. If an error is encountered and ASYNC is a +function, it is called with no arguments (instead of executing +body), otherwise the error is propagated. For description on the +other arguments see `package--with-work-buffer'." + (declare (indent 3) (debug t)) + `(if (or (not ,async) + (not (string-match-p "\\`https?:" ,location))) + (package--with-work-buffer ,location ,file ,@body) + (url-retrieve (concat ,location ,file) + (lambda (status) + (if (eq (car status) :error) + (if (functionp ,async) + (funcall ,async) + (signal (cdar status) (cddr status))) + (goto-char (point-min)) + (unless (search-forward "\n\n" nil 'noerror) + (error "Invalid url response")) + (delete-region (point-min) (point)) + ,@body) + (kill-buffer (current-buffer))) + nil + 'silent))) + +(defun package--check-signature-content (content string &optional sig-file) + "Check signature CONTENT against STRING. +SIG-FILE is the name of the signature file, used when signaling +errors." (let* ((context (epg-make-context 'OpenPGP)) - (homedir (expand-file-name "gnupg" package-user-dir)) - (sig-file (concat file ".sig")) - (sig-content (package--with-work-buffer location sig-file - (buffer-string)))) + (homedir (expand-file-name "gnupg" package-user-dir))) (setf (epg-context-home-directory context) homedir) (condition-case error - (epg-verify-string context sig-content (buffer-string)) - (error - (package--display-verify-error context sig-file) - (signal (car error) (cdr error)))) + (epg-verify-string context content string) + (error (package--display-verify-error context sig-file) + (signal (car error) (cdr error)))) (let (good-signatures had-fatal-error) ;; The .sig file may contain multiple signatures. Success if one ;; of the signatures is good. @@ -1114,6 +1137,30 @@ GnuPG keyring is located under \"gnupg\" in `package-user-dir'." (error "Failed to verify signature %s" sig-file)) good-signatures))) +(defun package--check-signature (location file &optional string async callback) + "Check signature of the current buffer. +Signature file is downloaded from LOCATION by appending \".sig\" +to FILE. +GnuPG keyring is located under \"gnupg\" in `package-user-dir'. +STRING is the string to verify, it defaults to `buffer-string'. +If ASYNC is non-nil, the download of the signature file is +done asynchronously. + +If the signature is verified and CALLBACK was provided, CALLBACK +is `funcall'ed with the list of good signatures as argument (the +list can be empty). If the signatures file is not found, +CALLBACK is called with no arguments." + (let ((sig-file (concat file ".sig")) + (string (or string (buffer-string)))) + (condition-case nil + (package--with-work-buffer-async + location sig-file (when async (or callback t)) + (let ((sig (package--check-signature-content + (buffer-string) string sig-file))) + (when callback (funcall callback sig)) + sig)) + (file-error (funcall callback))))) + ;;; Packages on Archives ;; The following variables store information about packages available @@ -1281,36 +1328,8 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." ;;;; Populating `package-archive-contents' from archives ;; This subsection populates the variables listed above from the ;; actual archives, instead of from a local cache. -(defun package--download-one-archive (archive file) - "Retrieve an archive file FILE from ARCHIVE, and cache it. -ARCHIVE should be a cons cell of the form (NAME . LOCATION), -similar to an entry in `package-alist'. Save the cached copy to -\"archives/NAME/archive-contents\" in `package-user-dir'." - (let ((dir (expand-file-name (format "archives/%s" (car archive)) - package-user-dir)) - (sig-file (concat file ".sig")) - good-signatures) - (package--with-work-buffer (cdr archive) file - ;; Check signature of archive-contents, if desired. - (if (and package-check-signature - (not (member archive package-unsigned-archives))) - (if (package--archive-file-exists-p (cdr archive) sig-file) - (setq good-signatures (package--check-signature (cdr archive) - file)) - (unless (eq package-check-signature 'allow-unsigned) - (error "Unsigned archive `%s'" - (car archive))))) - ;; Read the retrieved buffer to make sure it is valid (e.g. it - ;; may fetch a URL redirect page). - (when (listp (read (current-buffer))) - (make-directory dir t) - (write-region nil nil (expand-file-name file dir) nil 'silent))) - (when good-signatures - ;; Write out good signatures into archive-contents.signed file. - (write-region (mapconcat #'epg-signature-to-string good-signatures "\n") - nil - (expand-file-name (concat file ".signed") dir) - nil 'silent)))) +(defvar package--downloads-in-progress nil + "List of in-progress asynchronous downloads.") (declare-function epg-check-configuration "epg-config" (config &optional minimum-version)) @@ -1331,12 +1350,81 @@ similar to an entry in `package-alist'. Save the cached copy to (epg-import-keys-from-file context file) (message "Importing %s...done" (file-name-nondirectory file)))) +(defvar package--post-download-archives-hook nil + "Hook run after the archive contents are downloaded. +Don't run this hook directly. It is meant to be run as part of +`package--update-downloads-in-progress'.") +(put 'package--post-download-archives-hook 'risky-local-variable t) + +(defun package--update-downloads-in-progress (entry) + "Remove ENTRY from `package--downloads-in-progress'. +Once it's empty, run `package--post-download-archives-hook'." + ;; Keep track of the downloading progress. + (setq package--downloads-in-progress + (remove entry package--downloads-in-progress)) + ;; If this was the last download, run the hook. + (unless package--downloads-in-progress + (package--build-compatibility-table) + (package-read-all-archive-contents) + ;; We message before running the hook, so the hook can give + ;; messages as well. + (message "Package refresh done") + (run-hooks 'package--post-download-archives-hook))) + +(defun package--download-one-archive (archive file &optional async) + "Retrieve an archive file FILE from ARCHIVE, and cache it. +ARCHIVE should be a cons cell of the form (NAME . LOCATION), +similar to an entry in `package-alist'. Save the cached copy to +\"archives/NAME/FILE\" in `package-user-dir'." + (package--with-work-buffer-async (cdr archive) file async + (let* ((location (cdr archive)) + (name (car archive)) + (content (buffer-string)) + (dir (expand-file-name (format "archives/%s" name) package-user-dir)) + (local-file (expand-file-name file dir))) + (when (listp (read-from-string content)) + (make-directory dir t) + (if (or (not package-check-signature) + (member archive package-unsigned-archives)) + ;; If we don't care about the signature, save the file and + ;; we're done. + (progn (write-region content nil local-file nil 'silent) + (package--update-downloads-in-progress archive)) + ;; If we care, check it (perhaps async) and *then* write the file. + (package--check-signature + location file content async + (lambda (&optional good-sigs) + (unless (or good-sigs (eq package-check-signature 'allow-unsigned)) + (error "Unsigned archive `%s'" name)) + ;; Write out the archives file. + (write-region content nil local-file nil 'silent) + ;; Write out good signatures into archive-contents.signed file. + (when good-sigs + (write-region (mapconcat #'epg-signature-to-string good-sigs "\n") + nil (concat local-file ".signed") nil 'silent)) + (package--update-downloads-in-progress archive)))))))) + +(defun package--download-and-read-archives (&optional async) + "Download descriptions of all `package-archives' and read them. +This populates `package-archive-contents'. If ASYNC is non-nil, +the downloads are performed asynchronously." + ;; The dowloaded archive contents will be read as part of + ;; `package--update-downloads-in-progress'. + (setq package--downloads-in-progress package-archives) + (dolist (archive package-archives) + (condition-case-unless-debug nil + (package--download-one-archive archive "archive-contents" async) + (error (message "Failed to download `%s' archive." + (car archive)))))) + ;;;###autoload -(defun package-refresh-contents () +(defun package-refresh-contents (&optional async) "Download descriptions of all configured ELPA packages. For each archive configured in the variable `package-archives', inform Emacs about the latest versions of all packages it offers, -and make them available for download." +and make them available for download. +Optional argument, ASYNC, specifies whether the downloads should +be performed in the background." (interactive) ;; FIXME: Do it asynchronously. (unless (file-exists-p package-user-dir) @@ -1349,14 +1437,7 @@ and make them available for download." (epg-check-configuration (epg-configuration)) (package-import-keyring default-keyring)) (error (message "Cannot import default keyring: %S" (cdr error)))))) - (dolist (archive package-archives) - (condition-case-unless-debug nil - (package--download-one-archive archive "archive-contents") - (error (message "Failed to download `%s' archive." - (car archive))))) - (package-read-all-archive-contents) - (package--build-compatibility-table) - (message "Package refresh done")) + (package--download-and-read-archives async)) ;;; Dependency Management -- cgit v1.2.3 From aa33f4a100e4539aaa04a8e1647d926f972c2673 Mon Sep 17 00:00:00 2001 From: Artur Malabarba Date: Wed, 1 Apr 2015 11:09:00 +0100 Subject: * emacs-lisp/package.el: Make package-menu asynchronous. (package-menu-async): New variable. Controls whether `list-packages' is asynchronous. (list-packages): Now asynchronous by default. (package-menu--new-package-list): Always buffer-local. (package-menu--post-refresh) (package-menu--find-and-notify-upgrades) (package-menu--populate-new-package-list): New functions. --- lisp/ChangeLog | 9 +++++ lisp/emacs-lisp/package.el | 93 ++++++++++++++++++++++++++++++---------------- 2 files changed, 71 insertions(+), 31 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index da3cd513ca2..b35c78da09e 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -10,6 +10,15 @@ (package--post-download-archives-hook): New variable. Hook run after every refresh. + * emacs-lisp/package.el: Make package-menu asynchronous. + (package-menu-async): New variable. Controls whether + `list-packages' is asynchronous. + (list-packages): Now asynchronous by default. + (package-menu--new-package-list): Always buffer-local. + (package-menu--post-refresh) + (package-menu--find-and-notify-upgrades) + (package-menu--populate-new-package-list): New functions. + 2015-03-31 Simen Heggestøyl * textmodes/css-mode.el (css-mode): Derive from `prog-mode'. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 89d92464119..490fb45a98f 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2241,7 +2241,7 @@ will be deleted." map) "Local keymap for `package-menu-mode' buffers.") -(defvar package-menu--new-package-list nil +(defvar-local package-menu--new-package-list nil "List of newly-available packages since `list-packages' was last called.") (define-derived-mode package-menu-mode tabulated-list-mode "Package Menu" @@ -2749,6 +2749,49 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (string< (or (package-desc-archive (car A)) "") (or (package-desc-archive (car B)) ""))) +(defvar-local package-menu--old-archive-contents nil + "`package-archive-contents' before the latest refresh.") + +(defun package-menu--populate-new-package-list () + "Decide which packages are new in `package-archives-contents'. +Store this list in `package-menu--new-package-list'." + ;; Find which packages are new. + (when package-menu--old-archive-contents + (dolist (elt package-archive-contents) + (unless (assq (car elt) package-menu--old-archive-contents) + (push (car elt) package-menu--new-package-list))) + (setq package-menu--old-archive-contents nil))) + +(defun package-menu--find-and-notify-upgrades () + "Notify the user of upgradeable packages." + (when-let ((upgrades (package-menu--find-upgrades))) + (message "%d package%s can be upgraded; type `%s' to mark %s for upgrading." + (length upgrades) + (if (= (length upgrades) 1) "" "s") + (substitute-command-keys "\\[package-menu-mark-upgrades]") + (if (= (length upgrades) 1) "it" "them")))) + +(defun package-menu--post-refresh () + "Function to be called after `package-refresh-contents' is done. +Checks for new packages, reverts the *Packages* buffer, and +checks for upgrades. +This goes in `package--post-download-archives-hook', so that it +works with async refresh as well." + (package-menu--populate-new-package-list) + (let ((buf (get-buffer "*Packages*"))) + (when (buffer-live-p buf) + (with-current-buffer buf + (revert-buffer nil 'noconfirm)))) + (package-menu--find-and-notify-upgrades)) + +(defcustom package-menu-async t + "If non-nil, package-menu will use async operations when possible. +Currently, only the refreshing of archive contents supports +asynchronous operations. Package transactions are still done +synchronously." + :type 'boolean + :group 'package) + ;;;###autoload (defun list-packages (&optional no-fetch) "Display a list of packages. @@ -2760,36 +2803,24 @@ The list is displayed in a buffer named `*Packages*'." ;; Initialize the package system if necessary. (unless package--initialized (package-initialize t)) - (let (old-archives new-packages) - (unless no-fetch - ;; Read the locally-cached archive-contents. - (package-read-all-archive-contents) - (setq old-archives package-archive-contents) - ;; Fetch the remote list of packages. - (package-refresh-contents) - ;; Find which packages are new. - (dolist (elt package-archive-contents) - (unless (assq (car elt) old-archives) - (push (car elt) new-packages)))) - - ;; Generate the Package Menu. - (let ((buf (get-buffer-create "*Packages*"))) - (with-current-buffer buf - (package-menu-mode) - (set (make-local-variable 'package-menu--new-package-list) - new-packages) - (package-menu--generate nil t)) - ;; The package menu buffer has keybindings. If the user types - ;; `M-x list-packages', that suggests it should become current. - (switch-to-buffer buf)) - - (let ((upgrades (package-menu--find-upgrades))) - (if upgrades - (message "%d package%s can be upgraded; type `%s' to mark %s for upgrading." - (length upgrades) - (if (= (length upgrades) 1) "" "s") - (substitute-command-keys "\\[package-menu-mark-upgrades]") - (if (= (length upgrades) 1) "it" "them")))))) + ;; Integrate the package-menu with updating the archives. + (add-hook 'package--post-download-archives-hook + #'package-menu--post-refresh) + + (unless no-fetch + (setq package-menu--old-archive-contents package-archive-contents) + (setq package-menu--new-package-list nil) + ;; Fetch the remote list of packages. + (package-refresh-contents package-menu-async)) + + ;; Generate the Package Menu. + (let ((buf (get-buffer-create "*Packages*"))) + (with-current-buffer buf + (package-menu-mode) + (package-menu--generate nil t)) + ;; The package menu buffer has keybindings. If the user types + ;; `M-x list-packages', that suggests it should become current. + (switch-to-buffer buf))) ;;;###autoload (defalias 'package-list-packages 'list-packages) -- cgit v1.2.3 From bd55cd4d246c031151dc338813cb9c8ca5ea33dd Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Wed, 1 Apr 2015 10:21:47 -0700 Subject: * emacs-lisp/package.el: Spelling fixes and use active voice. --- lisp/ChangeLog | 4 ++++ lisp/emacs-lisp/package.el | 27 +++++++++++++-------------- 2 files changed, 17 insertions(+), 14 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b35c78da09e..46f519ef306 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2015-04-01 Paul Eggert + + * emacs-lisp/package.el: Spelling fixes and use active voice. + 2015-04-01 Artur Malabarba * emacs-lisp/package.el: Implement asynchronous refreshing. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 490fb45a98f..583598ee10c 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1084,11 +1084,11 @@ buffer is killed afterwards. Return the last value in BODY." (defmacro package--with-work-buffer-async (location file async &rest body) "Run BODY in a buffer containing the contents of FILE at LOCATION. -If ASYNC is non-nil, and if it is possible, the operation is run +If ASYNC is non-nil, and if it is possible, run BODY asynchronously. If an error is encountered and ASYNC is a -function, it is called with no arguments (instead of executing -body), otherwise the error is propagated. For description on the -other arguments see `package--with-work-buffer'." +function, call it with no arguments (instead of executing BODY), +otherwise propagate the error. For description of the other +arguments see `package--with-work-buffer'." (declare (indent 3) (debug t)) `(if (or (not ,async) (not (string-match-p "\\`https?:" ,location))) @@ -1139,7 +1139,7 @@ errors." (defun package--check-signature (location file &optional string async callback) "Check signature of the current buffer. -Signature file is downloaded from LOCATION by appending \".sig\" +Download the signature file from LOCATION by appending \".sig\" to FILE. GnuPG keyring is located under \"gnupg\" in `package-user-dir'. STRING is the string to verify, it defaults to `buffer-string'. @@ -1407,8 +1407,8 @@ similar to an entry in `package-alist'. Save the cached copy to (defun package--download-and-read-archives (&optional async) "Download descriptions of all `package-archives' and read them. This populates `package-archive-contents'. If ASYNC is non-nil, -the downloads are performed asynchronously." - ;; The dowloaded archive contents will be read as part of +perform the downloads asynchronously." + ;; The downloaded archive contents will be read as part of ;; `package--update-downloads-in-progress'. (setq package--downloads-in-progress package-archives) (dolist (archive package-archives) @@ -1423,8 +1423,8 @@ the downloads are performed asynchronously." For each archive configured in the variable `package-archives', inform Emacs about the latest versions of all packages it offers, and make them available for download. -Optional argument, ASYNC, specifies whether the downloads should -be performed in the background." +Optional argument ASYNC specifies whether to perform the +downloads in the background." (interactive) ;; FIXME: Do it asynchronously. (unless (file-exists-p package-user-dir) @@ -2763,7 +2763,7 @@ Store this list in `package-menu--new-package-list'." (setq package-menu--old-archive-contents nil))) (defun package-menu--find-and-notify-upgrades () - "Notify the user of upgradeable packages." + "Notify the user of upgradable packages." (when-let ((upgrades (package-menu--find-upgrades))) (message "%d package%s can be upgraded; type `%s' to mark %s for upgrading." (length upgrades) @@ -2772,10 +2772,9 @@ Store this list in `package-menu--new-package-list'." (if (= (length upgrades) 1) "it" "them")))) (defun package-menu--post-refresh () - "Function to be called after `package-refresh-contents' is done. -Checks for new packages, reverts the *Packages* buffer, and -checks for upgrades. -This goes in `package--post-download-archives-hook', so that it + "Check for new packages, revert the *Packages* buffer, and check for upgrades. +This function is called after `package-refresh-contents' is done. +It goes in `package--post-download-archives-hook', so that it works with async refresh as well." (package-menu--populate-new-package-list) (let ((buf (get-buffer "*Packages*"))) -- cgit v1.2.3 From 5e41a51e5cc45ca7289fc120f26ad90f45eb2682 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 2 Apr 2015 09:59:47 -0400 Subject: * lisp/emacs-lisp/lisp-mnt.el (lm-version): Don't burp in a non-file buffer. --- lisp/ChangeLog | 8 ++++++-- lisp/emacs-lisp/lisp-mnt.el | 6 ++++-- 2 files changed, 10 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 2092447fbcc..96732ec37ef 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,9 +1,13 @@ +2015-04-02 Stefan Monnier + + * emacs-lisp/lisp-mnt.el (lm-version): Don't burp in a non-file buffer. + 2015-04-01 Alan Mackenzie Fix the CC Mode fixes from 2015-03-30. Fixes debbugs#20240. - * progmodes/cc-mode.el (c-extend-after-change-region): Widen - before applying text properties. + * progmodes/cc-mode.el (c-extend-after-change-region): + Widen before applying text properties. * progmodes/cc-langs.el (c-before-font-lock-functions): Update an entry to a new function name. diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index f9874d83bb3..fec172d05ca 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -436,8 +436,10 @@ This can be found in an RCS or SCCS header." ;; Look for an SCCS header ((re-search-forward (concat - (regexp-quote "@(#)") - (regexp-quote (file-name-nondirectory (buffer-file-name))) + "@(#)" + (if buffer-file-name + (regexp-quote (file-name-nondirectory buffer-file-name)) + "[^\t\n]*") "\t\\([012345679.]*\\)") header-max t) (match-string-no-properties 1))))))) -- cgit v1.2.3