commit c4e2be4587ec6d0f1367b1bfe220a71360e25bea (HEAD, refs/remotes/origin/master) Author: Stefan Monnier Date: Mon Feb 16 02:22:46 2015 -0500 * 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. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index bb8c97b..e438343 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,28 @@ 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. * emacs-lisp/cl-preloaded.el (cl-struct-define): Add sanity checks about relationship between `type', `named', and `slots'. diff --git a/lisp/cedet/ChangeLog b/lisp/cedet/ChangeLog index 6bbae7e..838a269 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 e37b65a..b20a756 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 fcf02b9..1cc9f89 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 e71c54d..408922a 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 5260909..4f6b6d7 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 29b7c7d..87425a6 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 da5f59a..62f5603 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) ) commit 6bf61df8ab359f1371ab2e3e278bc8642d65a985 Author: Stefan Monnier Date: Mon Feb 16 01:37:57 2015 -0500 * 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. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ca180ff..bb8c97b 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 548aaa9..e929c02 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 c423286..ccd5bec 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 2861d66..caaf768 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 03045de..401d34b 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))) commit e59feb3c15ca1dfb7a2a7edef21cbdb07d6ea183 Author: Katsumi Yamaoka Date: Mon Feb 16 03:42:00 2015 +0000 lisp/ChangeLog: Restore entries accidentally deleted diff --git a/lisp/ChangeLog b/lisp/ChangeLog index f91313b..ca180ff 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -3,12 +3,72 @@ * net/tramp-sh.el (tramp-remote-process-environment): Disable paging with PAGER=cat. (Bug#19870) +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. + (describe-package-1): Describe why a package is incompatible. + +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. + +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. + (describe-package-1): Fix "incompat" handling. + +2015-02-13 Lars Ingebrigtsen + + * net/rfc2104.el: Moved here from lisp/gnus. + +2015-02-13 Magnus Henoch + + * net/sasl-scram-rfc.el: New file. + + * net/sasl.el (sasl-mechanisms): Remove SCRAM-MD5. + Add SCRAM-SHA-1 first. + (sasl-mechanism-alist): Remove SCRAM-MD5 entry. Add SCRAM-SHA-1 + entry (bug#17636). + +2015-02-13 Lars Ingebrigtsen + + * net/shr.el (shr-tag-li): Speed up rendering pages with lots of +
    . + +2015-02-12 Oleh Krehel + + * progmodes/gdb-mi.el (gdb-display-io-nopopup): New defcustom. + (gdb-inferior-filter): Don't pop up the buried output buffer when + `gdb-display-io-nopopup' is non-nil. + 2015-02-12 Fabián Ezequiel Gallina python.el: Allow killing shell buffer if process is dead. (Bug#19823) - * progmodes/python.el (python-shell-font-lock-kill-buffer): Don't - require a running process. + * progmodes/python.el (python-shell-font-lock-kill-buffer): + Don't require a running process. (python-shell-font-lock-post-command-hook): Fontify only if the shell process is running. commit 0d38b2f403fa873159138b194c0d45bc4c7e61cc Author: Lars Magne Ingebrigtsen Date: Sun Feb 15 23:11:41 2015 +0000 Don't mark nnimap articles as read on a server hangup * lisp/gnus/nnimap.el (nnimap-retrieve-headers): If the server closes connection during header retrieval, error out instead of interpreting the data in the buffer as the only messages there. This way, we don't mark articles as read on a server hangup (bug#19035). diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index b9ae796..7910d74 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,5 +1,10 @@ 2015-02-14 Lars Ingebrigtsen + * nnimap.el (nnimap-retrieve-headers): If the server closes connection + during header retrieval, error out instead of interpreting the data in + the buffer as the only messages there. This way, we don't mark + articles as read on a server hangup (bug#19035). + * mm-decode.el (mm-head-p): New function. (mm-display-part): Go to a blank line when inserting parts internally. diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index e7f91b7..4a9ca74 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -196,6 +196,8 @@ textual parts.") (nnimap-article-ranges (gnus-compress-sequence articles)) (nnimap-header-parameters)) t) + (unless (process-live-p (get-buffer-process (current-buffer))) + (error "Server closed connection")) (nnimap-transform-headers) (nnheader-remove-cr-followed-by-lf)) (insert-buffer-substring commit 6090b8f68dfc37bfe8bee539fc43149f9dd5d6bb Author: Lars Magne Ingebrigtsen Date: Sun Feb 15 23:10:06 2015 +0000 Revert previous patch (let ((url-news-server "news.gmane.org")) (url-retrieve-synchronously "news:87y4p9y2cq.fsf@violet.siamics.net")) works fine for me diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index df33198..b9ae796 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,8 +1,3 @@ -2015-02-14 Ivan Shmakov - - * nntp.el (nntp-open-server): Set variables in the correct buffer - (bug#19583). - 2015-02-14 Lars Ingebrigtsen * mm-decode.el (mm-head-p): New function. diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index a86f45e..0891dba 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -1066,8 +1066,7 @@ command whose response triggered the error." (setq defs (cons (list 'nntp-port-number (car defs)) (cdr defs)))) (unless (assq 'nntp-address defs) (setq defs (append defs (list (list 'nntp-address server))))) - (with-current-buffer nntp-server-buffer - (nnoo-change-server 'nntp server defs)) + (nnoo-change-server 'nntp server defs) (if connectionless t (or (nntp-find-connection nntp-server-buffer) commit 4aafd19a0e800607e36779f423052df8b7a84f5f Author: Ivan Shmakov Date: Sun Feb 15 23:08:03 2015 +0000 Make `url-retrieve-synchronously' work again with news: * lisp/gnus/nntp.el (nntp-open-server): Set variables in the correct buffer (bug#19583). diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index b9ae796..df33198 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,8 @@ +2015-02-14 Ivan Shmakov + + * nntp.el (nntp-open-server): Set variables in the correct buffer + (bug#19583). + 2015-02-14 Lars Ingebrigtsen * mm-decode.el (mm-head-p): New function. diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 0891dba..a86f45e 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -1066,7 +1066,8 @@ command whose response triggered the error." (setq defs (cons (list 'nntp-port-number (car defs)) (cdr defs)))) (unless (assq 'nntp-address defs) (setq defs (append defs (list (list 'nntp-address server))))) - (nnoo-change-server 'nntp server defs) + (with-current-buffer nntp-server-buffer + (nnoo-change-server 'nntp server defs)) (if connectionless t (or (nntp-find-connection nntp-server-buffer) commit 45c5ccd48cee9c703e64fc67139a2e3bb8e9b3a5 Author: Lars Magne Ingebrigtsen Date: Sun Feb 15 23:05:46 2015 +0000 Fix inserting parts with `E' in Gnus * lisp/gnus/mm-decode.el (mm-head-p): New function. (mm-display-part): Go to a blank line when inserting parts internally. Fix inserting parts with `E' in Gnus * lisp/gnus/mm-decode.el (mm-head-p): New function. (mm-display-part): Go to a blank line when inserting parts internally. diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 67929a3..b9ae796 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,8 @@ +2015-02-14 Lars Ingebrigtsen + + * mm-decode.el (mm-head-p): New function. + (mm-display-part): Go to a blank line when inserting parts internally. + 2015-02-13 Lars Ingebrigtsen * gnus-msg.el (gnus-msg-mail): Don't let-bind `gnus-newsgroup-name' so diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index b3121bf..8503095 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -5505,7 +5505,8 @@ If no internal viewer is available, use an external viewer." (gnus-mime-view-part-as-type nil (lambda (type) (mm-inlinable-p handle type))) (when handle - (gnus-bind-safe-url-regexp (mm-display-part handle)))))) + (gnus-bind-safe-url-regexp + (mm-display-part handle nil t)))))) (defun gnus-mime-action-on-part (&optional action) "Do something with the MIME attachment at \(point\)." diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 3fdcdba..459c793 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -791,6 +791,14 @@ MIME-Version header before proceeding." (autoload 'mailcap-parse-mailcaps "mailcap") (autoload 'mailcap-mime-info "mailcap") +(defun mm-head-p (&optional point) + "Return non-nil if point is in the article header." + (let ((point (or point (point)))) + (save-excursion + (goto-char point) + (and (not (re-search-backward "^$" nil t)) + (re-search-forward "^$" nil t))))) + (defun mm-display-part (handle &optional no-default force) "Display the MIME part represented by HANDLE. Returns nil if the part is removed; inline if displayed inline; @@ -824,6 +832,10 @@ external if displayed external." 'inline) ((and (mm-inlinable-p ehandle) (mm-inlined-p ehandle)) + (when force + (if (mm-head-p) + (re-search-forward "^$" nil t) + (forward-line 1))) (mm-display-inline handle) 'inline) ((or method commit ba5bc0ee7c81f2122072bee162fcf1dbd8b2a8f2 Author: Jérémy Compostella Date: Sun Feb 15 10:57:33 2015 +0100 Tramp: Disable paging with PAGER=cat. Fixes: debbugs:19870 * net/tramp-sh.el (tramp-remote-process-environment): Disable paging with PAGER=cat. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 3cc42a5..f91313b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,69 +1,14 @@ -2015-02-14 Artur Malabarba +2015-02-15 Jérémy Compostella - * 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. - (describe-package-1): Describe why a package is incompatible. - -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. - -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. - (describe-package-1): Fix "incompat" handling. - -2015-02-13 Lars Ingebrigtsen - - * net/rfc2104.el: Moved here from lisp/gnus. - -2015-02-13 Magnus Henoch - - * net/sasl-scram-rfc.el: New file. - - * net/sasl.el (sasl-mechanisms): Remove SCRAM-MD5. - Add SCRAM-SHA-1 first. - (sasl-mechanism-alist): Remove SCRAM-MD5 entry. Add SCRAM-SHA-1 - entry (bug#17636). - -2015-02-13 Lars Ingebrigtsen - - * net/shr.el (shr-tag-li): Speed up rendering pages with lots of -
      . - -2015-02-12 Oleh Krehel - - * progmodes/gdb-mi.el (gdb-display-io-nopopup): New defcustom. - (gdb-inferior-filter): Don't pop up the buried output buffer when - `gdb-display-io-nopopup' is non-nil. + * net/tramp-sh.el (tramp-remote-process-environment): Disable paging + with PAGER=cat. (Bug#19870) 2015-02-12 Fabián Ezequiel Gallina python.el: Allow killing shell buffer if process is dead. (Bug#19823) - * progmodes/python.el (python-shell-font-lock-kill-buffer): - Don't require a running process. + * progmodes/python.el (python-shell-font-lock-kill-buffer): Don't + require a running process. (python-shell-font-lock-post-command-hook): Fontify only if the shell process is running. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 45050cd..f3fdb63 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -475,7 +475,7 @@ as given in your `~/.profile'." ,(format "TERM=%s" tramp-terminal-type) "EMACS=t" ;; Deprecated. ,(format "INSIDE_EMACS='%s,tramp:%s'" emacs-version tramp-version) - "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH=" "PAGER=\"\"" + "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH=" "PAGER=cat" "autocorrect=" "correct=") "List of environment variables to be set on the remote host. commit ffec11d9b47d71978fbfc26fe37d936037f2dfac Author: Martin Rudalics Date: Sat Feb 14 18:50:37 2015 +0100 Fix doc-string of x_frame_normalize_before_maximize. * xterm.c (x_frame_normalize_before_maximize): Fix doc-string. Suggested by Alan Mackenzie . diff --git a/src/ChangeLog b/src/ChangeLog index 5144738..c89fa60 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,8 @@ +2015-02-14 Martin Rudalics + + * xterm.c (x_frame_normalize_before_maximize): Fix doc-string. + Suggested by Alan Mackenzie . + 2015-02-14 Eli Zaretskii * menu.c (Fx_popup_menu) [HAVE_X_WINDOWS]: Call diff --git a/src/xterm.c b/src/xterm.c index 0b3efe7..03c0811 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -11729,9 +11729,11 @@ default is nil, which is the same as `super'. */); DEFVAR_BOOL ("x-frame-normalize-before-maximize", x_frame_normalize_before_maximize, doc: /* Non-nil means normalize frame before maximizing. -If this variable is t, Emacs asks the window manager to give the frame -intermediately its normal size whenever changing from a full-height or -full-width state to the fully maximized one and vice versa. +If this variable is t, Emacs first asks the window manager to give the +frame its normal size, and only then the final state, whenever changing +from a full-height, full-width or full-both state to the maximized one +or when changing from the maximized to the full-height or full-width +state. Set this variable only if your window manager cannot handle the transition between the various maximization states. */); commit f4f4f93e42a0ae572a62c9f64b90e4401232d9f4 Author: Artur Malabarba Date: Sat Feb 14 15:06:27 2015 -0200 emacs-lisp/package.el (describe-package-1): Describe incompatibility. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 42b386f..3cc42a5 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 64a646a..d8a4fc9 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") commit 93888585deba41f7f67a83cda2c69927ffb130c8 Author: Eli Zaretskii Date: Sat Feb 14 15:11:30 2015 +0200 Fix assertion violations when popping menus on TTY (Bug#19862) src/menu.c (Fx_popup_menu) [HAVE_X_WINDOWS]: Call x_relative_mouse_position only for X frames. diff --git a/src/ChangeLog b/src/ChangeLog index 6d246fb..5144738 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,8 @@ +2015-02-14 Eli Zaretskii + + * menu.c (Fx_popup_menu) [HAVE_X_WINDOWS]: Call + x_relative_mouse_position only for X frames. (Bug#19862) + 2015-02-13 Paul Eggert Better support for future plugins diff --git a/src/menu.c b/src/menu.c index 5a8ea34..e925f29 100644 --- a/src/menu.c +++ b/src/menu.c @@ -1243,35 +1243,39 @@ no quit occurs and `x-popup-menu' returns nil. */) /* Use the mouse's current position. */ struct frame *new_f = SELECTED_FRAME (); #ifdef HAVE_X_WINDOWS - /* Can't use mouse_position_hook for X since it returns - coordinates relative to the window the mouse is in, - we need coordinates relative to the edit widget always. */ - if (new_f != 0) + if (FRAME_X_P (new_f)) { - int cur_x, cur_y; - - x_relative_mouse_position (new_f, &cur_x, &cur_y); - /* cur_x/y may be negative, so use make_number. */ - x = make_number (cur_x); - y = make_number (cur_y); + /* Can't use mouse_position_hook for X since it returns + coordinates relative to the window the mouse is in, + we need coordinates relative to the edit widget always. */ + if (new_f != 0) + { + int cur_x, cur_y; + + x_relative_mouse_position (new_f, &cur_x, &cur_y); + /* cur_x/y may be negative, so use make_number. */ + x = make_number (cur_x); + y = make_number (cur_y); + } + } + else +#endif /* HAVE_X_WINDOWS */ + { + Lisp_Object bar_window; + enum scroll_bar_part part; + Time time; + void (*mouse_position_hook) (struct frame **, int, + Lisp_Object *, + enum scroll_bar_part *, + Lisp_Object *, + Lisp_Object *, + Time *) = + FRAME_TERMINAL (new_f)->mouse_position_hook; + + if (mouse_position_hook) + (*mouse_position_hook) (&new_f, 1, &bar_window, + &part, &x, &y, &time); } - -#else /* not HAVE_X_WINDOWS */ - Lisp_Object bar_window; - enum scroll_bar_part part; - Time time; - void (*mouse_position_hook) (struct frame **, int, - Lisp_Object *, - enum scroll_bar_part *, - Lisp_Object *, - Lisp_Object *, - Time *) = - FRAME_TERMINAL (new_f)->mouse_position_hook; - - if (mouse_position_hook) - (*mouse_position_hook) (&new_f, 1, &bar_window, - &part, &x, &y, &time); -#endif /* not HAVE_X_WINDOWS */ if (new_f != 0) XSETFRAME (window, new_f); commit 34c75359126e78367e4542a39b4b687c8955e1c6 Author: Artur Malabarba Date: Sat Feb 14 11:13:29 2015 -0200 emacs-lisp/package.el: Move the compatibility-table building logic. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 24cf80a..42b386f 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 d8b4595..64a646a 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. commit 61b4c22c6eba96718327a0d208a8492d8bad76e0 Author: Stefan Monnier Date: Sat Feb 14 00:46:29 2015 -0500 * 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. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 257b11b..24cf80a 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 0f53418..4b12495 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 eaec2c5..2861d66 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 c9867b4..03045de 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 commit 0d54f2f51c799cc372d9521233a8009adc4c3691 Author: Stefan Monnier Date: Fri Feb 13 22:45:18 2015 -0500 * lisp/textmodes/flyspell.el (flyspell-word): Defvar. Fixes: debbugs:19844 (flyspell-generic-check-word-p): Mark as obsolete. * lisp/erc/erc-spelling.el (erc-spelling-init): Use flyspell-generic-check-word-predicate. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 030d572..257b11b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2015-02-14 Stefan Monnier + + * textmodes/flyspell.el (flyspell-word): Defvar (bug#19844). + (flyspell-generic-check-word-p): Mark as obsolete. + 2015-02-13 Artur Malabarba * emacs-lisp/package.el (package--compatibility-table): New var. @@ -14,8 +19,8 @@ * net/sasl-scram-rfc.el: New file. - * net/sasl.el (sasl-mechanisms): Remove SCRAM-MD5. Add - SCRAM-SHA-1 first. + * net/sasl.el (sasl-mechanisms): Remove SCRAM-MD5. + Add SCRAM-SHA-1 first. (sasl-mechanism-alist): Remove SCRAM-MD5 entry. Add SCRAM-SHA-1 entry (bug#17636). @@ -34,8 +39,8 @@ python.el: Allow killing shell buffer if process is dead. (Bug#19823) - * progmodes/python.el (python-shell-font-lock-kill-buffer): Don't - require a running process. + * progmodes/python.el (python-shell-font-lock-kill-buffer): + Don't require a running process. (python-shell-font-lock-post-command-hook): Fontify only if the shell process is running. diff --git a/lisp/erc/ChangeLog b/lisp/erc/ChangeLog index 44971cc..4c1c843 100644 --- a/lisp/erc/ChangeLog +++ b/lisp/erc/ChangeLog @@ -1,3 +1,8 @@ +2015-02-14 Stefan Monnier + + * erc-spelling.el (erc-spelling-init): + Use flyspell-generic-check-word-predicate. + 2015-01-28 Dima Kogan * erc-backend.el (define-erc-response-handler): Give hook-name diff --git a/lisp/erc/erc-spelling.el b/lisp/erc/erc-spelling.el index e2ddb04..0cba956 100644 --- a/lisp/erc/erc-spelling.el +++ b/lisp/erc/erc-spelling.el @@ -71,7 +71,7 @@ The current buffer is given by BUFFER." (if dicts (cadr (car dicts)) (erc-with-server-buffer ispell-local-dictionary))))) - (setq flyspell-generic-check-word-p 'erc-spelling-flyspell-verify) + (setq flyspell-generic-check-word-predicate #'erc-spelling-flyspell-verify) (flyspell-mode 1))) (defun erc-spelling-unhighlight-word (word) @@ -85,6 +85,7 @@ The cadr is the beginning and the caddr is the end." (defun erc-spelling-flyspell-verify () "Flyspell only the input line, nothing else." + ;; FIXME: Don't use `flyspell-word'! (let ((word-data (and (boundp 'flyspell-word) flyspell-word))) (when word-data diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index 91a43f0..ffaf7e7 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -304,8 +304,8 @@ Returns t to continue checking, nil otherwise. Flyspell mode sets this variable to whatever is the `flyspell-mode-predicate' property of the major mode name.") (make-variable-buffer-local 'flyspell-generic-check-word-predicate) -(defvaralias 'flyspell-generic-check-word-p - 'flyspell-generic-check-word-predicate) +(define-obsolete-variable-alias 'flyspell-generic-check-word-p + 'flyspell-generic-check-word-predicate "25.1") ;;*--- mail mode -------------------------------------------------------*/ (put 'mail-mode 'flyspell-mode-predicate 'mail-mode-flyspell-verify) @@ -398,7 +398,7 @@ like \"Some." "Turn on `flyspell-mode' for comments and strings." (interactive) (setq flyspell-generic-check-word-predicate - 'flyspell-generic-progmode-verify) + #'flyspell-generic-progmode-verify) (flyspell-mode 1) (run-hooks 'flyspell-prog-mode-hook)) @@ -1040,6 +1040,8 @@ Mostly we check word delimiters." (goto-char (1+ p))))) r))) +(defvar flyspell-word) ;Backward compatibility; some predicates made use of it! + ;;*---------------------------------------------------------------------*/ ;;* flyspell-word ... */ ;;*---------------------------------------------------------------------*/ commit 03306795dd19a07ea3ed845b508b5ef0638048e0 Author: Glenn Morris Date: Fri Feb 13 18:45:40 2015 -0800 # Add 2015 to copyright years diff --git a/lisp/net/sasl-scram-rfc.el b/lisp/net/sasl-scram-rfc.el index 3d86da4..6c8c009 100644 --- a/lisp/net/sasl-scram-rfc.el +++ b/lisp/net/sasl-scram-rfc.el @@ -1,6 +1,6 @@ ;;; sasl-scram-rfc.el --- SCRAM-SHA-1 module for the SASL client framework -*- lexical-binding: t; -*- -;; Copyright (C) 2014 Free Software Foundation, Inc. +;; Copyright (C) 2014-2015 Free Software Foundation, Inc. ;; Author: Magnus Henoch diff --git a/test/automated/sasl-scram-rfc-tests.el b/test/automated/sasl-scram-rfc-tests.el index c747e5f..46b139b 100644 --- a/test/automated/sasl-scram-rfc-tests.el +++ b/test/automated/sasl-scram-rfc-tests.el @@ -1,6 +1,6 @@ ;;; sasl-scram-rfc-tests.el --- tests for SCRAM-SHA-1 -*- lexical-binding: t; -*- -;; Copyright (C) 2014 Free Software Foundation, Inc. +;; Copyright (C) 2014-2015 Free Software Foundation, Inc. ;; Author: Magnus Henoch commit b9d8edcf6dbe5651919bfb42687d16794f2d86f8 Author: Jan D Date: Fri Feb 13 17:44:26 2015 +0100 Fixes: debbugs:19850 * configure.ac: Set locallisppath to empty for NS self contained, unless --enable-loadllisppath was given. diff --git a/ChangeLog b/ChangeLog index a574ac8..4365668 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2015-02-13 Jan Djärv + + * configure.ac: Set locallisppath to empty for NS self contained, + unless --enable-loadllisppath was given (Bug#19850). + 2015-02-09 Paul Eggert * configure.ac (HAVE_LIBXML2): Add missing comma. diff --git a/configure.ac b/configure.ac index 68291b8..0bcc55c 100644 --- a/configure.ac +++ b/configure.ac @@ -423,6 +423,7 @@ AC_ARG_ENABLE(ns-self-contained, EN_NS_SELF_CONTAINED=$enableval, EN_NS_SELF_CONTAINED=yes) +locallisppathset=no AC_ARG_ENABLE(locallisppath, [AS_HELP_STRING([--enable-locallisppath=PATH], [directories Emacs should search for lisp files specific @@ -430,7 +431,7 @@ AC_ARG_ENABLE(locallisppath, if test "${enableval}" = "no"; then locallisppath= elif test "${enableval}" != "yes"; then - locallisppath=${enableval} + locallisppath=${enableval} locallisppathset=yes fi) AC_ARG_ENABLE(checking, @@ -1871,6 +1872,7 @@ if test "${HAVE_NS}" = yes; then infodir="\${ns_appresdir}/info" mandir="\${ns_appresdir}/man" lispdir="\${ns_appresdir}/lisp" + test "$locallisppathset" = no && locallisppath="" INSTALL_ARCH_INDEP_EXTRA= fi commit a03ab7eaf532075d2948ece70b8f3c97cd26b577 Author: Artur Malabarba Date: Fri Feb 13 13:08:38 2015 +0000 emacs-lisp/package.el (describe-package-1): Fix "incompat" handling. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 75adddb..030d572 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 d9340e1..d8b4595 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. commit 3b8b549ffff5b5e774266a9662f738a9335997f2 Author: Artur Malabarba Date: Fri Feb 13 12:10:42 2015 +0000 emacs-lisp/package.el (package--incompatible-p): Check dependencies. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d0038f4..75adddb 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 67e2f40..d9340e1 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))