Merge remote-tracking branch 'savannah/master' into feature/tree-sitter
This commit is contained in:
Yuan Fu
commit
aaeaa310f0
692 changed files with 36720 additions and 8897 deletions
|
|
@ -753,7 +753,7 @@ property for use by navigation."
|
|||
|
||||
(defun backtrace--line-length-or-nil ()
|
||||
"Return `backtrace-line-length' if valid, nil else."
|
||||
;; mirror the logic in `cl-print-to-string-with-limits'
|
||||
;; mirror the logic in `cl-print-to-string-with-limit'
|
||||
(and (natnump backtrace-line-length)
|
||||
(not (zerop backtrace-line-length))
|
||||
backtrace-line-length))
|
||||
|
|
|
|||
|
|
@ -31,6 +31,7 @@
|
|||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(eval-when-compile (require 'subr-x)) ;For `named-let'.
|
||||
|
||||
(defmacro benchmark-elapse (&rest forms)
|
||||
|
|
|
|||
|
|
@ -163,7 +163,9 @@
|
|||
(let ((s (substring bindat-raw bindat-idx (+ bindat-idx len))))
|
||||
(setq bindat-idx (+ bindat-idx len))
|
||||
(if (stringp s) s
|
||||
(apply #'unibyte-string s))))
|
||||
;; FIXME: There should be a more efficient way to do this.
|
||||
;; Should `apply' accept vectors in addition to lists?
|
||||
(apply #'unibyte-string (append s nil)))))
|
||||
|
||||
(defun bindat--unpack-strz (&optional len)
|
||||
(let ((i 0) s)
|
||||
|
|
@ -172,7 +174,7 @@
|
|||
(setq s (substring bindat-raw bindat-idx (+ bindat-idx i)))
|
||||
(setq bindat-idx (+ bindat-idx (or len (1+ i))))
|
||||
(if (stringp s) s
|
||||
(apply #'unibyte-string s))))
|
||||
(apply #'unibyte-string (append s nil)))))
|
||||
|
||||
(defun bindat--unpack-bits (len)
|
||||
(let ((bits nil) (bnum (1- (* 8 len))) j m)
|
||||
|
|
|
|||
|
|
@ -178,7 +178,7 @@ Earlier variables shadow later ones with the same name.")
|
|||
;; be displayed when the function's source file will be
|
||||
;; compiled anyway, but more importantly we would otherwise
|
||||
;; emit spurious warnings here because we don't have the full
|
||||
;; context, such as `declare-functions' placed earlier in the
|
||||
;; context, such as `declare-function's placed earlier in the
|
||||
;; source file's code or `with-suppressed-warnings' that
|
||||
;; surrounded the `defsubst'.
|
||||
(byte-compile-warnings nil))
|
||||
|
|
|
|||
|
|
@ -481,6 +481,11 @@ convention was modified."
|
|||
(puthash (indirect-function function) signature
|
||||
advertised-signature-table))
|
||||
|
||||
(defun get-advertised-calling-convention (function)
|
||||
"Get the advertised SIGNATURE of FUNCTION.
|
||||
Return t if there isn't any."
|
||||
(gethash function advertised-signature-table t))
|
||||
|
||||
(defun make-obsolete (obsolete-name current-name when)
|
||||
"Make the byte-compiler warn that function OBSOLETE-NAME is obsolete.
|
||||
OBSOLETE-NAME should be a function name or macro name (a symbol).
|
||||
|
|
|
|||
|
|
@ -129,6 +129,7 @@
|
|||
;; us from emitting warnings when compiling files which use cl-lib without
|
||||
;; requiring it! (bug#30635)
|
||||
(eval-when-compile (require 'cl-lib))
|
||||
(eval-when-compile (require 'subr-x))
|
||||
|
||||
;; The feature of compiling in a specific target Emacs version
|
||||
;; has been turned off because compile time options are a bad idea.
|
||||
|
|
@ -1185,27 +1186,22 @@ message buffer `default-directory'."
|
|||
(defun byte-compile--first-symbol-with-pos (form)
|
||||
"Return the first symbol with position in form, or nil if none.
|
||||
Order is by depth-first search."
|
||||
(cond
|
||||
((symbol-with-pos-p form) form)
|
||||
((consp form)
|
||||
(or (byte-compile--first-symbol-with-pos (car form))
|
||||
(let ((sym nil))
|
||||
(setq form (cdr form))
|
||||
(while (and (consp form)
|
||||
(not (setq sym (byte-compile--first-symbol-with-pos
|
||||
(car form)))))
|
||||
(setq form (cdr form)))
|
||||
(or sym
|
||||
(and form (byte-compile--first-symbol-with-pos form))))))
|
||||
((or (vectorp form) (recordp form))
|
||||
(let ((len (length form))
|
||||
(i 0)
|
||||
(sym nil))
|
||||
(while (and (< i len)
|
||||
(not (setq sym (byte-compile--first-symbol-with-pos
|
||||
(aref form i)))))
|
||||
(setq i (1+ i)))
|
||||
sym))))
|
||||
(named-let loop ((form form)
|
||||
(depth 10)) ;Arbitrary limit.
|
||||
(cond
|
||||
((<= depth 0) nil) ;Avoid cycles (bug#58601).
|
||||
((symbol-with-pos-p form) form)
|
||||
((consp form)
|
||||
(or (loop (car form) (1- depth))
|
||||
(loop (cdr form) (1- depth))))
|
||||
((or (vectorp form) (recordp form))
|
||||
(let ((len (length form))
|
||||
(i 0)
|
||||
(sym nil))
|
||||
(while (and (< i len)
|
||||
(not (setq sym (loop (aref form i) (1- depth)))))
|
||||
(setq i (1+ i)))
|
||||
sym)))))
|
||||
|
||||
(defun byte-compile--warning-source-offset ()
|
||||
"Return a source offset from `byte-compile-form-stack' or nil if none."
|
||||
|
|
@ -1405,11 +1401,11 @@ when printing the error message."
|
|||
(and (not macro-p)
|
||||
(compiled-function-p (symbol-function fn)))))
|
||||
(setq fn (symbol-function fn)))
|
||||
(let ((advertised (gethash (if (and (symbolp fn) (fboundp fn))
|
||||
;; Could be a subr.
|
||||
(symbol-function fn)
|
||||
fn)
|
||||
advertised-signature-table t)))
|
||||
(let ((advertised (get-advertised-calling-convention
|
||||
(if (and (symbolp fn) (fboundp fn))
|
||||
;; Could be a subr.
|
||||
(symbol-function fn)
|
||||
fn))))
|
||||
(cond
|
||||
((listp advertised)
|
||||
(if macro-p
|
||||
|
|
@ -1469,9 +1465,11 @@ when printing the error message."
|
|||
|
||||
(defun byte-compile-arglist-signature-string (signature)
|
||||
(cond ((null (cdr signature))
|
||||
(format "%d+" (car signature)))
|
||||
(format "%d or more" (car signature)))
|
||||
((= (car signature) (cdr signature))
|
||||
(format "%d" (car signature)))
|
||||
((= (1+ (car signature)) (cdr signature))
|
||||
(format "%d or %d" (car signature) (cdr signature)))
|
||||
(t (format "%d-%d" (car signature) (cdr signature)))))
|
||||
|
||||
(defun byte-compile-function-warn (f nargs def)
|
||||
|
|
@ -1884,6 +1882,9 @@ Files in subdirectories of DIRECTORY are processed also."
|
|||
(interactive "DByte force recompile (directory): ")
|
||||
(byte-recompile-directory directory nil t))
|
||||
|
||||
(defvar byte-compile-ignore-files nil
|
||||
"List of regexps for files to ignore during byte compilation.")
|
||||
|
||||
;;;###autoload
|
||||
(defun byte-recompile-directory (directory &optional arg force follow-symlinks)
|
||||
"Recompile every `.el' file in DIRECTORY that needs recompilation.
|
||||
|
|
@ -1940,14 +1941,22 @@ also be compiled."
|
|||
;; This file is a subdirectory. Handle them differently.
|
||||
(or (null arg) (eq 0 arg)
|
||||
(y-or-n-p (concat "Check " source "? ")))
|
||||
(setq directories (nconc directories (list source))))
|
||||
;; Directory is requested to be ignored
|
||||
(not (string-match-p
|
||||
(regexp-opt byte-compile-ignore-files)
|
||||
source))
|
||||
(setq directories (nconc directories (list source))))
|
||||
;; It is an ordinary file. Decide whether to compile it.
|
||||
(if (and (string-match emacs-lisp-file-regexp source)
|
||||
;; The next 2 tests avoid compiling lock files
|
||||
(file-readable-p source)
|
||||
(not (string-match "\\`\\.#" file))
|
||||
(not (auto-save-file-name-p source))
|
||||
(not (member source (dir-locals--all-files directory))))
|
||||
(not (member source (dir-locals--all-files directory)))
|
||||
;; File is requested to be ignored
|
||||
(not (string-match-p
|
||||
(regexp-opt byte-compile-ignore-files)
|
||||
source)))
|
||||
(progn (cl-incf
|
||||
(pcase (byte-recompile-file source force arg)
|
||||
('no-byte-compile skip-count)
|
||||
|
|
@ -2321,9 +2330,15 @@ With argument ARG, insert value in current buffer after the form."
|
|||
(setq case-fold-search nil))
|
||||
(displaying-byte-compile-warnings
|
||||
(with-current-buffer inbuffer
|
||||
(and byte-compile-current-file
|
||||
(byte-compile-insert-header byte-compile-current-file
|
||||
byte-compile--outbuffer))
|
||||
(when byte-compile-current-file
|
||||
(byte-compile-insert-header byte-compile-current-file
|
||||
byte-compile--outbuffer)
|
||||
;; Instruct native-comp to ignore this file.
|
||||
(when (bound-and-true-p no-native-compile)
|
||||
(with-current-buffer byte-compile--outbuffer
|
||||
(insert
|
||||
"(when (boundp 'comp--no-native-compile)
|
||||
(puthash load-file-name t comp--no-native-compile))\n\n"))))
|
||||
(goto-char (point-min))
|
||||
;; Should we always do this? When calling multiple files, it
|
||||
;; would be useful to delay this warning until all have been
|
||||
|
|
@ -2561,7 +2576,7 @@ list that represents a doc string reference.
|
|||
;; macroexpand-all.
|
||||
;; (if (memq byte-optimize '(t source))
|
||||
;; (setq form (byte-optimize-form form for-effect)))
|
||||
(cconv-closure-convert form))
|
||||
(cconv-closure-convert form byte-compile-bound-variables))
|
||||
|
||||
;; byte-hunk-handlers cannot call this!
|
||||
(defun byte-compile-toplevel-file-form (top-level-form)
|
||||
|
|
@ -3622,7 +3637,7 @@ lambda-expression."
|
|||
(byte-compile-out base-op tmp)))
|
||||
|
||||
(defun byte-compile-dynamic-variable-bind (var)
|
||||
"Generate code to bind the lexical variable VAR to the top-of-stack value."
|
||||
"Generate code to bind the dynamic variable VAR to the top-of-stack value."
|
||||
(byte-compile-check-variable var 'let-bind)
|
||||
(push var byte-compile-bound-variables)
|
||||
(byte-compile-dynamic-variable-op 'byte-varbind var))
|
||||
|
|
@ -4659,13 +4674,6 @@ Return the offset in the form (VAR . OFFSET)."
|
|||
(byte-compile-form (cadr clause))
|
||||
(byte-compile-push-constant nil)))))
|
||||
|
||||
(defun byte-compile-not-lexical-var-p (var)
|
||||
(or (not (symbolp var))
|
||||
(special-variable-p var)
|
||||
(memq var byte-compile-bound-variables)
|
||||
(memq var '(nil t))
|
||||
(keywordp var)))
|
||||
|
||||
(defun byte-compile-bind (var init-lexenv)
|
||||
"Emit byte-codes to bind VAR and update `byte-compile--lexical-environment'.
|
||||
INIT-LEXENV should be a lexical-environment alist describing the
|
||||
|
|
@ -4674,7 +4682,7 @@ Return non-nil if the TOS value was popped."
|
|||
;; The mix of lexical and dynamic bindings mean that we may have to
|
||||
;; juggle things on the stack, to move them to TOS for
|
||||
;; dynamic binding.
|
||||
(if (and lexical-binding (not (byte-compile-not-lexical-var-p var)))
|
||||
(if (not (cconv--not-lexical-var-p var byte-compile-bound-variables))
|
||||
;; VAR is a simple stack-allocated lexical variable.
|
||||
(progn (push (assq var init-lexenv)
|
||||
byte-compile--lexical-environment)
|
||||
|
|
|
|||
|
|
@ -64,20 +64,12 @@
|
|||
;;
|
||||
;;; Code:
|
||||
|
||||
;; PROBLEM cases found during conversion to lexical binding.
|
||||
;; We should try and detect and warn about those cases, even
|
||||
;; for lexical-binding==nil to help prepare the migration.
|
||||
;; - Uses of run-hooks, and friends.
|
||||
;; - Cases where we want to apply the same code to different vars depending on
|
||||
;; some test. These sometimes use a (let ((foo (if bar 'a 'b)))
|
||||
;; ... (symbol-value foo) ... (set foo ...)).
|
||||
|
||||
;; TODO: (not just for cconv but also for the lexbind changes in general)
|
||||
;; - let (e)debug find the value of lexical variables from the stack.
|
||||
;; - make eval-region do the eval-sexp-add-defvars dance.
|
||||
;; - byte-optimize-form should be applied before cconv.
|
||||
;; OTOH, the warnings emitted by cconv-analyze need to come before optimize
|
||||
;; since afterwards they can because obnoxious (warnings about an "unused
|
||||
;; since afterwards they can become obnoxious (warnings about an "unused
|
||||
;; variable" should not be emitted when the variable use has simply been
|
||||
;; optimized away).
|
||||
;; - let macros specify that some let-bindings come from the same source,
|
||||
|
|
@ -87,33 +79,9 @@
|
|||
;; - canonize code in macro-expand so we don't have to handle (let (var) body)
|
||||
;; and other oddities.
|
||||
;; - new byte codes for unwind-protect so that closures aren't needed at all.
|
||||
;; - a reference to a var that is known statically to always hold a constant
|
||||
;; should be turned into a byte-constant rather than a byte-stack-ref.
|
||||
;; Hmm... right, that's called constant propagation and could be done here,
|
||||
;; but when that constant is a function, we have to be careful to make sure
|
||||
;; the bytecomp only compiles it once.
|
||||
;; - Since we know here when a variable is not mutated, we could pass that
|
||||
;; info to the byte-compiler, e.g. by using a new `immutable-let'.
|
||||
;; - call known non-escaping functions with `goto' rather than `call'.
|
||||
;; - optimize mapc to a dolist loop.
|
||||
|
||||
;; (defmacro dlet (binders &rest body)
|
||||
;; ;; Works in both lexical and non-lexical mode.
|
||||
;; (declare (indent 1) (debug let))
|
||||
;; `(progn
|
||||
;; ,@(mapcar (lambda (binder)
|
||||
;; `(defvar ,(if (consp binder) (car binder) binder)))
|
||||
;; binders)
|
||||
;; (let ,binders ,@body)))
|
||||
|
||||
;; (defmacro llet (binders &rest body)
|
||||
;; ;; Only works in lexical-binding mode.
|
||||
;; `(funcall
|
||||
;; (lambda ,(mapcar (lambda (binder) (if (consp binder) (car binder) binder))
|
||||
;; binders)
|
||||
;; ,@body)
|
||||
;; ,@(mapcar (lambda (binder) (if (consp binder) (cadr binder)))
|
||||
;; binders)))
|
||||
|
||||
(eval-when-compile (require 'cl-lib))
|
||||
|
||||
|
|
@ -142,13 +110,19 @@ is less than this number.")
|
|||
;; interactive forms.
|
||||
(make-hash-table :test #'eq :weakness 'key))
|
||||
|
||||
(defvar cconv--dynbound-variables nil
|
||||
"List of variables known to be dynamically bound.")
|
||||
|
||||
;;;###autoload
|
||||
(defun cconv-closure-convert (form)
|
||||
(defun cconv-closure-convert (form &optional dynbound-vars)
|
||||
"Main entry point for closure conversion.
|
||||
FORM is a piece of Elisp code after macroexpansion.
|
||||
DYNBOUND-VARS is a list of symbols that should be considered as
|
||||
using dynamic scoping.
|
||||
|
||||
Returns a form where all lambdas don't have any free variables."
|
||||
(let ((cconv-freevars-alist '())
|
||||
(let ((cconv--dynbound-variables dynbound-vars)
|
||||
(cconv-freevars-alist '())
|
||||
(cconv-var-classification '()))
|
||||
;; Analyze form - fill these variables with new information.
|
||||
(cconv-analyze-form form '())
|
||||
|
|
@ -156,8 +130,6 @@ Returns a form where all lambdas don't have any free variables."
|
|||
(prog1 (cconv-convert form nil nil) ; Env initially empty.
|
||||
(cl-assert (null cconv-freevars-alist)))))
|
||||
|
||||
(defconst cconv--dummy-var (make-symbol "ignored"))
|
||||
|
||||
(defun cconv--set-diff (s1 s2)
|
||||
"Return elements of set S1 that are not in set S2."
|
||||
(let ((res '()))
|
||||
|
|
@ -262,9 +234,7 @@ Returns a form where all lambdas don't have any free variables."
|
|||
;; it is often non-trivial for the programmer to avoid such
|
||||
;; unused vars.
|
||||
(not (intern-soft var))
|
||||
(eq ?_ (aref (symbol-name var) 0))
|
||||
;; As a special exception, ignore "ignored".
|
||||
(eq var 'ignored))
|
||||
(eq ?_ (aref (symbol-name var) 0)))
|
||||
(let ((suggestions (help-uni-confusable-suggestions (symbol-name var))))
|
||||
(format "Unused lexical %s `%S'%s"
|
||||
varkind (bare-symbol var)
|
||||
|
|
@ -342,7 +312,7 @@ EXTEND is a list of variables which might need to be accessed even from places
|
|||
where they are shadowed, because some part of ENV causes them to be used at
|
||||
places where they originally did not directly appear."
|
||||
(cl-assert (not (delq nil (mapcar (lambda (mapping)
|
||||
(if (eq (cadr mapping) 'apply-partially)
|
||||
(if (eq (cadr mapping) #'apply-partially)
|
||||
(cconv--set-diff (cdr (cddr mapping))
|
||||
extend)))
|
||||
env))))
|
||||
|
|
@ -634,6 +604,12 @@ places where they originally did not directly appear."
|
|||
|
||||
(defvar byte-compile-lexical-variables)
|
||||
|
||||
(defun cconv--not-lexical-var-p (var dynbounds)
|
||||
(or (not lexical-binding)
|
||||
(not (symbolp var))
|
||||
(special-variable-p var)
|
||||
(memq var dynbounds)))
|
||||
|
||||
(defun cconv--analyze-use (vardata form varkind)
|
||||
"Analyze the use of a variable.
|
||||
VARDATA should be (BINDER READ MUTATED CAPTURED CALLED).
|
||||
|
|
@ -677,7 +653,7 @@ FORM is the parent form that binds this var."
|
|||
;; outside of it.
|
||||
(envcopy
|
||||
(mapcar (lambda (vdata) (list (car vdata) nil nil nil nil)) env))
|
||||
(byte-compile-bound-variables byte-compile-bound-variables)
|
||||
(cconv--dynbound-variables cconv--dynbound-variables)
|
||||
(newenv envcopy))
|
||||
;; Push it before recursing, so cconv-freevars-alist contains entries in
|
||||
;; the order they'll be used by closure-convert-rec.
|
||||
|
|
@ -685,7 +661,7 @@ FORM is the parent form that binds this var."
|
|||
(when lexical-binding
|
||||
(dolist (arg args)
|
||||
(cond
|
||||
((byte-compile-not-lexical-var-p arg)
|
||||
((cconv--not-lexical-var-p arg cconv--dynbound-variables)
|
||||
(byte-compile-warn-x
|
||||
arg
|
||||
"Lexical argument shadows the dynamic variable %S"
|
||||
|
|
@ -715,6 +691,8 @@ FORM is the parent form that binds this var."
|
|||
(setf (nth 3 (car env)) t))
|
||||
(setq env (cdr env) envcopy (cdr envcopy))))))
|
||||
|
||||
(defvar cconv--dynbindings)
|
||||
|
||||
(defun cconv-analyze-form (form env)
|
||||
"Find mutated variables and variables captured by closure.
|
||||
Analyze lambdas if they are suitable for lambda lifting.
|
||||
|
|
@ -730,7 +708,7 @@ This function does not return anything but instead fills the
|
|||
(let ((orig-env env)
|
||||
(newvars nil)
|
||||
(var nil)
|
||||
(byte-compile-bound-variables byte-compile-bound-variables)
|
||||
(cconv--dynbound-variables cconv--dynbound-variables)
|
||||
(value nil))
|
||||
(dolist (binder binders)
|
||||
(if (not (consp binder))
|
||||
|
|
@ -743,7 +721,9 @@ This function does not return anything but instead fills the
|
|||
|
||||
(cconv-analyze-form value (if (eq letsym 'let*) env orig-env)))
|
||||
|
||||
(unless (or (byte-compile-not-lexical-var-p var) (not lexical-binding))
|
||||
(if (cconv--not-lexical-var-p var cconv--dynbound-variables)
|
||||
(when (boundp 'cconv--dynbindings)
|
||||
(push var cconv--dynbindings))
|
||||
(cl-pushnew var byte-compile-lexical-variables)
|
||||
(let ((varstruct (list var nil nil nil nil)))
|
||||
(push (cons binder (cdr varstruct)) newvars)
|
||||
|
|
@ -797,7 +777,8 @@ This function does not return anything but instead fills the
|
|||
(cconv-analyze-form protected-form env)
|
||||
(unless lexical-binding
|
||||
(setq var nil))
|
||||
(when (and var (symbolp var) (byte-compile-not-lexical-var-p var))
|
||||
(when (and var (symbolp var)
|
||||
(cconv--not-lexical-var-p var cconv--dynbound-variables))
|
||||
(byte-compile-warn-x
|
||||
var "Lexical variable shadows the dynamic variable %S" var))
|
||||
(let* ((varstruct (list var nil nil nil nil)))
|
||||
|
|
@ -813,9 +794,9 @@ This function does not return anything but instead fills the
|
|||
(cconv-analyze-form form env)
|
||||
(cconv--analyze-function () body env form))
|
||||
|
||||
(`(defvar ,var) (push var byte-compile-bound-variables))
|
||||
(`(defvar ,var) (push var cconv--dynbound-variables))
|
||||
(`(,(or 'defconst 'defvar) ,var ,value . ,_)
|
||||
(push var byte-compile-bound-variables)
|
||||
(push var cconv--dynbound-variables)
|
||||
(cconv-analyze-form value env))
|
||||
|
||||
(`(,(or 'funcall 'apply) ,fun . ,args)
|
||||
|
|
@ -847,5 +828,78 @@ This function does not return anything but instead fills the
|
|||
(setf (nth 1 dv) t))))))
|
||||
(define-obsolete-function-alias 'cconv-analyse-form #'cconv-analyze-form "25.1")
|
||||
|
||||
(defun cconv-fv (form lexvars dynvars)
|
||||
"Return the list of free variables in FORM.
|
||||
LEXVARS is the list of statically scoped vars in the context
|
||||
and DYNVARS is the list of dynamically scoped vars in the context.
|
||||
Returns a pair (LEXV . DYNV) of those vars actually used by FORM."
|
||||
(let* ((fun
|
||||
;; Wrap FORM into a function because the analysis code we
|
||||
;; have only computes freevars for functions.
|
||||
;; In practice FORM is always already of the form
|
||||
;; #'(lambda ...), so optimize for this case.
|
||||
(if (and (eq 'function (car-safe form))
|
||||
(eq 'lambda (car-safe (cadr form)))
|
||||
;; To get correct results, FUN needs to be a "simple lambda"
|
||||
;; without nested forms that aren't part of the body. :-(
|
||||
(not (assq 'interactive (cadr form)))
|
||||
(not (assq ':documentation (cadr form))))
|
||||
form
|
||||
`#'(lambda () ,form)))
|
||||
(analysis-env (mapcar (lambda (v) (list v nil nil nil nil)) lexvars))
|
||||
(cconv--dynbound-variables dynvars)
|
||||
(byte-compile-lexical-variables nil)
|
||||
(cconv--dynbindings nil)
|
||||
(cconv-freevars-alist '())
|
||||
(cconv-var-classification '()))
|
||||
(let* ((body (cddr (cadr fun))))
|
||||
;; Analyze form - fill these variables with new information.
|
||||
(cconv-analyze-form fun analysis-env)
|
||||
(setq cconv-freevars-alist (nreverse cconv-freevars-alist))
|
||||
(unless (equal (if (eq :documentation (car-safe (car body)))
|
||||
(cdr body) body)
|
||||
(caar cconv-freevars-alist))
|
||||
(message "BOOH!\n%S\n%S"
|
||||
body (caar cconv-freevars-alist)))
|
||||
(cl-assert (equal (if (eq :documentation (car-safe (car body)))
|
||||
(cdr body) body)
|
||||
(caar cconv-freevars-alist)))
|
||||
(let ((fvs (nreverse (cdar cconv-freevars-alist)))
|
||||
(dyns (delq nil (mapcar (lambda (var) (car (memq var dynvars)))
|
||||
(delete-dups cconv--dynbindings)))))
|
||||
(cons fvs dyns)))))
|
||||
|
||||
(defun cconv-make-interpreted-closure (fun env)
|
||||
(cl-assert (eq (car-safe fun) 'lambda))
|
||||
(let ((lexvars (delq nil (mapcar #'car-safe env))))
|
||||
(if (null lexvars)
|
||||
;; The lexical environment is empty, so there's no need to
|
||||
;; look for free variables.
|
||||
`(closure ,env . ,(cdr fun))
|
||||
;; We could try and cache the result of the macroexpansion and
|
||||
;; `cconv-fv' analysis. Not sure it's worth the trouble.
|
||||
(let* ((form `#',fun)
|
||||
(expanded-form
|
||||
(let ((lexical-binding t) ;; Tell macros which dialect is in use.
|
||||
;; Make the macro aware of any defvar declarations in scope.
|
||||
(macroexp--dynvars
|
||||
(if macroexp--dynvars
|
||||
(append env macroexp--dynvars) env)))
|
||||
(macroexpand-all form macroexpand-all-environment)))
|
||||
;; Since we macroexpanded the body, we may as well use that.
|
||||
(expanded-fun-cdr
|
||||
(pcase expanded-form
|
||||
(`#'(lambda . ,cdr) cdr)
|
||||
(_ (cdr fun))))
|
||||
|
||||
(dynvars (delq nil (mapcar (lambda (b) (if (symbolp b) b)) env)))
|
||||
(fvs (cconv-fv expanded-form lexvars dynvars))
|
||||
(newenv (nconc (mapcar (lambda (fv) (assq fv env)) (car fvs))
|
||||
(cdr fvs))))
|
||||
;; Never return a nil env, since nil means to use the dynbind
|
||||
;; dialect of ELisp.
|
||||
`(closure ,(or newenv '(t)) . ,expanded-fun-cdr)))))
|
||||
|
||||
|
||||
(provide 'cconv)
|
||||
;;; cconv.el ends here
|
||||
|
|
|
|||
|
|
@ -2265,8 +2265,8 @@ buffer, otherwise stop after the first error."
|
|||
(unless (and sym (or (boundp sym) (fboundp sym)))
|
||||
;; Find out how we spell-check this word.
|
||||
(unless (or
|
||||
;; All caps w/ option th, or s tacked on the end
|
||||
;; for pluralization or number.
|
||||
;; All caps with option th, or s tacked on the
|
||||
;; end for pluralization or number.
|
||||
(string-match "^[A-Z][A-Z]+\\(s\\|th\\)?$" word)
|
||||
(looking-at "}") ; a keymap expression
|
||||
)
|
||||
|
|
|
|||
|
|
@ -615,12 +615,12 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
|
|||
,(funcall setter
|
||||
`(cl--set-getf ,getter ,k ,val))
|
||||
,val)))))))))
|
||||
(let ((val-tail (cdr-safe (plist-member plist tag))))
|
||||
(let ((val-tail (cdr (plist-member plist tag))))
|
||||
(if val-tail (car val-tail) def)))
|
||||
|
||||
;;;###autoload
|
||||
(defun cl--set-getf (plist tag val)
|
||||
(let ((val-tail (cdr-safe (plist-member plist tag))))
|
||||
(let ((val-tail (cdr (plist-member plist tag))))
|
||||
(if val-tail (progn (setcar val-tail val) plist)
|
||||
(cl-list* tag val plist))))
|
||||
|
||||
|
|
|
|||
|
|
@ -650,13 +650,17 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
|
|||
(cl--generic-name generic)
|
||||
qualifiers specializers))
|
||||
current-load-list :test #'equal)
|
||||
(let (;; Prevent `defalias' from recording this as the definition site of
|
||||
(let ((old-adv-cc (get-advertised-calling-convention
|
||||
(symbol-function sym)))
|
||||
;; Prevent `defalias' from recording this as the definition site of
|
||||
;; the generic function.
|
||||
current-load-list
|
||||
;; BEWARE! Don't purify this function definition, since that leads
|
||||
;; to memory corruption if the hash-tables it holds are modified
|
||||
;; (the GC doesn't trace those pointers).
|
||||
(purify-flag nil))
|
||||
(when (listp old-adv-cc)
|
||||
(set-advertised-calling-convention gfun old-adv-cc nil))
|
||||
;; But do use `defalias', so that it interacts properly with nadvice,
|
||||
;; e.g. for tracing/debug-on-entry.
|
||||
(defalias sym gfun)))))
|
||||
|
|
|
|||
|
|
@ -656,6 +656,8 @@ its argument list allows full Common Lisp conventions."
|
|||
(check `(while ,var
|
||||
(cond
|
||||
((memq (car ,var) ',(append keys allow))
|
||||
(unless (cdr ,var)
|
||||
(error "Missing argument for %s" (car ,var)))
|
||||
(setq ,var (cdr (cdr ,var))))
|
||||
((car (cdr (memq (quote ,@allow) ,restarg)))
|
||||
(setq ,var nil))
|
||||
|
|
|
|||
|
|
@ -96,7 +96,7 @@ Integer values are handled in the `range' slot.")
|
|||
`comp-common-supertype'.")
|
||||
(subtype-p-mem (make-hash-table :test #'equal) :type hash-table
|
||||
:documentation "Serve memoization for
|
||||
`comp-subtype-p-mem'.")
|
||||
`comp-cstr-ctxt-subtype-p-mem'.")
|
||||
(union-1-mem-no-range (make-hash-table :test #'equal) :type hash-table
|
||||
:documentation "Serve memoization for
|
||||
`comp-cstr-union-1'.")
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@
|
|||
:safe #'integerp
|
||||
:version "28.1")
|
||||
|
||||
(defcustom native-comp-debug (if (eq 'windows-nt system-type) 1 0)
|
||||
(defcustom native-comp-debug 0
|
||||
"Debug level for native compilation, a number between 0 and 3.
|
||||
This is intended for debugging the compiler itself.
|
||||
0 no debug output.
|
||||
|
|
@ -67,7 +67,7 @@ This is intended for debugging the compiler itself.
|
|||
passes and libgccjit log file."
|
||||
:type 'natnum
|
||||
:safe #'natnump
|
||||
:version "28.1")
|
||||
:version "29.1")
|
||||
|
||||
(defcustom native-comp-verbose 0
|
||||
"Compiler verbosity for native compilation, a number between 0 and 3.
|
||||
|
|
@ -687,6 +687,9 @@ Useful to hook into pass checkers.")
|
|||
'native-compiler-error)
|
||||
|
||||
|
||||
(defvar comp-no-spawn nil
|
||||
"Non-nil don't spawn native compilation processes.")
|
||||
|
||||
;; Moved early to avoid circularity when comp.el is loaded and
|
||||
;; `macroexpand' needs to be advised (bug#47049).
|
||||
;;;###autoload
|
||||
|
|
@ -696,12 +699,9 @@ Useful to hook into pass checkers.")
|
|||
(memq subr-name native-comp-never-optimize-functions)
|
||||
(gethash subr-name comp-installed-trampolines-h))
|
||||
(cl-assert (subr-primitive-p (symbol-function subr-name)))
|
||||
(comp--install-trampoline
|
||||
subr-name
|
||||
(or (comp-trampoline-search subr-name)
|
||||
(comp-trampoline-compile subr-name)
|
||||
;; Should never happen.
|
||||
(cl-assert nil)))))
|
||||
(when-let ((trampoline (or (comp-trampoline-search subr-name)
|
||||
(comp-trampoline-compile subr-name))))
|
||||
(comp--install-trampoline subr-name trampoline))))
|
||||
|
||||
|
||||
(cl-defstruct (comp-vec (:copier nil))
|
||||
|
|
@ -2057,9 +2057,10 @@ and the annotation emission."
|
|||
"Lexically-scoped FUNCTION."
|
||||
(let ((args (comp-func-l-args function)))
|
||||
(cons (make-comp-mvar :constant (comp-args-base-min args))
|
||||
(make-comp-mvar :constant (if (comp-args-p args)
|
||||
(comp-args-max args)
|
||||
'many)))))
|
||||
(make-comp-mvar :constant (cond
|
||||
((comp-args-p args) (comp-args-max args))
|
||||
((comp-nargs-rest args) 'many)
|
||||
(t (comp-nargs-nonrest args)))))))
|
||||
|
||||
(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-d))
|
||||
"Dynamically scoped FUNCTION."
|
||||
|
|
@ -2822,7 +2823,7 @@ blocks."
|
|||
(first-processed (l)
|
||||
(if-let ((p (cl-find-if (lambda (p) (comp-block-idom p)) l)))
|
||||
p
|
||||
(signal 'native-ice "cant't find first preprocessed"))))
|
||||
(signal 'native-ice "can't find first preprocessed"))))
|
||||
|
||||
(when-let ((blocks (comp-func-blocks comp-func))
|
||||
(entry (gethash 'entry blocks))
|
||||
|
|
@ -3715,7 +3716,8 @@ Prepare every function for final compilation and drive the C back-end."
|
|||
(if (zerop
|
||||
(call-process (expand-file-name invocation-name
|
||||
invocation-directory)
|
||||
nil t t "--batch" "-l" temp-file))
|
||||
nil t t "-no-comp-spawn" "--batch" "-l"
|
||||
temp-file))
|
||||
(progn
|
||||
(delete-file temp-file)
|
||||
output)
|
||||
|
|
@ -3927,6 +3929,7 @@ processes from `comp-async-compilations'"
|
|||
"Start compiling files from `comp-files-queue' asynchronously.
|
||||
When compilation is finished, run `native-comp-async-all-done-hook' and
|
||||
display a message."
|
||||
(cl-assert (null comp-no-spawn))
|
||||
(if (or comp-files-queue
|
||||
(> (comp-async-runnings) 0))
|
||||
(unless (>= (comp-async-runnings) (comp-effective-async-max-jobs))
|
||||
|
|
@ -3945,8 +3948,8 @@ display a message."
|
|||
(file-newer-than-file-p
|
||||
source-file (comp-el-to-eln-filename source-file))))
|
||||
do (let* ((expr `((require 'comp)
|
||||
(setq comp-async-compilation t)
|
||||
(setq warning-fill-column most-positive-fixnum)
|
||||
(setq comp-async-compilation t
|
||||
warning-fill-column most-positive-fixnum)
|
||||
,(let ((set (list 'setq)))
|
||||
(dolist (var '(comp-file-preloaded-p
|
||||
native-compile-target-directory
|
||||
|
|
@ -4002,7 +4005,8 @@ display a message."
|
|||
:command (list
|
||||
(expand-file-name invocation-name
|
||||
invocation-directory)
|
||||
"--batch" "-l" temp-file)
|
||||
"-no-comp-spawn" "--batch" "-l"
|
||||
temp-file)
|
||||
:sentinel
|
||||
(lambda (process _event)
|
||||
(run-hook-with-args
|
||||
|
|
@ -4046,72 +4050,73 @@ the deferred compilation mechanism."
|
|||
(stringp function-or-file))
|
||||
(signal 'native-compiler-error
|
||||
(list "Not a function symbol or file" function-or-file)))
|
||||
(catch 'no-native-compile
|
||||
(let* ((print-symbols-bare t)
|
||||
(data function-or-file)
|
||||
(comp-native-compiling t)
|
||||
(byte-native-qualities nil)
|
||||
(symbols-with-pos-enabled t)
|
||||
;; Have byte compiler signal an error when compilation fails.
|
||||
(byte-compile-debug t)
|
||||
(comp-ctxt (make-comp-ctxt :output output
|
||||
:with-late-load with-late-load)))
|
||||
(comp-log "\n \n" 1)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(condition-case err
|
||||
(cl-loop
|
||||
with report = nil
|
||||
for t0 = (current-time)
|
||||
for pass in comp-passes
|
||||
unless (memq pass comp-disabled-passes)
|
||||
do
|
||||
(comp-log (format "(%s) Running pass %s:\n"
|
||||
function-or-file pass)
|
||||
2)
|
||||
(setf data (funcall pass data))
|
||||
(push (cons pass (float-time (time-since t0))) report)
|
||||
(cl-loop for f in (alist-get pass comp-post-pass-hooks)
|
||||
do (funcall f data))
|
||||
finally
|
||||
(when comp-log-time-report
|
||||
(comp-log (format "Done compiling %s" data) 0)
|
||||
(cl-loop for (pass . time) in (reverse report)
|
||||
do (comp-log (format "Pass %s took: %fs."
|
||||
pass time) 0))))
|
||||
(native-compiler-skip)
|
||||
(t
|
||||
(let ((err-val (cdr err)))
|
||||
;; If we are doing an async native compilation print the
|
||||
;; error in the correct format so is parsable and abort.
|
||||
(if (and comp-async-compilation
|
||||
(not (eq (car err) 'native-compiler-error)))
|
||||
(progn
|
||||
(message (if err-val
|
||||
"%s: Error: %s %s"
|
||||
"%s: Error %s")
|
||||
function-or-file
|
||||
(get (car err) 'error-message)
|
||||
(car-safe err-val))
|
||||
(kill-emacs -1))
|
||||
;; Otherwise re-signal it adding the compilation input.
|
||||
(signal (car err) (if (consp err-val)
|
||||
(cons function-or-file err-val)
|
||||
(list function-or-file err-val)))))))
|
||||
(if (stringp function-or-file)
|
||||
data
|
||||
;; So we return the compiled function.
|
||||
(native-elisp-load data)))
|
||||
;; We may have created a temporary file when we're being
|
||||
;; called with something other than a file as the argument.
|
||||
;; Delete it.
|
||||
(when (and (not (stringp function-or-file))
|
||||
(not output)
|
||||
comp-ctxt
|
||||
(comp-ctxt-output comp-ctxt)
|
||||
(file-exists-p (comp-ctxt-output comp-ctxt)))
|
||||
(message "Deleting %s" (comp-ctxt-output comp-ctxt))
|
||||
(delete-file (comp-ctxt-output comp-ctxt)))))))
|
||||
(when (or (null comp-no-spawn) comp-async-compilation)
|
||||
(catch 'no-native-compile
|
||||
(let* ((print-symbols-bare t)
|
||||
(data function-or-file)
|
||||
(comp-native-compiling t)
|
||||
(byte-native-qualities nil)
|
||||
(symbols-with-pos-enabled t)
|
||||
;; Have byte compiler signal an error when compilation fails.
|
||||
(byte-compile-debug t)
|
||||
(comp-ctxt (make-comp-ctxt :output output
|
||||
:with-late-load with-late-load)))
|
||||
(comp-log "\n \n" 1)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(condition-case err
|
||||
(cl-loop
|
||||
with report = nil
|
||||
for t0 = (current-time)
|
||||
for pass in comp-passes
|
||||
unless (memq pass comp-disabled-passes)
|
||||
do
|
||||
(comp-log (format "(%s) Running pass %s:\n"
|
||||
function-or-file pass)
|
||||
2)
|
||||
(setf data (funcall pass data))
|
||||
(push (cons pass (float-time (time-since t0))) report)
|
||||
(cl-loop for f in (alist-get pass comp-post-pass-hooks)
|
||||
do (funcall f data))
|
||||
finally
|
||||
(when comp-log-time-report
|
||||
(comp-log (format "Done compiling %s" data) 0)
|
||||
(cl-loop for (pass . time) in (reverse report)
|
||||
do (comp-log (format "Pass %s took: %fs."
|
||||
pass time) 0))))
|
||||
(native-compiler-skip)
|
||||
(t
|
||||
(let ((err-val (cdr err)))
|
||||
;; If we are doing an async native compilation print the
|
||||
;; error in the correct format so is parsable and abort.
|
||||
(if (and comp-async-compilation
|
||||
(not (eq (car err) 'native-compiler-error)))
|
||||
(progn
|
||||
(message (if err-val
|
||||
"%s: Error: %s %s"
|
||||
"%s: Error %s")
|
||||
function-or-file
|
||||
(get (car err) 'error-message)
|
||||
(car-safe err-val))
|
||||
(kill-emacs -1))
|
||||
;; Otherwise re-signal it adding the compilation input.
|
||||
(signal (car err) (if (consp err-val)
|
||||
(cons function-or-file err-val)
|
||||
(list function-or-file err-val)))))))
|
||||
(if (stringp function-or-file)
|
||||
data
|
||||
;; So we return the compiled function.
|
||||
(native-elisp-load data)))
|
||||
;; We may have created a temporary file when we're being
|
||||
;; called with something other than a file as the argument.
|
||||
;; Delete it.
|
||||
(when (and (not (stringp function-or-file))
|
||||
(not output)
|
||||
comp-ctxt
|
||||
(comp-ctxt-output comp-ctxt)
|
||||
(file-exists-p (comp-ctxt-output comp-ctxt)))
|
||||
(message "Deleting %s" (comp-ctxt-output comp-ctxt))
|
||||
(delete-file (comp-ctxt-output comp-ctxt))))))))
|
||||
|
||||
(defun native-compile-async-skip-p (file load selector)
|
||||
"Return non-nil if FILE's compilation should be skipped.
|
||||
|
|
@ -4119,6 +4124,7 @@ the deferred compilation mechanism."
|
|||
LOAD and SELECTOR work as described in `native--compile-async'."
|
||||
;; Make sure we are not already compiling `file' (bug#40838).
|
||||
(or (gethash file comp-async-compilations)
|
||||
(gethash (file-name-with-extension file "elc") comp--no-native-compile)
|
||||
(cond
|
||||
((null selector) nil)
|
||||
((functionp selector) (not (funcall selector file)))
|
||||
|
|
@ -4166,7 +4172,8 @@ bytecode definition was not changed in the meantime)."
|
|||
(error "LOAD must be nil, t or 'late"))
|
||||
(unless (listp files)
|
||||
(setf files (list files)))
|
||||
(let (file-list)
|
||||
(let ((added-something nil)
|
||||
file-list)
|
||||
(dolist (file-or-dir files)
|
||||
(cond ((file-directory-p file-or-dir)
|
||||
(dolist (file (if recursively
|
||||
|
|
@ -4194,16 +4201,31 @@ bytecode definition was not changed in the meantime)."
|
|||
(make-directory out-dir t))
|
||||
(if (file-writable-p out-filename)
|
||||
(setf comp-files-queue
|
||||
(append comp-files-queue `((,file . ,load))))
|
||||
(append comp-files-queue `((,file . ,load)))
|
||||
added-something t)
|
||||
(display-warning 'comp
|
||||
(format "No write access for %s skipping."
|
||||
out-filename)))))))
|
||||
(when (zerop (comp-async-runnings))
|
||||
;; Perhaps nothing passed `native-compile-async-skip-p'?
|
||||
(when (and added-something
|
||||
;; Don't start if there's one already running.
|
||||
(zerop (comp-async-runnings)))
|
||||
(comp-run-async-workers))))
|
||||
|
||||
|
||||
;;; Compiler entry points.
|
||||
|
||||
(defun comp-compile-all-trampolines ()
|
||||
"Pre-compile AOT all trampolines."
|
||||
(let ((comp-running-batch-compilation t)
|
||||
;; We want to target only the 'native-lisp' directory.
|
||||
(native-compile-target-directory
|
||||
(car (last native-comp-eln-load-path))))
|
||||
(mapatoms (lambda (f)
|
||||
(when (subr-primitive-p (symbol-function f))
|
||||
(message "Compiling trampoline for: %s" f)
|
||||
(comp-trampoline-compile f))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun comp-lookup-eln (filename)
|
||||
"Given a Lisp source FILENAME return the corresponding .eln file if found.
|
||||
|
|
@ -4223,14 +4245,13 @@ Search happens in `native-comp-eln-load-path'."
|
|||
(defun native-compile (function-or-file &optional output)
|
||||
"Compile FUNCTION-OR-FILE into native code.
|
||||
This is the synchronous entry-point for the Emacs Lisp native
|
||||
compiler.
|
||||
FUNCTION-OR-FILE is a function symbol, a form, or the filename of
|
||||
an Emacs Lisp source file.
|
||||
If OUTPUT is non-nil, use it as the filename for the compiled
|
||||
object.
|
||||
If FUNCTION-OR-FILE is a filename, return the filename of the
|
||||
compiled object. If FUNCTION-OR-FILE is a function symbol or a
|
||||
form, return the compiled function."
|
||||
compiler. FUNCTION-OR-FILE is a function symbol, a form, or the
|
||||
filename of an Emacs Lisp source file. If OUTPUT is non-nil, use
|
||||
it as the filename for the compiled object. If FUNCTION-OR-FILE
|
||||
is a filename, if the compilation was successful return the
|
||||
filename of the compiled object. If FUNCTION-OR-FILE is a
|
||||
function symbol or a form, if the compilation was successful
|
||||
return the compiled function."
|
||||
(comp--native-compile function-or-file nil output))
|
||||
|
||||
;;;###autoload
|
||||
|
|
@ -4317,13 +4338,15 @@ of (commands) to run simultaneously."
|
|||
;; `invocation-directory'.
|
||||
(setq dir (expand-file-name dir invocation-directory))
|
||||
(when (file-exists-p dir)
|
||||
(dolist (subdir (directory-files dir t))
|
||||
(dolist (subdir (seq-filter
|
||||
(lambda (f) (not (string-match (rx "/." (? ".") eos) f)))
|
||||
(directory-files dir t)))
|
||||
(when (and (file-directory-p subdir)
|
||||
(file-writable-p subdir)
|
||||
(not (equal (file-name-nondirectory
|
||||
(directory-file-name subdir))
|
||||
comp-native-version-dir)))
|
||||
(message "Deleting %s..." subdir)
|
||||
(message "Deleting `%s'..." subdir)
|
||||
;; We're being overly cautious here -- there shouldn't be
|
||||
;; anything but .eln files in these directories.
|
||||
(dolist (eln (directory-files subdir t "\\.eln\\(\\.tmp\\)?\\'"))
|
||||
|
|
@ -4335,6 +4358,6 @@ of (commands) to run simultaneously."
|
|||
|
||||
(provide 'comp)
|
||||
|
||||
;; LocalWords: limplified limplified limplification limplify Limple LIMPLE libgccjit elc eln
|
||||
;; LocalWords: limplified limplification limplify Limple LIMPLE libgccjit elc eln
|
||||
|
||||
;;; comp.el ends here
|
||||
|
|
|
|||
|
|
@ -201,7 +201,7 @@ This function is modeled after `minibuffer-complete-and-exit'."
|
|||
(if doexit (exit-minibuffer))))
|
||||
|
||||
(defun crm--choose-completion-string (choice buffer base-position
|
||||
&rest ignored)
|
||||
&rest _ignored)
|
||||
"Completion string chooser for `completing-read-multiple'.
|
||||
This is called from `choose-completion-string-functions'.
|
||||
It replaces the string that is currently being completed, without
|
||||
|
|
|
|||
|
|
@ -55,21 +55,24 @@
|
|||
:group 'extensions)
|
||||
|
||||
(defcustom eldoc-idle-delay 0.50
|
||||
"Number of seconds of idle time to wait before printing.
|
||||
"Number of seconds of idle time to wait before displaying documentation.
|
||||
If user input arrives before this interval of time has elapsed after the
|
||||
last input, no documentation will be printed.
|
||||
last input event, no documentation will be displayed.
|
||||
|
||||
If this variable is set to 0, no idle time is required."
|
||||
If this variable is set to 0, display the documentation without any delay."
|
||||
:type 'number)
|
||||
|
||||
(defcustom eldoc-print-after-edit nil
|
||||
"If non-nil, eldoc info is only shown when editing.
|
||||
"If non-nil, eldoc info is only shown after editing commands.
|
||||
Changing the value requires toggling `eldoc-mode'."
|
||||
:type 'boolean)
|
||||
|
||||
(defcustom eldoc-echo-area-display-truncation-message t
|
||||
"If non-nil, provide verbose help when a message has been truncated.
|
||||
If nil, truncated messages will just have \"...\" appended."
|
||||
When this is non-nil, and the documentation string was truncated to
|
||||
fit in the echo-area, the documentation will be followed by an
|
||||
explanation of how to display the full documentation text.
|
||||
If nil, truncated messages will just have \"...\" to indicate truncation."
|
||||
:type 'boolean
|
||||
:version "28.1")
|
||||
|
||||
|
|
@ -93,22 +96,24 @@ Note that this variable has no effect, unless
|
|||
|
||||
(defcustom eldoc-echo-area-use-multiline-p 'truncate-sym-name-if-fit
|
||||
"Allow long ElDoc doc strings to resize echo area display.
|
||||
If value is t, never attempt to truncate messages, even if the
|
||||
echo area must be resized to fit.
|
||||
If the value is t, never attempt to truncate messages, even if the
|
||||
echo area must be resized to fit. In that case, Emacs will resize
|
||||
the mini-window up to the limit set by `max-mini-window-height'.
|
||||
|
||||
If the value is a positive number, it is used to calculate a
|
||||
number of logical lines of documentation that ElDoc is allowed to
|
||||
put in the echo area. If a positive integer, the number is used
|
||||
directly, while a float specifies the number of lines as a
|
||||
proportion of the echo area frame's height.
|
||||
number of screen lines of documentation that ElDoc is allowed to
|
||||
put in the echo area. A positive integer specifies the maximum
|
||||
number of lines directly, while a floating-point number specifies
|
||||
the number of screen lines as a fraction of the echo area frame's
|
||||
height.
|
||||
|
||||
If value is the symbol `truncate-sym-name-if-fit', the part of
|
||||
If the value is the symbol `truncate-sym-name-if-fit', the part of
|
||||
the doc string that represents a symbol's name may be truncated
|
||||
if it will enable the rest of the doc string to fit on a single
|
||||
line, without resizing the echo area.
|
||||
|
||||
If value is nil, a doc string is always truncated to fit in a
|
||||
single line of display in the echo area.
|
||||
If the value is nil, a doc string is always truncated to fit in a
|
||||
single screen line of echo-area display.
|
||||
|
||||
Any resizing of the echo area additionally respects
|
||||
`max-mini-window-height'."
|
||||
|
|
@ -121,12 +126,12 @@ Any resizing of the echo area additionally respects
|
|||
line" truncate-sym-name-if-fit)))
|
||||
|
||||
(defcustom eldoc-echo-area-prefer-doc-buffer nil
|
||||
"Prefer ElDoc's documentation buffer if it is showing in some frame.
|
||||
"Prefer ElDoc's documentation buffer if it is displayed in some window.
|
||||
If this variable's value is t, ElDoc will skip showing
|
||||
documentation in the echo area if the dedicated documentation
|
||||
buffer (given by `eldoc-doc-buffer') is being displayed in some
|
||||
window. If the value is the symbol `maybe', then the echo area
|
||||
is only skipped if the documentation doesn't fit there."
|
||||
buffer (displayed by `eldoc-doc-buffer') is already displayed in
|
||||
some window. If the value is the symbol `maybe', then the echo area
|
||||
is only skipped if the documentation needs to be truncated there."
|
||||
:type 'boolean)
|
||||
|
||||
(defface eldoc-highlight-function-argument
|
||||
|
|
@ -287,8 +292,10 @@ reflect the change."
|
|||
(put 'eldoc-mode-line-string 'risky-local-variable t)
|
||||
|
||||
(defun eldoc-minibuffer-message (format-string &rest args)
|
||||
"Display messages in the mode-line when in the minibuffer.
|
||||
Otherwise work like `message'."
|
||||
"Display message specified by FORMAT-STRING and ARGS on the mode-line as needed.
|
||||
This function displays the message produced by formatting ARGS
|
||||
with FORMAT-STRING on the mode line when the current buffer is a minibuffer.
|
||||
Otherwise, it displays the message like `message' would."
|
||||
(if (minibufferp)
|
||||
(progn
|
||||
(add-hook 'minibuffer-exit-hook
|
||||
|
|
@ -632,8 +639,8 @@ If INTERACTIVE is t, also display the buffer."
|
|||
(when interactive (eldoc-doc-buffer t)))
|
||||
|
||||
(defun eldoc-documentation-default ()
|
||||
"Show first doc string for item at point.
|
||||
Default value for `eldoc-documentation-strategy'."
|
||||
"Show the first non-nil documentation string for item at point.
|
||||
This is the default value for `eldoc-documentation-strategy'."
|
||||
(run-hook-with-args-until-success 'eldoc-documentation-functions
|
||||
(eldoc--make-callback :patient)))
|
||||
|
||||
|
|
@ -651,18 +658,18 @@ else wait for all doc strings."
|
|||
t)
|
||||
|
||||
(defun eldoc-documentation-compose ()
|
||||
"Show multiple doc strings at once after waiting for all.
|
||||
Meant as a value for `eldoc-documentation-strategy'."
|
||||
"Show multiple documentation strings together after waiting for all of them.
|
||||
This is meant to be used as a value for `eldoc-documentation-strategy'."
|
||||
(eldoc--documentation-compose-1 nil))
|
||||
|
||||
(defun eldoc-documentation-compose-eagerly ()
|
||||
"Show multiple doc strings at once as soon as possible.
|
||||
Meant as a value for `eldoc-documentation-strategy'."
|
||||
"Show multiple documentation strings one by one as soon as possible.
|
||||
This is meant to be used as a value for `eldoc-documentation-strategy'."
|
||||
(eldoc--documentation-compose-1 t))
|
||||
|
||||
(defun eldoc-documentation-enthusiast ()
|
||||
"Show most important doc string produced so far.
|
||||
Meant as a value for `eldoc-documentation-strategy'."
|
||||
"Show most important documentation string produced so far.
|
||||
This is meant to be used as a value for `eldoc-documentation-strategy'."
|
||||
(run-hook-wrapped 'eldoc-documentation-functions
|
||||
(lambda (f)
|
||||
(let* ((callback (eldoc--make-callback :enthusiast))
|
||||
|
|
@ -692,40 +699,42 @@ Meant as a value for `eldoc-documentation-strategy'."
|
|||
(eldoc--documentation-strategy-defcustom eldoc-documentation-strategy
|
||||
eldoc-documentation-function
|
||||
#'eldoc-documentation-default
|
||||
"How to collect and organize results of `eldoc-documentation-functions'.
|
||||
"How to collect and display results of `eldoc-documentation-functions'.
|
||||
|
||||
This variable controls how `eldoc-documentation-functions', which
|
||||
specifies the sources of documentation, is queried and how its
|
||||
results are organized before being displayed to the user. The
|
||||
following values are allowed:
|
||||
This variable controls how to call the functions in the special hook
|
||||
`eldoc-documentation-functions', and how to organize their results
|
||||
for display to the user. The functions in `eldoc-documentation-functions'
|
||||
are the source of documentation, and act as back-end for ElDoc.
|
||||
|
||||
- `eldoc-documentation-default': calls functions in the special
|
||||
hook in order until one is found that produces a doc string
|
||||
value. Display only that value;
|
||||
The following values are supported:
|
||||
|
||||
- `eldoc-documentation-compose': calls all functions in the
|
||||
special hook and displays all of the resulting doc strings
|
||||
together. Wait for all strings to be ready, and preserve their
|
||||
relative order as specified by the order of functions in the hook;
|
||||
- `eldoc-documentation-default': Call functions in the special
|
||||
hook in order, until one of them returns a non-nil string
|
||||
value. Display only that string.
|
||||
|
||||
- `eldoc-documentation-compose-eagerly': calls all functions in
|
||||
the special hook and displays as many of the resulting doc
|
||||
strings as possible, as soon as possible. Preserves the
|
||||
relative order of doc strings;
|
||||
- `eldoc-documentation-compose': Call all the functions in the
|
||||
special hook and display all of the resulting strings together,
|
||||
after all of the functions were called, and in the order of the
|
||||
functions in the hook.
|
||||
|
||||
- `eldoc-documentation-enthusiast': calls all functions in the
|
||||
special hook and displays only the most important resulting
|
||||
docstring one at any given time. A function appearing first in
|
||||
the special hook is considered more important.
|
||||
- `eldoc-documentation-compose-eagerly': Call all the functions in
|
||||
the special hook, and display each non-nil string as soon as it
|
||||
is returned by a function, before calling the next function.
|
||||
|
||||
This variable can also be set to a function of no args that
|
||||
returns something other than a string or nil and allows for some
|
||||
- `eldoc-documentation-enthusiast': Call all the functions in the
|
||||
special hook, and display only the most important resulting
|
||||
string at any given time. A function appearing first in
|
||||
the special hook is considered more important than those which
|
||||
appear after it.
|
||||
|
||||
This variable can also be set to a function of no arguments that
|
||||
returns something other than a string or nil, and allows for some
|
||||
or all of the special hook `eldoc-documentation-functions' to be
|
||||
run. In that case, the strategy function should follow that
|
||||
other variable's protocol closely and endeavor to display the
|
||||
resulting doc strings itself.
|
||||
other variable's protocol closely and display the resulting doc
|
||||
strings itself.
|
||||
|
||||
For backward compatibility to the \"old\" protocol, this variable
|
||||
For backward compatibility with the \"old\" protocol, this variable
|
||||
can also be set to a function that returns nil or a doc string,
|
||||
depending whether or not there is documentation to display at
|
||||
all."
|
||||
|
|
|
|||
|
|
@ -560,6 +560,7 @@ The same keyword arguments are supported as in
|
|||
'("mock"
|
||||
(tramp-login-program "sh")
|
||||
(tramp-login-args (("-i")))
|
||||
(tramp-direct-async ("-c"))
|
||||
(tramp-remote-shell "/bin/sh")
|
||||
(tramp-remote-shell-args ("-c"))
|
||||
(tramp-connection-timeout 10)))
|
||||
|
|
|
|||
|
|
@ -208,7 +208,7 @@ is run. If a macro (possibly with side effects) is to be tested,
|
|||
it has to be wrapped in `(eval (quote ...))'.
|
||||
|
||||
If NAME is already defined as a test and Emacs is running
|
||||
in batch mode, an error is signalled.
|
||||
in batch mode, an error is signaled.
|
||||
|
||||
\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \
|
||||
[:tags \\='(TAG...)] BODY...)"
|
||||
|
|
|
|||
|
|
@ -445,16 +445,17 @@ The return value is the last VAL in the list.
|
|||
,v))))))))))
|
||||
|
||||
(gv-define-expander plist-get
|
||||
(lambda (do plist prop)
|
||||
(lambda (do plist prop &optional predicate)
|
||||
(macroexp-let2 macroexp-copyable-p key prop
|
||||
(gv-letplace (getter setter) plist
|
||||
(macroexp-let2 nil p `(cdr (plist-member ,getter ,key))
|
||||
(macroexp-let2 nil p `(cdr (plist-member ,getter ,key ,predicate))
|
||||
(funcall do
|
||||
`(car ,p)
|
||||
(lambda (val)
|
||||
`(if ,p
|
||||
(setcar ,p ,val)
|
||||
,(funcall setter `(cons ,key (cons ,val ,getter)))))))))))
|
||||
,(funcall setter
|
||||
`(cons ,key (cons ,val ,getter)))))))))))
|
||||
|
||||
;;; Some occasionally handy extensions.
|
||||
|
||||
|
|
|
|||
|
|
@ -71,7 +71,8 @@
|
|||
(:conc-name hierarchy--))
|
||||
(roots (list)) ; list of the hierarchy roots (no parent)
|
||||
(parents (make-hash-table :test 'equal)) ; map an item to its parent
|
||||
(children (make-hash-table :test 'equal)) ; map an item to its childre
|
||||
(children (make-hash-table :test 'equal)) ; map an item to its children
|
||||
(delaying-parents (make-hash-table :test 'equal)) ; map an item to its childrenfn
|
||||
;; cache containing the set of all items in the hierarchy
|
||||
(seen-items (make-hash-table :test 'equal))) ; map an item to t
|
||||
|
||||
|
|
@ -133,7 +134,8 @@ keys are :key and :test."
|
|||
"Create a hierarchy and return it."
|
||||
(hierarchy--make))
|
||||
|
||||
(defun hierarchy-add-tree (hierarchy item parentfn &optional childrenfn acceptfn)
|
||||
(defun hierarchy-add-tree (hierarchy item parentfn
|
||||
&optional childrenfn acceptfn delay-children-p)
|
||||
"In HIERARCHY, add ITEM.
|
||||
|
||||
PARENTFN is either nil or a function defining the child-to-parent
|
||||
|
|
@ -151,33 +153,45 @@ CHILDRENFN are expected to be coherent with each other.
|
|||
|
||||
ACCEPTFN is a function returning non-nil if its parameter (any object)
|
||||
should be an item of the hierarchy. By default, ACCEPTFN returns non-nil
|
||||
if its parameter is non-nil."
|
||||
if its parameter is non-nil.
|
||||
|
||||
DELAY-CHILDREN-P is a predicate determining whether the children that would
|
||||
normally be processed by CHILDRENFN should, instead, have their processing be
|
||||
delayed and stored to be processed by CHILDRENFN when the child is selected
|
||||
during use of the hierarchy."
|
||||
(unless (hierarchy-has-item hierarchy item)
|
||||
(let ((acceptfn (or acceptfn #'identity)))
|
||||
(hierarchy--seen-items-add hierarchy item)
|
||||
(let ((parent (and parentfn (funcall parentfn item))))
|
||||
(when (funcall acceptfn parent)
|
||||
(hierarchy--add-relation hierarchy item parent acceptfn)
|
||||
(hierarchy-add-tree hierarchy parent parentfn childrenfn)))
|
||||
(let ((children (and childrenfn (funcall childrenfn item))))
|
||||
(mapc (lambda (child)
|
||||
(when (funcall acceptfn child)
|
||||
(hierarchy--add-relation hierarchy child item acceptfn)
|
||||
(hierarchy-add-tree hierarchy child parentfn childrenfn)))
|
||||
children)))))
|
||||
(hierarchy-add-tree hierarchy parent
|
||||
parentfn (if delay-children-p nil childrenfn))))
|
||||
(if (and childrenfn delay-children-p)
|
||||
(map-put! (hierarchy--delaying-parents hierarchy) item childrenfn)
|
||||
(let ((children (and childrenfn (funcall childrenfn item))))
|
||||
(map-put! (hierarchy--delaying-parents hierarchy) item nil)
|
||||
(mapc (lambda (child)
|
||||
(when (funcall acceptfn child)
|
||||
(hierarchy--add-relation hierarchy child item acceptfn)
|
||||
(hierarchy-add-tree hierarchy child parentfn childrenfn)))
|
||||
children))))))
|
||||
|
||||
(defun hierarchy-add-trees (hierarchy items parentfn &optional childrenfn acceptfn)
|
||||
(defun hierarchy-add-trees (hierarchy items parentfn
|
||||
&optional childrenfn acceptfn delay-children-p)
|
||||
"Call `hierarchy-add-tree' on HIERARCHY and each element of ITEMS.
|
||||
|
||||
PARENTFN, CHILDRENFN and ACCEPTFN have the same meaning as in `hierarchy-add'."
|
||||
PARENTFN, CHILDRENFN, ACCEPTFN, and DELAY-CHILDREN-P have the same meaning as in
|
||||
`hierarchy-add'."
|
||||
(seq-map (lambda (item)
|
||||
(hierarchy-add-tree hierarchy item parentfn childrenfn acceptfn))
|
||||
(hierarchy-add-tree hierarchy item parentfn
|
||||
childrenfn acceptfn delay-children-p))
|
||||
items))
|
||||
|
||||
(defun hierarchy-add-list (hierarchy list &optional wrap childrenfn)
|
||||
"Add to HIERARCHY the sub-lists in LIST.
|
||||
|
||||
If WRAP is non-nil, allow duplicate items in LIST by wraping each
|
||||
If WRAP is non-nil, allow duplicate items in LIST by wrapping each
|
||||
item in a cons (id . item). The root's id is 1.
|
||||
|
||||
CHILDRENFN is a function (defaults to `cdr') taking LIST as a
|
||||
|
|
@ -541,6 +555,30 @@ nil. The buffer is returned."
|
|||
buffer))
|
||||
|
||||
(declare-function widget-convert "wid-edit")
|
||||
(defun hierarchy--create-delayed-tree-widget (elem labelfn indent childrenfn)
|
||||
"Return a list of tree-widgets for the children generated.
|
||||
|
||||
ELEM is the element of the hierarchy passed from
|
||||
`hierarchy-convert-to-tree-widget'; it and the CHILDRENFN are used to generate
|
||||
the children of the element dynamically.
|
||||
|
||||
LABELFN is the same function passed to `hierarchy-convert-to-tree-widget'.
|
||||
|
||||
INDENT is the same function passed to `hierarchy-convert-to-tree-widget'.
|
||||
|
||||
CHILDRENFN is the function used to discover the children of ELEM."
|
||||
(lambda (_widget)
|
||||
(mapcar
|
||||
(lambda (item)
|
||||
(widget-convert
|
||||
'tree-widget
|
||||
:tag (hierarchy-labelfn-to-string labelfn item indent)
|
||||
:expander (hierarchy--create-delayed-tree-widget
|
||||
item
|
||||
labelfn
|
||||
(1+ indent)
|
||||
childrenfn)))
|
||||
(funcall childrenfn elem))))
|
||||
(defun hierarchy-convert-to-tree-widget (hierarchy labelfn)
|
||||
"Return a tree-widget for HIERARCHY.
|
||||
|
||||
|
|
@ -550,10 +588,21 @@ node label."
|
|||
(require 'wid-edit)
|
||||
(require 'tree-widget)
|
||||
(hierarchy-map-tree (lambda (item indent children)
|
||||
(widget-convert
|
||||
'tree-widget
|
||||
:tag (hierarchy-labelfn-to-string labelfn item indent)
|
||||
:args children))
|
||||
(let ((childrenfn (map-elt
|
||||
(hierarchy--delaying-parents hierarchy)
|
||||
item)))
|
||||
(apply
|
||||
#'widget-convert
|
||||
(list 'tree-widget
|
||||
:tag (hierarchy-labelfn-to-string labelfn item indent)
|
||||
(if childrenfn :expander :args)
|
||||
(if childrenfn
|
||||
(hierarchy--create-delayed-tree-widget
|
||||
item
|
||||
labelfn
|
||||
(1+ indent)
|
||||
childrenfn)
|
||||
children)))))
|
||||
hierarchy))
|
||||
|
||||
(defun hierarchy-tree-display (hierarchy labelfn &optional buffer)
|
||||
|
|
|
|||
|
|
@ -196,18 +196,21 @@ present if the icon is represented by an image."
|
|||
(image-supported-file-p file)
|
||||
(propertize
|
||||
" " 'display
|
||||
(if-let ((height (plist-get keywords :height)))
|
||||
(create-image file
|
||||
nil nil
|
||||
:height (if (eq height 'line)
|
||||
(let ((props
|
||||
(append
|
||||
(if-let ((height (plist-get keywords :height)))
|
||||
(list :height (if (eq height 'line)
|
||||
(window-default-line-height)
|
||||
height)
|
||||
:scale 1
|
||||
:rotation (or (plist-get keywords :rotation) 0)
|
||||
:ascent (if (plist-member keywords :ascent)
|
||||
(plist-get keywords :ascent)
|
||||
'center))
|
||||
(create-image file))))))
|
||||
height)))
|
||||
'(:scale 1)
|
||||
(if-let ((rotation (plist-get keywords :rotation)))
|
||||
(list :rotation rotation))
|
||||
(if-let ((margin (plist-get keywords :margin)))
|
||||
(list :margin margin))
|
||||
(list :ascent (if (plist-member keywords :ascent)
|
||||
(plist-get keywords :ascent)
|
||||
'center)))))
|
||||
(apply 'create-image file nil nil props))))))
|
||||
|
||||
(cl-defmethod icons--create ((_type (eql 'emoji)) icon _keywords)
|
||||
(when-let ((font (and (display-multi-font-p)
|
||||
|
|
|
|||
|
|
@ -283,6 +283,12 @@ expression, in which case we want to handle forms differently."
|
|||
,@(when-let ((safe (plist-get props :safe)))
|
||||
`((put ',varname 'safe-local-variable ,safe))))))
|
||||
|
||||
;; Extract theme properties.
|
||||
((eq car 'deftheme)
|
||||
(let* ((name (car-safe (cdr-safe form)))
|
||||
(props (nthcdr 3 form)))
|
||||
`(put ',name 'theme-properties (list ,@props))))
|
||||
|
||||
((eq car 'defgroup)
|
||||
;; In Emacs this is normally handled separately by cus-dep.el, but for
|
||||
;; third party packages, it can be convenient to explicitly autoload
|
||||
|
|
@ -730,7 +736,14 @@ rules for built-in packages and excluded files."
|
|||
;; updated.
|
||||
(file-newer-than-file-p
|
||||
(expand-file-name "emacs-lisp/loaddefs-gen.el" lisp-directory)
|
||||
output-file))))
|
||||
output-file)))
|
||||
(let ((lisp-mode-autoload-regexp
|
||||
"^;;;###\\(\\(noexist\\)-\\)?\\(theme-autoload\\)"))
|
||||
(loaddefs-generate
|
||||
(expand-file-name "../etc/themes/" lisp-directory)
|
||||
(expand-file-name "theme-loaddefs.el" lisp-directory))))
|
||||
|
||||
;;;###autoload (load "theme-loaddefs.el" t)
|
||||
|
||||
(provide 'loaddefs-gen)
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
;; Author: Nicolas Petton <nicolas@petton.fr>
|
||||
;; Maintainer: emacs-devel@gnu.org
|
||||
;; Keywords: extensions, lisp
|
||||
;; Version: 3.2.1
|
||||
;; Version: 3.3.1
|
||||
;; Package-Requires: ((emacs "26"))
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
|
@ -80,48 +80,82 @@ MAP can be an alist, plist, hash-table, or array."
|
|||
`(pcase-let ((,(map--make-pcase-patterns keys) ,map))
|
||||
,@body))
|
||||
|
||||
(eval-when-compile
|
||||
(defmacro map--dispatch (map-var &rest args)
|
||||
"Evaluate one of the forms specified by ARGS based on the type of MAP-VAR.
|
||||
|
||||
The following keyword types are meaningful: `:list',
|
||||
`:hash-table' and `:array'.
|
||||
|
||||
An error is thrown if MAP-VAR is neither a list, hash-table nor array.
|
||||
|
||||
Returns the result of evaluating the form associated with MAP-VAR's type."
|
||||
(declare (debug t) (indent 1))
|
||||
`(cond ((listp ,map-var) ,(plist-get args :list))
|
||||
((hash-table-p ,map-var) ,(plist-get args :hash-table))
|
||||
((arrayp ,map-var) ,(plist-get args :array))
|
||||
(t (error "Unsupported map type `%S': %S"
|
||||
(type-of ,map-var) ,map-var)))))
|
||||
|
||||
(define-error 'map-not-inplace "Cannot modify map in-place")
|
||||
|
||||
(defsubst map--plist-p (list)
|
||||
"Return non-nil if LIST is the start of a nonempty plist map."
|
||||
(and (consp list) (atom (car list))))
|
||||
|
||||
(defconst map--plist-has-predicate
|
||||
(condition-case nil
|
||||
(with-no-warnings (plist-get () nil #'eq) t)
|
||||
(wrong-number-of-arguments))
|
||||
"Non-nil means `plist-get' & co. accept a predicate in Emacs 29+.
|
||||
Note that support for this predicate in map.el is patchy and
|
||||
deprecated.")
|
||||
|
||||
(defun map--plist-member-1 (plist prop &optional predicate)
|
||||
"Compatibility shim for the PREDICATE argument of `plist-member'.
|
||||
Assumes non-nil PLIST satisfies `map--plist-p'."
|
||||
(if (or (memq predicate '(nil eq)) (null plist))
|
||||
(plist-member plist prop)
|
||||
(let ((tail plist) found)
|
||||
(while (and (not (setq found (funcall predicate (car tail) prop)))
|
||||
(consp (setq tail (cdr tail)))
|
||||
(consp (setq tail (cdr tail)))))
|
||||
(and tail (not found)
|
||||
(signal 'wrong-type-argument `(plistp ,plist)))
|
||||
tail)))
|
||||
|
||||
(defalias 'map--plist-member
|
||||
(if map--plist-has-predicate #'plist-member #'map--plist-member-1)
|
||||
"Compatibility shim for `plist-member' in Emacs 29+.
|
||||
\n(fn PLIST PROP &optional PREDICATE)")
|
||||
|
||||
(defun map--plist-put-1 (plist prop val &optional predicate)
|
||||
"Compatibility shim for the PREDICATE argument of `plist-put'.
|
||||
Assumes non-nil PLIST satisfies `map--plist-p'."
|
||||
(if (or (memq predicate '(nil eq)) (null plist))
|
||||
(plist-put plist prop val)
|
||||
(let ((tail plist) prev found)
|
||||
(while (and (consp (cdr tail))
|
||||
(not (setq found (funcall predicate (car tail) prop)))
|
||||
(consp (setq prev tail tail (cddr tail)))))
|
||||
(cond (found (setcar (cdr tail) val))
|
||||
(tail (signal 'wrong-type-argument `(plistp ,plist)))
|
||||
(prev (setcdr (cdr prev) (cons prop (cons val (cddr prev)))))
|
||||
((setq plist (cons prop (cons val plist)))))
|
||||
plist)))
|
||||
|
||||
(defalias 'map--plist-put
|
||||
(if map--plist-has-predicate #'plist-put #'map--plist-put-1)
|
||||
"Compatibility shim for `plist-put' in Emacs 29+.
|
||||
\n(fn PLIST PROP VAL &optional PREDICATE)")
|
||||
|
||||
(cl-defgeneric map-elt (map key &optional default testfn)
|
||||
"Look up KEY in MAP and return its associated value.
|
||||
If KEY is not found, return DEFAULT which defaults to nil.
|
||||
|
||||
TESTFN is the function to use for comparing keys. It is
|
||||
deprecated because its default and valid values depend on the MAP
|
||||
argument. Generally, alist keys are compared with `equal', plist
|
||||
keys with `eq', and hash-table keys with the hash-table's test
|
||||
argument, and it was never consistently supported by the map.el
|
||||
API. Generally, alist keys are compared with `equal', plist keys
|
||||
with `eq', and hash-table keys with the hash-table's test
|
||||
function.
|
||||
|
||||
In the base definition, MAP can be an alist, plist, hash-table,
|
||||
or array."
|
||||
(declare
|
||||
;; `testfn' is deprecated.
|
||||
(advertised-calling-convention (map key &optional default) "27.1")
|
||||
(gv-expander
|
||||
(lambda (do)
|
||||
(gv-letplace (mgetter msetter) `(gv-delay-error ,map)
|
||||
(macroexp-let2* nil
|
||||
;; Eval them once and for all in the right order.
|
||||
((key key) (default default) (testfn testfn))
|
||||
(funcall do `(map-elt ,mgetter ,key ,default)
|
||||
(funcall do
|
||||
`(map-elt ,mgetter ,key ,default ,@(and testfn `(,testfn)))
|
||||
(lambda (v)
|
||||
(macroexp-let2 nil v v
|
||||
`(condition-case nil
|
||||
|
|
@ -132,19 +166,21 @@ or array."
|
|||
,(funcall msetter
|
||||
`(map-insert ,mgetter ,key ,v))
|
||||
;; Always return the value.
|
||||
,v)))))))))
|
||||
;; `testfn' is deprecated.
|
||||
(advertised-calling-convention (map key &optional default) "27.1"))
|
||||
;; Can't use `cl-defmethod' with `advertised-calling-convention'.
|
||||
(map--dispatch map
|
||||
:list (if (map--plist-p map)
|
||||
(let ((res (plist-member map key)))
|
||||
(if res (cadr res) default))
|
||||
(alist-get key map default nil (or testfn #'equal)))
|
||||
:hash-table (gethash key map default)
|
||||
:array (if (map-contains-key map key)
|
||||
(aref map key)
|
||||
default)))
|
||||
,v)))))))))))
|
||||
|
||||
(cl-defmethod map-elt ((map list) key &optional default testfn)
|
||||
(if (map--plist-p map)
|
||||
(let ((res (map--plist-member map key testfn)))
|
||||
(if res (cadr res) default))
|
||||
(alist-get key map default nil (or testfn #'equal))))
|
||||
|
||||
(cl-defmethod map-elt ((map hash-table) key &optional default _testfn)
|
||||
(gethash key map default))
|
||||
|
||||
(cl-defmethod map-elt ((map array) key &optional default _testfn)
|
||||
(if (map-contains-key map key)
|
||||
(aref map key)
|
||||
default))
|
||||
|
||||
(defmacro map-put (map key value &optional testfn)
|
||||
"Associate KEY with VALUE in MAP and return VALUE.
|
||||
|
|
@ -154,8 +190,12 @@ When MAP is an alist, test equality with TESTFN if non-nil,
|
|||
otherwise use `equal'.
|
||||
|
||||
MAP can be an alist, plist, hash-table, or array."
|
||||
(declare (obsolete "use map-put! or (setf (map-elt ...) ...) instead" "27.1"))
|
||||
`(setf (map-elt ,map ,key nil ,testfn) ,value))
|
||||
(declare
|
||||
(obsolete "use `map-put!' or `(setf (map-elt ...) ...)' instead." "27.1"))
|
||||
(if testfn
|
||||
`(with-no-warnings
|
||||
(setf (map-elt ,map ,key nil ,testfn) ,value))
|
||||
`(setf (map-elt ,map ,key) ,value)))
|
||||
|
||||
(defun map--plist-delete (map key)
|
||||
(let ((tail map) last)
|
||||
|
|
@ -338,15 +378,16 @@ The default implementation delegates to `map-length'."
|
|||
"Return non-nil if and only if MAP contains KEY.
|
||||
TESTFN is deprecated. Its default depends on MAP.
|
||||
The default implementation delegates to `map-some'."
|
||||
(declare (advertised-calling-convention (map key) "27.1"))
|
||||
(unless testfn (setq testfn #'equal))
|
||||
(map-some (lambda (k _v) (funcall testfn key k)) map))
|
||||
|
||||
(cl-defmethod map-contains-key ((map list) key &optional testfn)
|
||||
"Return non-nil if MAP contains KEY.
|
||||
If MAP is an alist, TESTFN defaults to `equal'.
|
||||
If MAP is a plist, `plist-member' is used instead."
|
||||
If MAP is a plist, TESTFN defaults to `eq'."
|
||||
(if (map--plist-p map)
|
||||
(plist-member map key)
|
||||
(map--plist-member map key testfn)
|
||||
(let ((v '(nil)))
|
||||
(not (eq v (alist-get key map v nil (or testfn #'equal)))))))
|
||||
|
||||
|
|
@ -459,24 +500,30 @@ This operates by modifying MAP in place.
|
|||
If it cannot do that, it signals a `map-not-inplace' error.
|
||||
To insert an element without modifying MAP, use `map-insert'."
|
||||
;; `testfn' only exists for backward compatibility with `map-put'!
|
||||
(declare (advertised-calling-convention (map key value) "27.1"))
|
||||
;; Can't use `cl-defmethod' with `advertised-calling-convention'.
|
||||
(map--dispatch
|
||||
map
|
||||
:list
|
||||
(progn
|
||||
(if (map--plist-p map)
|
||||
(plist-put map key value)
|
||||
(let ((oldmap map))
|
||||
(setf (alist-get key map key nil (or testfn #'equal)) value)
|
||||
(unless (eq oldmap map)
|
||||
(signal 'map-not-inplace (list oldmap)))))
|
||||
;; Always return the value.
|
||||
value)
|
||||
:hash-table (puthash key value map)
|
||||
;; FIXME: If `key' is too large, should we signal `map-not-inplace'
|
||||
;; and let `map-insert' grow the array?
|
||||
:array (aset map key value)))
|
||||
(declare (advertised-calling-convention (map key value) "27.1")))
|
||||
|
||||
(cl-defmethod map-put! ((map list) key value &optional testfn)
|
||||
(if (map--plist-p map)
|
||||
(map--plist-put map key value testfn)
|
||||
(let ((oldmap map))
|
||||
(setf (alist-get key map key nil (or testfn #'equal)) value)
|
||||
(unless (eq oldmap map)
|
||||
(signal 'map-not-inplace (list oldmap)))))
|
||||
;; Always return the value.
|
||||
value)
|
||||
|
||||
(cl-defmethod map-put! ((map hash-table) key value &optional _testfn)
|
||||
(puthash key value map))
|
||||
|
||||
(cl-defmethod map-put! ((map array) key value &optional _testfn)
|
||||
;; FIXME: If `key' is too large, should we signal `map-not-inplace'
|
||||
;; and let `map-insert' grow the array?
|
||||
(aset map key value))
|
||||
|
||||
;; There shouldn't be old source code referring to `map--put', yet we do
|
||||
;; need to keep it for backward compatibility with .elc files where the
|
||||
;; expansion of `setf' may call this function.
|
||||
(define-obsolete-function-alias 'map--put #'map-put! "27.1")
|
||||
|
||||
(cl-defgeneric map-insert (map key value)
|
||||
"Return a new map like MAP except that it associates KEY with VALUE.
|
||||
|
|
@ -493,11 +540,6 @@ The default implementation defaults to `map-copy' and `map-put!'."
|
|||
(cons key (cons value map))
|
||||
(cons (cons key value) map)))
|
||||
|
||||
;; There shouldn't be old source code referring to `map--put', yet we do
|
||||
;; need to keep it for backward compatibility with .elc files where the
|
||||
;; expansion of `setf' may call this function.
|
||||
(define-obsolete-function-alias 'map--put #'map-put! "27.1")
|
||||
|
||||
(cl-defmethod map-apply (function (map list))
|
||||
(if (map--plist-p map)
|
||||
(cl-call-next-method)
|
||||
|
|
|
|||
|
|
@ -262,12 +262,7 @@ by counted more than once."
|
|||
(cl-struct-slot-info struct-type)))))
|
||||
|
||||
(defun memory-report--format (bytes)
|
||||
(setq bytes (/ bytes 1024.0))
|
||||
(let ((units '("KiB" "MiB" "GiB" "TiB")))
|
||||
(while (>= bytes 1024)
|
||||
(setq bytes (/ bytes 1024.0))
|
||||
(setq units (cdr units)))
|
||||
(format "%6.1f %s" bytes (car units))))
|
||||
(format "%10s" (file-size-human-readable bytes 'iec " ")))
|
||||
|
||||
(defun memory-report--gc-elem (elems type)
|
||||
(* (nth 1 (assq type elems))
|
||||
|
|
|
|||
|
|
@ -19,7 +19,18 @@
|
|||
|
||||
;;; Commentary:
|
||||
|
||||
;; This library provides multisession variables for Emacs Lisp, to
|
||||
;; make them persist between sessions.
|
||||
;;
|
||||
;; Use `define-multisession-variable' to define a multisession
|
||||
;; variable, and `multisession-value' to read its value. Use
|
||||
;; `list-multisession-values' to list multisession variables.
|
||||
;;
|
||||
;; Users might want to customize `multisession-storage' and
|
||||
;; `multisession-directory'.
|
||||
;;
|
||||
;; See Info node `(elisp) Multisession Variables' for more
|
||||
;; information.
|
||||
|
||||
;;; Code:
|
||||
|
||||
|
|
|
|||
|
|
@ -216,7 +216,7 @@ is a list of additional properties among the following:
|
|||
function) named COPIER. It will take an object of type NAME as first
|
||||
argument followed by ARGS. ARGS lists the names of the slots that will
|
||||
be updated with the value of the corresponding argument.
|
||||
SLOTS is a list if slot descriptions. Each slot can be a single symbol
|
||||
SLOTS is a list of slot descriptions. Each slot can be a single symbol
|
||||
which is the name of the slot, or it can be of the form (SLOT-NAME . SPROPS)
|
||||
where SLOT-NAME is then the name of the slot and SPROPS is a property
|
||||
list of slot properties. The currently known properties are the following:
|
||||
|
|
@ -341,11 +341,11 @@ list of slot properties. The currently known properties are the following:
|
|||
|
||||
(defmacro oclosure--lambda (type bindings mutables args &rest body)
|
||||
"Low level construction of an OClosure object.
|
||||
TYPE should be a form returning an OClosure type (a symbol)
|
||||
TYPE should be a form returning an OClosure type (a symbol).
|
||||
BINDINGS should list all the slots expected by this type, in the proper order.
|
||||
MUTABLE is a list of symbols indicating which of the BINDINGS
|
||||
should be mutable.
|
||||
No checking is performed,"
|
||||
No checking is performed."
|
||||
(declare (indent 3) (debug (sexp (&rest (sexp form)) sexp def-body)))
|
||||
;; FIXME: Fundamentally `oclosure-lambda' should be a special form.
|
||||
;; We define it here as a macro which expands to something that
|
||||
|
|
|
|||
791
lisp/emacs-lisp/package-vc.el
Normal file
791
lisp/emacs-lisp/package-vc.el
Normal file
|
|
@ -0,0 +1,791 @@
|
|||
;;; package-vc.el --- Manage packages from VC checkouts -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2022 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Philip Kaludercic <philipk@posteo.net>
|
||||
;; Keywords: tools
|
||||
|
||||
;; 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 <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; While packages managed by package.el use tarballs for distributing
|
||||
;; the source code, this extension allows for packages to be fetched
|
||||
;; and updated directly from a version control system.
|
||||
;;
|
||||
;; To install a package from source use `package-vc-install'. If you
|
||||
;; aren't interested in activating a package, you can use
|
||||
;; `package-vc-checkout' instead, which will prompt you for a target
|
||||
;; directory. If you wish to re-use an existing checkout, the command
|
||||
;; `package-vc-install-from-checkout' will create a symbolic link and
|
||||
;; prepare the package.
|
||||
;;
|
||||
;; If you make local changes that you wish to share with an upstream
|
||||
;; maintainer, the command `package-vc-prepare-patch' can prepare
|
||||
;; these as patches to send via Email.
|
||||
|
||||
;;; TODO:
|
||||
|
||||
;; - Allow maintaining patches that are ported back onto regular
|
||||
;; packages and maintained between versions.
|
||||
;;
|
||||
;; - Add a heuristic for guessing a `:lisp-dir' when cloning directly
|
||||
;; from a URL.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'rx))
|
||||
(eval-when-compile (require 'inline))
|
||||
(eval-when-compile (require 'map))
|
||||
(require 'package)
|
||||
(require 'lisp-mnt)
|
||||
(require 'vc)
|
||||
(require 'seq)
|
||||
|
||||
(defgroup package-vc nil
|
||||
"Manage packages from VC checkouts."
|
||||
:group 'package
|
||||
:link '(custom-manual "(emacs) Package from Source")
|
||||
:prefix "package-vc-"
|
||||
:version "29.1")
|
||||
|
||||
(defconst package-vc--elpa-packages-version 1
|
||||
"Version number of the package specification format understood by package-vc.")
|
||||
|
||||
(defcustom package-vc-heuristic-alist
|
||||
`((,(rx bos "http" (? "s") "://"
|
||||
(or (: (? "www.") "github.com"
|
||||
"/" (+ (or alnum "-" "." "_"))
|
||||
"/" (+ (or alnum "-" "." "_")))
|
||||
(: "codeberg.org"
|
||||
"/" (+ (or alnum "-" "." "_"))
|
||||
"/" (+ (or alnum "-" "." "_")))
|
||||
(: (? "www.") "gitlab" (+ "." (+ alnum))
|
||||
"/" (+ (or alnum "-" "." "_"))
|
||||
"/" (+ (or alnum "-" "." "_")))
|
||||
(: "git.sr.ht"
|
||||
"/~" (+ (or alnum "-" "." "_"))
|
||||
"/" (+ (or alnum "-" "." "_")))
|
||||
(: "git." (or "savannah" "sv") "." (? "non") "gnu.org/"
|
||||
(or "r" "git") "/"
|
||||
(+ (or alnum "-" "." "_")) (? "/")))
|
||||
(or (? "/") ".git") eos)
|
||||
. Git)
|
||||
(,(rx bos "http" (? "s") "://"
|
||||
(or (: "hg.sr.ht"
|
||||
"/~" (+ (or alnum "-" "." "_"))
|
||||
"/" (+ (or alnum "-" "." "_")))
|
||||
(: "hg." (or "savannah" "sv") "." (? "non") "gnu.org/hgweb/"
|
||||
(+ (or alnum "-" "." "_")) (? "/")))
|
||||
eos)
|
||||
. Hg)
|
||||
(,(rx bos "http" (? "s") "://"
|
||||
(or (: "bzr." (or "savannah" "sv") "." (? "non") "gnu.org/r/"
|
||||
(+ (or alnum "-" "." "_")) (? "/")))
|
||||
eos)
|
||||
. Bzr))
|
||||
"Heuristic mapping URL regular expressions to VC backends."
|
||||
:type `(alist :key-type (regexp :tag "Regular expression matching URLs")
|
||||
:value-type (choice :tag "VC Backend"
|
||||
,@(mapcar (lambda (b) `(const ,b))
|
||||
vc-handled-backends)))
|
||||
:version "29.1")
|
||||
|
||||
(defcustom package-vc-default-backend 'Git
|
||||
"Default VC backend used when cloning a package repository.
|
||||
If no repository type was specified or could be guessed by
|
||||
`package-vc-heuristic-alist', this is the default VC backend
|
||||
used as fallback. The value must be a member of
|
||||
`vc-handled-backends' and the named backend must implement
|
||||
the `clone' function."
|
||||
:type `(choice ,@(mapcar (lambda (b) (list 'const b))
|
||||
vc-handled-backends))
|
||||
:version "29.1")
|
||||
|
||||
(defvar package-vc-selected-packages) ; pacify byte-compiler
|
||||
|
||||
;;;###autoload
|
||||
(defun package-vc-install-selected-packages ()
|
||||
"Ensure packages specified in `package-vc-selected-packages' are installed."
|
||||
(interactive)
|
||||
(pcase-dolist (`(,name . ,spec) package-vc-selected-packages)
|
||||
(when (stringp name)
|
||||
(setq name (intern name)))
|
||||
(let ((pkg-descs (assoc name package-alist #'string=)))
|
||||
(unless (seq-some #'package-vc-p (cdr pkg-descs))
|
||||
(cond
|
||||
((null spec)
|
||||
(package-vc-install name))
|
||||
((stringp spec)
|
||||
(package-vc-install name nil spec))
|
||||
((listp spec)
|
||||
(package-vc--archives-initialize)
|
||||
(package-vc--unpack (cadr pkg-descs) spec)))))))
|
||||
|
||||
;;;###autoload
|
||||
(defcustom package-vc-selected-packages '()
|
||||
"List of packages that must be installed.
|
||||
Each member of the list is of the form (NAME . SPEC), where NAME
|
||||
is a symbol designating the package and SPEC is one of:
|
||||
|
||||
- nil, if any package version can be installed;
|
||||
- a version string, if that specific revision is to be installed;
|
||||
- a property list, describing a package specification. Valid
|
||||
key/value pairs are
|
||||
|
||||
`:url' (string)
|
||||
The URL of the repository used to fetch the package source.
|
||||
|
||||
`:branch' (string)
|
||||
If given, the name of the branch to checkout after cloning the directory.
|
||||
|
||||
`:lisp-dir' (string)
|
||||
The repository-relative name of the directory to use for loading the Lisp
|
||||
sources. If not given, the value defaults to the root directory
|
||||
of the repository.
|
||||
|
||||
`:main-file' (string)
|
||||
The main file of the project, relevant to gather package metadata.
|
||||
If not given, the assumed default is the package name with \".el\"
|
||||
appended to it.
|
||||
|
||||
`:vc-backend' (symbol)
|
||||
A symbol of the VC backend to use for cloning the package. The
|
||||
value ought to be a member of `vc-handled-backends'. If omitted,
|
||||
`vc-clone' will fall back onto the archive default or on
|
||||
`package-vc-default-backend'.
|
||||
|
||||
All other keys are ignored.
|
||||
|
||||
This user option differs from `package-selected-packages' in that
|
||||
it is meant to be specified manually. If you want to install all
|
||||
the packages in the list, you cal also use
|
||||
`package-vc-install-selected-packages'.
|
||||
|
||||
Note that this option will not override an existing source
|
||||
package installation or revert the checked out revision."
|
||||
:type '(alist :tag "List of packages you want to be installed"
|
||||
:key-type (symbol :tag "Package")
|
||||
:value-type
|
||||
(choice (const :tag "Any revision" nil)
|
||||
(string :tag "Specific revision")
|
||||
(plist :options ((:url string)
|
||||
(:branch string)
|
||||
(:lisp-dir string)
|
||||
(:main-file string)
|
||||
(:vc-backend symbol)))))
|
||||
:initialize #'custom-initialize-default
|
||||
:set (lambda (sym val)
|
||||
(custom-set-default sym val)
|
||||
(package-vc-install-selected-packages))
|
||||
:version "29.1")
|
||||
|
||||
(defvar package-vc--archive-spec-alist nil
|
||||
"List of package specifications for each archive.
|
||||
The list maps each package name, as a string, to a plist as
|
||||
specified in `package-vc-selected-packages'.")
|
||||
|
||||
(defvar package-vc--archive-data-alist nil
|
||||
"List of package specification metadata for archives.
|
||||
Each element of the list has the form (ARCHIVE . PLIST), where
|
||||
PLIST keys are one of:
|
||||
|
||||
`:version' (integer)
|
||||
Indicates the version of the file formatting, to be compared
|
||||
with `package-vc--elpa-packages-version'.
|
||||
|
||||
`:vc-backend' (symbol)
|
||||
A symbol of the default VC backend to use if a package specification
|
||||
does not indicate a backend. The value ought to be a member of
|
||||
`vc-handled-backends'. If omitted, `vc-clone' will fall back on
|
||||
`package-vc-default-backend'.
|
||||
|
||||
All other values are ignored.")
|
||||
|
||||
(defun package-vc--desc->spec (pkg-desc &optional name)
|
||||
"Retrieve the package specification for PKG-DESC.
|
||||
The optional argument NAME can be used to override the default
|
||||
name for PKG-DESC."
|
||||
(alist-get
|
||||
(or name (package-desc-name pkg-desc))
|
||||
(if (package-desc-archive pkg-desc)
|
||||
(alist-get (intern (package-desc-archive pkg-desc))
|
||||
package-vc--archive-spec-alist)
|
||||
(apply #'append (mapcar #'cdr package-vc--archive-spec-alist)))
|
||||
nil nil #'string=))
|
||||
|
||||
(define-inline package-vc--query-spec (pkg-desc prop)
|
||||
"Query the property PROP for the package specification of PKG-DESC.
|
||||
If no package specification can be determined, the function will
|
||||
return nil."
|
||||
(inline-letevals (pkg-desc prop)
|
||||
(inline-quote (plist-get (package-vc--desc->spec ,pkg-desc) ,prop))))
|
||||
|
||||
(defun package-vc--read-archive-data (archive)
|
||||
"Update `package-vc--archive-spec-alist' for ARCHIVE.
|
||||
This function is meant to be used as a hook for `package-read-archive-hook'."
|
||||
(let ((contents-file (expand-file-name
|
||||
(format "archives/%s/elpa-packages.eld" archive)
|
||||
package-user-dir)))
|
||||
(when (file-exists-p contents-file)
|
||||
(with-temp-buffer
|
||||
(let ((coding-system-for-read 'utf-8))
|
||||
(insert-file-contents contents-file)
|
||||
;; The response from the server is expected to have the form
|
||||
;;
|
||||
;; ((("foo" :url "..." ...) ...)
|
||||
;; :version 1
|
||||
;; :default-vc Git)
|
||||
(let ((spec (read (current-buffer))))
|
||||
(when (eq package-vc--elpa-packages-version
|
||||
(plist-get (cdr spec) :version))
|
||||
(setf (alist-get (intern archive) package-vc--archive-spec-alist)
|
||||
(car spec)))
|
||||
(setf (alist-get (intern archive) package-vc--archive-data-alist)
|
||||
(cdr spec))
|
||||
(when-let ((default-vc (plist-get (cdr spec) :default-vc))
|
||||
((not (memq default-vc vc-handled-backends))))
|
||||
(warn "Archive `%S' expects missing VC backend %S"
|
||||
archive (plist-get (cdr spec) :default-vc)))))))))
|
||||
|
||||
(defun package-vc--download-and-read-archives (&optional async)
|
||||
"Download specifications of all `package-archives' and read them.
|
||||
Populate `package-vc--archive-spec-alist' with the result.
|
||||
|
||||
If optional argument ASYNC is non-nil, perform the downloads
|
||||
asynchronously."
|
||||
(dolist (archive package-archives)
|
||||
(condition-case-unless-debug nil
|
||||
(package--download-one-archive archive "elpa-packages.eld" async)
|
||||
(error (message "Failed to download `%s' archive." (car archive))))))
|
||||
|
||||
(add-hook 'package-read-archive-hook #'package-vc--read-archive-data 20)
|
||||
|
||||
(defun package-vc-commit (pkg)
|
||||
"Return the last commit of a development package PKG."
|
||||
(cl-assert (package-vc-p pkg))
|
||||
;; FIXME: vc should be extended to allow querying the commit of a
|
||||
;; directory (as is possible when dealing with git repositories).
|
||||
;; This should be a fallback option.
|
||||
(cl-loop with dir = (package-desc-dir pkg)
|
||||
for file in (directory-files dir t "\\.el\\'" t)
|
||||
when (vc-working-revision file) return it
|
||||
finally return "unknown"))
|
||||
|
||||
(defun package-vc--version (pkg)
|
||||
"Return the version number for the source package PKG."
|
||||
(cl-assert (package-vc-p pkg))
|
||||
(if-let ((main-file (package-vc--main-file pkg)))
|
||||
(with-temp-buffer
|
||||
(insert-file-contents main-file)
|
||||
(package-strip-rcs-id
|
||||
(or (lm-header "package-version")
|
||||
(lm-header "version"))))
|
||||
"0"))
|
||||
|
||||
(defun package-vc--main-file (pkg-desc)
|
||||
"Return the name of the main file for PKG-DESC."
|
||||
(cl-assert (package-vc-p pkg-desc))
|
||||
(let ((pkg-spec (package-vc--desc->spec pkg-desc))
|
||||
(name (symbol-name (package-desc-name pkg-desc))))
|
||||
(or (plist-get pkg-spec :main-file)
|
||||
(expand-file-name
|
||||
(concat name ".el")
|
||||
(file-name-concat
|
||||
(or (package-desc-dir pkg-desc)
|
||||
(expand-file-name name package-user-dir))
|
||||
(plist-get pkg-spec :lisp-dir))))))
|
||||
|
||||
(defun package-vc--generate-description-file (pkg-desc pkg-file)
|
||||
"Generate a package description file for PKG-DESC and write it to PKG-FILE."
|
||||
(let ((name (package-desc-name pkg-desc)))
|
||||
;; Infer the subject if missing.
|
||||
(unless (package-desc-summary pkg-desc)
|
||||
(setf (package-desc-summary pkg-desc)
|
||||
(let ((main-file (package-vc--main-file pkg-desc)))
|
||||
(or (package-desc-summary pkg-desc)
|
||||
(and-let* ((pkg (cadr (assq name package-archive-contents))))
|
||||
(package-desc-summary pkg))
|
||||
(and main-file (file-exists-p main-file)
|
||||
(lm-summary main-file))
|
||||
package--default-summary))))
|
||||
(let ((print-level nil)
|
||||
(print-quoted t)
|
||||
(print-length nil))
|
||||
(write-region
|
||||
(concat
|
||||
";;; Generated package description from "
|
||||
(replace-regexp-in-string
|
||||
"-pkg\\.el\\'" ".el"
|
||||
(file-name-nondirectory pkg-file))
|
||||
" -*- no-byte-compile: t -*-\n"
|
||||
(prin1-to-string
|
||||
(nconc
|
||||
(list 'define-package
|
||||
(symbol-name name)
|
||||
(cons 'vc (package-vc--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))))
|
||||
|
||||
(declare-function org-export-to-file "ox" (backend file))
|
||||
|
||||
(defun package-vc--build-documentation (pkg-desc file)
|
||||
"Build documentation for package PKG-DESC from documentation source in FILE.
|
||||
FILE can be an Org file, indicated by its \".org\" extension,
|
||||
otherwise it's assumed to be an Info file."
|
||||
(let* ((pkg-name (package-desc-name pkg-desc))
|
||||
(default-directory (package-desc-dir pkg-desc))
|
||||
(output (expand-file-name (format "%s.info" pkg-name)))
|
||||
clean-up)
|
||||
(when (string-match-p "\\.org\\'" file)
|
||||
(require 'ox)
|
||||
(require 'ox-texinfo)
|
||||
(with-temp-buffer
|
||||
(insert-file-contents file)
|
||||
(setq file (make-temp-file "ox-texinfo-"))
|
||||
(org-export-to-file 'texinfo file)
|
||||
(setq clean-up t)))
|
||||
(with-current-buffer (get-buffer-create " *package-vc doc*")
|
||||
(erase-buffer)
|
||||
(cond
|
||||
((/= 0 (call-process "makeinfo" nil t nil
|
||||
"--no-split" file "-o" output))
|
||||
(message "Failed to build manual %s, see buffer %S"
|
||||
file (buffer-name)))
|
||||
((/= 0 (call-process "install-info" nil t nil
|
||||
output (expand-file-name "dir")))
|
||||
(message "Failed to install manual %s, see buffer %S"
|
||||
output (buffer-name)))
|
||||
((kill-buffer))))
|
||||
(when clean-up
|
||||
(delete-file file))))
|
||||
|
||||
(defun package-vc--unpack-1 (pkg-desc pkg-dir)
|
||||
"Prepare PKG-DESC that is already checked-out in PKG-DIR.
|
||||
This includes downloading missing dependencies, generating
|
||||
autoloads, generating a package description file (used to
|
||||
identify a package as a source package later on), building
|
||||
documentation and marking the package as installed."
|
||||
;; Remove any previous instance of PKG-DESC from `package-alist'
|
||||
(let ((pkgs (assq (package-desc-name pkg-desc) package-alist)))
|
||||
(when pkgs
|
||||
(setf (cdr pkgs) (seq-remove #'package-vc-p (cdr pkgs)))))
|
||||
|
||||
;; In case the package was installed directly from source, the
|
||||
;; dependency list wasn't know beforehand, and they might have
|
||||
;; to be installed explicitly.
|
||||
(let ((deps '()))
|
||||
(dolist (file (directory-files pkg-dir t "\\.el\\'" t))
|
||||
(with-temp-buffer
|
||||
(insert-file-contents file)
|
||||
(when-let* ((require-lines (lm-header-multiline "package-requires")))
|
||||
(thread-last
|
||||
(mapconcat #'identity require-lines " ")
|
||||
package-read-from-string
|
||||
package--prepare-dependencies
|
||||
(nconc deps)
|
||||
(setq deps)))))
|
||||
(dolist (dep deps)
|
||||
(cl-callf version-to-list (cadr dep)))
|
||||
(package-download-transaction
|
||||
(package-compute-transaction nil (delete-dups deps))))
|
||||
|
||||
(let ((default-directory (file-name-as-directory pkg-dir))
|
||||
(pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir)))
|
||||
;; Generate autoloads
|
||||
(let* ((name (package-desc-name pkg-desc))
|
||||
(auto-name (format "%s-autoloads.el" name))
|
||||
(extras (package-desc-extras pkg-desc))
|
||||
(lisp-dir (alist-get :lisp-dir extras)))
|
||||
(package-generate-autoloads
|
||||
name (file-name-concat pkg-dir lisp-dir))
|
||||
(when lisp-dir
|
||||
(write-region
|
||||
(with-temp-buffer
|
||||
(insert ";; Autoload indirection for package-vc\n\n")
|
||||
(prin1 `(load (expand-file-name
|
||||
,(file-name-concat lisp-dir auto-name)
|
||||
(or (and load-file-name
|
||||
(file-name-directory load-file-name))
|
||||
(car load-path))))
|
||||
(current-buffer))
|
||||
(buffer-string))
|
||||
nil (expand-file-name auto-name pkg-dir))))
|
||||
|
||||
;; Generate package file
|
||||
(package-vc--generate-description-file pkg-desc pkg-file)
|
||||
|
||||
;; Detect a manual
|
||||
(when-let ((pkg-spec (package-vc--desc->spec pkg-desc))
|
||||
((executable-find "install-info")))
|
||||
(dolist (doc-file (ensure-list (plist-get pkg-spec :doc)))
|
||||
(package-vc--build-documentation pkg-desc doc-file))))
|
||||
|
||||
;; Update package-alist.
|
||||
(let ((new-desc (package-load-descriptor pkg-dir)))
|
||||
;; Activation has to be done before compilation, so that if we're
|
||||
;; upgrading and macros have changed we load the new definitions
|
||||
;; before compiling.
|
||||
(when (package-activate-1 new-desc :reload :deps)
|
||||
;; FIXME: Compilation should be done as a separate, optional, step.
|
||||
;; E.g. for multi-package installs, we should first install all packages
|
||||
;; and then compile them.
|
||||
(package--compile new-desc)
|
||||
(when package-native-compile
|
||||
(package--native-compile-async new-desc))
|
||||
;; After compilation, load again any files loaded by
|
||||
;; `activate-1', so that we use the byte-compiled definitions.
|
||||
(package--reload-previously-loaded new-desc)))
|
||||
|
||||
;; Mark package as selected
|
||||
(package--save-selected-packages
|
||||
(cons (package-desc-name pkg-desc)
|
||||
package-selected-packages))
|
||||
|
||||
;; Confirm that the installation was successful
|
||||
(let ((main-file (package-vc--main-file pkg-desc)))
|
||||
(message "Source package `%s' installed (Version %s, Revision %S)."
|
||||
(package-desc-name pkg-desc)
|
||||
(lm-with-file main-file
|
||||
(package-strip-rcs-id
|
||||
(or (lm-header "package-version")
|
||||
(lm-header "version"))))
|
||||
(vc-working-revision main-file)))
|
||||
t)
|
||||
|
||||
(defun package-vc--guess-backend (url)
|
||||
"Guess the VC backend for URL.
|
||||
This function will internally query `package-vc-heuristic-alist'
|
||||
and return nil if it cannot reasonably guess."
|
||||
(and url (alist-get url package-vc-heuristic-alist
|
||||
nil nil #'string-match-p)))
|
||||
|
||||
(defun package-vc--clone (pkg-desc pkg-spec dir rev)
|
||||
"Clone the package PKG-DESC whose spec is PKG-SPEC into the directory DIR.
|
||||
REV specifies a specific revision to checkout. This overrides the `:branch'
|
||||
attribute in PKG-SPEC."
|
||||
(pcase-let* ((name (package-desc-name pkg-desc))
|
||||
((map :url :branch) pkg-spec))
|
||||
|
||||
;; Clone the repository into `repo-dir' if necessary
|
||||
(unless (file-exists-p dir)
|
||||
(make-directory (file-name-directory dir) t)
|
||||
(let ((backend (or (plist-get pkg-spec :vc-backend)
|
||||
(package-vc--query-spec pkg-desc :vc-backend)
|
||||
(package-vc--guess-backend url)
|
||||
(plist-get (alist-get (package-desc-archive pkg-desc)
|
||||
package-vc--archive-data-alist
|
||||
nil nil #'string=)
|
||||
:vc-backend)
|
||||
package-vc-default-backend)))
|
||||
(unless (vc-clone url backend dir
|
||||
(or (and (not (eq rev :last-release)) rev) branch))
|
||||
(error "Failed to clone %s from %s" name url))))
|
||||
|
||||
;; Check out the latest release if requested
|
||||
(when (eq rev :last-release)
|
||||
(if-let ((release-rev (package-vc--release-rev pkg-desc)))
|
||||
(vc-retrieve-tag dir release-rev)
|
||||
(message "No release revision was found, continuing...")))))
|
||||
|
||||
(defun package-vc--unpack (pkg-desc pkg-spec &optional rev)
|
||||
"Install the package described by PKG-DESC.
|
||||
PKG-SPEC is a package specification, a property list describing
|
||||
how to fetch and build the package. See `package-vc--archive-spec-alist'
|
||||
for details. The optional argument REV specifies a specific revision to
|
||||
checkout. This overrides the `:branch' attribute in PKG-SPEC."
|
||||
(pcase-let* (((map :lisp-dir) pkg-spec)
|
||||
(name (package-desc-name pkg-desc))
|
||||
(dirname (package-desc-full-name pkg-desc))
|
||||
(pkg-dir (expand-file-name dirname package-user-dir)))
|
||||
(setf (package-desc-dir pkg-desc) pkg-dir)
|
||||
(when (file-exists-p pkg-dir)
|
||||
(if (yes-or-no-p "Overwrite previous checkout?")
|
||||
(package--delete-directory pkg-dir)
|
||||
(error "There already exists a checkout for %s" name)))
|
||||
(package-vc--clone pkg-desc pkg-spec pkg-dir rev)
|
||||
|
||||
(when lisp-dir
|
||||
(push (cons :lisp-dir lisp-dir)
|
||||
(package-desc-extras pkg-desc)))
|
||||
(package-vc--unpack-1 pkg-desc pkg-dir)))
|
||||
|
||||
(defun package-vc--read-package-name (prompt &optional allow-url installed)
|
||||
"Query the user for a source package and return a name with PROMPT.
|
||||
If the optional argument ALLOW-URL is non-nil, the user is also
|
||||
allowed to specify a non-package name. If the optional argument
|
||||
INSTALLED is non-nil, the selection will be filtered down to
|
||||
source packages that have already been installed."
|
||||
(package-vc--archives-initialize)
|
||||
(completing-read prompt (if installed package-alist package-archive-contents)
|
||||
(if installed
|
||||
(lambda (pkg) (package-vc-p (cadr pkg)))
|
||||
(lambda (pkg)
|
||||
(or (package-vc--desc->spec (cadr pkg))
|
||||
;; If we have no explicit VC data, we can try a kind of
|
||||
;; heuristic and use the URL header, that might already be
|
||||
;; pointing towards a repository, and use that as a backup
|
||||
(and-let* ((extras (package-desc-extras (cadr pkg)))
|
||||
(url (alist-get :url extras))
|
||||
((package-vc--guess-backend url)))))))
|
||||
(not allow-url)))
|
||||
|
||||
(defun package-vc--read-package-desc (prompt &optional installed)
|
||||
"Query the user for a source package and return a description with PROMPT.
|
||||
If the optional argument INSTALLED is non-nil, the selection will
|
||||
be filtered down to source packages that have already been
|
||||
installed, and the package description will be that of an
|
||||
installed package."
|
||||
(cadr (assoc (package-vc--read-package-name prompt nil installed)
|
||||
(if installed package-alist package-archive-contents)
|
||||
#'string=)))
|
||||
|
||||
;;;###autoload
|
||||
(defun package-vc-update-all ()
|
||||
"Attempt to update all installed VC packages."
|
||||
(interactive)
|
||||
(dolist (package package-alist)
|
||||
(dolist (pkg-desc (cdr package))
|
||||
(when (package-vc-p pkg-desc)
|
||||
(package-vc-update pkg-desc))))
|
||||
(message "Done updating packages."))
|
||||
|
||||
;;;###autoload
|
||||
(defun package-vc-update (pkg-desc)
|
||||
"Attempt to update the package PKG-DESC."
|
||||
(interactive (list (package-vc--read-package-desc "Update source package: " t)))
|
||||
;; HACK: To run `package-vc--unpack-1' after checking out the new
|
||||
;; revision, we insert a hook into `vc-post-command-functions', and
|
||||
;; remove it right after it ran. To avoid running the hook multiple
|
||||
;; times or even for the wrong repository (as `vc-pull' is often
|
||||
;; asynchronous), we extract the relevant arguments using a pseudo
|
||||
;; filter for `vc-filter-command-function', executed only for the
|
||||
;; side effect, and store them in the lexical scope. When the hook
|
||||
;; is run, we check if the arguments are the same (`eq') as the ones
|
||||
;; previously extracted, and only in that case will be call
|
||||
;; `package-vc--unpack-1'. Ugh...
|
||||
;;
|
||||
;; If there is a better way to do this, it should be done.
|
||||
(cl-assert (package-vc-p pkg-desc))
|
||||
(letrec ((pkg-dir (package-desc-dir pkg-desc))
|
||||
(vc-flags)
|
||||
(vc-filter-command-function
|
||||
(lambda (command file-or-list flags)
|
||||
(setq vc-flags flags)
|
||||
(list command file-or-list flags)))
|
||||
(post-upgrade
|
||||
(lambda (_command _file-or-list flags)
|
||||
(when (and (file-equal-p pkg-dir default-directory)
|
||||
(eq flags vc-flags))
|
||||
(unwind-protect
|
||||
(with-demoted-errors "Failed to activate: %S"
|
||||
(package-vc--unpack-1 pkg-desc pkg-dir))
|
||||
(remove-hook 'vc-post-command-functions post-upgrade))))))
|
||||
(add-hook 'vc-post-command-functions post-upgrade)
|
||||
(with-demoted-errors "Failed to fetch: %S"
|
||||
(let ((default-directory pkg-dir))
|
||||
(vc-pull)))))
|
||||
|
||||
(defun package-vc--archives-initialize ()
|
||||
"Initialize package.el and fetch package specifications."
|
||||
(package--archives-initialize)
|
||||
(unless package-vc--archive-data-alist
|
||||
(package-vc--download-and-read-archives)))
|
||||
|
||||
(defun package-vc--release-rev (pkg-desc)
|
||||
"Return the latest revision that bumps the \"Version\" tag for PKG-DESC.
|
||||
If no such revision can be found, return nil."
|
||||
(with-current-buffer (find-file-noselect (package-vc--main-file pkg-desc))
|
||||
(vc-buffer-sync)
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(let ((case-fold-search t))
|
||||
(when (cond
|
||||
((re-search-forward
|
||||
(concat (lm-get-header-re "package-version") ".*$")
|
||||
(lm-code-start) t))
|
||||
((re-search-forward
|
||||
(concat (lm-get-header-re "version") ".*$")
|
||||
(lm-code-start) t)))
|
||||
(ignore-error vc-not-supported
|
||||
(vc-call-backend (vc-backend (buffer-file-name))
|
||||
'last-change
|
||||
(buffer-file-name)
|
||||
(line-number-at-pos nil t))))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun package-vc-install (package &optional name rev backend)
|
||||
"Fetch a PACKAGE and set it up for using with Emacs.
|
||||
|
||||
If PACKAGE is a string containing an URL, download the package
|
||||
from the repository at that URL; the function will try to guess
|
||||
the name of the package from the URL. This can be overridden by
|
||||
passing the optional argument NAME. If PACKAGE is a cons-cell,
|
||||
it should have the form (NAME . SPEC), where NAME is a symbol
|
||||
indicating the package name and SPEC is a plist as described in
|
||||
`package-vc-selected-packages'. Otherwise PACKAGE should be a
|
||||
symbol whose name is the package name, and the URL for the
|
||||
package will be taken from the package's metadata.
|
||||
|
||||
By default, this function installs the last version of the package
|
||||
available from its repository, but if REV is given and non-nil, it
|
||||
specifies the revision to install. If REV has the special value
|
||||
`:last-release' (interactively, the prefix argument), that stands
|
||||
for the last released version of the package.
|
||||
|
||||
Optional argument BACKEND specifies the VC backend to use for cloning
|
||||
the package's repository; this is only possible if NAME-OR-URL is a URL,
|
||||
a string. If BACKEND is omitted or nil, the function
|
||||
uses `package-vc-heuristic-alist' to guess the backend.
|
||||
Note that by default, a source package will be prioritized over a
|
||||
regular package, but it will not remove a source package."
|
||||
(interactive
|
||||
(progn
|
||||
;; Initialize the package system to get the list of package
|
||||
;; symbols for completion.
|
||||
(package-vc--archives-initialize)
|
||||
(let* ((name-or-url (package-vc--read-package-name
|
||||
"Fetch and install package: " t))
|
||||
(name (file-name-base name-or-url)))
|
||||
(list name-or-url (intern (string-remove-prefix "emacs-" name))
|
||||
(and current-prefix-arg :last-release)))))
|
||||
(package-vc--archives-initialize)
|
||||
(cond
|
||||
((null package)
|
||||
(signal 'wrong-type-argument nil))
|
||||
((consp package)
|
||||
(package-vc--unpack
|
||||
(package-desc-create :name (car package)
|
||||
:kind 'vc)
|
||||
(cdr package)
|
||||
rev))
|
||||
((and-let* (((stringp package))
|
||||
(backend (or backend (package-vc--guess-backend package))))
|
||||
(package-vc--unpack
|
||||
(package-desc-create
|
||||
:name (or name (intern (file-name-base package)))
|
||||
:kind 'vc)
|
||||
(list :vc-backend backend :url package)
|
||||
rev)))
|
||||
((and-let* ((desc (assoc package package-archive-contents #'string=)))
|
||||
(package-vc--unpack
|
||||
(let ((copy (copy-package-desc (cadr desc))))
|
||||
(setf (package-desc-kind copy) 'vc)
|
||||
copy)
|
||||
(or (package-vc--desc->spec (cadr desc))
|
||||
(and-let* ((extras (package-desc-extras (cadr desc)))
|
||||
(url (alist-get :url extras))
|
||||
(backend (package-vc--guess-backend url)))
|
||||
(list :vc-backend backend :url url))
|
||||
(user-error "Package `%s' has no VC data" package))
|
||||
rev)))
|
||||
((user-error "Unknown package to fetch: %s" package))))
|
||||
|
||||
;;;###autoload
|
||||
(defun package-vc-checkout (pkg-desc directory &optional rev)
|
||||
"Clone the sources for PKG-DESC into DIRECTORY and visit that directory.
|
||||
Unlike `package-vc-install', this does not yet set up the package
|
||||
for use with Emacs; use `package-vc-link-directory' for setting
|
||||
the package up after this function finishes.
|
||||
Optional argument REV means to clone a specific version of the
|
||||
package; it defaults to the last version available from the
|
||||
package's repository. If REV has the special value
|
||||
`:last-release' (interactively, the prefix argument), that stands
|
||||
for the last released version of the package."
|
||||
(interactive
|
||||
(let* ((name (package-vc--read-package-name "Fetch package source: ")))
|
||||
(list (cadr (assoc name package-archive-contents #'string=))
|
||||
(read-file-name "Clone into new or empty directory: " nil nil t nil
|
||||
(lambda (dir) (or (not (file-exists-p dir))
|
||||
(directory-empty-p dir))))
|
||||
(and current-prefix-arg :last-release))))
|
||||
(package-vc--archives-initialize)
|
||||
(let ((pkg-spec (or (package-vc--desc->spec pkg-desc)
|
||||
(and-let* ((extras (package-desc-extras pkg-desc))
|
||||
(url (alist-get :url extras))
|
||||
(backend (package-vc--guess-backend url)))
|
||||
(list :vc-backend backend :url url))
|
||||
(user-error "Package `%s' has no VC data"
|
||||
(package-desc-name pkg-desc)))))
|
||||
(package-vc--clone pkg-desc pkg-spec directory rev)
|
||||
(find-file directory)))
|
||||
|
||||
;;;###autoload
|
||||
(defun package-vc-install-from-checkout (dir name)
|
||||
"Set up the package NAME in DIR by linking it into the ELPA directory.
|
||||
Interactively, prompt the user for DIR, which should be a directory
|
||||
under version control, typically one created by `package-vc-checkout'.
|
||||
If invoked interactively with a prefix argument, prompt the user
|
||||
for the NAME of the package to set up. Otherwise infer the package
|
||||
name from the base name of DIR."
|
||||
(interactive (let ((dir (read-directory-name "Directory: ")))
|
||||
(list dir
|
||||
(if current-prefix-arg
|
||||
(read-string "Package name: ")
|
||||
(file-name-base (directory-file-name dir))))))
|
||||
(unless (vc-responsible-backend dir)
|
||||
(user-error "Directory %S is not under version control" dir))
|
||||
(package-vc--archives-initialize)
|
||||
(let* ((name (or name (file-name-base (directory-file-name dir))))
|
||||
(pkg-dir (expand-file-name name package-user-dir)))
|
||||
(make-symbolic-link (expand-file-name dir) pkg-dir)
|
||||
(package-vc--unpack-1
|
||||
(package-desc-create
|
||||
:name (intern name)
|
||||
:kind 'vc)
|
||||
(file-name-as-directory pkg-dir))))
|
||||
|
||||
;;;###autoload
|
||||
(defun package-vc-rebuild (pkg-desc)
|
||||
"Rebuild the installation for package given by PKG-DESC.
|
||||
Rebuilding an installation means scraping for new autoload
|
||||
cookies, re-compiling Emacs Lisp files, building and installing
|
||||
any documentation, downloading any missing dependencies. This
|
||||
command does not fetch new revisions from a remote server. That
|
||||
is the responsibility of `package-vc-update'. Interactively,
|
||||
prompt for the name of the package to rebuild."
|
||||
(interactive (list (package-vc--read-package-desc "Rebuild package: " t)))
|
||||
(package-vc--unpack-1 pkg-desc (package-desc-dir pkg-desc)))
|
||||
|
||||
;;;###autoload
|
||||
(defun package-vc-prepare-patch (pkg-desc subject revisions)
|
||||
"Send patch for REVISIONS to maintainer of the package PKG using SUBJECT.
|
||||
The function uses `vc-prepare-patch', passing SUBJECT and
|
||||
REVISIONS directly. PKG-DESC must be a package description.
|
||||
Interactively, prompt for PKG-DESC, SUBJECT, and REVISIONS. When
|
||||
invoked with a numerical prefix argument, use the last N
|
||||
revisions. When invoked interactively in a Log View buffer with
|
||||
marked revisions, use those."
|
||||
(interactive
|
||||
(list (package-vc--read-package-desc "Package to prepare a patch for: " t)
|
||||
(and (not vc-prepare-patches-separately)
|
||||
(read-string "Subject: " "[PATCH] " nil nil t))
|
||||
(vc-prepare-patch-prompt-revisions)))
|
||||
(let ((default-directory (package-desc-dir pkg-desc)))
|
||||
(vc-prepare-patch (package-maintainers pkg-desc t)
|
||||
subject revisions)))
|
||||
|
||||
(provide 'package-vc)
|
||||
;;; package-vc.el ends here
|
||||
|
|
@ -146,6 +146,7 @@
|
|||
(require 'cl-lib)
|
||||
(eval-when-compile (require 'subr-x))
|
||||
(eval-when-compile (require 'epg)) ;For setf accessors.
|
||||
(eval-when-compile (require 'inline)) ;For `define-inline'
|
||||
(require 'seq)
|
||||
|
||||
(require 'tabulated-list)
|
||||
|
|
@ -346,21 +347,28 @@ default directory."
|
|||
|
||||
(defcustom package-check-signature 'allow-unsigned
|
||||
"Non-nil means to check package signatures when installing.
|
||||
More specifically the value can be:
|
||||
- nil: package signatures are ignored.
|
||||
- `allow-unsigned': install a package even if it is unsigned, but
|
||||
if it is signed, we have the key for it, and OpenGPG is
|
||||
installed, verify the signature.
|
||||
- t: accept a package only if it comes with at least one verified signature.
|
||||
- `all': same as t, except when the package has several signatures,
|
||||
in which case we verify all the signatures.
|
||||
|
||||
This also applies to the \"archive-contents\" file that lists the
|
||||
contents of the archive."
|
||||
contents of the archive.
|
||||
|
||||
The value can be one of:
|
||||
|
||||
t Accept a package only if it comes with at least
|
||||
one verified signature.
|
||||
|
||||
`all' Same as t, but verify all signatures if there
|
||||
are more than one.
|
||||
|
||||
`allow-unsigned' Install a package even if it is unsigned,
|
||||
but verify the signature if possible (that
|
||||
is, if it is signed, we have the key for it,
|
||||
and GnuPG is installed).
|
||||
|
||||
nil Package signatures are ignored."
|
||||
:type '(choice (const :value nil :tag "Never")
|
||||
(const :value allow-unsigned :tag "Allow unsigned")
|
||||
(const :value t :tag "Check always")
|
||||
(const :value all :tag "Check all signatures"))
|
||||
(const :value all :tag "Check always (all signatures)"))
|
||||
:risky t
|
||||
:version "27.1")
|
||||
|
||||
|
|
@ -449,6 +457,11 @@ synchronously."
|
|||
|
||||
(defvar package--default-summary "No description available.")
|
||||
|
||||
(define-inline package-vc-p (pkg-desc)
|
||||
"Return non-nil if PKG-DESC is a source package."
|
||||
(inline-letevals (pkg-desc)
|
||||
(inline-quote (eq (package-desc-kind ,pkg-desc) 'vc))))
|
||||
|
||||
(cl-defstruct (package-desc
|
||||
;; Rename the default constructor from `make-package-desc'.
|
||||
(:constructor package-desc-create)
|
||||
|
|
@ -461,14 +474,18 @@ synchronously."
|
|||
&rest rest-plist
|
||||
&aux
|
||||
(name (intern name-string))
|
||||
(version (version-to-list version-string))
|
||||
(version (if (eq (car-safe version-string) 'vc)
|
||||
(version-to-list (cdr version-string))
|
||||
(version-to-list version-string)))
|
||||
(reqs (mapcar (lambda (elt)
|
||||
(list (car elt)
|
||||
(version-to-list (cadr elt))))
|
||||
(if (eq 'quote (car requirements))
|
||||
(nth 1 requirements)
|
||||
requirements)))
|
||||
(kind (plist-get rest-plist :kind))
|
||||
(kind (if (eq (car-safe version-string) 'vc)
|
||||
'vc
|
||||
(plist-get rest-plist :kind)))
|
||||
(archive (plist-get rest-plist :archive))
|
||||
(extras (let (alist)
|
||||
(while rest-plist
|
||||
|
|
@ -560,9 +577,11 @@ This is, approximately, the inverse of `version-to-list'.
|
|||
(defun package-desc-full-name (pkg-desc)
|
||||
"Return full name of package-desc object PKG-DESC.
|
||||
This is the name of the package with its version appended."
|
||||
(format "%s-%s"
|
||||
(package-desc-name pkg-desc)
|
||||
(package-version-join (package-desc-version pkg-desc))))
|
||||
(if (package-vc-p pkg-desc)
|
||||
(symbol-name (package-desc-name pkg-desc))
|
||||
(format "%s-%s"
|
||||
(package-desc-name pkg-desc)
|
||||
(package-version-join (package-desc-version pkg-desc)))))
|
||||
|
||||
(defun package-desc-suffix (pkg-desc)
|
||||
"Return file-name extension of package-desc object PKG-DESC.
|
||||
|
|
@ -593,6 +612,25 @@ package."
|
|||
"Return the priority of the archive of package-desc object PKG-DESC."
|
||||
(package-archive-priority (package-desc-archive pkg-desc)))
|
||||
|
||||
(defun package--parse-elpaignore (pkg-desc)
|
||||
"Return the of regular expression to match files ignored by PKG-DESC."
|
||||
(let* ((pkg-dir (file-name-as-directory (package-desc-dir pkg-desc)))
|
||||
(ignore (expand-file-name ".elpaignore" pkg-dir))
|
||||
files)
|
||||
(when (file-exists-p ignore)
|
||||
(with-temp-buffer
|
||||
(insert-file-contents ignore)
|
||||
(goto-char (point-min))
|
||||
(while (not (eobp))
|
||||
(push (wildcard-to-regexp
|
||||
(let ((line (buffer-substring
|
||||
(line-beginning-position)
|
||||
(line-end-position))))
|
||||
(file-name-concat pkg-dir (string-trim-left line "/"))))
|
||||
files)
|
||||
(forward-line)))
|
||||
files)))
|
||||
|
||||
(cl-defstruct (package--bi-desc
|
||||
(:constructor package-make-builtin (version summary))
|
||||
(:type vector))
|
||||
|
|
@ -641,6 +679,8 @@ loaded and/or activated, customize `package-load-list'.")
|
|||
;; `package-load-all-descriptors', which ultimately populates the
|
||||
;; `package-alist' variable.
|
||||
|
||||
(declare-function package-vc-version "package-vc" (pkg))
|
||||
|
||||
(defun package-process-define-package (exp)
|
||||
"Process define-package expression EXP and push it to `package-alist'.
|
||||
EXP should be a form read from a foo-pkg.el file.
|
||||
|
|
@ -669,6 +709,8 @@ are sorted with the highest version first."
|
|||
nil)))
|
||||
new-pkg-desc)))
|
||||
|
||||
(declare-function package-vc-commit "package-vc" (pkg))
|
||||
|
||||
(defun package-load-descriptor (pkg-dir)
|
||||
"Load the package description file in directory PKG-DIR.
|
||||
Create a new `package-desc' object, add it to `package-alist' and
|
||||
|
|
@ -699,11 +741,9 @@ description file containing a call to `define-package', which
|
|||
updates `package-alist'."
|
||||
(dolist (dir (cons package-user-dir package-directory-list))
|
||||
(when (file-directory-p dir)
|
||||
(dolist (subdir (directory-files dir))
|
||||
(unless (equal subdir "..")
|
||||
(let ((pkg-dir (expand-file-name subdir dir)))
|
||||
(when (file-directory-p pkg-dir)
|
||||
(package-load-descriptor pkg-dir))))))))
|
||||
(dolist (pkg-dir (directory-files dir t "\\`[^.]" t))
|
||||
(when (file-directory-p pkg-dir)
|
||||
(package-load-descriptor pkg-dir))))))
|
||||
|
||||
(defun package--alist ()
|
||||
"Return `package-alist', after computing it if needed."
|
||||
|
|
@ -828,8 +868,7 @@ byte-compilation of the new package to fail."
|
|||
If DEPS is non-nil, also activate its dependencies (unless they
|
||||
are already activated).
|
||||
If RELOAD is non-nil, also `load' any files inside the package which
|
||||
correspond to previously loaded files (those returned by
|
||||
`package--list-loaded-files')."
|
||||
correspond to previously loaded files."
|
||||
(let* ((name (package-desc-name pkg-desc))
|
||||
(pkg-dir (package-desc-dir pkg-desc)))
|
||||
(unless pkg-dir
|
||||
|
|
@ -867,14 +906,22 @@ correspond to previously loaded files (those returned by
|
|||
|
||||
(defun package--get-activatable-pkg (pkg-name)
|
||||
;; Is "activatable" a word?
|
||||
(let ((pkg-descs (cdr (assq pkg-name package-alist))))
|
||||
(let ((pkg-descs (sort (cdr (assq pkg-name package-alist))
|
||||
(lambda (p1 p2)
|
||||
(let ((v1 (package-desc-version p1))
|
||||
(v2 (package-desc-version p2)))
|
||||
(or
|
||||
;; Prefer source packages.
|
||||
(package-vc-p p1)
|
||||
(package-vc-p p2)
|
||||
;; Prefer builtin packages.
|
||||
(package-disabled-p p1 v1)
|
||||
(not (package-disabled-p p2 v2))))))))
|
||||
;; Check if PACKAGE is available in `package-alist'.
|
||||
(while
|
||||
(when pkg-descs
|
||||
(let ((available-version (package-desc-version (car pkg-descs))))
|
||||
(or (package-disabled-p pkg-name available-version)
|
||||
;; Prefer a builtin package.
|
||||
(package-built-in-p pkg-name available-version))))
|
||||
(package-disabled-p pkg-name available-version)))
|
||||
(setq pkg-descs (cdr pkg-descs)))
|
||||
(car pkg-descs)))
|
||||
|
||||
|
|
@ -923,7 +970,7 @@ untar into a directory named DIR; otherwise, signal an error."
|
|||
(or (string-match regexp name)
|
||||
;; Tarballs created by some utilities don't list
|
||||
;; directories with a trailing slash (Bug#13136).
|
||||
(and (string-equal dir name)
|
||||
(and (string-equal (expand-file-name dir) name)
|
||||
(eq (tar-header-link-type tar-data) 5))
|
||||
(error "Package does not untar cleanly into directory %s/" dir)))))
|
||||
(tar-untar-buffer))
|
||||
|
|
@ -952,7 +999,7 @@ untar into a directory named DIR; otherwise, signal an error."
|
|||
;; indistinguishable from a `tar' or a `single'. Let's make
|
||||
;; things simple by ensuring we're one of them.
|
||||
(setf (package-desc-kind pkg-desc)
|
||||
(if (> (length file-list) 1) 'tar 'single))))
|
||||
(if (length> file-list 1) 'tar 'single))))
|
||||
('tar
|
||||
(make-directory package-user-dir t)
|
||||
(let* ((default-directory (file-name-as-directory package-user-dir)))
|
||||
|
|
@ -1015,6 +1062,7 @@ untar into a directory named DIR; otherwise, signal an error."
|
|||
"\n")
|
||||
nil pkg-file nil 'silent))))
|
||||
|
||||
|
||||
;;;; Autoload
|
||||
(declare-function autoload-rubric "autoload" (file &optional type feature))
|
||||
|
||||
|
|
@ -1042,10 +1090,15 @@ untar into a directory named DIR; otherwise, signal an error."
|
|||
(backup-inhibited t)
|
||||
(version-control 'never))
|
||||
(loaddefs-generate
|
||||
pkg-dir output-file
|
||||
nil
|
||||
"(add-to-list 'load-path (directory-file-name
|
||||
(or (file-name-directory #$) (car load-path))))")
|
||||
pkg-dir output-file nil
|
||||
(prin1-to-string
|
||||
'(add-to-list
|
||||
'load-path
|
||||
;; Add the directory that will contain the autoload file to
|
||||
;; the load path. We don't hard-code `pkg-dir', to avoid
|
||||
;; issues if the package directory is moved around.
|
||||
(or (and load-file-name (file-name-directory load-file-name))
|
||||
(car load-path)))))
|
||||
(let ((buf (find-buffer-visiting output-file)))
|
||||
(when buf (kill-buffer buf)))
|
||||
auto-name))
|
||||
|
|
@ -1062,11 +1115,13 @@ untar into a directory named DIR; otherwise, signal an error."
|
|||
|
||||
;;;; Compilation
|
||||
(defvar warning-minimum-level)
|
||||
(defvar byte-compile-ignore-files)
|
||||
(defun package--compile (pkg-desc)
|
||||
"Byte-compile installed package PKG-DESC.
|
||||
This assumes that `pkg-desc' has already been activated with
|
||||
`package-activate-1'."
|
||||
(let ((warning-minimum-level :error)
|
||||
(let ((byte-compile-ignore-files (package--parse-elpaignore pkg-desc))
|
||||
(warning-minimum-level :error)
|
||||
(load-path load-path))
|
||||
(byte-recompile-directory (package-desc-dir pkg-desc) 0 t)))
|
||||
|
||||
|
|
@ -1185,8 +1240,12 @@ Return the pkg-desc, with desc-kind set to KIND."
|
|||
"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))))
|
||||
(let* ((dir-name (named-let loop
|
||||
((filename (tar-header-name (car tar-parse-info))))
|
||||
(let ((dirname (file-name-directory filename)))
|
||||
;; The first file can be in a subdir: look for the top.
|
||||
(if dirname (loop (directory-file-name dirname))
|
||||
(file-name-as-directory filename)))))
|
||||
(desc-file (package--description-file dir-name))
|
||||
(tar-desc (tar-get-file-descriptor (concat dir-name desc-file))))
|
||||
(unless tar-desc
|
||||
|
|
@ -1304,10 +1363,7 @@ is non-nil, don't propagate connection errors (does not apply to
|
|||
errors signaled by ERROR-FORM or by BODY).
|
||||
|
||||
\(fn URL &key ASYNC FILE ERROR-FORM NOERROR &rest BODY)"
|
||||
(declare (indent defun)
|
||||
;; FIXME: This should be something like
|
||||
;; `form def-body &rest form', but that doesn't work.
|
||||
(debug (form &rest sexp)))
|
||||
(declare (indent defun) (debug (sexp body)))
|
||||
(while (keywordp (car body))
|
||||
(setq body (cdr (cdr body))))
|
||||
`(package--with-response-buffer-1 ,url (lambda () ,@body)
|
||||
|
|
@ -1591,13 +1647,19 @@ This is the value of `package-archive-priorities' last time
|
|||
by arbitrary functions to decide whether it is necessary to call
|
||||
it again.")
|
||||
|
||||
(defvar package-read-archive-hook (list #'package-read-archive-contents)
|
||||
"List of functions to call to read the archive contents.
|
||||
Each function must take an optional argument, a symbol indicating
|
||||
what archive to read in. The symbol ought to be a key in
|
||||
`package-archives'.")
|
||||
|
||||
(defun package-read-all-archive-contents ()
|
||||
"Read cached archive file for all archives in `package-archives'.
|
||||
If successful, set or update `package-archive-contents'."
|
||||
(setq package-archive-contents nil)
|
||||
(setq package--old-archive-priorities package-archive-priorities)
|
||||
(dolist (archive package-archives)
|
||||
(package-read-archive-contents (car archive))))
|
||||
(run-hook-with-args 'package-read-archive-hook (car archive))))
|
||||
|
||||
|
||||
;;;; Package Initialize
|
||||
|
|
@ -1723,9 +1785,14 @@ Once it's empty, run `package--post-download-archives-hook'."
|
|||
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'."
|
||||
;; The downloaded archive contents will be read as part of
|
||||
;; `package--update-downloads-in-progress'.
|
||||
(when async
|
||||
(cl-pushnew (cons archive file) package--downloads-in-progress
|
||||
:test #'equal))
|
||||
(package--with-response-buffer (cdr archive) :file file
|
||||
:async async
|
||||
:error-form (package--update-downloads-in-progress archive)
|
||||
:error-form (package--update-downloads-in-progress (cons archive file))
|
||||
(let* ((location (cdr archive))
|
||||
(name (car archive))
|
||||
(content (buffer-string))
|
||||
|
|
@ -1738,10 +1805,10 @@ similar to an entry in `package-alist'. Save the cached copy to
|
|||
;; If we don't care about the signature, save the file and
|
||||
;; we're done.
|
||||
(progn
|
||||
(cl-assert (not enable-multibyte-characters))
|
||||
(let ((coding-system-for-write 'binary))
|
||||
(write-region content nil local-file nil 'silent))
|
||||
(package--update-downloads-in-progress archive))
|
||||
(cl-assert (not enable-multibyte-characters))
|
||||
(let ((coding-system-for-write 'binary))
|
||||
(write-region content nil local-file nil 'silent))
|
||||
(package--update-downloads-in-progress (cons archive file)))
|
||||
;; If we care, check it (perhaps async) and *then* write the file.
|
||||
(package--check-signature
|
||||
location file content async
|
||||
|
|
@ -1754,7 +1821,7 @@ similar to an entry in `package-alist'. Save the cached copy to
|
|||
(when good-sigs
|
||||
(write-region (mapconcat #'epg-signature-to-string good-sigs "\n")
|
||||
nil (concat local-file ".signed") nil 'silent)))
|
||||
(lambda () (package--update-downloads-in-progress archive))))))))
|
||||
(lambda () (package--update-downloads-in-progress (cons archive file)))))))))
|
||||
|
||||
(defun package--download-and-read-archives (&optional async)
|
||||
"Download descriptions of all `package-archives' and read them.
|
||||
|
|
@ -1762,17 +1829,17 @@ Populate `package-archive-contents' with the result.
|
|||
|
||||
If optional argument ASYNC is non-nil, perform the downloads
|
||||
asynchronously."
|
||||
;; The downloaded archive contents will be read as part of
|
||||
;; `package--update-downloads-in-progress'.
|
||||
(dolist (archive package-archives)
|
||||
(cl-pushnew archive package--downloads-in-progress
|
||||
:test #'equal))
|
||||
(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))))))
|
||||
|
||||
(defvar package-refresh-contents-hook (list #'package--download-and-read-archives)
|
||||
"List of functions to call to refresh the package archive.
|
||||
Each function may take an optional argument indicating that the
|
||||
operation ought to be executed asynchronously.")
|
||||
|
||||
;;;###autoload
|
||||
(defun package-refresh-contents (&optional async)
|
||||
"Download descriptions of all configured ELPA packages.
|
||||
|
|
@ -1791,7 +1858,7 @@ downloads in the background."
|
|||
(condition-case-unless-debug error
|
||||
(package-import-keyring default-keyring)
|
||||
(error (message "Cannot import default keyring: %S" (cdr error))))))
|
||||
(package--download-and-read-archives async))
|
||||
(run-hook-with-args 'package-refresh-contents-hook async))
|
||||
|
||||
|
||||
;;; Dependency Management
|
||||
|
|
@ -2025,9 +2092,9 @@ if all the in-between dependencies are also in PACKAGE-LIST."
|
|||
(cdr (assoc (package-desc-archive desc) package-archives)))
|
||||
|
||||
(defun package-install-from-archive (pkg-desc)
|
||||
"Download and install a tar package defined by PKG-DESC."
|
||||
"Download and install a package defined by PKG-DESC."
|
||||
;; This won't happen, unless the archive is doing something wrong.
|
||||
(when (eq (package-desc-kind pkg-desc) 'dir)
|
||||
(when (package-vc-p pkg-desc)
|
||||
(error "Can't install directory package from archive"))
|
||||
(let* ((location (package-archive-base pkg-desc))
|
||||
(file (concat (package-desc-full-name pkg-desc)
|
||||
|
|
@ -2165,17 +2232,22 @@ to install it but still mark it as selected."
|
|||
(message "Package `%s' installed." name))
|
||||
(message "`%s' is already installed" name))))
|
||||
|
||||
(declare-function package-vc-update "package-vc" (pkg))
|
||||
|
||||
;;;###autoload
|
||||
(defun package-update (name)
|
||||
"Update package NAME if a newer version exists."
|
||||
(interactive
|
||||
(list (completing-read
|
||||
"Update package: " (package--updateable-packages) nil t)))
|
||||
(let ((package (if (symbolp name)
|
||||
name
|
||||
(intern name))))
|
||||
(package-delete (cadr (assq package package-alist)) 'force)
|
||||
(package-install package 'dont-select)))
|
||||
(let* ((package (if (symbolp name)
|
||||
name
|
||||
(intern name)))
|
||||
(pkg-desc (cadr (assq package package-alist))))
|
||||
(if (package-vc-p pkg-desc)
|
||||
(package-vc-update pkg-desc)
|
||||
(package-delete pkg-desc 'force)
|
||||
(package-install package 'dont-select))))
|
||||
|
||||
(defun package--updateable-packages ()
|
||||
;; Initialize the package system to get the list of package
|
||||
|
|
@ -2185,12 +2257,13 @@ to install it but still mark it as selected."
|
|||
#'car
|
||||
(seq-filter
|
||||
(lambda (elt)
|
||||
(let ((available
|
||||
(assq (car elt) package-archive-contents)))
|
||||
(and available
|
||||
(version-list-<
|
||||
(package-desc-version (cadr elt))
|
||||
(package-desc-version (cadr available))))))
|
||||
(or (let ((available
|
||||
(assq (car elt) package-archive-contents)))
|
||||
(and available
|
||||
(version-list-<
|
||||
(package-desc-version (cadr elt))
|
||||
(package-desc-version (cadr available)))))
|
||||
(package-vc-p (cadr (assq (car elt) package-alist)))))
|
||||
package-alist)))
|
||||
|
||||
;;;###autoload
|
||||
|
|
@ -2347,15 +2420,19 @@ installed), maybe you need to \\[package-refresh-contents]")
|
|||
pkg))
|
||||
|
||||
(declare-function comp-el-to-eln-filename "comp.c")
|
||||
(defvar package-vc-repository-store)
|
||||
(defun package--delete-directory (dir)
|
||||
"Delete DIR recursively.
|
||||
"Delete PKG-DESC directory DIR recursively.
|
||||
Clean-up the corresponding .eln files if Emacs is native
|
||||
compiled."
|
||||
(when (featurep 'native-compile)
|
||||
(cl-loop
|
||||
for file in (directory-files-recursively dir "\\.el\\'")
|
||||
do (comp-clean-up-stale-eln (comp-el-to-eln-filename file))))
|
||||
(delete-directory dir t))
|
||||
(if (file-symlink-p (directory-file-name dir))
|
||||
(delete-file (directory-file-name dir))
|
||||
(delete-directory dir t)))
|
||||
|
||||
|
||||
(defun package-delete (pkg-desc &optional force nosave)
|
||||
"Delete package PKG-DESC.
|
||||
|
|
@ -2620,7 +2697,10 @@ Helper function for `describe-package'."
|
|||
(incompatible-reason (package--incompatible-p desc))
|
||||
(signed (if desc (package-desc-signed desc)))
|
||||
(maintainer (cdr (assoc :maintainer extras)))
|
||||
(authors (cdr (assoc :authors extras))))
|
||||
(authors (cdr (assoc :authors extras)))
|
||||
(news (and-let* ((file (expand-file-name "news" pkg-dir))
|
||||
((file-readable-p file)))
|
||||
file)))
|
||||
(when (string= status "avail-obso")
|
||||
(setq status "available obsolete"))
|
||||
(when incompatible-reason
|
||||
|
|
@ -2819,6 +2899,14 @@ Helper function for `describe-package'."
|
|||
t)
|
||||
(insert (or readme-string
|
||||
"This package does not provide a description.")))))
|
||||
|
||||
;; Insert news if available.
|
||||
(when news
|
||||
(insert "\n" (make-separator-line) "\n"
|
||||
(propertize "* News" 'face 'package-help-section-name)
|
||||
"\n\n")
|
||||
(insert-file-contents news))
|
||||
|
||||
;; Make library descriptions into links.
|
||||
(goto-char start-of-description)
|
||||
(package--describe-add-library-links)
|
||||
|
|
@ -2909,6 +2997,7 @@ either a full name or nil, and EMAIL is a valid email address."
|
|||
"r" #'revert-buffer
|
||||
"~" #'package-menu-mark-obsolete-for-deletion
|
||||
"w" #'package-browse-url
|
||||
"b" #'package-report-bug
|
||||
"x" #'package-menu-execute
|
||||
"h" #'package-menu-quick-help
|
||||
"H" #'package-menu-hide-package
|
||||
|
|
@ -3067,6 +3156,7 @@ of these dependencies, similar to the list returned by
|
|||
(signed (or (not package-list-unsigned)
|
||||
(package-desc-signed pkg-desc))))
|
||||
(cond
|
||||
((package-vc-p pkg-desc) "source")
|
||||
((eq dir 'builtin) "built-in")
|
||||
((and lle (null held)) "disabled")
|
||||
((stringp held)
|
||||
|
|
@ -3155,8 +3245,9 @@ to their archives."
|
|||
(if (not installed)
|
||||
filtered-by-priority
|
||||
(let ((ins-version (package-desc-version installed)))
|
||||
(cl-remove-if (lambda (p) (version-list-= (package-desc-version p)
|
||||
ins-version))
|
||||
(cl-remove-if (lambda (p) (or (version-list-= (package-desc-version p)
|
||||
ins-version)
|
||||
(package-vc-p installed)))
|
||||
filtered-by-priority))))))))
|
||||
|
||||
(defcustom package-hidden-regexps nil
|
||||
|
|
@ -3358,6 +3449,11 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])."
|
|||
"Face used on the status and version of installed packages."
|
||||
:version "25.1")
|
||||
|
||||
(defface package-status-from-source
|
||||
'((t :inherit font-lock-negation-char-face))
|
||||
"Face used on the status and version of installed packages."
|
||||
:version "29.1")
|
||||
|
||||
(defface package-status-dependency
|
||||
'((t :inherit package-status-installed))
|
||||
"Face used on the status and version of dependency packages."
|
||||
|
|
@ -3395,6 +3491,7 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])."
|
|||
("held" 'package-status-held)
|
||||
("disabled" 'package-status-disabled)
|
||||
("installed" 'package-status-installed)
|
||||
("source" 'package-status-from-source)
|
||||
("dependency" 'package-status-dependency)
|
||||
("unsigned" 'package-status-unsigned)
|
||||
("incompat" 'package-status-incompat)
|
||||
|
|
@ -3406,9 +3503,14 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])."
|
|||
follow-link t
|
||||
package-desc ,pkg
|
||||
action package-menu-describe-package)
|
||||
,(propertize (package-version-join
|
||||
(package-desc-version pkg))
|
||||
'font-lock-face face)
|
||||
,(propertize
|
||||
(if (package-vc-p pkg)
|
||||
(progn
|
||||
(require 'package-vc)
|
||||
(package-vc-commit pkg))
|
||||
(package-version-join
|
||||
(package-desc-version pkg)))
|
||||
'font-lock-face face)
|
||||
,(propertize status 'font-lock-face face)
|
||||
,@(if (cdr package-archives)
|
||||
(list (propertize (or (package-desc-archive pkg) "")
|
||||
|
|
@ -3483,7 +3585,7 @@ If optional arg BUTTON is non-nil, describe its associated package."
|
|||
(interactive "p" package-menu-mode)
|
||||
(package--ensure-package-menu-mode)
|
||||
(if (member (package-menu-get-status)
|
||||
'("installed" "dependency" "obsolete" "unsigned"))
|
||||
'("installed" "source" "dependency" "obsolete" "unsigned"))
|
||||
(tabulated-list-put-tag "D" t)
|
||||
(forward-line)))
|
||||
|
||||
|
|
@ -3839,6 +3941,8 @@ This is used for `tabulated-list-format' in `package-menu-mode'."
|
|||
((string= sB "installed") nil)
|
||||
((string= sA "dependency") t)
|
||||
((string= sB "dependency") nil)
|
||||
((string= sA "source") t)
|
||||
((string= sB "source") nil)
|
||||
((string= sA "unsigned") t)
|
||||
((string= sB "unsigned") nil)
|
||||
((string= sA "held") t)
|
||||
|
|
@ -4132,6 +4236,7 @@ packages."
|
|||
"held"
|
||||
"incompat"
|
||||
"installed"
|
||||
"source"
|
||||
"new"
|
||||
"unsigned")))
|
||||
package-menu-mode)
|
||||
|
|
@ -4203,22 +4308,22 @@ Unlike other filters, this leaves the marks intact."
|
|||
(while (not (eobp))
|
||||
(setq mark (char-after))
|
||||
(unless (eq mark ?\s)
|
||||
(setq pkg-id (tabulated-list-get-id))
|
||||
(setq pkg-id (tabulated-list-get-id))
|
||||
(setq entry (package-menu--print-info-simple pkg-id))
|
||||
(push entry found-entries)
|
||||
;; remember the mark
|
||||
(push (cons pkg-id mark) marks))
|
||||
(push entry found-entries)
|
||||
;; remember the mark
|
||||
(push (cons pkg-id mark) marks))
|
||||
(forward-line))
|
||||
(if found-entries
|
||||
(progn
|
||||
(setq tabulated-list-entries found-entries)
|
||||
(package-menu--display t nil)
|
||||
;; redo the marks, but we must remember the marks!!
|
||||
(goto-char (point-min))
|
||||
(while (not (eobp))
|
||||
(setq mark (cdr (assq (tabulated-list-get-id) marks)))
|
||||
(tabulated-list-put-tag (char-to-string mark) t)))
|
||||
(user-error "No packages found")))))
|
||||
;; redo the marks, but we must remember the marks!!
|
||||
(goto-char (point-min))
|
||||
(while (not (eobp))
|
||||
(setq mark (cdr (assq (tabulated-list-get-id) marks)))
|
||||
(tabulated-list-put-tag (char-to-string mark) t)))
|
||||
(user-error "No packages found")))))
|
||||
|
||||
(defun package-menu-filter-upgradable ()
|
||||
"Filter \"*Packages*\" buffer to show only upgradable packages."
|
||||
|
|
@ -4400,11 +4505,22 @@ beginning of the line."
|
|||
(package-version-join (package-desc-version package-desc))
|
||||
(package-desc-summary package-desc))))
|
||||
|
||||
(defun package--query-desc (&optional alist)
|
||||
"Query the user for a package or return the package at point.
|
||||
The optional argument ALIST must consist of elements with the
|
||||
form (PKG-NAME PKG-DESC). If not specified, it will default to
|
||||
`package-alist'."
|
||||
(or (tabulated-list-get-id)
|
||||
(let ((alist (or alist package-alist)))
|
||||
(cadr (assoc (completing-read "Package: " alist nil t)
|
||||
alist #'string=)))))
|
||||
|
||||
(defun package-browse-url (desc &optional secondary)
|
||||
"Open the website of the package under point in a browser.
|
||||
`browse-url' is used to determine the browser to be used.
|
||||
If SECONDARY (interactively, the prefix), use the secondary browser."
|
||||
(interactive (list (tabulated-list-get-id)
|
||||
`browse-url' is used to determine the browser to be used. If
|
||||
SECONDARY (interactively, the prefix), use the secondary browser.
|
||||
DESC must be a `package-desc' object."
|
||||
(interactive (list (package--query-desc)
|
||||
current-prefix-arg)
|
||||
package-menu-mode)
|
||||
(unless desc
|
||||
|
|
@ -4413,9 +4529,56 @@ If SECONDARY (interactively, the prefix), use the secondary browser."
|
|||
(unless url
|
||||
(user-error "No website for %s" (package-desc-name desc)))
|
||||
(if secondary
|
||||
(funcall browse-url-secondary-browser-function url)
|
||||
(funcall browse-url-secondary-browser-function url)
|
||||
(browse-url url))))
|
||||
|
||||
(declare-function ietf-drums-parse-address "ietf-drums"
|
||||
(string &optional decode))
|
||||
|
||||
(defun package-maintainers (pkg-desc &optional no-error)
|
||||
"Return an email address for the maintainers of PKG-DESC.
|
||||
The email address may contain commas, if there are multiple
|
||||
maintainers. If no maintainers are found, an error will be
|
||||
signaled. If the optional argument NO-ERROR is non-nil no error
|
||||
will be signaled in that case."
|
||||
(unless (package-desc-p pkg-desc)
|
||||
(error "Invalid package description: %S" pkg-desc))
|
||||
(let* ((name (package-desc-name pkg-desc))
|
||||
(extras (package-desc-extras pkg-desc))
|
||||
(maint (alist-get :maintainer extras)))
|
||||
(cond
|
||||
((and (null maint) (null no-error))
|
||||
(user-error "Package `%s' has no explicit maintainer" name))
|
||||
((and (not (progn
|
||||
(require 'ietf-drums)
|
||||
(ietf-drums-parse-address maint)))
|
||||
(null no-error))
|
||||
(user-error "Package `%s' has no maintainer address" name))
|
||||
((not (null maint))
|
||||
(with-temp-buffer
|
||||
(package--print-email-button maint)
|
||||
(string-trim (substring-no-properties (buffer-string))))))))
|
||||
|
||||
(defun package-report-bug (desc)
|
||||
"Prepare a message to send to the maintainers of a package.
|
||||
DESC must be a `package-desc' object."
|
||||
(interactive (list (package--query-desc package-alist))
|
||||
package-menu-mode)
|
||||
(let ((maint (package-maintainers desc))
|
||||
(name (symbol-name (package-desc-name desc)))
|
||||
vars)
|
||||
(dolist-with-progress-reporter (group custom-current-group-alist)
|
||||
"Scanning for modified user options..."
|
||||
(dolist (ent (get (cdr group) 'custom-group))
|
||||
(when (and (custom-variable-p (car ent))
|
||||
(boundp (car ent))
|
||||
(not (eq (custom--standard-value (car ent))
|
||||
(default-toplevel-value (car ent))))
|
||||
(file-in-directory-p (car group) (package-desc-dir desc)))
|
||||
(push (car ent) vars))))
|
||||
(dlet ((reporter-prompt-for-summary-p t))
|
||||
(reporter-submit-bug-report maint name vars))))
|
||||
|
||||
;;;; Introspection
|
||||
|
||||
(defun package-get-descriptor (pkg-name)
|
||||
|
|
|
|||
|
|
@ -211,6 +211,7 @@ Except for Lisp syntax this is the same as `reb-regexp'.")
|
|||
|
||||
(defvar reb-valid-string ""
|
||||
"String in mode line showing validity of RE.")
|
||||
(put 'reb-valid-string 'risky-local-variable t)
|
||||
|
||||
(defconst reb-buffer "*RE-Builder*"
|
||||
"Buffer to use for the RE Builder.")
|
||||
|
|
@ -308,13 +309,13 @@ Except for Lisp syntax this is the same as `reb-regexp'.")
|
|||
"Return t if display is capable of displaying colors."
|
||||
(eq 'color (frame-parameter nil 'display-type)))
|
||||
|
||||
(defsubst reb-lisp-syntax-p ()
|
||||
(defun reb-lisp-syntax-p ()
|
||||
"Return non-nil if RE Builder uses `rx' syntax."
|
||||
(eq reb-re-syntax 'rx))
|
||||
|
||||
(defmacro reb-target-binding (symbol)
|
||||
(defun reb-target-value (symbol)
|
||||
"Return binding for SYMBOL in the RE Builder target buffer."
|
||||
`(with-current-buffer reb-target-buffer ,symbol))
|
||||
(buffer-local-value symbol reb-target-buffer))
|
||||
|
||||
(defun reb-initialize-buffer ()
|
||||
"Initialize the current buffer as a RE Builder buffer."
|
||||
|
|
@ -440,7 +441,7 @@ provided in the Commentary section of this library."
|
|||
(interactive)
|
||||
(reb-update-regexp)
|
||||
(let ((re (with-output-to-string
|
||||
(print (reb-target-binding reb-regexp)))))
|
||||
(print (reb-target-value 'reb-regexp)))))
|
||||
(setq re (substring re 1 (1- (length re))))
|
||||
(setq re (string-replace "\n" "\\n" re))
|
||||
(kill-new re)
|
||||
|
|
@ -518,12 +519,17 @@ An actual update is only done if the regexp has changed or if the
|
|||
optional fourth argument FORCE is non-nil."
|
||||
(let ((prev-valid reb-valid-string)
|
||||
(new-valid
|
||||
(condition-case nil
|
||||
(condition-case err
|
||||
(progn
|
||||
(when (or (reb-update-regexp) force)
|
||||
(reb-do-update))
|
||||
"")
|
||||
(error " *invalid*"))))
|
||||
(error (propertize
|
||||
(format " %s"
|
||||
(if (and (consp (cdr err)) (stringp (cadr err)))
|
||||
(format "%s: %s" (car err) (cadr err))
|
||||
(car err)))
|
||||
'face 'font-lock-warning-face)))))
|
||||
(setq reb-valid-string new-valid)
|
||||
(force-mode-line-update)
|
||||
|
||||
|
|
@ -554,7 +560,7 @@ optional fourth argument FORCE is non-nil."
|
|||
(if reb-subexp-mode
|
||||
(format " (subexp %s)" (or reb-subexp-displayed "-"))
|
||||
"")
|
||||
(if (not (reb-target-binding case-fold-search))
|
||||
(if (not (reb-target-value 'case-fold-search))
|
||||
" Case"
|
||||
"")))
|
||||
(force-mode-line-update))
|
||||
|
|
@ -600,7 +606,7 @@ optional fourth argument FORCE is non-nil."
|
|||
|
||||
(defun reb-insert-regexp ()
|
||||
"Insert current RE."
|
||||
(let ((re (or (reb-target-binding reb-regexp)
|
||||
(let ((re (or (reb-target-value 'reb-regexp)
|
||||
(reb-empty-regexp))))
|
||||
(cond ((eq reb-re-syntax 'read)
|
||||
(print re (current-buffer)))
|
||||
|
|
@ -608,7 +614,7 @@ optional fourth argument FORCE is non-nil."
|
|||
(insert "\n\"" re "\""))
|
||||
;; For the Lisp syntax we need the "source" of the regexp
|
||||
((reb-lisp-syntax-p)
|
||||
(insert (or (reb-target-binding reb-regexp-src)
|
||||
(insert (or (reb-target-value 'reb-regexp-src)
|
||||
(reb-empty-regexp)))))))
|
||||
|
||||
(defun reb-cook-regexp (re)
|
||||
|
|
@ -627,9 +633,8 @@ Return t if the (cooked) expression changed."
|
|||
(prog1
|
||||
(not (string= oldre re))
|
||||
(setq reb-regexp re)
|
||||
;; Only update the source re for the lisp formats
|
||||
(when (reb-lisp-syntax-p)
|
||||
(setq reb-regexp-src re-src)))))))
|
||||
;; Update the source re for the Lisp formats.
|
||||
(setq reb-regexp-src re-src))))))
|
||||
|
||||
|
||||
;; And now the real core of the whole thing
|
||||
|
|
@ -644,7 +649,7 @@ Return t if the (cooked) expression changed."
|
|||
(defun reb-update-overlays (&optional subexp)
|
||||
"Switch to `reb-target-buffer' and mark all matches of `reb-regexp'.
|
||||
If SUBEXP is non-nil mark only the corresponding sub-expressions."
|
||||
(let* ((re (reb-target-binding reb-regexp))
|
||||
(let* ((re (reb-target-value 'reb-regexp))
|
||||
(subexps (reb-count-subexps re))
|
||||
(matches 0)
|
||||
(submatches 0)
|
||||
|
|
|
|||
|
|
@ -125,7 +125,7 @@
|
|||
;;;###autoload
|
||||
(defun read-multiple-choice (prompt choices &optional help-string show-help
|
||||
long-form)
|
||||
"Ask user to select an entry from CHOICES, promting with PROMPT.
|
||||
"Ask user to select an entry from CHOICES, prompting with PROMPT.
|
||||
This function allows to ask the user a multiple-choice question.
|
||||
|
||||
CHOICES should be a list of the form (KEY NAME [DESCRIPTION]).
|
||||
|
|
|
|||
|
|
@ -63,8 +63,7 @@
|
|||
;; preloaded. See also Bug#39761#26.
|
||||
|
||||
(defmacro seq-doseq (spec &rest body)
|
||||
"Loop over a sequence.
|
||||
Evaluate BODY with VAR bound to each element of SEQUENCE, in turn.
|
||||
"Loop over a SEQUENCE, evaluating BODY with VAR bound to each of its elements.
|
||||
|
||||
Similar to `dolist' but can be applied to lists, strings, and vectors.
|
||||
|
||||
|
|
@ -95,7 +94,7 @@ name to be bound to the rest of SEQUENCE."
|
|||
,@body))
|
||||
|
||||
(defmacro seq-setq (args sequence)
|
||||
"Assign to the variables in ARGS the elements of SEQUENCE.
|
||||
"Assign the elements of SEQUENCE to the variables in ARGS.
|
||||
|
||||
ARGS can also include the `&rest' marker followed by a variable
|
||||
name to be bound to the rest of SEQUENCE."
|
||||
|
|
@ -105,7 +104,7 @@ name to be bound to the rest of SEQUENCE."
|
|||
|
||||
;;; Basic seq functions that have to be implemented by new sequence types
|
||||
(cl-defgeneric seq-elt (sequence n)
|
||||
"Return Nth element of SEQUENCE."
|
||||
"Return the Nth element of SEQUENCE."
|
||||
(elt sequence n))
|
||||
|
||||
;; Default gv setters for `seq-elt'.
|
||||
|
|
@ -118,7 +117,7 @@ name to be bound to the rest of SEQUENCE."
|
|||
(setcar (nthcdr n sequence) store))
|
||||
|
||||
(cl-defgeneric seq-length (sequence)
|
||||
"Return the number of elements of SEQUENCE."
|
||||
"Return the number of elements in SEQUENCE."
|
||||
(length sequence))
|
||||
|
||||
(defun seq-first (sequence)
|
||||
|
|
@ -126,11 +125,12 @@ name to be bound to the rest of SEQUENCE."
|
|||
(seq-elt sequence 0))
|
||||
|
||||
(defun seq-rest (sequence)
|
||||
"Return a sequence of the elements of SEQUENCE except the first one."
|
||||
"Return SEQUENCE with its first element removed."
|
||||
(seq-drop sequence 1))
|
||||
|
||||
(cl-defgeneric seq-do (function sequence)
|
||||
"Apply FUNCTION to each element of SEQUENCE, presumably for side effects.
|
||||
"Apply FUNCTION to each element of SEQUENCE.
|
||||
Presumably, FUNCTION has useful side effects.
|
||||
Return SEQUENCE."
|
||||
(mapc function sequence))
|
||||
|
||||
|
|
@ -216,8 +216,9 @@ the sequence, and its index within the sequence."
|
|||
(mapcar function sequence))
|
||||
|
||||
(cl-defgeneric seq-mapn (function sequence &rest sequences)
|
||||
"Like `seq-map' but FUNCTION is mapped over all SEQUENCES.
|
||||
The arity of FUNCTION must match the number of SEQUENCES, and the
|
||||
"Return the result of applying FUNCTION to each element of SEQUENCEs.
|
||||
Like `seq-map', but FUNCTION is mapped over all SEQUENCEs.
|
||||
The arity of FUNCTION must match the number of SEQUENCEs, and the
|
||||
mapping stops on the shortest sequence.
|
||||
Return a list of the results.
|
||||
|
||||
|
|
@ -232,7 +233,7 @@ Return a list of the results.
|
|||
(nreverse result)))
|
||||
|
||||
(cl-defgeneric seq-drop (sequence n)
|
||||
"Remove the first N elements of SEQUENCE and return the result.
|
||||
"Remove the first N elements of SEQUENCE and return the resulting sequence.
|
||||
The result is a sequence of the same type as SEQUENCE.
|
||||
|
||||
If N is a negative integer or zero, SEQUENCE is returned."
|
||||
|
|
@ -243,7 +244,7 @@ If N is a negative integer or zero, SEQUENCE is returned."
|
|||
|
||||
;;;###autoload
|
||||
(cl-defgeneric seq-take (sequence n)
|
||||
"Take the first N elements of SEQUENCE and return the result.
|
||||
"Return the sequence made of the first N elements of SEQUENCE.
|
||||
The result is a sequence of the same type as SEQUENCE.
|
||||
|
||||
If N is a negative integer or zero, an empty sequence is
|
||||
|
|
@ -252,14 +253,17 @@ returned."
|
|||
|
||||
(cl-defgeneric seq-drop-while (pred sequence)
|
||||
"Remove the successive elements of SEQUENCE for which PRED returns non-nil.
|
||||
PRED is a function of one argument. The result is a sequence of
|
||||
the same type as SEQUENCE."
|
||||
PRED is a function of one argument. The function keeps removing
|
||||
elements from SEQUENCE until PRED returns nil for an element.
|
||||
Value is a sequence of the same type as SEQUENCE."
|
||||
(seq-drop sequence (seq--count-successive pred sequence)))
|
||||
|
||||
(cl-defgeneric seq-take-while (pred sequence)
|
||||
"Take the successive elements of SEQUENCE for which PRED returns non-nil.
|
||||
PRED is a function of one argument. The result is a sequence of
|
||||
the same type as SEQUENCE."
|
||||
PRED is a function of one argument. The function keeps collecting
|
||||
elements from SEQUENCE and adding them to the result until PRED
|
||||
returns nil for an element.
|
||||
Value is a sequence of the same type as SEQUENCE."
|
||||
(seq-take sequence (seq--count-successive pred sequence)))
|
||||
|
||||
(cl-defgeneric seq-empty-p (sequence)
|
||||
|
|
@ -267,7 +271,7 @@ the same type as SEQUENCE."
|
|||
(= 0 (seq-length sequence)))
|
||||
|
||||
(cl-defgeneric seq-sort (pred sequence)
|
||||
"Sort SEQUENCE using PRED as comparison function.
|
||||
"Sort SEQUENCE using PRED as the sorting comparison function.
|
||||
The result is a sequence of the same type as SEQUENCE."
|
||||
(let ((result (seq-sort pred (append sequence nil))))
|
||||
(seq-into result (type-of sequence))))
|
||||
|
|
@ -277,7 +281,7 @@ The result is a sequence of the same type as SEQUENCE."
|
|||
|
||||
;;;###autoload
|
||||
(defun seq-sort-by (function pred sequence)
|
||||
"Sort SEQUENCE using PRED as a comparison function.
|
||||
"Sort SEQUENCE transformed by FUNCTION using PRED as the comparison function.
|
||||
Elements of SEQUENCE are transformed by FUNCTION before being
|
||||
sorted. FUNCTION must be a function of one argument."
|
||||
(seq-sort (lambda (a b)
|
||||
|
|
@ -300,7 +304,7 @@ sorted. FUNCTION must be a function of one argument."
|
|||
|
||||
(cl-defgeneric seq-concatenate (type &rest sequences)
|
||||
"Concatenate SEQUENCES into a single sequence of type TYPE.
|
||||
TYPE must be one of following symbols: vector, string or list.
|
||||
TYPE must be one of following symbols: `vector', `string' or `list'.
|
||||
|
||||
\n(fn TYPE SEQUENCE...)"
|
||||
(setq sequences (mapcar #'seq-into-sequence sequences))
|
||||
|
|
@ -322,8 +326,8 @@ of sequence."
|
|||
|
||||
(cl-defgeneric seq-into (sequence type)
|
||||
"Concatenate the elements of SEQUENCE into a sequence of type TYPE.
|
||||
TYPE can be one of the following symbols: vector, string or
|
||||
list."
|
||||
TYPE can be one of the following symbols: `vector', `string' or
|
||||
`list'."
|
||||
(pcase type
|
||||
(`vector (seq--into-vector sequence))
|
||||
(`string (seq--into-string sequence))
|
||||
|
|
@ -332,7 +336,7 @@ list."
|
|||
|
||||
;;;###autoload
|
||||
(cl-defgeneric seq-filter (pred sequence)
|
||||
"Return a list of all elements for which (PRED element) is non-nil in SEQUENCE."
|
||||
"Return a list of all the elements in SEQUENCE for which PRED returns non-nil."
|
||||
(let ((exclude (make-symbol "exclude")))
|
||||
(delq exclude (seq-map (lambda (elt)
|
||||
(if (funcall pred elt)
|
||||
|
|
@ -342,13 +346,13 @@ list."
|
|||
|
||||
;;;###autoload
|
||||
(cl-defgeneric seq-remove (pred sequence)
|
||||
"Return a list of all the elements for which (PRED element) is nil in SEQUENCE."
|
||||
"Return a list of all the elements in SEQUENCE for which PRED returns nil."
|
||||
(seq-filter (lambda (elt) (not (funcall pred elt)))
|
||||
sequence))
|
||||
|
||||
;;;###autoload
|
||||
(cl-defgeneric seq-remove-at-position (sequence n)
|
||||
"Return a copy of SEQUENCE where the element at N got removed.
|
||||
"Return a copy of SEQUENCE with the element at index N removed.
|
||||
|
||||
N is the (zero-based) index of the element that should not be in
|
||||
the result.
|
||||
|
|
@ -381,7 +385,7 @@ If SEQUENCE is empty, return INITIAL-VALUE and FUNCTION is not called."
|
|||
|
||||
;;;###autoload
|
||||
(cl-defgeneric seq-every-p (pred sequence)
|
||||
"Return non-nil if (PRED element) is non-nil for all elements of SEQUENCE."
|
||||
"Return non-nil if PRED returns non-nil for all the elements of SEQUENCE."
|
||||
(catch 'seq--break
|
||||
(seq-doseq (elt sequence)
|
||||
(or (funcall pred elt)
|
||||
|
|
@ -390,8 +394,8 @@ If SEQUENCE is empty, return INITIAL-VALUE and FUNCTION is not called."
|
|||
|
||||
;;;###autoload
|
||||
(cl-defgeneric seq-some (pred sequence)
|
||||
"Return non-nil if PRED is satisfied for at least one element of SEQUENCE.
|
||||
If so, return the first non-nil value returned by PRED."
|
||||
"Return non-nil if PRED returns non-nil for at least one element of SEQUENCE.
|
||||
If the value is non-nil, it is the first non-nil value returned by PRED."
|
||||
(catch 'seq--break
|
||||
(seq-doseq (elt sequence)
|
||||
(let ((result (funcall pred elt)))
|
||||
|
|
@ -401,12 +405,12 @@ If so, return the first non-nil value returned by PRED."
|
|||
|
||||
;;;###autoload
|
||||
(cl-defgeneric seq-find (pred sequence &optional default)
|
||||
"Return the first element for which (PRED element) is non-nil in SEQUENCE.
|
||||
If no element is found, return DEFAULT.
|
||||
"Return the first element in SEQUENCE for which PRED returns non-nil.
|
||||
If no such element is found, return DEFAULT.
|
||||
|
||||
Note that `seq-find' has an ambiguity if the found element is
|
||||
identical to DEFAULT, as it cannot be known if an element was
|
||||
found or not."
|
||||
identical to DEFAULT, as in that case it is impossible to know
|
||||
whether an element was found or not."
|
||||
(catch 'seq--break
|
||||
(seq-doseq (elt sequence)
|
||||
(when (funcall pred elt)
|
||||
|
|
@ -414,7 +418,7 @@ found or not."
|
|||
default))
|
||||
|
||||
(cl-defgeneric seq-count (pred sequence)
|
||||
"Return the number of elements for which (PRED element) is non-nil in SEQUENCE."
|
||||
"Return the number of elements in SEQUENCE for which PRED returns non-nil."
|
||||
(let ((count 0))
|
||||
(seq-doseq (elt sequence)
|
||||
(when (funcall pred elt)
|
||||
|
|
@ -422,8 +426,8 @@ found or not."
|
|||
count))
|
||||
|
||||
(cl-defgeneric seq-contains (sequence elt &optional testfn)
|
||||
"Return the first element in SEQUENCE that is equal to ELT.
|
||||
Equality is defined by the function TESTFN, which defaults to `equal'."
|
||||
"Return the first element in SEQUENCE that is \"equal\" to ELT.
|
||||
\"Equality\" is defined by the function TESTFN, which defaults to `equal'."
|
||||
(declare (obsolete seq-contains-p "27.1"))
|
||||
(seq-some (lambda (e)
|
||||
(when (funcall (or testfn #'equal) elt e)
|
||||
|
|
@ -431,8 +435,8 @@ Equality is defined by the function TESTFN, which defaults to `equal'."
|
|||
sequence))
|
||||
|
||||
(cl-defgeneric seq-contains-p (sequence elt &optional testfn)
|
||||
"Return non-nil if SEQUENCE contains an element equal to ELT.
|
||||
Equality is defined by the function TESTFN, which defaults to `equal'."
|
||||
"Return non-nil if SEQUENCE contains an element \"equal\" to ELT.
|
||||
\"Equality\" is defined by the function TESTFN, which defaults to `equal'."
|
||||
(catch 'seq--break
|
||||
(seq-doseq (e sequence)
|
||||
(let ((r (funcall (or testfn #'equal) e elt)))
|
||||
|
|
@ -442,15 +446,16 @@ Equality is defined by the function TESTFN, which defaults to `equal'."
|
|||
|
||||
(cl-defgeneric seq-set-equal-p (sequence1 sequence2 &optional testfn)
|
||||
"Return non-nil if SEQUENCE1 and SEQUENCE2 contain the same elements.
|
||||
This does not depend on the order of the elements.
|
||||
Equality is defined by the function TESTFN, which defaults to `equal'."
|
||||
The order of the elements in the sequences is not important.
|
||||
\"Equality\" of elements is defined by the function TESTFN, which
|
||||
defaults to `equal'."
|
||||
(and (seq-every-p (lambda (item1) (seq-contains-p sequence2 item1 testfn)) sequence1)
|
||||
(seq-every-p (lambda (item2) (seq-contains-p sequence1 item2 testfn)) sequence2)))
|
||||
|
||||
;;;###autoload
|
||||
(cl-defgeneric seq-position (sequence elt &optional testfn)
|
||||
"Return the (zero-based) index of the first element in SEQUENCE equal to ELT.
|
||||
Equality is defined by the function TESTFN, which defaults to `equal'."
|
||||
"Return the (zero-based) index of the first element in SEQUENCE \"equal\" to ELT.
|
||||
\"Equality\" is defined by the function TESTFN, which defaults to `equal'."
|
||||
(let ((index 0))
|
||||
(catch 'seq--break
|
||||
(seq-doseq (e sequence)
|
||||
|
|
@ -461,11 +466,11 @@ Equality is defined by the function TESTFN, which defaults to `equal'."
|
|||
|
||||
;;;###autoload
|
||||
(cl-defgeneric seq-positions (sequence elt &optional testfn)
|
||||
"Return indices for which (TESTFN (seq-elt SEQUENCE index) ELT) is non-nil.
|
||||
"Return list of indices of SEQUENCE elements for which TESTFN returns non-nil.
|
||||
|
||||
TESTFN is a two-argument function which is passed each element of
|
||||
SEQUENCE as first argument and ELT as second. TESTFN defaults to
|
||||
`equal'.
|
||||
TESTFN is a two-argument function which is called with each element of
|
||||
SEQUENCE as the first argument and ELT as the second.
|
||||
TESTFN defaults to `equal'.
|
||||
|
||||
The result is a list of (zero-based) indices."
|
||||
(let ((result '()))
|
||||
|
|
@ -479,7 +484,7 @@ The result is a list of (zero-based) indices."
|
|||
;;;###autoload
|
||||
(cl-defgeneric seq-uniq (sequence &optional testfn)
|
||||
"Return a list of the elements of SEQUENCE with duplicates removed.
|
||||
TESTFN is used to compare elements, or `equal' if TESTFN is nil."
|
||||
TESTFN is used to compare elements, and defaults to `equal'."
|
||||
(let ((result '()))
|
||||
(seq-doseq (elt sequence)
|
||||
(unless (seq-contains-p result elt testfn)
|
||||
|
|
@ -514,15 +519,15 @@ TESTFN is used to compare elements, or `equal' if TESTFN is nil."
|
|||
(nreverse result)))
|
||||
|
||||
(cl-defgeneric seq-mapcat (function sequence &optional type)
|
||||
"Concatenate the result of applying FUNCTION to each element of SEQUENCE.
|
||||
The result is a sequence of type TYPE, or a list if TYPE is nil."
|
||||
"Concatenate the results of applying FUNCTION to each element of SEQUENCE.
|
||||
The result is a sequence of type TYPE; TYPE defaults to `list'."
|
||||
(apply #'seq-concatenate (or type 'list)
|
||||
(seq-map function sequence)))
|
||||
|
||||
(cl-defgeneric seq-partition (sequence n)
|
||||
"Return list of elements of SEQUENCE grouped into sub-sequences of length N.
|
||||
The last sequence may contain less than N elements. If N is a
|
||||
negative integer or 0, nil is returned."
|
||||
negative integer or 0, the function returns nil."
|
||||
(unless (< n 1)
|
||||
(let ((result '()))
|
||||
(while (not (seq-empty-p sequence))
|
||||
|
|
@ -532,8 +537,9 @@ negative integer or 0, nil is returned."
|
|||
|
||||
;;;###autoload
|
||||
(cl-defgeneric seq-union (sequence1 sequence2 &optional testfn)
|
||||
"Return a list of all elements that appear in either SEQUENCE1 or SEQUENCE2.
|
||||
Equality is defined by the function TESTFN, which defaults to `equal'."
|
||||
"Return a list of all the elements that appear in either SEQUENCE1 or SEQUENCE2.
|
||||
\"Equality\" of elements is defined by the function TESTFN, which
|
||||
defaults to `equal'."
|
||||
(let* ((accum (lambda (acc elt)
|
||||
(if (seq-contains-p acc elt testfn)
|
||||
acc
|
||||
|
|
@ -544,8 +550,9 @@ Equality is defined by the function TESTFN, which defaults to `equal'."
|
|||
|
||||
;;;###autoload
|
||||
(cl-defgeneric seq-intersection (sequence1 sequence2 &optional testfn)
|
||||
"Return a list of the elements that appear in both SEQUENCE1 and SEQUENCE2.
|
||||
Equality is defined by the function TESTFN, which defaults to `equal'."
|
||||
"Return a list of all the elements that appear in both SEQUENCE1 and SEQUENCE2.
|
||||
\"Equality\" of elements is defined by the function TESTFN, which
|
||||
defaults to `equal'."
|
||||
(seq-reduce (lambda (acc elt)
|
||||
(if (seq-contains-p sequence2 elt testfn)
|
||||
(cons elt acc)
|
||||
|
|
@ -554,8 +561,9 @@ Equality is defined by the function TESTFN, which defaults to `equal'."
|
|||
'()))
|
||||
|
||||
(cl-defgeneric seq-difference (sequence1 sequence2 &optional testfn)
|
||||
"Return a list of the elements that appear in SEQUENCE1 but not in SEQUENCE2.
|
||||
Equality is defined by the function TESTFN, which defaults to `equal'."
|
||||
"Return list of all the elements that appear in SEQUENCE1 but not in SEQUENCE2.
|
||||
\"Equality\" of elements is defined by the function TESTFN, which
|
||||
defaults to `equal'."
|
||||
(seq-reduce (lambda (acc elt)
|
||||
(if (seq-contains-p sequence2 elt testfn)
|
||||
acc
|
||||
|
|
@ -591,7 +599,7 @@ SEQUENCE must be a sequence of numbers or markers."
|
|||
(apply #'max (seq-into sequence 'list)))
|
||||
|
||||
(defun seq--count-successive (pred sequence)
|
||||
"Count successive elements for which (PRED element) is non-nil in SEQUENCE."
|
||||
"Count successive elements in SEQUENCE for which PRED returns non-nil."
|
||||
(let ((n 0)
|
||||
(len (seq-length sequence)))
|
||||
(while (and (< n len)
|
||||
|
|
@ -628,13 +636,13 @@ SEQUENCE must be a sequence of numbers or markers."
|
|||
|
||||
;; TODO: make public?
|
||||
(defun seq--elt-safe (sequence n)
|
||||
"Return element of SEQUENCE at the index N.
|
||||
"Return the element of SEQUENCE whose zero-based index is N.
|
||||
If no element is found, return nil."
|
||||
(ignore-errors (seq-elt sequence n)))
|
||||
|
||||
;;;###autoload
|
||||
(cl-defgeneric seq-random-elt (sequence)
|
||||
"Return a random element from SEQUENCE.
|
||||
"Return a randomly chosen element from SEQUENCE.
|
||||
Signal an error if SEQUENCE is empty."
|
||||
(if (seq-empty-p sequence)
|
||||
(error "Sequence cannot be empty")
|
||||
|
|
@ -681,8 +689,8 @@ Signal an error if SEQUENCE is empty."
|
|||
(concat sequence)))
|
||||
|
||||
(defun seq-split (sequence length)
|
||||
"Split SEQUENCE into a list of sub-sequences of at most LENGTH.
|
||||
All the sub-sequences will be of LENGTH, except the last one,
|
||||
"Split SEQUENCE into a list of sub-sequences of at most LENGTH elements.
|
||||
All the sub-sequences will be LENGTH long, except the last one,
|
||||
which may be shorter."
|
||||
(when (< length 1)
|
||||
(error "Sub-sequence length must be larger than zero"))
|
||||
|
|
@ -696,7 +704,7 @@ which may be shorter."
|
|||
(nreverse result)))
|
||||
|
||||
(defun seq-keep (function sequence)
|
||||
"Apply FUNCTION to SEQUENCE and return all non-nil results."
|
||||
"Apply FUNCTION to SEQUENCE and return the list of all the non-nil results."
|
||||
(delq nil (seq-map function sequence)))
|
||||
|
||||
(provide 'seq)
|
||||
|
|
|
|||
|
|
@ -833,7 +833,7 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
|
|||
(seq-set-equal-p
|
||||
:eval (seq-set-equal-p '(1 2 3) '(3 1 2)))
|
||||
(seq-some
|
||||
:eval (seq-some #'cl-evenp '(1 2 3)))
|
||||
:eval (seq-some #'floatp '(1 2.0 3)))
|
||||
"Building Sequences"
|
||||
(seq-concatenate
|
||||
:eval (seq-concatenate 'vector '(1 2) '(c d)))
|
||||
|
|
@ -897,13 +897,15 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
|
|||
:eval (seq-drop-while #'numberp '(1 2 c d 5)))
|
||||
(seq-filter
|
||||
:eval (seq-filter #'numberp '(a b 3 4 f 6)))
|
||||
(seq-keep
|
||||
:eval (seq-keep #'car-safe '((1 2) 3 t (a . b))))
|
||||
(seq-remove
|
||||
:eval (seq-remove #'numberp '(1 2 c d 5)))
|
||||
(seq-remove-at-position
|
||||
:eval (seq-remove-at-position '(a b c d e) 3)
|
||||
:eval (seq-remove-at-position [a b c d e] 0))
|
||||
(seq-group-by
|
||||
:eval (seq-group-by #'cl-plusp '(-1 2 3 -4 -5 6)))
|
||||
:eval (seq-group-by #'natnump '(-1 2 3 -4 -5 6)))
|
||||
(seq-union
|
||||
:eval (seq-union '(1 2 3) '(3 5)))
|
||||
(seq-difference
|
||||
|
|
@ -919,7 +921,7 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
|
|||
(seq-split
|
||||
:eval (seq-split [0 1 2 3 5] 2))
|
||||
(seq-take-while
|
||||
:eval (seq-take-while #'cl-evenp [2 4 9 6 5]))
|
||||
:eval (seq-take-while #'integerp [1 2 3.0 4]))
|
||||
(seq-uniq
|
||||
:eval (seq-uniq '(a b d b a c))))
|
||||
|
||||
|
|
@ -1372,13 +1374,20 @@ If SAME-WINDOW, don't pop to a new window."
|
|||
(unless (bobp)
|
||||
(insert "\n"))
|
||||
(insert (propertize
|
||||
(concat (substitute-command-keys data) "\n\n")
|
||||
(substitute-command-keys data)
|
||||
'face 'shortdoc-heading
|
||||
'shortdoc-section t
|
||||
'outline-level 1))
|
||||
(insert (propertize
|
||||
"\n\n"
|
||||
'face 'shortdoc-heading
|
||||
'shortdoc-section t)))
|
||||
;; There may be functions not yet defined in the data.
|
||||
((fboundp (car data))
|
||||
(when prev
|
||||
(insert (make-separator-line)))
|
||||
(insert (make-separator-line)
|
||||
;; This helps with hidden outlines (bug#53981)
|
||||
(propertize "\n" 'face '(:height 0))))
|
||||
(setq prev t)
|
||||
(shortdoc--display-function data))))
|
||||
(cdr (assq group shortdoc--groups))))
|
||||
|
|
@ -1395,7 +1404,7 @@ If SAME-WINDOW, don't pop to a new window."
|
|||
(start-section (point))
|
||||
arglist-start)
|
||||
;; Function calling convention.
|
||||
(insert (propertize "(" 'shortdoc-function function))
|
||||
(insert (propertize "(" 'shortdoc-function function 'outline-level 2))
|
||||
(if (plist-get data :no-manual)
|
||||
(insert-text-button
|
||||
(symbol-name function)
|
||||
|
|
@ -1529,7 +1538,10 @@ Example:
|
|||
|
||||
(define-derived-mode shortdoc-mode special-mode "shortdoc"
|
||||
"Mode for shortdoc."
|
||||
:interactive nil)
|
||||
:interactive nil
|
||||
(setq-local outline-search-function #'outline-search-level
|
||||
outline-level (lambda ()
|
||||
(get-text-property (point) 'outline-level))))
|
||||
|
||||
(defun shortdoc--goto-section (arg sym &optional reverse)
|
||||
(unless (natnump arg)
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@
|
|||
;; which includes a kind of tutorial to get started with SMIE:
|
||||
;;
|
||||
;; SMIE: Weakness is Power! Auto-indentation with incomplete information
|
||||
;; Stefan Monnier, <Programming> Journal 2020, volumn 5, issue 1.
|
||||
;; Stefan Monnier, <Programming> Journal 2020, volume 5, issue 1.
|
||||
;; doi: 10.22152/programming-journal.org/2021/5/1
|
||||
|
||||
;; A good background to understand the development (especially the parts
|
||||
|
|
|
|||
|
|
@ -322,6 +322,10 @@ as the new values of the bound variables in the recursive invocation."
|
|||
;; Keeping a work buffer around is more efficient than creating a
|
||||
;; new temporary buffer.
|
||||
(with-current-buffer (get-buffer-create " *string-pixel-width*")
|
||||
;; `display-line-numbers-mode' is enabled in internal buffers
|
||||
;; that breaks width calculation, so need to disable (bug#59311)
|
||||
(when (bound-and-true-p display-line-numbers-mode)
|
||||
(display-line-numbers-mode -1))
|
||||
(delete-region (point-min) (point-max))
|
||||
(insert string)
|
||||
(car (buffer-text-pixel-size nil nil t)))))
|
||||
|
|
|
|||
|
|
@ -374,7 +374,7 @@ Optional arg POS is a buffer position where to look for a fake header;
|
|||
defaults to `point-min'."
|
||||
(overlays-at (or pos (point-min))))
|
||||
|
||||
(defun tabulated-list-revert (&rest ignored)
|
||||
(defun tabulated-list-revert (&rest _ignored)
|
||||
"The `revert-buffer-function' for `tabulated-list-mode'.
|
||||
It runs `tabulated-list-revert-hook', then calls `tabulated-list-print'."
|
||||
(interactive)
|
||||
|
|
|
|||
|
|
@ -569,7 +569,7 @@ spreadsheet files with invalid formatting."
|
|||
(signal 'singularity-error nil)) ;Shouldn't get here
|
||||
(singularity-error (error "No error from %s?" x))
|
||||
(error nil)))
|
||||
;;Test quit-handling in ses-update-cells. Cant' use `eval' here.
|
||||
;; Test quit-handling in ses-update-cells. Can't use `eval' here.
|
||||
(let ((inhibit-quit t))
|
||||
(setq quit-flag t)
|
||||
(condition-case nil
|
||||
|
|
|
|||
|
|
@ -208,8 +208,14 @@ and if a matching region is found, place point at the start of the region."
|
|||
(goto-char end)
|
||||
(setq ended t)))))
|
||||
;; End this at the first place the property changes value.
|
||||
(setq end (previous-single-property-change
|
||||
(point) property nil (point-min)))
|
||||
(setq end
|
||||
(if (and (> (point) (point-min))
|
||||
(text-property--match-p
|
||||
value (get-text-property (1- (point)) property)
|
||||
predicate))
|
||||
(previous-single-property-change (point)
|
||||
property nil (point-min))
|
||||
(point)))
|
||||
(goto-char end))
|
||||
(make-prop-match :beginning end
|
||||
:end (1+ start)
|
||||
|
|
|
|||
|
|
@ -353,6 +353,11 @@ This also updates the displayed table."
|
|||
(let* ((cache (vtable--cache table))
|
||||
(inhibit-read-only t)
|
||||
(keymap (get-text-property (point) 'keymap))
|
||||
(ellipsis (if (vtable-ellipsis table)
|
||||
(propertize (truncate-string-ellipsis)
|
||||
'face (vtable-face table))
|
||||
""))
|
||||
(ellipsis-width (string-pixel-width ellipsis))
|
||||
(elem (and after-object
|
||||
(assq after-object (car cache))))
|
||||
(line (cons object (vtable--compute-cached-line table object))))
|
||||
|
|
@ -370,7 +375,8 @@ This also updates the displayed table."
|
|||
;; FIXME: We have to adjust colors in lines below this if we
|
||||
;; have :row-colors.
|
||||
(vtable--insert-line table line 0
|
||||
(nth 1 cache) (vtable--spacer table))
|
||||
(nth 1 cache) (vtable--spacer table)
|
||||
ellipsis ellipsis-width)
|
||||
(add-text-properties start (point) (list 'keymap keymap
|
||||
'vtable table)))
|
||||
;; We may have inserted a non-numerical value into a previously
|
||||
|
|
@ -516,7 +522,8 @@ This also updates the displayed table."
|
|||
(if (> (nth 1 elem) (elt widths index))
|
||||
(concat
|
||||
(vtable--limit-string
|
||||
pre-computed (- (elt widths index) ellipsis-width))
|
||||
pre-computed (- (elt widths index)
|
||||
(or ellipsis-width 0)))
|
||||
ellipsis)
|
||||
pre-computed))
|
||||
;; Recompute widths.
|
||||
|
|
@ -524,7 +531,8 @@ This also updates the displayed table."
|
|||
(if (> (string-pixel-width value) (elt widths index))
|
||||
(concat
|
||||
(vtable--limit-string
|
||||
value (- (elt widths index) ellipsis-width))
|
||||
value (- (elt widths index)
|
||||
(or ellipsis-width 0)))
|
||||
ellipsis)
|
||||
value))))
|
||||
(start (point))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue