diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 189 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cconv.el | 15 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-lib.el | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-loaddefs.el | 11 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 50 | ||||
| -rw-r--r-- | lisp/emacs-lisp/edebug.el | 5 | ||||
| -rw-r--r-- | lisp/emacs-lisp/generic.el | 89 | ||||
| -rw-r--r-- | lisp/emacs-lisp/lisp-mode.el | 9 | ||||
| -rw-r--r-- | lisp/emacs-lisp/macroexp.el | 15 | ||||
| -rw-r--r-- | lisp/emacs-lisp/package-x.el | 63 | ||||
| -rw-r--r-- | lisp/emacs-lisp/package.el | 378 | ||||
| -rw-r--r-- | lisp/emacs-lisp/smie.el | 175 |
12 files changed, 545 insertions, 458 deletions
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index c910acdbc14..e603f76f41d 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -411,6 +411,9 @@ specify different fields to sort on." (defvar byte-compile-bound-variables nil "List of dynamic variables bound in the context of the current form. This list lives partly on the stack.") +(defvar byte-compile-lexical-variables nil + "List of variables that have been treated as lexical. +Filled in `cconv-analyse-form' but initialized and consulted here.") (defvar byte-compile-const-variables nil "List of variables declared as constants during compilation of this file.") (defvar byte-compile-free-references) @@ -1489,6 +1492,7 @@ extra args." (byte-compile--outbuffer nil) (byte-compile-function-environment nil) (byte-compile-bound-variables nil) + (byte-compile-lexical-variables nil) (byte-compile-const-variables nil) (byte-compile-free-references nil) (byte-compile-free-assignments nil) @@ -2245,15 +2249,24 @@ list that represents a doc string reference. (put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar) (put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar) -(defun byte-compile-file-form-defvar (form) - (when (and (symbolp (nth 1 form)) - (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) + +(defun byte-compile--declare-var (sym) + (when (and (symbolp sym) + (not (string-match "[-*/:$]" (symbol-name sym))) (byte-compile-warning-enabled-p 'lexical)) (byte-compile-warn "global/dynamic var `%s' lacks a prefix" - (nth 1 form))) - (push (nth 1 form) byte-compile-bound-variables) - (if (eq (car form) 'defconst) - (push (nth 1 form) byte-compile-const-variables)) + sym)) + (when (memq sym byte-compile-lexical-variables) + (setq byte-compile-lexical-variables + (delq sym byte-compile-lexical-variables)) + (byte-compile-warn "Variable `%S' declared after its first use" sym)) + (push sym byte-compile-bound-variables)) + +(defun byte-compile-file-form-defvar (form) + (let ((sym (nth 1 form))) + (byte-compile--declare-var sym) + (if (eq (car form) 'defconst) + (push sym byte-compile-const-variables))) (if (and (null (cddr form)) ;No `value' provided. (eq (car form) 'defvar)) ;Just a declaration. nil @@ -2267,7 +2280,7 @@ list that represents a doc string reference. 'byte-compile-file-form-define-abbrev-table) (defun byte-compile-file-form-define-abbrev-table (form) (if (eq 'quote (car-safe (car-safe (cdr form)))) - (push (car-safe (cdr (cadr form))) byte-compile-bound-variables)) + (byte-compile--declare-var (car-safe (cdr (cadr form))))) (byte-compile-keep-pending form)) (put 'custom-declare-variable 'byte-hunk-handler @@ -2275,7 +2288,7 @@ list that represents a doc string reference. (defun byte-compile-file-form-custom-declare-variable (form) (when (byte-compile-warning-enabled-p 'callargs) (byte-compile-nogroup-warn form)) - (push (nth 1 (nth 1 form)) byte-compile-bound-variables) + (byte-compile--declare-var (nth 1 (nth 1 form))) (byte-compile-keep-pending form)) (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) @@ -2576,19 +2589,16 @@ If FORM is a lambda or a macro, byte-compile it as a function." "Return a list of the variables in the lambda argument list ARGLIST." (remq '&rest (remq '&optional arglist))) -(defun byte-compile-make-lambda-lexenv (form) +(defun byte-compile-make-lambda-lexenv (args) "Return a new lexical environment for a lambda expression FORM." - ;; See if this is a closure or not - (let ((args (byte-compile-arglist-vars (cadr form)))) - (let ((lexenv nil)) - ;; Fill in the initial stack contents - (let ((stackpos 0)) - ;; Add entries for each argument - (dolist (arg args) - (push (cons arg stackpos) lexenv) - (setq stackpos (1+ stackpos))) - ;; Return the new lexical environment - lexenv)))) + (let* ((lexenv nil) + (stackpos 0)) + ;; Add entries for each argument. + (dolist (arg args) + (push (cons arg stackpos) lexenv) + (setq stackpos (1+ stackpos))) + ;; Return the new lexical environment. + lexenv)) (defun byte-compile-make-args-desc (arglist) (let ((mandatory 0) @@ -2626,9 +2636,9 @@ for symbols generated by the byte compiler itself." (byte-compile-set-symbol-position 'lambda)) (byte-compile-check-lambda-list (nth 1 fun)) (let* ((arglist (nth 1 fun)) + (arglistvars (byte-compile-arglist-vars arglist)) (byte-compile-bound-variables - (append (and (not lexical-binding) - (byte-compile-arglist-vars arglist)) + (append (if (not lexical-binding) arglistvars) byte-compile-bound-variables)) (body (cdr (cdr fun))) (doc (if (stringp (car body)) @@ -2676,7 +2686,8 @@ for symbols generated by the byte compiler itself." ;; args (since lambda expressions should be ;; closed by now). (and lexical-binding - (byte-compile-make-lambda-lexenv fun)) + (byte-compile-make-lambda-lexenv + arglistvars)) reserved-csts))) ;; Build the actual byte-coded function. (cl-assert (eq 'byte-code (car-safe compiled))) @@ -3435,32 +3446,38 @@ discarding." (byte-defop-compiler (/ byte-quo) byte-compile-quo) (byte-defop-compiler nconc) +;; Is this worth it? Both -before and -after are written in C. (defun byte-compile-char-before (form) - (cond ((= 2 (length form)) + (cond ((or (= 1 (length form)) + (and (= 2 (length form)) (not (nth 1 form)))) + (byte-compile-form '(char-after (1- (point))))) + ((= 2 (length form)) (byte-compile-form (list 'char-after (if (numberp (nth 1 form)) (1- (nth 1 form)) - `(1- ,(nth 1 form)))))) - ((= 1 (length form)) - (byte-compile-form '(char-after (1- (point))))) + `(1- (or ,(nth 1 form) + (point))))))) (t (byte-compile-subr-wrong-args form "0-1")))) ;; backward-... ==> forward-... with negated argument. +;; Is this worth it? Both -backward and -forward are written in C. (defun byte-compile-backward-char (form) - (cond ((= 2 (length form)) + (cond ((or (= 1 (length form)) + (and (= 2 (length form)) (not (nth 1 form)))) + (byte-compile-form '(forward-char -1))) + ((= 2 (length form)) (byte-compile-form (list 'forward-char (if (numberp (nth 1 form)) (- (nth 1 form)) - `(- ,(nth 1 form)))))) - ((= 1 (length form)) - (byte-compile-form '(forward-char -1))) + `(- (or ,(nth 1 form) 1)))))) (t (byte-compile-subr-wrong-args form "0-1")))) (defun byte-compile-backward-word (form) - (cond ((= 2 (length form)) + (cond ((or (= 1 (length form)) + (and (= 2 (length form)) (not (nth 1 form)))) + (byte-compile-form '(forward-word -1))) + ((= 2 (length form)) (byte-compile-form (list 'forward-word (if (numberp (nth 1 form)) (- (nth 1 form)) - `(- ,(nth 1 form)))))) - ((= 1 (length form)) - (byte-compile-form '(forward-word -1))) + `(- (or ,(nth 1 form) 1)))))) (t (byte-compile-subr-wrong-args form "0-1")))) (defun byte-compile-list (form) @@ -3862,9 +3879,8 @@ that suppresses all warnings during execution of BODY." "Emit byte-codes to push the initialization value for CLAUSE on the stack. Return the offset in the form (VAR . OFFSET)." (let* ((var (if (consp clause) (car clause) clause))) - ;; We record the stack position even of dynamic bindings and - ;; variables in non-stack lexical environments; we'll put - ;; them in the proper place below. + ;; We record the stack position even of dynamic bindings; we'll put + ;; them in the proper place later. (prog1 (cons var byte-compile-depth) (if (consp clause) (byte-compile-form (cadr clause)) @@ -3882,33 +3898,41 @@ Return the offset in the form (VAR . OFFSET)." INIT-LEXENV should be a lexical-environment alist describing the positions of the init value that have been pushed on the stack. Return non-nil if the TOS value was popped." - ;; The presence of lexical bindings mean that we may have to + ;; 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. - (cond ((not (byte-compile-not-lexical-var-p var)) - ;; VAR is a simple stack-allocated lexical variable - (push (assq var init-lexenv) - byte-compile--lexical-environment) - nil) - ((eq var (caar init-lexenv)) - ;; VAR is dynamic and is on the top of the - ;; stack, so we can just bind it like usual - (byte-compile-dynamic-variable-bind var) - t) - (t - ;; VAR is dynamic, but we have to get its - ;; value out of the middle of the stack - (let ((stack-pos (cdr (assq var init-lexenv)))) - (byte-compile-stack-ref stack-pos) - (byte-compile-dynamic-variable-bind var) - ;; Now we have to store nil into its temporary - ;; stack position to avoid problems with GC - (byte-compile-push-constant nil) - (byte-compile-stack-set stack-pos)) - nil))) - -(defun byte-compile-unbind (clauses init-lexenv - &optional preserve-body-value) + (if (and lexical-binding (not (byte-compile-not-lexical-var-p var))) + ;; VAR is a simple stack-allocated lexical variable. + (progn (push (assq var init-lexenv) + byte-compile--lexical-environment) + nil) + ;; VAR should be dynamically bound. + (while (assq var byte-compile--lexical-environment) + ;; This dynamic binding shadows a lexical binding. + (setq byte-compile--lexical-environment + (remq (assq var byte-compile--lexical-environment) + byte-compile--lexical-environment))) + (cond + ((eq var (caar init-lexenv)) + ;; VAR is dynamic and is on the top of the + ;; stack, so we can just bind it like usual. + (byte-compile-dynamic-variable-bind var) + t) + (t + ;; VAR is dynamic, but we have to get its + ;; value out of the middle of the stack. + (let ((stack-pos (cdr (assq var init-lexenv)))) + (byte-compile-stack-ref stack-pos) + (byte-compile-dynamic-variable-bind var) + ;; Now we have to store nil into its temporary + ;; stack position so it doesn't prevent the value from being GC'd. + ;; FIXME: Not worth the trouble. + ;; (byte-compile-push-constant nil) + ;; (byte-compile-stack-set stack-pos) + ) + nil)))) + +(defun byte-compile-unbind (clauses init-lexenv preserve-body-value) "Emit byte-codes to unbind the variables bound by CLAUSES. CLAUSES is a `let'-style variable binding list. INIT-LEXENV should be a lexical-environment alist describing the positions of the init value that @@ -3916,7 +3940,7 @@ have been pushed on the stack. If PRESERVE-BODY-VALUE is true, then an additional value on the top of the stack, above any lexical binding slots, is preserved, so it will be on the top of the stack after all binding slots have been popped." - ;; Unbind dynamic variables + ;; Unbind dynamic variables. (let ((num-dynamic-bindings 0)) (dolist (clause clauses) (unless (assq (if (consp clause) (car clause) clause) @@ -3927,14 +3951,15 @@ binding slots have been popped." ;; Pop lexical variables off the stack, possibly preserving the ;; return value of the body. (when init-lexenv - ;; INIT-LEXENV contains all init values left on the stack + ;; INIT-LEXENV contains all init values left on the stack. (byte-compile-discard (length init-lexenv) preserve-body-value))) (defun byte-compile-let (form) - "Generate code for the `let' form FORM." + "Generate code for the `let' or `let*' form FORM." (let ((clauses (cadr form)) - (init-lexenv nil)) - (when (eq (car form) 'let) + (init-lexenv nil) + (is-let (eq (car form) 'let))) + (when is-let ;; First compute the binding values in the old scope. (dolist (var clauses) (push (byte-compile-push-binding-init var) init-lexenv))) @@ -3946,28 +3971,20 @@ binding slots have been popped." ;; For `let', do it in reverse order, because it makes no ;; semantic difference, but it is a lot more efficient since the ;; values are now in reverse order on the stack. - (dolist (var (if (eq (car form) 'let) (reverse clauses) clauses)) - (unless (eq (car form) 'let) + (dolist (var (if is-let (reverse clauses) clauses)) + (unless is-let (push (byte-compile-push-binding-init var) init-lexenv)) (let ((var (if (consp var) (car var) var))) - (cond ((null lexical-binding) - ;; If there are no lexical bindings, we can do things simply. - (byte-compile-dynamic-variable-bind var)) - ((byte-compile-bind var init-lexenv) - (pop init-lexenv))))) + (if (byte-compile-bind var init-lexenv) + (pop init-lexenv)))) ;; Emit the body. (let ((init-stack-depth byte-compile-depth)) (byte-compile-body-do-effect (cdr (cdr form))) - ;; Unbind the variables. - (if lexical-binding - ;; Unbind both lexical and dynamic variables. - (progn - (cl-assert (or (eq byte-compile-depth init-stack-depth) - (eq byte-compile-depth (1+ init-stack-depth)))) - (byte-compile-unbind clauses init-lexenv (> byte-compile-depth - init-stack-depth))) - ;; Unbind dynamic variables. - (byte-compile-out 'byte-unbind (length clauses))))))) + ;; Unbind both lexical and dynamic variables. + (cl-assert (or (eq byte-compile-depth init-stack-depth) + (eq byte-compile-depth (1+ init-stack-depth)))) + (byte-compile-unbind clauses init-lexenv + (> byte-compile-depth init-stack-depth)))))) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index ee84a9f69ba..761e33c059d 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -81,7 +81,6 @@ ;; and other oddities. ;; - new byte codes for unwind-protect, catch, and condition-case so that ;; closures aren't needed at all. -;; - inline source code of different binding mode by first compiling it. ;; - 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, @@ -95,6 +94,7 @@ ;; (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))) @@ -489,6 +489,7 @@ places where they originally did not directly appear." (unless (fboundp 'byte-compile-not-lexical-var-p) ;; Only used to test the code in non-lexbind Emacs. (defalias 'byte-compile-not-lexical-var-p 'boundp)) +(defvar byte-compile-lexical-variables) (defun cconv--analyse-use (vardata form varkind) "Analyze the use of a variable. @@ -530,6 +531,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) (newenv envcopy)) ;; Push it before recursing, so cconv-freevars-alist contains entries in ;; the order they'll be used by closure-convert-rec. @@ -541,6 +543,7 @@ FORM is the parent form that binds this var." (format "Argument %S is not a lexical variable" arg))) ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... (t (let ((varstruct (list arg nil nil nil nil))) + (cl-pushnew arg byte-compile-lexical-variables) (push (cons (list arg) (cdr varstruct)) newvars) (push varstruct newenv))))) (dolist (form body) ;Analyze body forms. @@ -579,6 +582,7 @@ and updates the data stored in ENV." (let ((orig-env env) (newvars nil) (var nil) + (byte-compile-bound-variables byte-compile-bound-variables) (value nil)) (dolist (binder binders) (if (not (consp binder)) @@ -592,6 +596,7 @@ and updates the data stored in ENV." (cconv-analyse-form value (if (eq letsym 'let*) env orig-env))) (unless (byte-compile-not-lexical-var-p var) + (cl-pushnew var byte-compile-lexical-variables) (let ((varstruct (list var nil nil nil nil))) (push (cons binder (cdr varstruct)) newvars) (push varstruct env)))) @@ -616,7 +621,8 @@ and updates the data stored in ENV." (`((lambda . ,_) . ,_) ; First element is lambda expression. (byte-compile-log-warning - "Use of deprecated ((lambda ...) ...) form" t :warning) + (format "Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form))) + t :warning) (dolist (exp `((function ,(car form)) . ,(cdr form))) (cconv-analyse-form exp env))) @@ -645,6 +651,7 @@ and updates the data stored in ENV." (`(track-mouse . ,body) (cconv--analyse-function () body env form)) + (`(defvar ,var) (push var byte-compile-bound-variables)) (`(,(or `defconst `defvar) ,var ,value . ,_) (push var byte-compile-bound-variables) (cconv-analyse-form value env)) @@ -668,7 +675,9 @@ and updates the data stored in ENV." ;; seem worth the trouble. (dolist (form forms) (cconv-analyse-form form nil))) - (`(declare . ,_) nil) ;The args don't contain code. + ;; `declare' should now be macro-expanded away (and if they're not, we're + ;; in trouble because they *can* contain code nowadays). + ;; (`(declare . ,_) nil) ;The args don't contain code. (`(,_ . ,body-forms) ; First element is a function or whatever. (dolist (form body-forms) (cconv-analyse-form form env))) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index f3bf70b0190..52f123c83ec 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -156,8 +156,8 @@ an element already on the list. ;; earlier and should have triggered them already. (with-no-warnings ,place) (setq ,place (cons ,var ,place)))) - (list 'setq place (cl-list* 'cl-adjoin x place keys))) - (cl-list* 'cl-callf2 'cl-adjoin x place keys))) + `(setq ,place (cl-adjoin ,x ,place ,@keys))) + `(cl-callf2 cl-adjoin ,x ,place ,@keys))) (defun cl--set-elt (seq n val) (if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val))) diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index af19db63f30..a06abb03b95 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -267,7 +267,7 @@ including `cl-block' and `cl-eval-when'. ;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when ;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp ;;;;;; cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*) -;;;;;; "cl-macs" "cl-macs.el" "b839ad3781c4f2f849df0639b4eba166") +;;;;;; "cl-macs" "cl-macs.el" "fd824d987086eafec0b1cb2efa8312f4") ;;; Generated autoloads from cl-macs.el (autoload 'cl--compiler-macro-list* "cl-macs" "\ @@ -699,9 +699,10 @@ OPTION is either a single keyword or (KEYWORD VALUE) where KEYWORD can be one of :conc-name, :constructor, :copier, :predicate, :type, :named, :initial-offset, :print-function, or :include. -Each SLOT may instead take the form (SLOT SLOT-OPTS...), where -SLOT-OPTS are keyword-value pairs for that slot. Currently, only -one keyword is supported, `:read-only'. If this has a non-nil +Each SLOT may instead take the form (SNAME SDEFAULT SOPTIONS...), where +SDEFAULT is the default value of that slot and SOPTIONS are keyword-value +pairs for that slot. +Currently, only one keyword is supported, `:read-only'. If this has a non-nil value, that slot cannot be set via `setf'. \(fn NAME SLOTS...)" nil t) @@ -724,6 +725,8 @@ TYPE is a Common Lisp-style type specifier. \(fn OBJECT TYPE)" nil nil) +(eval-and-compile (put 'cl-typep 'compiler-macro #'cl--compiler-macro-typep)) + (autoload 'cl-check-type "cl-macs" "\ Verify that FORM is of type TYPE; signal an error if not. STRING is an optional description of the desired type. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 4aae2c6efe5..34957d86796 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -584,7 +584,7 @@ If `load' is in WHEN, BODY is evaluated when loaded after top-level compile. If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. \(fn (WHEN...) BODY...)" - (declare (indent 1) (debug ((&rest &or "compile" "load" "eval") body))) + (declare (indent 1) (debug (sexp body))) (if (and (fboundp 'cl--compiling-file) (cl--compiling-file) (not cl--not-toplevel) (not (boundp 'for-effect))) ;Horrible kludge. (let ((comp (or (memq 'compile when) (memq :compile-toplevel when))) @@ -2276,9 +2276,10 @@ OPTION is either a single keyword or (KEYWORD VALUE) where KEYWORD can be one of :conc-name, :constructor, :copier, :predicate, :type, :named, :initial-offset, :print-function, or :include. -Each SLOT may instead take the form (SLOT SLOT-OPTS...), where -SLOT-OPTS are keyword-value pairs for that slot. Currently, only -one keyword is supported, `:read-only'. If this has a non-nil +Each SLOT may instead take the form (SNAME SDEFAULT SOPTIONS...), where +SDEFAULT is the default value of that slot and SOPTIONS are keyword-value +pairs for that slot. +Currently, only one keyword is supported, `:read-only'. If this has a non-nil value, that slot cannot be set via `setf'. \(fn NAME SLOTS...)" @@ -2574,9 +2575,16 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (defun cl-typep (object type) ; See compiler macro below. "Check that OBJECT is of type TYPE. TYPE is a Common Lisp-style type specifier." + (declare (compiler-macro cl--compiler-macro-typep)) (let ((cl--object object)) ;; Yuck!! (eval (cl--make-type-test 'cl--object type)))) +(defun cl--compiler-macro-typep (form val type) + (if (macroexp-const-p type) + (macroexp-let2 macroexp-copyable-p temp val + (cl--make-type-test temp (cl--const-expr-val type))) + form)) + ;;;###autoload (defmacro cl-check-type (form type &optional string) "Verify that FORM is of type TYPE; signal an error if not. @@ -2635,19 +2643,13 @@ and then returning foo." (let ((p args) (res nil)) (while (consp p) (push (pop p) res)) (setq args (nconc (nreverse res) (and p (list '&rest p))))) - `(cl-eval-when (compile load eval) - (put ',func 'compiler-macro - (cl-function (lambda ,(if (memq '&whole args) (delq '&whole args) - (cons '_cl-whole-arg args)) - ,@body))) - ;; This is so that describe-function can locate - ;; the macro definition. - (let ((file ,(or buffer-file-name - (and (boundp 'byte-compile-current-file) - (stringp byte-compile-current-file) - byte-compile-current-file)))) - (if file (put ',func 'compiler-macro-file - (purecopy (file-name-nondirectory file))))))) + (let ((fname (make-symbol (concat (symbol-name func) "--cmacro")))) + `(eval-and-compile + ;; Name the compiler-macro function, so that `symbol-file' can find it. + (cl-defun ,fname ,(if (memq '&whole args) (delq '&whole args) + (cons '_cl-whole-arg args)) + ,@body) + (put ',func 'compiler-macro #',fname)))) ;;;###autoload (defun cl-compiler-macroexpand (form) @@ -2763,22 +2765,16 @@ surrounded by (cl-block NAME ...). ;;;###autoload (defun cl--compiler-macro-adjoin (form a list &rest keys) - (if (and (cl--simple-expr-p a) (cl--simple-expr-p list) - (not (memq :key keys))) - `(if (cl-member ,a ,list ,@keys) ,list (cons ,a ,list)) - form)) + (if (memq :key keys) form + (macroexp-let2 macroexp-copyable-p va a + (macroexp-let2 macroexp-copyable-p vlist list + `(if (cl-member ,va ,vlist ,@keys) ,vlist (cons ,va ,vlist)))))) (defun cl--compiler-macro-get (_form sym prop &optional def) (if def `(cl-getf (symbol-plist ,sym) ,prop ,def) `(get ,sym ,prop))) -(cl-define-compiler-macro cl-typep (&whole form val type) - (if (macroexp-const-p type) - (macroexp-let2 macroexp-copyable-p temp val - (cl--make-type-test temp (cl--const-expr-val type))) - form)) - (dolist (y '(cl-first cl-second cl-third cl-fourth cl-fifth cl-sixth cl-seventh cl-eighth cl-ninth cl-tenth diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 867f079ce5f..319af588eac 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -472,6 +472,8 @@ the option `edebug-all-forms'." (or (fboundp 'edebug-original-eval-defun) (defalias 'edebug-original-eval-defun (symbol-function 'eval-defun))) +(defvar edebug-result) ; The result of the function call returned by body. + ;; We should somehow arrange to be able to do this ;; without actually replacing the eval-defun command. (defun edebug-eval-defun (edebug-it) @@ -487,7 +489,7 @@ With a prefix argument, instrument the code for Edebug. Setting option `edebug-all-defs' to a non-nil value reverses the meaning of the prefix argument. Code is then instrumented when this function is -invoked without a prefix argument +invoked without a prefix argument. If acting on a `defun' for FUNCTION, and the function was instrumented, `Edebug: FUNCTION' is printed in the minibuffer. If not instrumented, @@ -2106,7 +2108,6 @@ expressions; a `progn' form will be returned enclosing these forms." (defvar edebug-coverage) ; the coverage results of each expression of function. (defvar edebug-buffer) ; which buffer the function is in. -(defvar edebug-result) ; the result of the function call returned by body (defvar edebug-outside-executing-macro) (defvar edebug-outside-defining-kbd-macro) diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el index dd5ff0ec694..cb86a554335 100644 --- a/lisp/emacs-lisp/generic.el +++ b/lisp/emacs-lisp/generic.el @@ -93,6 +93,8 @@ ;;; Code: +(eval-when-compile (require 'pcase)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Internal Variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -224,18 +226,11 @@ Some generic modes are defined in `generic-x.el'." (funcall (intern mode))) ;;; Comment Functionality -(defun generic-mode-set-comments (comment-list) - "Set up comment functionality for generic mode." - (let ((st (make-syntax-table)) - (chars nil) - (comstyles)) - (make-local-variable 'comment-start) - (make-local-variable 'comment-start-skip) - (make-local-variable 'comment-end) - ;; Go through all the comments +(defun generic--normalise-comments (comment-list) + (let ((normalized '())) (dolist (start comment-list) - (let (end (comstyle "")) + (let (end) ;; Normalize (when (consp start) (setq end (cdr start)) @@ -244,58 +239,79 @@ Some generic modes are defined in `generic-x.el'." (cond ((characterp end) (setq end (char-to-string end))) ((zerop (length end)) (setq end "\n"))) + (push (cons start end) normalized))) + (nreverse normalized))) - ;; Setup the vars for `comment-region' - (if comment-start - ;; We have already setup a comment-style, so use style b - (progn - (setq comstyle "b") - (setq comment-start-skip - (concat comment-start-skip "\\|" (regexp-quote start) "+\\s-*"))) - ;; First comment-style - (setq comment-start start) - (setq comment-end (if (string-equal end "\n") "" end)) - (setq comment-start-skip (concat (regexp-quote start) "+\\s-*"))) - - ;; Reuse comstyles if necessary - (setq comstyle +(defun generic-set-comment-syntax (st comment-list) + "Set up comment functionality for generic mode." + (let ((chars nil) + (comstyles) + (comstyle "") + (comment-start nil)) + + ;; Go through all the comments. + (pcase-dolist (`(,start . ,end) comment-list) + (let ((comstyle + ;; Reuse comstyles if necessary. (or (cdr (assoc start comstyles)) (cdr (assoc end comstyles)) - comstyle)) + ;; Otherwise, use a style not yet in use. + (if (not (rassoc "" comstyles)) "") + (if (not (rassoc "b" comstyles)) "b") + "c"))) (push (cons start comstyle) comstyles) (push (cons end comstyle) comstyles) - ;; Setup the syntax table + ;; Setup the syntax table. (if (= (length start) 1) - (modify-syntax-entry (string-to-char start) + (modify-syntax-entry (aref start 0) (concat "< " comstyle) st) - (let ((c0 (elt start 0)) (c1 (elt start 1))) - ;; Store the relevant info but don't update yet + (let ((c0 (aref start 0)) (c1 (aref start 1))) + ;; Store the relevant info but don't update yet. (push (cons c0 (concat (cdr (assoc c0 chars)) "1")) chars) (push (cons c1 (concat (cdr (assoc c1 chars)) (concat "2" comstyle))) chars))) (if (= (length end) 1) - (modify-syntax-entry (string-to-char end) + (modify-syntax-entry (aref end 0) (concat ">" comstyle) st) - (let ((c0 (elt end 0)) (c1 (elt end 1))) - ;; Store the relevant info but don't update yet + (let ((c0 (aref end 0)) (c1 (aref end 1))) + ;; Store the relevant info but don't update yet. (push (cons c0 (concat (cdr (assoc c0 chars)) (concat "3" comstyle))) chars) (push (cons c1 (concat (cdr (assoc c1 chars)) "4")) chars))))) ;; Process the chars that were part of a 2-char comment marker + (with-syntax-table st ;For `char-syntax'. (dolist (cs (nreverse chars)) (modify-syntax-entry (car cs) (concat (char-to-string (char-syntax (car cs))) " " (cdr cs)) - st)) + st))))) + +(defun generic-set-comment-vars (comment-list) + (when comment-list + (setq-local comment-start (caar comment-list)) + (setq-local comment-end + (let ((end (cdar comment-list))) + (if (string-equal end "\n") "" end))) + (setq-local comment-start-skip + (concat (regexp-opt (mapcar #'car comment-list)) + "+[ \t]*")) + (setq-local comment-end-skip + (concat "[ \t]*" (regexp-opt (mapcar #'cdr comment-list)))))) + +(defun generic-mode-set-comments (comment-list) + "Set up comment functionality for generic mode." + (let ((st (make-syntax-table)) + (comment-list (generic--normalise-comments comment-list))) + (generic-set-comment-syntax st comment-list) + (generic-set-comment-vars comment-list) (set-syntax-table st))) (defun generic-bracket-support () "Imenu support for [KEYWORD] constructs found in INF, INI and Samba files." - (setq imenu-generic-expression - '((nil "^\\[\\(.*\\)\\]" 1)) - imenu-case-fold-search t)) + (setq-local imenu-generic-expression '((nil "^\\[\\(.*\\)\\]" 1))) + (setq-local imenu-case-fold-search t)) ;;;###autoload (defun generic-make-keywords-list (keyword-list face &optional prefix suffix) @@ -306,6 +322,7 @@ expression that matches these keywords and concatenates it with PREFIX and SUFFIX. Then it returns a construct based on this regular expression that can be used as an element of `font-lock-keywords'." + (declare (obsolete regexp-opt "24.4")) (unless (listp keyword-list) (error "Keywords argument must be a list of strings")) (list (concat prefix "\\_<" diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 02b020fa241..cbd8854e7d6 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -225,11 +225,13 @@ font-lock keywords will not be case sensitive." (setq-local syntax-begin-function 'beginning-of-defun) (setq font-lock-defaults `((lisp-font-lock-keywords - lisp-font-lock-keywords-1 lisp-font-lock-keywords-2) + lisp-font-lock-keywords-1 + lisp-font-lock-keywords-2) nil ,keywords-case-insensitive nil nil (font-lock-mark-block-function . mark-defun) (font-lock-syntactic-face-function - . lisp-font-lock-syntactic-face-function)))) + . lisp-font-lock-syntactic-face-function))) + (prog-prettify-install lisp--prettify-symbols-alist)) (defun lisp-outline-level () "Lisp mode `outline-level' function." @@ -448,6 +450,9 @@ All commands in `lisp-mode-shared-map' are inherited by this map.") :type 'hook :group 'lisp) +(defconst lisp--prettify-symbols-alist + '(("lambda" . ?λ))) + (define-derived-mode emacs-lisp-mode prog-mode "Emacs-Lisp" "Major mode for editing Lisp code to run in Emacs. Commands: diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 6bb796434fd..e8b513fcd3e 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -111,15 +111,20 @@ and also to avoid outputting the warning during normal execution." (funcall (eval (cadr form))) (byte-compile-constant nil))) +(defun macroexp--compiling-p () + "Return non-nil if we're macroexpanding for the compiler." + ;; FIXME: ¡¡Major Ugly Hack!! To determine whether the output of this + ;; macro-expansion will be processed by the byte-compiler, we check + ;; circumstantial evidence. + (member '(declare-function . byte-compile-macroexpand-declare-function) + macroexpand-all-environment)) + + (defun macroexp--warn-and-return (msg form) (let ((when-compiled (lambda () (byte-compile-log-warning msg t)))) (cond ((null msg) form) - ;; FIXME: ¡¡Major Ugly Hack!! To determine whether the output of this - ;; macro-expansion will be processed by the byte-compiler, we check - ;; circumstantial evidence. - ((member '(declare-function . byte-compile-macroexpand-declare-function) - macroexpand-all-environment) + ((macroexp--compiling-p) `(progn (macroexp--funcall-if-compiled ',when-compiled) ,form)) diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el index a3ce1672a63..17919d9bbeb 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el @@ -162,9 +162,11 @@ DESCRIPTION is the text of the news item." description archive-url)) -(defun package-upload-buffer-internal (pkg-info extension &optional archive-url) +(declare-function lm-commentary "lisp-mnt" (&optional file)) + +(defun package-upload-buffer-internal (pkg-desc extension &optional archive-url) "Upload a package whose contents are in the current buffer. -PKG-INFO is the package info, see `package-buffer-info'. +PKG-DESC is the `package-desc'. EXTENSION is the file extension, a string. It can be either \"el\" or \"tar\". @@ -196,18 +198,18 @@ if it exists." (error "Aborted"))) (save-excursion (save-restriction - (let* ((file-type (cond - ((equal extension "el") 'single) - ((equal extension "tar") 'tar) - (t (error "Unknown extension `%s'" extension)))) - (file-name (aref pkg-info 0)) - (pkg-name (intern file-name)) - (requires (aref pkg-info 1)) - (desc (if (string= (aref pkg-info 2) "") + (let* ((file-type (package-desc-kind pkg-desc)) + (pkg-name (package-desc-name pkg-desc)) + (requires (package-desc-reqs pkg-desc)) + (desc (if (eq (package-desc-summary pkg-desc) + package--default-summary) (read-string "Description of package: ") - (aref pkg-info 2))) - (pkg-version (aref pkg-info 3)) - (commentary (aref pkg-info 4)) + (package-desc-summary pkg-desc))) + (pkg-version (package-desc-version pkg-desc)) + (commentary + (pcase file-type + (`single (lm-commentary)) + (`tar nil))) ;; FIXME: Get it from the README file. (split-version (version-to-list pkg-version)) (pkg-buffer (current-buffer))) @@ -215,7 +217,8 @@ if it exists." ;; from `package-archive-upload-base' otherwise. (let ((contents (or (package--archive-contents-from-url archive-url) (package--archive-contents-from-file))) - (new-desc (vector split-version requires desc file-type))) + (new-desc (package-make-ac-desc + split-version requires desc file-type))) (if (> (car contents) package-archive-version) (error "Unrecognized archive version %d" (car contents))) (let ((elt (assq pkg-name (cdr contents)))) @@ -232,6 +235,7 @@ if it exists." ;; this and the package itself. For now we assume ELPA is ;; writable via file primitives. (let ((print-level nil) + (print-quoted t) (print-length nil)) (write-region (concat (pp-to-string contents) "\n") nil @@ -241,29 +245,29 @@ if it exists." ;; If there is a commentary section, write it. (when commentary (write-region commentary nil - (expand-file-name - (concat (symbol-name pkg-name) "-readme.txt") - package-archive-upload-base))) + (expand-file-name + (concat (symbol-name pkg-name) "-readme.txt") + package-archive-upload-base))) (set-buffer pkg-buffer) (write-region (point-min) (point-max) (expand-file-name - (concat file-name "-" pkg-version "." extension) + (format "%s-%s.%s" pkg-name pkg-version extension) package-archive-upload-base) nil nil nil 'excl) ;; Write a news entry. (and package-update-news-on-upload archive-url - (package--update-news (concat file-name "." extension) + (package--update-news (format "%s.%s" pkg-name extension) pkg-version desc archive-url)) ;; special-case "package": write a second copy so that the ;; installer can easily find the latest version. - (if (string= file-name "package") + (if (eq pkg-name 'package) (write-region (point-min) (point-max) (expand-file-name - (concat file-name "." extension) + (format "%s.%s" pkg-name extension) package-archive-upload-base) nil nil nil 'ask)))))))) @@ -275,8 +279,8 @@ destination, prompt for one." (save-excursion (save-restriction ;; Find the package in this buffer. - (let ((pkg-info (package-buffer-info))) - (package-upload-buffer-internal pkg-info "el"))))) + (let ((pkg-desc (package-buffer-info))) + (package-upload-buffer-internal pkg-desc "el"))))) (defun package-upload-file (file) "Upload the Emacs Lisp package FILE to the package archive. @@ -288,12 +292,13 @@ destination, prompt for one." (interactive "fPackage file name: ") (with-temp-buffer (insert-file-contents-literally file) - (let ((info (cond - ((string-match "\\.tar$" file) (package-tar-file-info file)) - ((string-match "\\.el$" file) (package-buffer-info)) - (t (error "Unrecognized extension `%s'" - (file-name-extension file)))))) - (package-upload-buffer-internal info (file-name-extension file))))) + (let ((pkg-desc + (cond + ((string-match "\\.tar\\'" file) (package-tar-file-info file)) + ((string-match "\\.el\\'" file) (package-buffer-info)) + (t (error "Unrecognized extension `%s'" + (file-name-extension file)))))) + (package-upload-buffer-internal pkg-desc (file-name-extension file))))) (defun package-gnus-summary-upload () "Upload a package contained in the current *Article* buffer. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 41b635bbe30..d5176abded0 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -170,6 +170,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (require 'tabulated-list) (defgroup package nil @@ -262,11 +264,8 @@ Lower version numbers than this will probably be understood as well.") ;; We don't prime the cache since it tends to get out of date. (defvar package-archive-contents nil "Cache of the contents of the Emacs Lisp Package Archive. -This is an alist mapping package names (symbols) to package -descriptor vectors. These are like the vectors for `package-alist' -but have extra entries: one which is 'tar for tar packages and -'single for single-file packages, and one which is the name of -the archive from which it came.") +This is an alist mapping package names (symbols) to +`package--desc' structures.") (put 'package-archive-contents 'risky-local-variable t) (defcustom package-user-dir (locate-user-emacs-file "elpa") @@ -297,6 +296,62 @@ contrast, `package-user-dir' contains packages for personal use." :group 'package :version "24.1") +(defvar package--default-summary "No description available.") + +(cl-defstruct (package-desc + ;; Rename the default constructor from `make-package-desc'. + (:constructor package-desc-create) + ;; Has the same interface as the old `define-package', + ;; which is still used in the "foo-pkg.el" files. Extra + ;; options can be supported by adding additional keys. + (:constructor + package-desc-from-define + (name-string version-string &optional summary requirements + &key kind archive + &aux + (name (intern name-string)) + (version (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)))))) + "Structure containing information about an individual package. + +Slots: + +`name' Name of the package, as a symbol. + +`version' Version of the package, as a version list. + +`summary' Short description of the package, typically taken from +the first line of the file. + +`reqs' Requirements of the package. A list of (PACKAGE +VERSION-LIST) naming the dependent package and the minimum +required version. + +`kind' The distribution format of the package. Currently, it is +either `single' or `tar'. + +`archive' The name of the archive (as a string) whence this +package came." + name + version + (summary package--default-summary) + reqs + kind + archive) + +;; Package descriptor format used in finder-inf.el and package--builtins. +(cl-defstruct (package--bi-desc + (:constructor package-make-builtin (version summary)) + (:type vector)) + version + reqs + summary) + ;; The value is precomputed in finder-inf.el, but don't load that ;; until it's needed (i.e. when `package-initialize' is called). (defvar package--builtins nil @@ -305,27 +360,14 @@ The actual value is initialized by loading the library `finder-inf'; this is not done until it is needed, e.g. by the function `package-built-in-p'. -Each element has the form (PKG . DESC), where PKG is a package -name (a symbol) and DESC is a vector that describes the package. -The vector DESC has the form [VERSION-LIST REQS DOCSTRING]. - VERSION-LIST is a version list. - REQS is a list of packages required by the package, each - requirement having the form (NAME VL), where NAME is a string - and VL is a version list. - DOCSTRING is a brief description of the package.") +Each element has the form (PKG . PACKAGE-BI-DESC), where PKG is a package +name (a symbol) and DESC is a `package--bi-desc' structure.") (put 'package--builtins 'risky-local-variable t) (defvar package-alist nil "Alist of all packages available for activation. Each element has the form (PKG . DESC), where PKG is a package -name (a symbol) and DESC is a vector that describes the package. - -The vector DESC has the form [VERSION-LIST REQS DOCSTRING]. - VERSION-LIST is a version list. - REQS is a list of packages required by the package, each - requirement having the form (NAME VL) where NAME is a string - and VL is a version list. - DOCSTRING is a brief description of the package. +name (a symbol) and DESC is a `package-desc' structure. This variable is set automatically by `package-load-descriptor', called via `package-initialize'. To change which packages are @@ -339,7 +381,10 @@ loaded and/or activated, customize `package-load-list'.") (defvar package-obsolete-alist nil "Representation of obsolete packages. Like `package-alist', but maps package name to a second alist. -The inner alist is keyed by version.") +The inner alist is keyed by version. + +Each element of the list is (NAME . VERSION-ALIST), where each +entry in VERSION-ALIST is (VERSION-LIST . PACKAGE-DESC).") (put 'package-obsolete-alist 'risky-local-variable t) (defun package-version-join (vlist) @@ -430,26 +475,16 @@ the package by calling `package-load-descriptor'." ;; Actually load the descriptor: (package-load-descriptor dir subdir)))) -(defsubst package-desc-vers (desc) - "Extract version from a package description vector." - (aref desc 0)) +(define-obsolete-function-alias 'package-desc-vers 'package-desc-version "24.4") -(defsubst package-desc-reqs (desc) - "Extract requirements from a package description vector." - (aref desc 1)) +(define-obsolete-function-alias 'package-desc-doc 'package-desc-summary "24.4") -(defsubst package-desc-doc (desc) - "Extract doc string from a package description vector." - (aref desc 2)) - -(defsubst package-desc-kind (desc) - "Extract the kind of download from an archive package description vector." - (aref desc 3)) (defun package--dir (name version) + ;; FIXME: Keep this as a field in the package-desc. "Return the directory where a package is installed, or nil if none. -NAME and VERSION are both strings." - (let* ((subdir (concat name "-" version)) +NAME is a symbol and VERSION is a string." + (let* ((subdir (format "%s-%s" name version)) (dir-list (cons package-user-dir package-directory-list)) pkg-dir) (while dir-list @@ -460,9 +495,9 @@ NAME and VERSION are both strings." (setq dir-list (cdr dir-list))))) pkg-dir)) -(defun package-activate-1 (package pkg-vec) - (let* ((name (symbol-name package)) - (version-str (package-version-join (package-desc-vers pkg-vec))) +(defun package-activate-1 (pkg-desc) + (let* ((name (package-desc-name pkg-desc)) + (version-str (package-version-join (package-desc-version pkg-desc))) (pkg-dir (package--dir name version-str))) (unless pkg-dir (error "Internal error: unable to find directory for `%s-%s'" @@ -475,8 +510,8 @@ NAME and VERSION are both strings." (push pkg-dir Info-directory-list)) ;; Add to load path, add autoloads, and activate the package. (push pkg-dir load-path) - (load (expand-file-name (concat name "-autoloads") pkg-dir) nil t) - (push package package-activated-list) + (load (expand-file-name (format "%s-autoloads" name) pkg-dir) nil t) + (push name package-activated-list) ;; Don't return nil. t)) @@ -489,7 +524,12 @@ specifying the minimum acceptable version." (version-list-<= min-version (version-to-list emacs-version)) (let ((elt (assq package package--builtins))) (and elt (version-list-<= min-version - (package-desc-vers (cdr elt))))))) + (package--bi-desc-version (cdr elt))))))) + +(defun package--from-builtin (bi-desc) + (package-desc-create :name (pop bi-desc) + :version (package--bi-desc-version bi-desc) + :summary (package--bi-desc-summary bi-desc))) ;; This function goes ahead and activates a newer version of a package ;; if an older one was already activated. This is not ideal; we'd at @@ -504,7 +544,7 @@ Return nil if the package could not be activated." available-version found) ;; Check if PACKAGE is available in `package-alist'. (when pkg-vec - (setq available-version (package-desc-vers pkg-vec) + (setq available-version (package-desc-version pkg-vec) found (version-list-<= min-version available-version))) (cond ;; If no such package is found, maybe it's built-in. @@ -525,7 +565,7 @@ Return nil if the package could not be activated." Required package `%s-%s' is unavailable" package (car fail) (package-version-join (cadr fail))) ;; If all goes well, activate the package itself. - (package-activate-1 package pkg-vec))))))) + (package-activate-1 pkg-vec))))))) (defun package-mark-obsolete (package pkg-vec) "Put package on the obsolete list, if not already there." @@ -533,11 +573,11 @@ Required package `%s-%s' is unavailable" (if elt ;; If this obsolete version does not exist in the list, update ;; it the list. - (unless (assoc (package-desc-vers pkg-vec) (cdr elt)) - (setcdr elt (cons (cons (package-desc-vers pkg-vec) pkg-vec) + (unless (assoc (package-desc-version pkg-vec) (cdr elt)) + (setcdr elt (cons (cons (package-desc-version pkg-vec) pkg-vec) (cdr elt)))) ;; Make a new association. - (push (cons package (list (cons (package-desc-vers pkg-vec) + (push (cons package (list (cons (package-desc-version pkg-vec) pkg-vec))) package-obsolete-alist)))) @@ -555,21 +595,17 @@ REQUIREMENTS is a list of dependencies on other packages. EXTRA-PROPERTIES is currently unused." (let* ((name (intern name-string)) (version (version-to-list version-string)) - (new-pkg-desc - (cons name - (vector version - (mapcar - (lambda (elt) - (list (car elt) - (version-to-list (car (cdr elt))))) - requirements) - docstring))) + (new-pkg-desc (cons name + (package-desc-from-define name-string + version-string + docstring + requirements))) (old-pkg (assq name package-alist))) (cond ;; If there's no old package, just add this to `package-alist'. ((null old-pkg) (push new-pkg-desc package-alist)) - ((version-list-< (package-desc-vers (cdr old-pkg)) version) + ((version-list-< (package-desc-version (cdr old-pkg)) version) ;; Remove the old package and declare it obsolete. (package-mark-obsolete name (cdr old-pkg)) (setq package-alist (cons new-pkg-desc @@ -577,7 +613,7 @@ EXTRA-PROPERTIES is currently unused." ;; You can have two packages with the same version, e.g. one in ;; the system package directory and one in your private ;; directory. We just let the first one win. - ((not (version-list-= (package-desc-vers (cdr old-pkg)) version)) + ((not (version-list-= (package-desc-version (cdr old-pkg)) version)) ;; The package is born obsolete. (package-mark-obsolete name (cdr new-pkg-desc)))))) @@ -603,14 +639,15 @@ EXTRA-PROPERTIES is currently unused." (defun package-generate-autoloads (name pkg-dir) (require 'autoload) ;Load before we let-bind generated-autoload-file! - (let* ((auto-name (concat name "-autoloads.el")) + (let* ((auto-name (format "%s-autoloads.el" name)) ;;(ignore-name (concat name "-pkg.el")) (generated-autoload-file (expand-file-name auto-name pkg-dir)) (version-control 'never)) (package-autoload-ensure-default-file generated-autoload-file) (update-directory-autoloads pkg-dir) (let ((buf (find-buffer-visiting generated-autoload-file))) - (when buf (kill-buffer buf))))) + (when buf (kill-buffer buf))) + auto-name)) (defvar tar-parse-info) (declare-function tar-untar-buffer "tar-mode" ()) @@ -644,57 +681,62 @@ untar into a directory named DIR; otherwise, signal an error." ;; FIXME: should we delete PKG-DIR if it exists? (let* ((default-directory (file-name-as-directory package-user-dir))) (package-untar-buffer dirname) - (package--make-autoloads-and-compile name pkg-dir)))) + (package--make-autoloads-and-compile package pkg-dir)))) (defun package--make-autoloads-and-compile (name pkg-dir) "Generate autoloads and do byte-compilation for package named NAME. PKG-DIR is the name of the package directory." - (package-generate-autoloads name pkg-dir) - (let ((load-path (cons pkg-dir load-path))) + (let ((auto-name (package-generate-autoloads name pkg-dir)) + (load-path (cons pkg-dir load-path))) ;; We must load the autoloads file before byte compiling, in ;; case there are magic cookies to set up non-trivial paths. - (load (expand-file-name (concat name "-autoloads") pkg-dir) nil t) + (load auto-name nil t) + ;; 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. (byte-recompile-directory pkg-dir 0 t))) (defun package--write-file-no-coding (file-name) (let ((buffer-file-coding-system 'no-conversion)) (write-region (point-min) (point-max) file-name))) -(defun package-unpack-single (file-name version desc requires) +(defun package-unpack-single (name version desc requires) "Install the contents of the current buffer as a package." - ;; Special case "package". - (if (string= file-name "package") + ;; Special case "package". FIXME: Should this still be supported? + (if (eq name 'package) (package--write-file-no-coding - (expand-file-name (concat file-name ".el") package-user-dir)) - (let* ((pkg-dir (expand-file-name (concat file-name "-" + (expand-file-name (format "%s.el" name) package-user-dir)) + (let* ((pkg-dir (expand-file-name (format "%s-%s" name (package-version-join (version-to-list version))) package-user-dir)) - (el-file (expand-file-name (concat file-name ".el") pkg-dir)) - (pkg-file (expand-file-name (concat file-name "-pkg.el") pkg-dir))) + (el-file (expand-file-name (format "%s.el" name) pkg-dir)) + (pkg-file (expand-file-name (format "%s-pkg.el" name) pkg-dir))) (make-directory pkg-dir t) (package--write-file-no-coding el-file) (let ((print-level nil) + (print-quoted t) (print-length nil)) (write-region (concat (prin1-to-string (list 'define-package - file-name + (symbol-name name) version desc - (list 'quote - ;; Turn version lists into string form. - (mapcar - (lambda (elt) - (list (car elt) - (package-version-join (cadr elt)))) - requires)))) + (when requires ;Don't bother quoting nil. + (list 'quote + ;; Turn version lists into string form. + (mapcar + (lambda (elt) + (list (car elt) + (package-version-join (cadr elt)))) + requires))))) "\n") nil pkg-file nil nil nil 'excl)) - (package--make-autoloads-and-compile file-name pkg-dir)))) + (package--make-autoloads-and-compile name pkg-dir)))) (defmacro package--with-work-buffer (location file &rest body) "Run BODY in a buffer containing the contents of FILE at LOCATION. @@ -744,7 +786,7 @@ It will move point to somewhere in the headers." (let ((location (package-archive-base name)) (file (concat (symbol-name name) "-" version ".el"))) (package--with-work-buffer location file - (package-unpack-single (symbol-name name) version desc requires)))) + (package-unpack-single name version desc requires)))) (defun package-download-tar (name version) "Download and install a tar package." @@ -762,7 +804,7 @@ MIN-VERSION should be a version list." (let ((pkg-desc (assq package package-alist))) (if pkg-desc (version-list-<= min-version - (package-desc-vers (cdr pkg-desc))) + (package-desc-version (cdr pkg-desc))) ;; Also check built-in packages. (package-built-in-p package min-version)))) @@ -785,7 +827,7 @@ not included in this list." (unless (package-installed-p next-pkg next-version) ;; A package is required, but not installed. It might also be ;; blocked via `package-load-list'. - (let ((pkg-desc (assq next-pkg package-archive-contents)) + (let ((pkg-desc (cdr (assq next-pkg package-archive-contents))) hold) (when (setq hold (assq next-pkg package-load-list)) (setq hold (cadr hold)) @@ -805,17 +847,17 @@ but version %s required" (symbol-name next-pkg) (package-version-join next-version))) (unless (version-list-<= next-version - (package-desc-vers (cdr pkg-desc))) + (package-desc-version pkg-desc)) (error "Need package `%s-%s', but only %s is available" (symbol-name next-pkg) (package-version-join next-version) - (package-version-join (package-desc-vers (cdr pkg-desc))))) + (package-version-join (package-desc-version pkg-desc)))) ;; Move to front, so it gets installed early enough (bug#14082). (setq package-list (cons next-pkg (delq next-pkg package-list))) (setq package-list (package-compute-transaction package-list (package-desc-reqs - (cdr pkg-desc)))))))) + pkg-desc))))))) package-list) (defun package-read-from-string (str) @@ -867,13 +909,29 @@ If the archive version is too new, signal an error." (dolist (package contents) (package--add-to-archive-contents package archive))))) +;; Package descriptor objects used inside the "archive-contents" file. +;; Changing this defstruct implies changing the format of the +;; "archive-contents" files. +(cl-defstruct (package--ac-desc + (:constructor package-make-ac-desc (version reqs summary kind)) + (:copier nil) + (:type vector)) + version reqs summary kind) + (defun package--add-to-archive-contents (package archive) "Add the PACKAGE from the given ARCHIVE if necessary. -Also, add the originating archive to the end of the package vector." - (let* ((name (car package)) - (version (package-desc-vers (cdr package))) - (entry (cons name - (vconcat (cdr package) (vector archive)))) +PACKAGE should have the form (NAME . PACKAGE--AC-DESC). +Also, add the originating archive to the `package-desc' structure." + (let* ((name (car package)) + (pkg-desc + (package-desc-create + :name name + :version (package--ac-desc-version (cdr package)) + :reqs (package--ac-desc-reqs (cdr package)) + :summary (package--ac-desc-summary (cdr package)) + :kind (package--ac-desc-kind (cdr package)) + :archive archive)) + (entry (cons name pkg-desc)) (existing-package (assq name package-archive-contents)) (pinned-to-archive (assoc name package-pinned-packages))) (cond ((and pinned-to-archive @@ -881,9 +939,9 @@ Also, add the originating archive to the end of the package vector." (not (equal (cdr pinned-to-archive) archive))) nil) ((not existing-package) - (add-to-list 'package-archive-contents entry)) - ((version-list-< (package-desc-vers (cdr existing-package)) - version) + (push entry package-archive-contents)) + ((version-list-< (package-desc-version (cdr existing-package)) + (package-desc-version pkg-desc)) ;; Replace the entry with this one. (setq package-archive-contents (cons entry @@ -902,14 +960,14 @@ using `package-compute-transaction'." ;; `package-load-list', download the held version. (hold (cadr (assq elt package-load-list))) (v-string (or (and (stringp hold) hold) - (package-version-join (package-desc-vers desc)))) + (package-version-join (package-desc-version desc)))) (kind (package-desc-kind desc))) (cond ((eq kind 'tar) (package-download-tar elt v-string)) ((eq kind 'single) (package-download-single elt v-string - (package-desc-doc desc) + (package-desc-summary desc) (package-desc-reqs desc))) (t (error "Unknown package kind: %s" (symbol-name kind)))) @@ -961,17 +1019,7 @@ Otherwise return nil." (error nil)))) (defun package-buffer-info () - "Return a vector describing the package in the current buffer. -The vector has the form - - [FILENAME REQUIRES DESCRIPTION VERSION COMMENTARY] - -FILENAME is the file name, a string, sans the \".el\" extension. -REQUIRES is a list of requirements, each requirement having the - form (NAME VER); NAME is a string and VER is a version list. -DESCRIPTION is the package description, a string. -VERSION is the version, a string. -COMMENTARY is the commentary section, a string, or nil if none. + "Return a `package-desc' describing the package in the current buffer. If the buffer does not contain a conforming package, signal an error. If there is a package, narrow the buffer to the file's @@ -990,25 +1038,18 @@ boundaries." (require 'lisp-mnt) ;; Use some headers we've invented to drive the process. (let* ((requires-str (lm-header "package-requires")) - (requires (if requires-str - (package-read-from-string requires-str))) ;; Prefer Package-Version; if defined, the package author ;; probably wants us to use it. Otherwise try Version. (pkg-version (or (package-strip-rcs-id (lm-header "package-version")) - (package-strip-rcs-id (lm-header "version")))) - (commentary (lm-commentary))) + (package-strip-rcs-id (lm-header "version"))))) (unless pkg-version (error "Package lacks a \"Version\" or \"Package-Version\" header")) - ;; Turn string version numbers into list form. - (setq requires - (mapcar - (lambda (elt) - (list (car elt) - (version-to-list (car (cdr elt))))) - requires)) - (vector file-name requires desc pkg-version commentary)))) + (package-desc-from-define + file-name pkg-version desc + (if requires-str (package-read-from-string requires-str)) + :kind 'single)))) (defun package-tar-file-info (file) "Find package information for a tar file. @@ -1025,67 +1066,46 @@ The return result is a vector like `package-buffer-info'." (pkg-def-contents (shell-command-to-string ;; Requires GNU tar. (concat "tar -xOf " file " " - pkg-name "-" pkg-version "/" pkg-name "-pkg.el"))) (pkg-def-parsed (package-read-from-string pkg-def-contents))) (unless (eq (car pkg-def-parsed) 'define-package) (error "No `define-package' sexp is present in `%s-pkg.el'" pkg-name)) - (let ((name-str (nth 1 pkg-def-parsed)) - (version-string (nth 2 pkg-def-parsed)) - (docstring (nth 3 pkg-def-parsed)) - (requires (nth 4 pkg-def-parsed)) - (readme (shell-command-to-string - ;; Requires GNU tar. - (concat "tar -xOf " file " " - pkg-name "-" pkg-version "/README")))) - (unless (equal pkg-version version-string) + (let ((pkg-desc + (apply #'package-desc-from-define (append (cdr pkg-def-parsed) + '(:kind tar))))) + (unless (equal pkg-version + (package-version-join (package-desc-version pkg-desc))) (error "Package has inconsistent versions")) - (unless (equal pkg-name name-str) + (unless (equal pkg-name (symbol-name (package-desc-name pkg-desc))) (error "Package has inconsistent names")) - ;; Kind of a hack. - (if (string-match ": Not found in archive" readme) - (setq readme nil)) - ;; Turn string version numbers into list form. - (if (eq (car requires) 'quote) - (setq requires (car (cdr requires)))) - (setq requires - (mapcar (lambda (elt) - (list (car elt) - (version-to-list (cadr elt)))) - requires)) - (vector pkg-name requires docstring version-string readme))))) + pkg-desc)))) + ;;;###autoload -(defun package-install-from-buffer (pkg-info type) +(defun package-install-from-buffer (pkg-desc) "Install a package from the current buffer. When called interactively, the current buffer is assumed to be a single .el file that follows the packaging guidelines; see info node `(elisp)Packaging'. -When called from Lisp, PKG-INFO is a vector describing the -information, of the type returned by `package-buffer-info'; and -TYPE is the package type (either `single' or `tar')." - (interactive (list (package-buffer-info) 'single)) +When called from Lisp, PKG-DESC is a `package-desc' describing the +information)." + (interactive (list (package-buffer-info))) (save-excursion (save-restriction - (let* ((file-name (aref pkg-info 0)) - (requires (aref pkg-info 1)) - (desc (if (string= (aref pkg-info 2) "") - "No description available." - (aref pkg-info 2))) - (pkg-version (aref pkg-info 3))) + (let* ((name (package-desc-name pkg-desc)) + (requires (package-desc-reqs pkg-desc)) + (desc (package-desc-summary pkg-desc)) + (pkg-version (package-desc-version pkg-desc))) ;; Download and install the dependencies. (let ((transaction (package-compute-transaction nil requires))) (package-download-transaction transaction)) ;; Install the package itself. - (cond - ((eq type 'single) - (package-unpack-single file-name pkg-version desc requires)) - ((eq type 'tar) - (package-unpack (intern file-name) pkg-version)) - (t - (error "Unknown type: %s" (symbol-name type)))) + (pcase (package-desc-kind pkg-desc) + (`single (package-unpack-single name pkg-version desc requires)) + (`tar (package-unpack name pkg-version)) + (type (error "Unknown type: %S" type))) ;; Try to activate it. (package-initialize))))) @@ -1097,10 +1117,10 @@ The file can either be a tar file or an Emacs Lisp file." (with-temp-buffer (insert-file-contents-literally file) (cond - ((string-match "\\.el$" file) - (package-install-from-buffer (package-buffer-info) 'single)) - ((string-match "\\.tar$" file) - (package-install-from-buffer (package-tar-file-info file) 'tar)) + ((string-match "\\.el\\'" file) + (package-install-from-buffer (package-buffer-info))) + ((string-match "\\.tar\\'" file) + (package-install-from-buffer (package-tar-file-info file))) (t (error "Unrecognized extension `%s'" (file-name-extension file)))))) (defun package-delete (name version) @@ -1118,7 +1138,7 @@ The file can either be a tar file or an Emacs Lisp file." (defun package-archive-base (name) "Return the archive containing the package NAME." (let ((desc (cdr (assq (intern-soft name) package-archive-contents)))) - (cdr (assoc (aref desc (- (length desc) 1)) package-archives)))) + (cdr (assoc (package-desc-archive desc) package-archives)))) (defun package--download-one-archive (archive file) "Retrieve an archive file FILE from ARCHIVE, and cache it. @@ -1163,7 +1183,7 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (package-read-all-archive-contents) (unless no-activate (dolist (elt package-alist) - (package-activate (car elt) (package-desc-vers (cdr elt))))) + (package-activate (car elt) (package-desc-version (cdr elt))))) (setq package--initialized t)) @@ -1210,22 +1230,22 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (cond ;; Loaded packages are in `package-alist'. ((setq desc (cdr (assq package package-alist))) - (setq version (package-version-join (package-desc-vers desc))) + (setq version (package-version-join (package-desc-version desc))) (if (setq pkg-dir (package--dir package-name version)) (insert "an installed package.\n\n") ;; This normally does not happen. (insert "a deleted package.\n\n"))) ;; Available packages are in `package-archive-contents'. ((setq desc (cdr (assq package package-archive-contents))) - (setq version (package-version-join (package-desc-vers desc)) - archive (aref desc (- (length desc) 1)) + (setq version (package-version-join (package-desc-version desc)) + archive (package-desc-archive desc) installable t) (if built-in (insert "a built-in package.\n\n") (insert "an uninstalled package.\n\n"))) (built-in - (setq desc (cdr built-in) - version (package-version-join (package-desc-vers desc))) + (setq desc (package--from-builtin built-in) + version (package-version-join (package-desc-version desc))) (insert "a built-in package.\n\n")) (t (insert "an orphan package.\n\n"))) @@ -1246,7 +1266,8 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (insert "'."))) (installable (if built-in - (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face) + (insert (propertize "Built-in." + 'font-lock-face 'font-lock-builtin-face) " Alternate version available") (insert "Available")) (insert " from " archive) @@ -1261,7 +1282,8 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." 'package-symbol package 'action 'package-install-button-action))) (built-in - (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face))) + (insert (propertize "Built-in." + 'font-lock-face 'font-lock-builtin-face))) (t (insert "Deleted."))) (insert "\n") (and version (> (length version) 0) @@ -1286,7 +1308,7 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (help-insert-xref-button text 'help-package name)) (insert "\n"))) (insert " " (propertize "Summary" 'font-lock-face 'bold) - ": " (if desc (package-desc-doc desc)) "\n\n") + ": " (if desc (package-desc-summary desc)) "\n\n") (if built-in ;; For built-in packages, insert the commentary. @@ -1418,10 +1440,10 @@ If the alist stored in the symbol LISTNAME lacks an entry for a package PACKAGE with descriptor DESC, add one. The alist is keyed with cons cells (PACKAGE . VERSION-LIST), where PACKAGE is a symbol and VERSION-LIST is a version list." - `(let* ((version (package-desc-vers ,desc)) + `(let* ((version (package-desc-version ,desc)) (key (cons ,package version))) (unless (assoc key ,listname) - (push (list key ,status (package-desc-doc ,desc)) ,listname)))) + (push (list key ,status (package-desc-summary ,desc)) ,listname)))) (defun package-menu--generate (remember-pos packages) "Populate the Package Menu. @@ -1444,7 +1466,7 @@ or a list of package names (symbols) to display." (setq name (car elt)) (when (and (not (eq name 'emacs)) ; Hide the `emacs' package. (or (eq packages t) (memq name packages))) - (package--push name (cdr elt) "built-in" info-list))) + (package--push name (package--from-builtin elt) "built-in" info-list))) ;; Available and disabled packages: (dolist (elt package-archive-contents) diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index a88b9d70930..f9d0fd9366b 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -957,7 +957,7 @@ If non-nil, it will blink not only for \"begin..end\" but also for \"if...else\" (let ((ender (funcall smie-backward-token-function))) (cond ((not (and ender (rassoc ender smie-closer-alist))) - ;; This not is one of the begin..end we know how to check. + ;; This is not one of the begin..end we know how to check. (blink-matching-check-mismatch start end)) ((not start) t) ((eq t (car (rassoc ender smie-closer-alist))) nil) @@ -1012,6 +1012,9 @@ This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'. (or (eq (char-before) last-command-event) (not (memq (char-before) smie-blink-matching-triggers))) + ;; FIXME: For octave's "switch ... case ... case" we flash + ;; `switch' at the end of the first `case' and we burp + ;; "mismatch" at the end of the second `case'. (or smie-blink-matching-inners (not (numberp (nth 2 (assoc token smie-grammar)))))) ;; The major mode might set blink-matching-check-function @@ -1021,87 +1024,90 @@ This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'. (let ((blink-matching-check-function #'smie-blink-matching-check)) (blink-matching-open)))))))) -(defface smie-matching-block-highlight '((t (:inherit highlight))) - "Face used to highlight matching block." - :group 'smie) - -(defvar smie--highlight-matching-block-overlay nil) -(defvar-local smie--highlight-matching-block-lastpos -1) - -(defun smie-highlight-matching-block () - (when (and smie-closer-alist - (/= (point) smie--highlight-matching-block-lastpos)) - (unless (overlayp smie--highlight-matching-block-overlay) - (setq smie--highlight-matching-block-overlay - (make-overlay (point) (point)))) - (setq smie--highlight-matching-block-lastpos (point)) - (let ((beg-of-tok - (lambda (&optional start) - "Move to the beginning of current token at START." - (let* ((token) - (start (or start (point))) - (beg (progn +(defvar-local smie--matching-block-data-cache nil) + +(defun smie--opener/closer-at-point () + "Return (OPENER TOKEN START END) or nil. +OPENER is non-nil if TOKEN is an opener and nil if it's a closer." + (let* ((start (point)) + ;; Move to a previous position outside of a token. + (_ (funcall smie-backward-token-function)) + ;; Move to the end of the token before point. + (btok (funcall smie-forward-token-function)) + (bend (point))) + (cond + ;; Token before point is a closer? + ((and (>= bend start) (rassoc btok smie-closer-alist)) + (funcall smie-backward-token-function) + (when (< (point) start) + (prog1 (list nil btok (point) bend) + (goto-char bend)))) + ;; Token around point is an opener? + ((and (> bend start) (assoc btok smie-closer-alist)) + (funcall smie-backward-token-function) + (when (<= (point) start) (list t btok (point) bend))) + ((<= bend start) + (let ((atok (funcall smie-forward-token-function)) + (aend (point))) + (cond + ((< aend start) nil) ;Hopefully shouldn't happen. + ;; Token after point is a closer? + ((assoc atok smie-closer-alist) + (funcall smie-backward-token-function) + (when (<= (point) start) + (list t atok (point) aend))))))))) + +(defun smie--matching-block-data (orig &rest args) + "A function suitable for `show-paren-data-function' (which see)." + (if (or (null smie-closer-alist) + (eq (point) (car smie--matching-block-data-cache))) + (or (cdr smie--matching-block-data-cache) + (apply orig args)) + (setq smie--matching-block-data-cache (list (point))) + (unless (nth 8 (syntax-ppss)) + (condition-case nil + (let ((here (smie--opener/closer-at-point))) + (when (and here + (or smie-blink-matching-inners + (not (numberp + (nth (if (nth 0 here) 1 2) + (assoc (nth 1 here) smie-grammar)))))) + (let ((there + (cond + ((car here) ; Opener. + (let ((data (smie-forward-sexp 'halfsexp)) + (tend (point))) + (unless (car data) (funcall smie-backward-token-function) - (forward-comment (point-max)) - (point))) - (end (progn - (setq token (funcall smie-forward-token-function)) - (forward-comment (- (point))) - (point)))) - (if (and (<= beg start) (<= start end) - (or (assoc token smie-closer-alist) - (rassoc token smie-closer-alist))) - (progn (goto-char beg) token) - (goto-char start) - nil)))) - (highlight - (lambda (beg end) - (move-overlay smie--highlight-matching-block-overlay - beg end (current-buffer)) - (overlay-put smie--highlight-matching-block-overlay - 'face 'smie-matching-block-highlight)))) - (overlay-put smie--highlight-matching-block-overlay 'face nil) - (unless (nth 8 (syntax-ppss)) - (save-excursion - (condition-case nil - (let ((token - (or (funcall beg-of-tok) - (funcall beg-of-tok - (prog1 (point) - (funcall smie-forward-token-function)))))) - (cond - ((assoc token smie-closer-alist) ; opener - (forward-sexp 1) - (let ((end (point)) - (closer (funcall smie-backward-token-function))) - (when (rassoc closer smie-closer-alist) - (funcall highlight (point) end)))) - ((rassoc token smie-closer-alist) ; closer - (funcall smie-forward-token-function) - (forward-sexp -1) - (let ((beg (point)) - (opener (funcall smie-forward-token-function))) - (when (assoc opener smie-closer-alist) - (funcall highlight beg (point))))))) - (scan-error))))))) - -(defvar smie--highlight-matching-block-timer nil) - -;;;###autoload -(define-minor-mode smie-highlight-matching-block-mode nil - :global t :group 'smie - (when (timerp smie--highlight-matching-block-timer) - (cancel-timer smie--highlight-matching-block-timer)) - (setq smie--highlight-matching-block-timer nil) - (if smie-highlight-matching-block-mode - (progn - (remove-hook 'post-self-insert-hook #'smie-blink-matching-open 'local) - (setq smie--highlight-matching-block-timer - (run-with-idle-timer 0.2 t #'smie-highlight-matching-block))) - (when smie--highlight-matching-block-overlay - (delete-overlay smie--highlight-matching-block-overlay) - (setq smie--highlight-matching-block-overlay nil)) - (kill-local-variable 'smie--highlight-matching-block-lastpos))) + (list (member (cons (nth 1 here) (nth 2 data)) + smie-closer-alist) + (point) tend)))) + (t ;Closer. + (let ((data (smie-backward-sexp 'halfsexp)) + (htok (nth 1 here))) + (if (car data) + (let* ((hprec (nth 2 (assoc htok smie-grammar))) + (ttok (nth 2 data)) + (tprec (nth 1 (assoc ttok smie-grammar)))) + (when (and (numberp hprec) ;Here is an inner. + (eq hprec tprec)) + (goto-char (nth 1 data)) + (let ((tbeg (point))) + (funcall smie-forward-token-function) + (list t tbeg (point))))) + (let ((tbeg (point))) + (funcall smie-forward-token-function) + (list (member (cons (nth 2 data) htok) + smie-closer-alist) + tbeg (point))))))))) + ;; Update the cache. + (setcdr smie--matching-block-data-cache + (list (nth 2 here) (nth 3 here) + (nth 1 there) (nth 2 there) + (not (nth 0 there))))))) + (scan-error nil)) + (goto-char (car smie--matching-block-data-cache))) + (apply #'smie--matching-block-data orig args))) ;;; The indentation engine. @@ -1799,9 +1805,10 @@ KEYWORDS are additional arguments, which can use the following keywords: (setq-local smie-closer-alist ca) ;; Only needed for interactive calls to blink-matching-open. (setq-local blink-matching-check-function #'smie-blink-matching-check) - (unless smie-highlight-matching-block-mode - (add-hook 'post-self-insert-hook - #'smie-blink-matching-open 'append 'local)) + (add-hook 'post-self-insert-hook + #'smie-blink-matching-open 'append 'local) + (add-function :around (local 'show-paren-data-function) + #'smie--matching-block-data) ;; Setup smie-blink-matching-triggers. Rather than wait for SPC to ;; blink, try to blink as soon as we type the last char of a block ender. (let ((closers (sort (mapcar #'cdr smie-closer-alist) #'string-lessp)) |