commit 18491f48d973c9cbc453d9f742ec7f73e83df3bb (HEAD, refs/remotes/origin/master) Author: Richard M. Stallman Date: Fri Aug 2 12:03:45 2024 -0400 Install cond* * oond-star.el: New file. diff --git a/lisp/emacs-lisp/cond-star.el b/lisp/emacs-lisp/cond-star.el new file mode 100644 index 00000000000..6309b0d1a15 --- /dev/null +++ b/lisp/emacs-lisp/cond-star.el @@ -0,0 +1,707 @@ +;;; -*-lexical-binding: t; -*- + +;; Copyright (C) 1985-2024 Free Software Foundation, Inc. + +;; Maintainer: rms@gnu.org +;; Package: emacs + +;; This file is part of GNU Emacs. It implements `cond*'. + +;; cond* 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. + +;; cond* is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;; Here is the list of functions the generated code is known to call: +;; car, cdr, car-safe, cdr-safe, nth, nthcdr, null, eq, equal, eql, =, +;; vectorp, length. +;; It also uses these control and binding promitives: +;; and, or, if, progn, let, let*, setq. +;; For regexp matching only, it can call string-match and match-string. + +;;; ??? If a clause starts with a keyword, +;;; should the element after the kwyword be treated in the usual way +;;; as a pattern? Curently `cond*-non-exit-clause-substance' explicitly +;;; prevents that by adding t at the front of its value. + +(defmacro cond* (&rest clauses) + "Extended form of traditional Lisp `cond' construct. +A `cond*' construct is a series of clauses, and a clause +normally has the form (CONDITION BDOY...). + +CONDITION can be a Lisp expression, as in `cond'. +Or it can be `(bind* BINDINGS...)' or `(match* PATTERN DATUM)'. + +`(bind* BINDINGS...)' means to bind BINDINGS (as if they were in `let*') +for the body of the clause. As a condition, it counts as true +if the first binding's value is non-nil. All the bindings are made +unconditionally for whatever scope they cover. + +`(match* PATTERN DATUM)' means to match DATUM against the pattern PATTERN +The condition counts as true if PATTERN matches DATUM. + +When a clause's condition is true, and it exits the `cond*' +or is the last clause, the value of the last expression +in its body becomes the return value of the `cond*' construct. + +Mon-exit clause: + +If a clause has only one element, or if its first element is +t, or if it ends with the keyword :non-exit, then +this clause never exits the `cond*' construct. Instead, +control falls through to the next clause (if any). +The bindings made in CONDITION for the BODY of the non-exit clause +are passed along to the rest of the clauses in this `cond*' construct. + +\\[match*\\] for documentation of the patterns for use in `match*'." + (cond*-convert clauses)) + +(defmacro match* (pattern datum) + "This specifies matching DATUM against PATTERN. +It is not really a LIsp function, and it is meaningful +only in the CONDITION of a `cond*' clause. + +`_' matches any value. +KEYWORD matches that keyword. +nil matches nil. +t matches t. +SYMBOL matches any value and binds SYMBOL to that value. + If SYMBOL has been matched and bound earlier in this pattern, + it matches here the same value that it matched before. +REGEXP matches a string if REGEXP matches it. + The match must cover the entire string from its first char to its last. +ATOM (meaning any other kind of non-list not described above) + matches anything `equal' to it. +(rx REGEXP) uses a regexp specified in s-expression form, + as in the function `rx', and matches the data that way. +(rx REGEXP SYM0 SYM1...) uses a regexp specified in s-expression form, + and binds the symbols SYM0, SYM1, and so on + to (match-string 0 DATUM), (match-string 1 DATUM), and so on. + You can use as many SYMs as regexp matching supports. + +`OBJECT matches any value `equal' to OBJECT. +(cons CARPAT CDRPAT) + matches a cons cell if CARPAT matches its car and CDRPAT matches its cdr. +(list ELTPATS...) + matches a list if the ELTPATS match its elements. + The first ELTPAT should match the list's first element. + The second ELTPAT should match the list's second element. And so on. +(vector ELTPATS...) + matches a vector if the ELTPATS match its elements. + The first ELTPAT should match the vector's first element. + The second ELTPAT should match the vector's second element. And so on. +(cdr PATTERN) matches PATTERN with strict checking of cdrs. + That means that `list' patterns verify that the final cdr is nil. + Strict checking is the default. +(cdr-safe PATTERN) matches PATTERN with lax checking of cdrs. + That means that `list' patterns do not examine the final cdr. +(and CONJUNCTS...) matches each of the CONJUNCTS against the same data. + If all of them match, this pattern succeeds. + If one CONJUNCT fails, this pattern fails and does not try more CONJUNCTS. +(or DISJUNCTS...) matches each of te DISJUNCTS against the same data. + If one DISJUNCT succeeds, this pattern succeeds + and does not try more DISJUNCTs. + If all of them fail, this pattern fails. +(COND*-EXPANDER ...) + Here the car is a symbol that has a `cond*-expander' property + which defines how to handle it in a pattern. The property value + is a function. Trying to match such a pattern calls that + function with one argument, the pattern in question (including its car). + The function should return an equivalent pattern + to be matched inetead. +(PREDICATE SYMBOL) + matches datum if (PREDICATE DATUM) is true, + then binds SYMBOL to DATUM. +(PREDICATE SYMBOL MORE-ARGS...) + matches datum if (PREDICATE DATUM MORE-ARGS...) is true, + then binds SYMBOL to DATUM. + MORE-ARGS... can refer to symbols bound earlier in the pattern. +(constrain SYMBOL EXP) + matches datum if the form EXP is true. + EXP can refer to symbols bound earlier in the pattern." + (ignore datum) + (byte-compile-warn-x pattern "`match*' used other than as a `cond*' condition")) + +(defun cond*-non-exit-clause-p (clause) + "If CLAUSE, a cond* clause, is a non-exit clause, return t." + (or (null (cdr-safe clause)) ;; clause has only one element. + (and (cdr-safe clause) + ;; Starts with t. + (or (eq (car clause) t) + ;; Begins with keyword. + (keywordp (car clause)))) + ;; Ends with keyword. + (keywordp (car (last clause))))) + +(defun cond*-non-exit-clause-substance (clause) + "For a non-exit cond* clause CLAUSE, return its substance. +This removes a final keyword if that's what makes CLAUSE non-exit." + (cond ((null (cdr-safe clause)) ;; clause has only one element. + clause) + ;; Starts with t or a keyword. + ;; Include t as the first element of the substancea + ;; so that the following element is not treated as a pattern. + ((and (cdr-safe clause) + (or (eq (car clause) t) + (keywordp (car clause)))) + ;; Standardize on t as the first element. + (cons t (cdr clause))) + + ;; Ends with keyword. + ((keywordp (car (last clause))) + ;; Do NOT include the final keyword. + (butlast clause)))) + +(defun cond*-convert (clauses) + "Process a list of cond* clauses, CLAUSES. +Returns the equivalent Lisp expression." + (if clauses + (cond*-convert-clause (car-safe clauses) (cdr-safe clauses)))) + +(defun cond*-convert-clause (clause rest) + "Process one `cond*' clause, CLAUSE. +REST is the rest of the clauses of this cond* expression." + (if (cond*-non-exit-clause-p clause) + ;; Handle a non-exit clause. Make its bindings active + ;; around the whole rest of this cond*, treating it as + ;; a condition whose value is always t, around the rest + ;; of this cond*. + (let ((substance (cond*-non-exit-clause-substance clause))) + (cond*-convert-condition + ;; Handle the first substantial element in the non-exit clause + ;; as a matching condition. + (car substance) + ;; Any following elements in the + ;; non-exit clause are just expressions. + (cdr substance) + ;; Remaining clauses will be UNCONDIT-CLAUSES: + ;; run unconditionally and handled as a cond* body. + rest + nil nil)) + ;; Handle a normal (conditional exit) clauss. + (cond*-convert-condition (car-safe clause) (cdr-safe clause) nil + rest (cond*-convert rest)))) + +(defun cond*-convert-condition (condition true-exps uncondit-clauses rest iffalse) + "Process the condition part of one cond* clause. +TRUE-EXPS is a list of Lisp expressions to be executed if this +condition is true, and inside its bindings. +UNCONDIT-CLAUSES is a list of cond*-clauses to be executed if this +condition is true, and inside its bindings. +This is used for non-exit clauses; it is nil for conditional-exit clauses. + +REST and IFFALSE are non-nil for conditional-exit clauses that are not final. +REST is a list of clauses to process after this one if +this one could have exited but does not exit. +This is used for conditional exit clauses. +IFFALSE is the value to compute after this one if +this one could have exited but does not exit. +This is used for conditional exit clauses." + (if (and uncondit-clauses rest) + (error "Clause is both exiting and non-exit")) + (let ((pat-type (car-safe condition))) + (cond ((eq pat-type 'bind*) + (let* ((bindings (cdr condition)) + (first-binding (car bindings)) + (first-variable (if (symbolp first-binding) first-binding + (car first-binding))) + (first-value (if (symbolp first-binding) nil + (cadr first-binding))) + (init-gensym (gensym "init")) + ;; BINDINGS with the initial value of the first binding + ;; replaced by INIT-GENSYM. + (mod-bindings + (cons (list first-variable init-gensym) (cdr bindings)))) + ;;; ??? Here pull out all nontrivial initial values + ;;; ??? to compute them earlier. + (if rest + ;; bind* starts an exiting clause which is not final. + ;; Therefore, must run IFFALSE. + `(let ((,init-gensym ,first-value)) + (if ,init-gensym + (let* ,mod-bindings + . ,true-exps) + ;; Always calculate all bindings' initial values, + ;; but the bindings must not cover IFFALSE. + (let* ,mod-bindings nil) + ,iffalse)) + (if uncondit-clauses + ;; bind* starts a non-exit clause which is not final. + ;; Run the TRUE-EXPS if condition value is true. + ;; Then always go on to run the UNCONDIT-CLAUSES. + (if true-exps + `(let ((,init-gensym ,first-value)) +;;; ??? Should we make the bindings a second time for the UNCONDIT-CLAUSES. +;;; as the doc string says, for uniformity with match*? + (let* ,mod-bindings + (when ,init-gensym + . ,true-exps) + ,(cond*-convert uncondit-clauses))) + `(let* ,bindings + ,(cond*-convert uncondit-clauses))) + ;; bind* starts a final clause. + ;; If there are TRUE-EXPS, run them if condition succeeded. + ;; Always make the bindings, in case the + ;; initial values have side effects. + `(let ((,init-gensym ,first-value)) + ;; Calculate all binding values unconditionally. + (let* ,mod-bindings + (when ,init-gensym + . ,true-exps))))))) + ((eq pat-type 'match*) + (cond*-match condition true-exps uncondit-clauses iffalse)) + (t + ;; Ordinary Lixp expression is the condition + (if rest + ;; A nonfinal exiting clause. + ;; If condition succeeds, run the TRUE-EXPS. + ;; There are following clauses, so run IFFALSE + ;; if the condition fails. + `(if ,condition + (progn . ,true-exps) + ,iffalse) + (if uncondit-clauses + ;; A non-exit clause. + ;; If condition succeeds, run the TRUE-EXPS. + ;; Then always go on to run the UNCONDIT-CLAUSES. + `(progn (if ,condition + (progn . ,true-exps)) + ,(cond*-convert uncondit-clauses)) + ;; An exiting clause which is also final. + ;; If there are TRUE-EXPS, run them if CONDITION succeeds. + (if true-exps + `(if ,condition (progn . ,true-exps)) + ;; Run and return CONDITION. + condition))))))) + +(defun cond*-match (matchexp true-exps uncondit-clauses iffalse) + "Generate code to match a match* pattern PATTERN. +Match it against data represented by the expression DATA. +TRUE-EXPS, UNCONDIT-CLAUSES and IFFALSE have the same meanings +as in `cond*-condition'." + (when (or (null matchexp) (null (cdr-safe matchexp)) + (null (cdr-safe (cdr matchexp))) + (cdr-safe (cdr (cdr matchexp)))) + (byte-compile-warn-x matchexp "Malformed (match* ...) expression")) + (let* (raw-result + (pattern (nth 1 matchexp)) + (data (nth 2 matchexp)) + expression + (inner-data data) + ;; Add backtrack aliases for or-subpatterns to cdr of this. + (backtrack-aliases (list nil)) + run-true-exps + store-value-swap-outs retrieve-value-swap-outs + gensym) + ;; For now, always bind a gensym to the data to be matched. + (setq gensym (gensym "d") inner-data gensym) + ;; Process the whole pattern as a subpattern. + (setq raw-result (cond*-subpat pattern nil nil nil backtrack-aliases inner-data)) + (setq expression (cdr raw-result)) + ;; If there are conditional expressions and some + ;; unconditional clauses to follow, + ;; and the pattern bound some variables, + ;; copy their values into special aliases + ;; to be copied back at the start of the unonditional clauses. + (when (and uncondit-clauses true-exps + (car raw-result)) + (dolist (bound-var (car raw-result)) + (push `(setq ,(gensym "ua") ,(car bound-var)) store-value-swap-outs) + (push `(,(car bound-var) ,(gensym "ua")) retrieve-value-swap-outs))) + + ;; Make an expression to run the TRUE-EXPS inside our bindings. + (if store-value-swap-outs + ;; If we have to store those bindings' values in aliases + ;; for the UNCONDIT-CLAUSES, ;; do so inside these bindigs. + (setq run-true-exps + (cond*-bind-pattern-syms + (car raw-result) + `(prog1 (progn . ,true-exps) . ,store-value-swap-outs))) + (setq run-true-exps + (cond*-bind-pattern-syms + (car raw-result) + `(progn . ,true-exps)))) + ;; Run TRUE-EXPS if match succeeded. Bind our bindings around it. + (setq expression + (if (and (null run-true-exps) (null iffalse)) + ;; We MUST compute the expression, even when no decision + ;; depends on its value, because it may call functions with + ;; side effects. + expression + `(if ,expression + ,run-true-exps + ;; For a non-final exiting clause, run IFFALSE if match failed. + ;; Don't bind the bindings around it, since + ;; an exiting clause's bindings don't affect later clauses. + ,iffalse))) + ;; For a non-final non-exiting clause, + ;; always run the UNCONDIT-CLAUSES. + (if uncondit-clauses + (setq expression + `(progn ,expression + (cond*-bind-pattern-syms + ,(if retrieve-value-swap-outs + ;; If we saved the bindings' values after the + ;; true-clauses, bind the same variables + ;; here to the values we saved then. + retrieve-value-swap-outs + ;; Otherwise bind them to the values + ;; they matched in the pattern. + (car raw-result)) + (cond*-convert uncondit-clauses))))) + ;; Bind the backtrack-aliases if any. + ;; We need them bound for the TRUE-EXPS. + ;; It is harmless to bind them around IFFALSE + ;; because they are all gensyms anyway. + (if (cdr backtrack-aliases) + (setq expression + `(let ,(mapcar 'cdr (cdr backtrack-aliases)) + ,expression))) + (if retrieve-value-swap-outs + (setq expression + `(let ,(mapcar 'cadr retrieve-value-swap-outs) + ,expression))) + ;; If we used a gensym, wrap on code to bind it. + (if gensym + (if (and (listp expression) (eq (car expression) 'progn)) + `(let ((,gensym ,data)) . ,(cdr expression)) + `(let ((,gensym ,data)) ,expression)) + expression))) + +(defun cond*-bind-pattern-syms (bindings expr) + "Wrap EXPR in code to bind the BINDINGS. +This is used for the bindings specified explicitly in match* patterns." + ;; They can't have side effects. Skip them + ;; if we don't actually need them. + (if (equal expr '(progn)) + nil + (if bindings + (if (eq (car expr) 'progn) + `(let* ,bindings . ,(cdr expr)) + `(let* ,bindings ,expr)) + expr))) + +(defvar cond*-debug-pattern nil) + +;;; ??? Structure type patterns not implemented yet. +;;; ??? Probably should optimize the `nth' calls in handling `list'. + +(defun cond*-subpat (subpat cdr-ignore bindings inside-or backtrack-aliases data) + "Generate code to match the subpattern within `match*'. +SUBPAT is the subpattern to handle. +CDR-IGNORE if true means don't verify there are no extra elts in a list. +BINDINGS is the list of bindings made by +the containing and previous subpatterns of this pattern. +Each element of BINDINGS must have the form (VAR VALUE). +BACKTRACK-ALIASES is used to pass data upward. Initial call should +pass (list). The cdr of this collects backtracking aliases made for +variables bound within (or...) patterns so that the caller +can bind them etc. Each of them has the form (USER-SYMBOL . GENSYM). +DATA is the expression for the data that this subpattern is +supposed to match against. + +Return Value has the form (BINDINGS . CONDITION), where +BINDINGS is the list of bindings to be made for SUBPAT +plus the subpatterns that contain/precede it. +Each element of BINDINGS has the form (VAR VALUE). +CONDITION is the condition to be tested to decide +whether SUBPAT (as well as the subpatterns that contain/precede it) matches," + (if (equal cond*-debug-pattern subpat) + (debug)) +;;; (push subpat subpat-log) + (cond ((eq subpat '_) + ;; _ as pattern makes no bindings and matches any data. + (cons bindings t)) + ((memq subpat '(nil t)) + (cons bindings `(eq ,subpat ,data))) + ((keywordp subpat) + (cons bindings `(eq ,subpat ,data))) + ((symbolp subpat) + (let ((this-binding (assq subpat bindings)) + (this-alias (assq subpat (cdr backtrack-aliases)))) + (if this-binding + ;; Variable already bound. + ;; Compare what this variable should be bound to + ;; to the data it is supposed to match. + ;; That is because we don't actually bind these bindings + ;; around the condition-testing expression. + (cons bindings `(equal ,(cadr this-binding) ,data)) + (if inside-or + (let (alias-gensym) + (if this-alias + ;; Inside `or' subpattern, if this symbol already + ;; has an alias for backtracking, just use that. + ;; This means the symbol was matched + ;; in a previous arm of the `or'. + (setq alias-gensym (cdr this-alias)) + ;; Inside `or' subpattern but this symbol has no alias, + ;; make an alias for it. + (setq alias-gensym (gensym "ba")) + (push (cons subpat alias-gensym) (cdr backtrack-aliases))) + ;; Make a binding for the symbol, to its backtrack-alias, + ;; and set the alias (a gensym) to nil. + (cons `((,subpat ,alias-gensym) . ,bindings) + `(setq ,alias-gensym ,data))) + ;; Not inside `or' subpattern: ask for a binding for this symbol + ;; and say it does match whatever datum. + (cons `((,subpat ,data) . ,bindings) + t))))) + ;; Various constants. + ((numberp subpat) + (cons bindings `(eql ,subpat ,data))) + ;; Regular expressions as strings. + ((stringp subpat) + (cons bindings `(string-match ,(concat subpat "\\'") ,data))) + ;; All other atoms match with `equal'. + ((not (consp subpat)) + (cons bindings `(equal ,subpat ,data))) + ((not (consp (cdr subpat))) + (byte-compile-warn-x subpat "%s subpattern with malformed or missing arguments" (car subpat))) + ;; Regular expressions specified as list structure. + ;; (rx REGEXP VARS...) + ((eq (car subpat) 'rx) + (let* ((rxpat (concat (rx-to-string (cadr subpat) t) "\\'")) + (vars (cddr subpat)) setqs (varnum 0) + (match-exp `(string-match ,rxpat ,data))) + (if (null vars) + (cons bindings match-exp) + ;; There are variables to bind to the matched substrings. + (if (> (length vars) 10) + (byte-compile-warn-x vars "Too many variables specified for matched substrings")) + (dolist (elt vars) + (unless (symbolp elt) + (byte-compile-warn-x vars "Non-symbol %s given as name for matched substring" elt))) + ;; Bind these variables to nil, before the pattern. + (setq bindings (nconc (mapcar 'list vars) bindings)) + ;; Make the expressions to set the variables. + (setq setqs (mapcar + (lambda (var) + (prog1 `(setq ,var (match-string ,varnum ,data)) + (setq varnum (1+ varnum)))) + vars)) + (cons bindings `(if ,match-exp + (progn ,@setqs t)))))) + ;; Quoted object as constant to match with `eq' or `equal'. + ((eq (car subpat) 'quote) + (if (symbolp (car-safe (cdr-safe subpat))) + (cons bindings `(eq ,subpat ,data)) + (cons bindings `(equal ,subpat ,data)))) + ;; Match a call to `cons' by destructuring. + ((eq (car subpat) 'cons) + (let (car-result cdr-result car-exp cdr-exp) + (setq car-result + (cond*-subpat (nth 1 subpat) cdr-ignore bindings inside-or backtrack-aliases `(car ,data))) + (setq bindings (car car-result) + car-exp (cdr car-result)) + (setq cdr-result + (cond*-subpat (nth 2 subpat) cdr-ignore bindings inside-or backtrack-aliases `(cdr ,data))) + (setq bindings (car cdr-result) + cdr-exp (cdr cdr-result)) + (cons bindings + (cond*-and `((consp ,data) ,car-exp ,cdr-exp))))) + ;; Match a call to `list' by destructuring. + ((eq (car subpat) 'list) + (let ((i 0) expressions) + ;; Check for bad structure of SUBPAT here? + (dolist (this-elt (cdr subpat)) + (let ((result + (cond*-subpat this-elt cdr-ignore bindings inside-or backtrack-aliases `(nth ,i ,data)))) + (setq bindings (car result)) + (push `(consp ,(if (zerop i) data `(nthcdr ,i ,data))) + expressions) + (setq i (1+ i)) + (push (cdr result) expressions))) + ;; Verify that list ends here, if we are supposed to check that. + (unless cdr-ignore + (push `(null (nthcdr ,i ,data)) expressions)) + (cons bindings (cond*-and (nreverse expressions))))) + ;; Match (apply 'vector (backquote-list* LIST...)), destructuring. + ((eq (car subpat) 'apply) + ;; We only try to handle the case generated by backquote. + ;; Convert it to a call to `vector' and handle that. + (let ((cleaned-up + `(vector . ,(cond*-un-backquote-list* (cdr (nth 2 subpat)))))) + ;; (cdr (nth 2 subpat)) gets LIST as above. + (cond*-subpat cleaned-up + cdr-ignore bindings inside-or backtrack-aliases data))) + ;; Match a call to `vector' by destructuring. + ((eq (car subpat) 'vector) + (let* ((elts (cdr subpat)) + (length (length elts)) + expressions (i 0)) + (dolist (elt elts) + (let* ((result + (cond*-subpat elt cdr-ignore + bindings inside-or backtrack-aliases `(aref ,i ,data)))) + (setq i (1+ i)) + (setq bindings (car result)) + (push (cdr result) expressions))) + (cons bindings + (cond*-and `((vectorp ,data) (= (length ,data) ,length) + . ,(nreverse expressions)))))) + ;; Subpattern to set the cdr-ignore flag + ((eq (car subpat) 'cdr-ignore) + (cond*-subpat (cadr subpat) t bindings inside-or backtrack-aliases data)) + ;; Subpattern to clear the cdr-ignore flag + ((eq (car subpat) 'cdr) + (cond*-subpat (cadr subpat) nil bindings inside-or backtrack-aliases data)) + ;; Handle conjunction subpatterns. + ((eq (car subpat) 'and) + (let (expressions) + ;; Check for bad structure of SUBPAT here? + (dolist (this-elt (cdr subpat)) + (let ((result + (cond*-subpat this-elt cdr-ignore bindings inside-or backtrack-aliases data))) + (setq bindings (car result)) + (push (cdr result) expressions))) + (cons bindings (cond*-and (nreverse expressions))))) + ;; Handle disjunction subpatterns. + ((eq (car subpat) 'or) + ;; The main complexity is unsetting the pattern variables + ;; that tentatively matche in an or-branch that later failed. + (let (expressions + (bindings-before-or bindings) + (aliases-before-or (cdr backtrack-aliases))) + ;; Check for bad structure of SUBPAT here? + (dolist (this-elt (cdr subpat)) + (let* ((bindings bindings-before-or) + bindings-to-clear expression + result) + (setq result + (cond*-subpat this-elt cdr-ignore bindings t backtrack-aliases data)) + (setq bindings (car result)) + (setq expression (cdr result)) + ;; Were any bindings made by this arm of the disjunction? + (when (not (eq bindings bindings-before-or)) + ;; Ok, arrange to clear their backtrack aliases + ;; if this arm does not match. + (setq bindings-to-clear bindings) + (let (clearing) + ;; For each of those bindings, + (while (not (eq bindings-to-clear bindings-before-or)) + ;; Make an expression to set it to nil, in CLEARING. + (let* ((this-variable (caar bindings-to-clear)) + (this-backtrack (assq this-variable + (cdr backtrack-aliases)))) + (push `(setq ,(cdr this-backtrack) nil) clearing)) + (setq bindings-to-clear (cdr bindings-to-clear))) + ;; Wrap EXPRESSION to clear those backtrack aliases + ;; if EXPRESSION is false. + (setq expression + (if (null clearing) + expression + (if (null (cdr clearing)) + `(or ,expression + ,(car clearing)) + `(progn ,@clearing)))))) + (push expression expressions))) + ;; At end of (or...), EACH variable bound by any arm + ;; has a backtrack alias gensym. At run time, that gensym's value + ;; will be what was bound in the successful arm, or nil. + ;; Now make a binding for each variable from its alias gensym. + (let ((aliases (cdr backtrack-aliases))) + (while (not (eq aliases aliases-before-or)) + (push `(,(caar aliases) ,(cdar aliases)) bindings) + (pop aliases))) + (cons bindings `(or . ,(nreverse expressions))))) + ;; Expand cond*-macro call, treat result as a subpattern. + ((get (car subpat) 'cond*-expander) + ;; Treat result as a subpattern. + (cond*-subpat (funcall (get (car subpat) 'cond*-expander) subpat) + cdr-ignore bindings inside-or backtrack-aliases data)) + ((macrop (car subpat)) + (cond*-subpat (macroexpand subpat) cdr-ignore bindings inside-or backtrack-aliases data)) + ;; Simple constrained variable, as in (symbolp x). + ((functionp (car subpat)) + ;; Without this, nested constrained variables just work. + (unless (symbolp (cadr subpat)) + (byte-compile-warn-x subpat "Complex pattern nested in constrained variable pattern")) + (let* ((rest-args (cddr subpat)) + ;; Process VAR to get a binding for it. + (result (cond*-subpat (cadr subpat) cdr-ignore bindings inside-or backtrack-aliases data)) + (new-bindings (car result)) + (expression (cdr result)) + (combined-exp + (cond*-and (list `(,(car subpat) ,data . ,rest-args) expression)))) + + (cons new-bindings + (cond*-bind-around new-bindings combined-exp)))) + ;; Generalized constrained variable: (constrain VAR EXP) + ((eq (car subpat) 'constrain) + ;; Without this, nested constrained variables just work. + (unless (symbolp (cadr subpat)) + (byte-compile-warn-x subpat "Complex pattern nested in constrained variable pattern")) + ;; Process VAR to get a binding for it. + (let ((result (cond*-subpat (cadr subpat) cdr-ignore bindings inside-or backtrack-aliases data))) + (cons (car result) + ;; This is the test condition. + (cond*-bind-around (car result) (nth 2 subpat))))) + (t + (byte-compile-warn-x subpat "Undefined pattern type `%s' in `cond*'" (car subpat))))) + +;;; Subroutines of cond*-subpat. + +(defun cond*-bind-around (bindings exp) + "Wrap a `let*' around EXP, to bind those of BINDINGS used in EXP." + (let ((what-to-bind (cond*-used-within bindings exp))) + (if what-to-bind + `(let* ,(nreverse what-to-bind) ,exp) + exp))) + +(defun cond*-used-within (bindings exp) + "Return the list of those bindings in BINDINGS which EXP refers to. +This operates naively and errs on the side of overinclusion, +and does not distinguish function names from variable names. +That is safe for the purpose this is used for." + (cond ((symbolp exp) + (let ((which (assq exp bindings))) + (if which (list which)))) + ((listp exp) + (let (combined (rest exp)) + ;; Find the bindings used in each element of EXP + ;; and merge them together in COMBINED. + ;; It would be simpler to use dolist at each level, + ;; but this avoids errors from improper lists. + (while rest + (let ((in-this-elt (cond*-used-within bindings (car rest)))) + (while in-this-elt + ;; Don't insert the same binding twice. + (unless (memq (car-safe in-this-elt) combined) + (push (car-safe in-this-elt) combined)) + (pop in-this-elt))) + (pop rest)) + combined)))) + +;; Construct a simplified equivalent to `(and . ,CONJUNCTS), +;; assuming that it will be used only as a truth value. +;; We don't bother checking for nil in CONJUNCTS +;; because that would not normally happen. +(defun cond*-and (conjuncts) + (setq conjuncts (remq t conjuncts)) + (if (null conjuncts) + t + (if (null (cdr conjuncts)) + (car conjuncts) + `(and . ,conjuncts)))) + +;; Convert the arguments in a form that calls `backquote-list*' +;; into equivalent args to pass to `list'. +;; We assume the last argument has the form 'LIST. +;; That means quotify each of that list's elements, +;; and preserve the other arguments in front of them. +(defun cond*-un-backquote-list* (args) + (if (cdr args) + (cons (car args) + (cond*-un-backquote-list* (cdr args))) + (mapcar (lambda (x) (list 'quote x)) (cadr (car args))))) + + + commit 80108438e5e2e95ca75e59212fb1669a723241b5 Author: Eli Zaretskii Date: Fri Aug 2 09:48:55 2024 +0300 Fix display of empty margins when default face is remapped * src/xdisp.c (display_line): Append space glyphs to margin areas if the default face is remapped and nothing is written to the margin area of this screen line. (produce_special_glyphs): If the truncation/continuation glyphs do not specify a face, use the remapped default face, not the original frame-global default face. Reported by Nicolas P. Rougier in https://lists.gnu.org/archive/html/emacs-devel/2024-07/msg01217.html. diff --git a/src/xdisp.c b/src/xdisp.c index a8f9f59b654..491ce9cc970 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -25961,6 +25961,18 @@ display_line (struct it *it, int cursor_vpos) } it->hpos = hpos_before; } + /* If the default face is remapped, and the window has + display margins, and no glyphs were written yet to the + margins on this screen line, we must add one space + glyph to the margin area to make sure the margins use + the background of the remapped default face. */ + if (lookup_basic_face (it->w, it->f, DEFAULT_FACE_ID) + != DEFAULT_FACE_ID /* default face is remapped */ + && ((WINDOW_LEFT_MARGIN_WIDTH (it->w) > 0 + && it->glyph_row->used[LEFT_MARGIN_AREA] == 0) + || (WINDOW_RIGHT_MARGIN_WIDTH (it->w) > 0 + && it->glyph_row->used[RIGHT_MARGIN_AREA] == 0))) + extend_face_to_end_of_line (it); } else if (IT_OVERFLOW_NEWLINE_INTO_FRINGE (it)) { @@ -32179,6 +32191,8 @@ produce_special_glyphs (struct it *it, enum display_element_type what) struct it temp_it; Lisp_Object gc; GLYPH glyph; + /* Take face-remapping into consideration. */ + int face_id = lookup_basic_face (it->w, it->f, DEFAULT_FACE_ID); temp_it = *it; temp_it.object = Qnil; @@ -32188,27 +32202,27 @@ produce_special_glyphs (struct it *it, enum display_element_type what) { /* Continuation glyph. For R2L lines, we mirror it by hand. */ if (it->bidi_it.paragraph_dir == R2L) - SET_GLYPH_FROM_CHAR (glyph, '/'); + SET_GLYPH (glyph, '/', face_id); else - SET_GLYPH_FROM_CHAR (glyph, '\\'); + SET_GLYPH (glyph, '\\', face_id); if (it->dp && (gc = DISP_CONTINUE_GLYPH (it->dp), GLYPH_CODE_P (gc))) { /* FIXME: Should we mirror GC for R2L lines? */ SET_GLYPH_FROM_GLYPH_CODE (glyph, gc); - spec_glyph_lookup_face (XWINDOW (it->window), &glyph); + spec_glyph_lookup_face (it->w, &glyph); } } else if (what == IT_TRUNCATION) { /* Truncation glyph. */ - SET_GLYPH_FROM_CHAR (glyph, '$'); + SET_GLYPH (glyph, '$', face_id); if (it->dp && (gc = DISP_TRUNC_GLYPH (it->dp), GLYPH_CODE_P (gc))) { /* FIXME: Should we mirror GC for R2L lines? */ SET_GLYPH_FROM_GLYPH_CODE (glyph, gc); - spec_glyph_lookup_face (XWINDOW (it->window), &glyph); + spec_glyph_lookup_face (it->w, &glyph); } } else commit 4fa540f86587d4458cf33da352176f57e20723d4 Author: Eli Zaretskii Date: Fri Aug 2 09:24:55 2024 +0300 Fix finding anchor references after 'Info-on-current-buffer' * lisp/info.el (Info--record-tag-table): New function, extracted from 'Info-find-node-2'. (Info-find-node-2, Info-on-current-buffer): Use 'Info--record-tag-table'. (Bug#72391) diff --git a/lisp/info.el b/lisp/info.el index d151c6365b8..e18772436e9 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -1032,6 +1032,48 @@ If NOERROR, inhibit error messages when we can't find the node." Info-history)) (Info-find-node-2 filename nodename no-going-back strict-case)) +(defun Info--record-tag-table (nodename) + "If the current Info file has a tag table, record its location for NODENAME. + +This creates a tag-table buffer, sets `Info-tag-table-buffer' to +name that buffer, and records the buffer and the tag table in +the marker `Info-tag-table-buffer'. If the Info file has no +tag table, or if NODENAME is \"*\", the function sets the marker +to nil to indicate the tag table is not available/relevant. + +The function assumes that the Info buffer is widened, and does +not preserve point." + (goto-char (point-max)) + (forward-line -8) + ;; Use string-equal, not equal, to ignore text props. + (if (not (or (string-equal nodename "*") + (not + (search-forward "\^_\nEnd tag table\n" nil t)))) + (let (pos) + ;; We have a tag table. Find its beginning. + ;; Is this an indirect file? + (search-backward "\nTag table:\n") + (setq pos (point)) + (if (save-excursion + (forward-line 2) + (looking-at "(Indirect)\n")) + ;; It is indirect. Copy it to another buffer + ;; and record that the tag table is in that buffer. + (let ((buf (current-buffer)) + (tagbuf + (or Info-tag-table-buffer + (generate-new-buffer " *info tag table*")))) + (setq Info-tag-table-buffer tagbuf) + (with-current-buffer tagbuf + (buffer-disable-undo (current-buffer)) + (setq case-fold-search t) + (erase-buffer) + (insert-buffer-substring buf)) + (set-marker Info-tag-table-marker + (match-end 0) tagbuf)) + (set-marker Info-tag-table-marker pos))) + (set-marker Info-tag-table-marker nil))) + ;;;###autoload (defun Info-on-current-buffer (&optional nodename) "Use Info mode to browse the current Info buffer. @@ -1048,6 +1090,7 @@ otherwise, that defaults to `Top'." (or buffer-file-name ;; If called on a non-file buffer, make a fake file name. (concat default-directory (buffer-name)))) + (Info--record-tag-table nodename) (Info-find-node-2 nil nodename)) (defun Info-revert-find-node (filename nodename) @@ -1210,36 +1253,7 @@ is non-nil)." (Info-file-supports-index-cookies filename)) ;; See whether file has a tag table. Record the location if yes. - (goto-char (point-max)) - (forward-line -8) - ;; Use string-equal, not equal, to ignore text props. - (if (not (or (string-equal nodename "*") - (not - (search-forward "\^_\nEnd tag table\n" nil t)))) - (let (pos) - ;; We have a tag table. Find its beginning. - ;; Is this an indirect file? - (search-backward "\nTag table:\n") - (setq pos (point)) - (if (save-excursion - (forward-line 2) - (looking-at "(Indirect)\n")) - ;; It is indirect. Copy it to another buffer - ;; and record that the tag table is in that buffer. - (let ((buf (current-buffer)) - (tagbuf - (or Info-tag-table-buffer - (generate-new-buffer " *info tag table*")))) - (setq Info-tag-table-buffer tagbuf) - (with-current-buffer tagbuf - (buffer-disable-undo (current-buffer)) - (setq case-fold-search t) - (erase-buffer) - (insert-buffer-substring buf)) - (set-marker Info-tag-table-marker - (match-end 0) tagbuf)) - (set-marker Info-tag-table-marker pos))) - (set-marker Info-tag-table-marker nil)) + (Info--record-tag-table nodename) (setq Info-current-file filename) ))) commit 1134734e19617a0875b77f8c7df64cfb265ec118 Author: Jim Porter Date: Thu Aug 1 09:31:44 2024 -0700 ; * lisp/eshell/em-dirs.el (eshell/cd): Remove extraneous 'eshell-protect'. diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el index e70f2cfe196..9cf0994fe78 100644 --- a/lisp/eshell/em-dirs.el +++ b/lisp/eshell/em-dirs.el @@ -427,8 +427,7 @@ in the minibuffer: (let ((eshell-last-command-name) (eshell-last-command-status) (eshell-last-arguments)) - (eshell-protect - (eshell-plain-command "ls" (cdr args))))) + (eshell-plain-command "ls" (cdr args)))) nil)))) (put 'eshell/cd 'eshell-no-numeric-conversions t) commit 0892b66e9b0233cf66d5f6d10bbd9bf096c41755 Author: Martin Rudalics Date: Thu Aug 1 18:04:20 2024 +0200 Fix regression in 'todo-test-todo-quit02' * lisp/window.el (switch-to-prev-buffer): If BURY-OR-KILL is non-nil, remove any 'quit-restore' or 'quit-restore-prev' parameter referencing the old buffer too. This fixes a regression when running 'todo-test-todo-quit02' from 'ert' (reported by Andrea Corallo ). diff --git a/lisp/window.el b/lisp/window.el index 4687860db11..75c3b29b5dd 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -4799,9 +4799,10 @@ This function is called by `previous-buffer'." (if bury-or-kill (let ((entry (and (eq bury-or-kill 'append) (assq old-buffer (window-prev-buffers window))))) - ;; Remove `old-buffer' from WINDOW's previous and (restored list - ;; of) next buffers. - (unrecord-window-buffer window old-buffer) + ;; Remove `old-buffer' from WINDOW's previous and (restored + ;; list of) next buffers and also from its 'quit-restore' and + ;; 'quit-restore-prev' parameters. + (unrecord-window-buffer window old-buffer t) (when entry ;; Append old-buffer's entry to list of WINDOW's previous ;; buffers so it's less likely to get switched to soon but commit 889e7027d3ec54be204e7bd1f1fa1b8c93f3e172 Author: Michael Albinus Date: Thu Aug 1 16:57:53 2024 +0200 Fix edge cases in tramp-crypt.el * lisp/net/tramp-crypt.el (tramp-crypt-handle-set-visited-file-modtime) (tramp-crypt-handle-verify-visited-file-modtime): New defuns. (tramp-crypt-file-name-handler-alist): Use them. (tramp-crypt-handle-lock-file): Care about `buffer-file-name'. (tramp-crypt-handle-unlock-file): Remove compat code. diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 4f19ddb75fc..e9d9eb2a2c2 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -231,7 +231,7 @@ If NAME doesn't belong to an encrypted remote directory, return nil." (set-file-modes . tramp-crypt-handle-set-file-modes) (set-file-selinux-context . ignore) (set-file-times . tramp-crypt-handle-set-file-times) - (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) + (set-visited-file-modtime . tramp-crypt-handle-set-visited-file-modtime) (shell-command . ignore) (start-file-process . ignore) ;; `substitute-in-file-name' performed by default handler. @@ -244,7 +244,8 @@ If NAME doesn't belong to an encrypted remote directory, return nil." (unhandled-file-name-directory . ignore) (unlock-file . tramp-crypt-handle-unlock-file) (vc-registered . ignore) - (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (verify-visited-file-modtime + . tramp-crypt-handle-verify-visited-file-modtime) (write-region . tramp-handle-write-region)) "Alist of handler functions for crypt method. Operations not mentioned here will be handled by the default Emacs primitives.") @@ -802,10 +803,11 @@ WILDCARD is not supported." (defun tramp-crypt-handle-lock-file (filename) "Like `lock-file' for Tramp files." - (let (tramp-crypt-enabled) - ;; `lock-file' exists since Emacs 28.1. - (tramp-compat-funcall - 'lock-file (tramp-crypt-encrypt-file-name filename)))) + ;; `tramp-handle-lock-file' calls `verify-visited-file-modtime', so + ;; we must care `buffer-file-name'. + (let (tramp-crypt-enabled + (buffer-file-name (tramp-crypt-encrypt-file-name (buffer-file-name)))) + (lock-file (tramp-crypt-encrypt-file-name filename)))) (defun tramp-crypt-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -846,12 +848,27 @@ WILDCARD is not supported." (tramp-set-file-uid-gid (tramp-crypt-encrypt-file-name filename) uid gid)))) +(defun tramp-crypt-handle-set-visited-file-modtime (&optional time-list) + "Like `set-visited-file-modtime' for Tramp files." + (unless (buffer-file-name) + (error "Can't set-visited-file-modtime: buffer `%s' not visiting a file" + (buffer-name))) + (let (tramp-crypt-enabled + (buffer-file-name (tramp-crypt-encrypt-file-name (buffer-file-name)))) + (set-visited-file-modtime time-list))) + (defun tramp-crypt-handle-unlock-file (filename) "Like `unlock-file' for Tramp files." (let (tramp-crypt-enabled) - ;; `unlock-file' exists since Emacs 28.1. - (tramp-compat-funcall - 'unlock-file (tramp-crypt-encrypt-file-name filename)))) + (unlock-file (tramp-crypt-encrypt-file-name filename)))) + +(defun tramp-crypt-handle-verify-visited-file-modtime (&optional buf) + "Like `verify-visited-file-modtime' for Tramp files." + (with-current-buffer (or buf (current-buffer)) + (let (tramp-crypt-enabled + (buffer-file-name + (tramp-crypt-encrypt-file-name (buffer-file-name buf)))) + (verify-visited-file-modtime buf)))) (defun tramp-crypt-cleanup-connection (vec) "Cleanup crypt resources determined by VEC." commit 4437d730a5fff6dca61f99a146c99aefd0f67577 Author: Mattias Engdegård Date: Thu Aug 1 10:29:10 2024 +0200 Remove misspelled rx category `chinse-two-byte` * lisp/emacs-lisp/rx.el (rx--categories): Remove misspelled variant present in Emacs 21-1-24.3, correct name since 24.4. * etc/NEWS: Announce. diff --git a/etc/NEWS b/etc/NEWS index d3a99af86b7..02007830bfc 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -213,6 +213,9 @@ any. ** The obsolete calling convention of 'error' has been removed. That convention was: '(error &rest ARGS)'. +** The 'rx' category name 'chinese-two-byte' must now be spelled correctly. +An old alternative name (without the first 'e') has been removed. + * Lisp Changes in Emacs 31.1 diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index 7113d5a6241..2a2315f08b5 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -52,7 +52,6 @@ ;; (repeat N FORM) (= N FORM) ;; (syntax CHARACTER) (syntax NAME) ;; (syntax CHAR-SYM) [1] (syntax NAME) -;; (category chinse-two-byte) (category chinese-two-byte) ;; unibyte ascii ;; multibyte nonascii ;; -------------------------------------------------------- @@ -1011,7 +1010,6 @@ Return (REGEXP . PRECEDENCE)." (not-at-beginning-of-line . ?>) (alpha-numeric-two-byte . ?A) (chinese-two-byte . ?C) - (chinse-two-byte . ?C) ; A typo in Emacs 21.1-24.3. (greek-two-byte . ?G) (japanese-hiragana-two-byte . ?H) (indian-two-byte . ?I) commit 27381d71c65bd0ba93ed61f57011dbc66bd5bfab Author: Martin Rudalics Date: Thu Aug 1 09:37:50 2024 +0200 Improve window/buffer handling code The purpose of these changes is to improve the code handling the display of buffers in windows, switching to previous and next buffers in windows and restoring a previous state after quitting or killing buffers. In particular it does: - Add a new window parameter 'quit-restore-prev' so a window can keep its initial 'quit-restore' parameter and undoing a sequence of quit window operations becomes more reliable (Bug#59862). - Optionally have 'kill-buffer' call 'quit-restore-window' for all windows showing the argument buffer (Bug#59862). - Add a new hook so it's possible to avoid that a window gets deleted implicitly by functions like 'kill-buffer' (Bug#71386). - Add a new option to make 'quit-restore-window' delete windows more aggressively (Bug#59862). - Immediately remove killed buffers from all windows' previous and next buffers. For windows that are already dead, use a weak hash table to be used by 'kill-buffer'. This avoids any special handling of such windows by the garbage collector. - Immediately remove 'quit-restore' and 'quit-restore-prev' window parameters that reference killed buffers. These parameters have no more use once their buffers got killed. - Make sure that internal windows do not have any previous and next buffers. This fixes a silly memory leak. - Make sure that after set_window_buffer and some wset_buffer calls the buffer now shown in the window does not appear in the lists of that window's previous and next buffers. The old behavior could make functions investigating these lists erroneously believe that there still existed some other buffer to switch to. * src/alloc.c (mark_discard_killed_buffers): Remove function. (mark_window): No more filter previous and next buffer lists. * src/window.h (struct window): Move up prev_buffers and next-buffers in structure; they are now treated by the collector as usual. * src/window.c (window_discard_buffer_from_alist) (window_discard_buffer_from_list) (window_discard_buffer_from_window) (window_discard_buffer_from_dead_windows) (Fwindow_discard_buffer): New functions. (set_window_buffer): Discard BUFFER from WINDOW's previous and next buffers. (make_parent_window): Make sure internal windows have no previous and next buffers. (make_window): Don't initialize window's previous and next buffers, they are handled by allocate_window now. (Fdelete_window_internal): Add WINDOW to window_dead_windows_table. (Fset_window_configuration): Remove resurrected window from window_dead_windows_table. Make sure buffers set by wset_buffer calls are not recorded in window's previous and next buffers. (delete_all_child_windows): Add deleted windows to window_dead_windows_table. (window_dead_windows_table): New weak hash table to record dead windows that are stored in saved window configurations. * src/buffer.c (Fkill_buffer): Call new function 'window_discard_buffer_from_dead_windows'. * lisp/window.el (window-deletable-functions): New hook. (window-deletable-p): Update doc-string. Run 'window-deletable-functions' (Bug#71386). (unrecord-window-buffer): New argument ALL. Move body to 'window-discard-buffer-from-window' so that if ALL is non-nil, WINDOW's 'quit-restore' and 'quit-restore-prev' parameters get removed too. (switch-to-prev-buffer): Don't care about killed buffers here; 'replace-buffer-in-windows' should have done that already. Use 'unrecord-window-buffer'. (switch-to-next-buffer): Don't care about killed buffers here; 'replace-buffer-in-windows' should do that now. (kill-buffer-quit-windows): New option. (delete-windows-on): Update doc-string. Handle new option 'kill-buffer-quit-windows'. Update 'unrecord-window-buffer' calls. (replace-buffer-in-windows): Update doc-string. Handle new option 'kill-buffer-quit-windows' (Bug#59862). Update call to 'unrecord-window-buffer'. (quit-restore-window-no-switch): New option. (quit-restore-window): Update doc-string. Handle additional values of BURY-OR-KILL so to not kill a buffer about to be killed by the caller. Handle 'quit-restore-prev' parameter (Bug#59862). Handle new option 'quit-restore-window-no-switch' (Bug#59862). (quit-windows-on): Update doc-string. Call 'quit-window-hook' and call 'quit-restore-window' directly so that the buffer does not get buried or killed by the latter. Update 'unrecord-window-buffer' call. (display-buffer-record-window): Update doc-string. Handle new `quit-restore-prev' parameter (Bug#59862). (switch-to-buffer): Call 'display-buffer-record-window' so a latter 'quit-restore-window' can use its parameters. * doc/lispref/windows.texi (Deleting Windows): Describe implicit deletion of windows and new hook 'window-deletable-functions'. (Buffers and Windows): Update description of 'replace-buffer-in-windows'. Describe new option 'kill-buffer-quit-windows'. (Quitting Windows): Describe 'quit-restore-prev' parameter and new option 'quit-restore-window-no-switch'. Update description of 'quit-restore-window'. (Window Parameters): Mention 'quit-restore-prev' parameter. * etc/NEWS: Add entries for 'window-deletable-functions', 'kill-buffer-quit-windows', 'quit-restore-window-no-switch'. mention new parameter 'quit-restore-prev' and new argument values for 'quit-restore-window'. diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index f5963d984e9..656a44dfcbf 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -1647,6 +1647,45 @@ Ordering}). Specifically, the meanings of @code{t} and @code{nil} here are the opposite of what they are in those other functions. @end deffn +@cindex implicit deletion of windows +@cindex deleting windows implicitly + + The above commands delete windows explicitly. However, Emacs may also +delete a window implicitly when it thinks that it's more intuitive to +eliminate it rather than showing some unrelated buffer in it. Functions +that may delete windows implicitly are @code{kill-buffer} +(@pxref{Killing Buffers}), @code{quit-restore-window} (@pxref{Quitting +Windows}) and @code{bury-buffer} (@pxref{Buffer List}). Some of these +delete a window if and only if that window is dedicated to its buffer +(@pxref{Dedicated Windows}). Others delete a window when that window +has been created by @code{display-buffer} (@pxref{Displaying Buffers}). +Some will also try to delete a window's frame together with the window, +provided there are other frames on the same terminal and the frame does +not host the active minibuffer window. + + The hook described next can be used to avoid that a window gets +deleted by these functions. + +@defopt window-deletable-functions +This is an abnormal hook that can be used to avoid that a window gets +deleted implicitly. The value should be a list of functions that take +two arguments. The first argument is the window about to be deleted. +The second argument, if non-@code{nil}, means that the window is the +only window on its frame and would be deleted together with its frame. +The window's buffer is current when running this hook. + +If any of these functions returns @code{nil}, the window will not be +deleted and another buffer will be shown in it. This hook is run +(indirectly) by the functions @code{quit-restore-window}, +@code{kill-buffer} and @code{bury-buffer}. It is not run by functions +that delete windows explicitly like @code{delete-window}, +@code{delete-other-windows} or @code{delete-windows-on}. + +The purpose of this hook is to give its clients a chance to save a +window or its frame from deletion because they might still want to use +that window or frame for their own purposes. +@end defopt + @node Recombining Windows @section Recombining Windows @@ -2297,16 +2336,41 @@ all windows displaying it. @var{buffer-or-name} should be a buffer, or the name of an existing buffer; if omitted or @code{nil}, it defaults to the current buffer. -The replacement buffer in each window is chosen via +The replacement buffer in each window is usually chosen via @code{switch-to-prev-buffer} (@pxref{Window History}). With the exception of side windows (@pxref{Side Windows}), any dedicated window displaying @var{buffer-or-name} is deleted if possible (@pxref{Dedicated Windows}). If such a window is the only window on its frame and there -are other frames on the same terminal, the frame is deleted as well. -If the dedicated window is the only window on the only frame on its +are other frames on the same terminal, the frame is deleted as well. If +the dedicated window is the only window on the only frame on its terminal, the buffer is replaced anyway. + +The main purpose of this function is to decide what to do with windows +whose buffers are about to be killed by @code{kill-buffer} +(@pxref{Killing Buffers}). It will, however, also remove the buffer +specified by @var{buffer-or-name} from the lists of previous and next +buffers (@pxref{Window History}) of all windows (including dead windows +that are only referenced by window configurations) and remove any +@code{quit-restore} or @code{quit-restore-prev} parameters +(@pxref{Window Parameters}) referencing that buffer. @end deffn +By default, @code{replace-buffer-in-windows} deletes only windows +dedicated to their buffers and ignores any @code{quit-restore} or +@code{quit-restore-prev} parameters of the windows it works on. The +following option is useful for circumventing these restrictions. + +@defopt kill-buffer-quit-windows +If this option is @code{nil}, @code{kill-buffer} (and in consequence +@code{replace-buffer-in-windows}) may only delete windows that are +dedicated to the buffer about to be killed. If this is non-@code{nil}, +@code{replace-buffer-in-windows} has @code{quit-restore-window} +(@pxref{Quitting Windows}) deal with any such window. That function may +delete such a window even if it's not dedicated to its buffer. Also, +@code{delete-windows-on} will use @code{quit-restore-window} as fallback +when a window cannot be deleted and another buffer must be shown in it. +@end defopt + @node Switching Buffers @section Switching to a Buffer in a Window @@ -4532,6 +4596,15 @@ this buffer again, short of killing the buffer. @item kill This means to kill @var{window}'s buffer. + +@item killing +This is handled like @code{kill} but assumes that @var{window}'s buffer +gets killed elsewhere. This value is used by +@code{replace-buffer-in-windows} and @code{quit-windows-on}. + +@item burying +This is handled like @code{bury} but assumes that @var{window}'s buffer +gets buried elsewhere. This value is used by @code{quit-windows-on}. @end table The argument @var{bury-or-kill} also specifies what to do with @@ -4541,14 +4614,18 @@ terminal. If @var{bury-or-kill} equals @code{kill}, it means to delete the frame. Otherwise, the fate of the frame is determined by calling @code{frame-auto-hide-function} (see below) with that frame as sole argument. - -This function always sets @var{window}'s @code{quit-restore} parameter -to @code{nil} unless it deletes the window. @end defun -The window @var{window}'s @code{quit-restore} parameter (@pxref{Window -Parameters}) should be @code{nil} or a list of four elements: -@c FIXME: describe what quit-restore-window does if this is nil. + A window's @code{quit-restore} and @code{quit-restore-prev} parameters +(@pxref{Window Parameters}) guide @code{quit-restore-window} through its +process of dealing with its @var{window} argument. If such a parameter +is absent or @code{nil}, this usually means that the window has been +created by a command like @code{split-window-below} or +@code{split-window-right} (@pxref{Split Window,,, emacs, The GNU Emacs +Manual}) and @code{quit-restore-window} will delete the window only if +it was dedicated to its buffer. + + If non-@code{nil}, any such parameter is a list of four elements: @lisp (@var{method} @var{obuffer} @var{owindow} @var{this-buffer}) @@ -4586,17 +4663,17 @@ just before the displaying was done. If quitting deletes @var{window}, it tries to select @var{owindow}. The fourth element, @var{this-buffer}, is the buffer whose displaying -set the @code{quit-restore} parameter. Quitting @var{window} may delete -that window only if it still shows that buffer. - -Quitting @var{window} tries to delete it if and only if (1) -@var{method} is either @code{window} or @code{frame}, (2) the window -has no history of previously-displayed buffers and (3) -@var{this-buffer} equals the buffer currently displayed in -@var{window}. If @var{window} is part of an atomic window -(@pxref{Atomic Windows}), quitting will try to delete the root of that -atomic window instead. In either case, it tries to avoid signaling an -error when @var{window} cannot be deleted. +set the @code{quit-restore} parameter. Quitting @var{window} will use +the information stored by that parameter if and only if it still shows +that buffer. + +@code{quit-restore-window} tries to delete its @var{window} if (1) +@var{method} is either @code{window} or @code{frame}, (2) the window has +no history of previously-displayed buffers and (3) @var{this-buffer} +equals the buffer currently displayed in @var{window}. If @var{window} +is part of an atomic window (@pxref{Atomic Windows}), it will try to +delete the root of that atomic window instead. In either case, it tries +to avoid signaling an error when @var{window} cannot be deleted. If @var{obuffer} is a list, and @var{prev-buffer} is still live, quitting displays @var{prev-buffer} in @var{window} according to the @@ -4608,6 +4685,58 @@ Otherwise, if @var{window} was previously used for displaying other buffers (@pxref{Window History}), the most recent buffer in that history will be displayed. + Conceptually, the @code{quit-restore} parameter is used for undoing +the first buffer display operation for a specific window. The +@code{quit-restore-prev} parameter is used for undoing the last buffer +display operation in a row of such operations for a specific window. +Any buffer display operation for that window that happened in between, +is undone by displaying the buffer previously shown in that window. + + @code{display-buffer} sets up the @code{quit-restore} parameter of any +window it uses when that window has been either created by it or has no +non-@code{nil} @code{quit-restore} parameter. If the window already has +a @code{quit-restore} parameter, @code{display-buffer} adds a +@code{quit-restore-prev} parameter whose @var{method} element is either +@code{same} or @code{other}. In either case, if the window already has +a @code{quit-restore-prev} or @code{quit-restore} parameter, it may +update that parameter's contents. + + @code{quit-restore-window} now first tries to find a suitable +@code{quit-restore-prev} parameter for its window telling which buffer +to show instead. If it doesn't find one, it will look for a suitable +@code{quit-restore} parameter to either delete the window or show +another buffer in it. + + Once it has used one of these parameters, @code{quit-restore-window} +resets it to @code{nil}. Parameters it did not use are left alone. Any +of these parameters are also reset by @code{replace-buffer-in-windows} +(@pxref{Buffers and Windows}) when they reference a buffer that is about +to be killed, either as the buffer specified by @var{prev-buffer} or as +the buffer specified by @var{this-buffer}. + + All operations on these parameters are supposed to preserve the +following invariant: If a window has a non-@code{nil} +@code{quit-restore-prev} parameter, it also has a non-@code{nil} +@code{quit-restore} parameter. + +The following option allows @code{quit-restore-window} to delete its +window more aggressively. + +@defopt quit-restore-window-no-switch +If this option is @code{nil}, @code{quit-restore-window} will always +call @code{switch-to-prev-buffer} unless the window has been made by +@code{display-buffer}. If this is @code{t}, @code{quit-restore-window} +will try hard to switch only to buffers previously shown in that window. +If this is the symbol @code{skip-first}, it will switch to a previous +buffer if and only the window has at least two previous buffers. + +In either case, if @code{quit-restore-window} doesn't switch to a +previous buffer, it will try to delete the window (and maybe its +frame) instead. Note also that if a window is dedicated, +@code{quit-restore-window} will usually not switch to a previous +buffer in it either. +@end defopt + @ignore @c FIXME: Should we document display-buffer-reuse-window? If we document display-buffer-record-window, it should be with @defun. @@ -6668,12 +6797,14 @@ parameter is installed and updated by the function @code{window-preserve-size} (@pxref{Preserving Window Sizes}). @item quit-restore +@item quit-restore-prev @vindex quit-restore@r{, a window parameter} -This parameter is installed by the buffer display functions +@vindex quit-restore-prev@r{, a window parameter} +These parameters ares installed by the buffer display functions (@pxref{Choosing Window}) and consulted by @code{quit-restore-window} -(@pxref{Quitting Windows}). It is a list of four elements, see the -description of @code{quit-restore-window} in @ref{Quitting Windows} -for details. +(@pxref{Quitting Windows}). They are lists of four elements, see the +description of @code{quit-restore-window} in @ref{Quitting Windows} for +details. @item window-side @itemx window-slot diff --git a/etc/NEWS b/etc/NEWS index 3a07a75b42c..d3a99af86b7 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -43,6 +43,37 @@ The 'find-function', 'find-library', 'find-face-definition', and 'find-variable' commands now allow retrieving previous input using the usual minibuffer history commands. Each command has a separate history. + +** Windows + ++++ +*** New hook 'window-deletable-functions'. +This abnormal hook gives its client a way to save a window from getting +deleted implicitly by functions like 'kill-buffer', 'bury-buffer' and +'quit-restore-window', + ++++ +*** New option 'kill-buffer-quit-windows'. +This option has 'kill-buffer' call 'quit-restore-window' to handle the +further destiny of any window showing the buffer to be killed. + ++++ +*** New window parameter 'quit-restore-prev'. +This parameter is set up by 'display-buffer' when it detects that the +window used already has a 'quit-restore' parameter. Its presence gives +'quit-restore-window' a way to undo a sequence of buffer display +operations more intuitively. + ++++ +*** 'quit-restore-window' now handles the values 'killing' and 'burying' +for its BURY-OR-KILL argument just like 'kill' and 'bury' but assumes +that the actual killing or burying of the buffer is done by the caller. + ++++ +*** New option 'quit-restore-window-no-switch'. +With this option set, 'quit-restore-window' will delete its window more +aggressively rather than switching to some other buffer in it. + * Editing Changes in Emacs 31.1 diff --git a/lisp/window.el b/lisp/window.el index 006cfa19525..4687860db11 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -4104,12 +4104,35 @@ and no others." (next-window base-window (if nomini 'arg) all-frames)))) ;;; Deleting windows. -(defun window-deletable-p (&optional window) +(defcustom window-deletable-functions nil + "Abnormal hook to decide whether a window may be implicitly deleted. +The value should be a list of functions that take two arguments. The +first argument is the window about to be deleted. The second argument +if non-nil, means that the window is the only window on its frame and +should be deleted together with its frame. The window's buffer is +current when running this hook. + +If any of these functions returns nil, the window will not be deleted +and another buffer will be shown in it. This hook is run implicitly by +the functions `quit-restore-window', `kill-buffer' and `bury-buffer'. +It is not run by `delete-window' and `delete-windows-on'. The purpose +of this hook is to give its clients a chance to save a window or its +frame from deletion because they might still want to use that window or +frame for their own purposes." + :type 'hook + :version "31.1" + :group 'windows) + +(defun window-deletable-p (&optional window no-run) "Return t if WINDOW can be safely deleted from its frame. WINDOW must be a valid window and defaults to the selected one. Return `frame' if WINDOW is the root window of its frame and that -frame can be safely deleted." +frame can be safely deleted. + +Unless the optional argument NO-RUN is non-nil, run the abnormal hook +`window-deletable-functions' and return nil if any function on that hook +returns nil." (setq window (window-normalize-window window)) (unless (or ignore-window-parameters @@ -4137,14 +4160,22 @@ frame can be safely deleted." (and minibuf (eq frame (window-frame minibuf)) (not (eq (default-toplevel-value 'minibuffer-follows-selected-frame) - t))))) + t)))) + (or no-run + (not (with-current-buffer (window-buffer window) + (run-hook-with-args-until-failure + 'window-deletable-functions window t))))) 'frame)) ((window-minibuffer-p window) ;; If WINDOW is the minibuffer window of a non-minibuffer-only ;; frame, it cannot be deleted separately. nil) - ((or ignore-window-parameters - (not (eq window (window-main-window frame)))) + ((and (or ignore-window-parameters + (not (eq window (window-main-window frame)))) + (or no-run + (with-current-buffer (window-buffer window) + (run-hook-with-args-until-failure + 'window-deletable-functions window nil)))) ;; Otherwise, WINDOW can be deleted unless it is the main window ;; of its frame. t)))) @@ -4515,17 +4546,26 @@ WINDOW must be a live window and defaults to the selected one." (push-window-buffer-onto-prev window) (run-hooks 'buffer-list-update-hook)))) -(defun unrecord-window-buffer (&optional window buffer) +(defun unrecord-window-buffer (&optional window buffer all) "Unrecord BUFFER in WINDOW. -WINDOW must be a live window and defaults to the selected one. -BUFFER must be a live buffer and defaults to the buffer of -WINDOW." +WINDOW must be a live window and defaults to the selected one. BUFFER +must be a live buffer and defaults to the buffer of WINDOW (although +that default hardly makes any sense). + +Make BUFFER disappear from most components specified by the object of +WINDOW. This includes the buffers previously shown in WINDOW as well as +any buffers mentioned by WINDOW's `quit-restore' and `quit-restore-prev' +parameters. + +This function is called by `replace-buffer-in-windows' which is mainly +concerned with finding another buffer for all windows showing a buffer +about to be killed. It's also called by `delete-windows-on' and +`quit-windows-on' and should be called wherever the traces of a buffer +should be erased from the window handling subsystem." (let* ((window (window-normalize-window window t)) (buffer (or buffer (window-buffer window)))) - (set-window-prev-buffers - window (assq-delete-all buffer (window-prev-buffers window))) - (set-window-next-buffers - window (delq buffer (window-next-buffers window))))) + (when (buffer-live-p buffer) + (window-discard-buffer-from-window buffer window all)))) (defun set-window-buffer-start-and-point (window buffer &optional start point) "Set WINDOW's buffer to BUFFER. @@ -4683,7 +4723,7 @@ This function is called by `previous-buffer'." ((or switch-to-prev-buffer-skip (not switch-to-visible-buffer)) frame))) - entry new-buffer killed-buffers skipped) + entry new-buffer skipped) (when (window-minibuffer-p window) ;; Don't switch in minibuffer window. (unless (setq window (minibuffer-selected-window)) @@ -4699,14 +4739,14 @@ This function is called by `previous-buffer'." (dolist (entry (window-prev-buffers window)) (when (and (not (eq (car entry) old-buffer)) (setq new-buffer (car entry)) - (or (buffer-live-p new-buffer) - (not (setq killed-buffers - (cons new-buffer killed-buffers)))) - (or (null pred) (funcall pred new-buffer)) + ;; Beware: new-buffer might have been killed by + ;; a function on 'buffer-predicate'. + (buffer-live-p new-buffer) + (or (null pred) (funcall pred new-buffer)) ;; When BURY-OR-KILL is nil, avoid switching to a ;; buffer in WINDOW's next buffers list. (or bury-or-kill (not (memq new-buffer next-buffers)))) - (if (switch-to-prev-buffer-skip-p skip window new-buffer bury-or-kill) + (if (switch-to-prev-buffer-skip-p skip window new-buffer bury-or-kill) (setq skipped new-buffer) (set-window-buffer-start-and-point window new-buffer (nth 1 entry) (nth 2 entry)) @@ -4740,11 +4780,7 @@ This function is called by `previous-buffer'." ;; Scan reverted next buffers last (must not use nreverse ;; here!). (dolist (buffer (reverse next-buffers)) - ;; Actually, buffer _must_ be live here since otherwise it - ;; would have been caught in the scan of previous buffers. - (when (and (or (buffer-live-p buffer) - (not (setq killed-buffers - (cons buffer killed-buffers)))) + (when (and (buffer-live-p buffer) (not (eq buffer old-buffer)) (or (null pred) (funcall pred buffer)) (setq entry (assq buffer (window-prev-buffers window)))) @@ -4765,9 +4801,7 @@ This function is called by `previous-buffer'." (assq old-buffer (window-prev-buffers window))))) ;; Remove `old-buffer' from WINDOW's previous and (restored list ;; of) next buffers. - (set-window-prev-buffers - window (assq-delete-all old-buffer (window-prev-buffers window))) - (set-window-next-buffers window (delq old-buffer next-buffers)) + (unrecord-window-buffer window old-buffer) (when entry ;; Append old-buffer's entry to list of WINDOW's previous ;; buffers so it's less likely to get switched to soon but @@ -4780,14 +4814,6 @@ This function is called by `previous-buffer'." (set-window-next-buffers window (cons old-buffer (delq old-buffer next-buffers)))) - ;; Remove killed buffers from WINDOW's previous and next buffers. - (when killed-buffers - (dolist (buffer killed-buffers) - (set-window-prev-buffers - window (assq-delete-all buffer (window-prev-buffers window))) - (set-window-next-buffers - window (delq buffer (window-next-buffers window))))) - ;; Return new-buffer. new-buffer)) @@ -4819,7 +4845,7 @@ This function is called by `next-buffer'." ((or switch-to-prev-buffer-skip (not switch-to-visible-buffer)) frame))) - new-buffer entry killed-buffers skipped) + new-buffer entry skipped) (when (window-minibuffer-p window) ;; Don't switch in minibuffer window. (unless (setq window (minibuffer-selected-window)) @@ -4832,9 +4858,7 @@ This function is called by `next-buffer'." (catch 'found ;; Scan WINDOW's next buffers first. (dolist (buffer next-buffers) - (when (and (or (buffer-live-p buffer) - (not (setq killed-buffers - (cons buffer killed-buffers)))) + (when (and (buffer-live-p buffer) (not (eq buffer old-buffer)) (or (null pred) (funcall pred buffer)) (setq entry (assq buffer (window-prev-buffers window)))) @@ -4867,9 +4891,7 @@ This function is called by `next-buffer'." (when (and (not (eq new-buffer (car entry))) (not (eq old-buffer (car entry))) (setq new-buffer (car entry)) - (or (buffer-live-p new-buffer) - (not (setq killed-buffers - (cons new-buffer killed-buffers)))) + (buffer-live-p new-buffer) (or (null pred) (funcall pred new-buffer))) (if (switch-to-prev-buffer-skip-p skip window new-buffer) (setq skipped (or skipped new-buffer)) @@ -4885,14 +4907,6 @@ This function is called by `next-buffer'." ;; Remove `new-buffer' from and restore WINDOW's next buffers. (set-window-next-buffers window (delq new-buffer next-buffers)) - ;; Remove killed buffers from WINDOW's previous and next buffers. - (when killed-buffers - (dolist (buffer killed-buffers) - (set-window-prev-buffers - window (assq-delete-all buffer (window-prev-buffers window))) - (set-window-next-buffers - window (delq buffer (window-next-buffers window))))) - ;; Return new-buffer. new-buffer)) @@ -5044,6 +5058,18 @@ minibuffer window or is dedicated to its buffer." (not (or executing-kbd-macro noninteractive))) (user-error "No previous buffer")))))) +(defcustom kill-buffer-quit-windows nil + "Non-nil means killing buffers shall quit windows. +If this is nil, killing a buffer may only delete windows dedicated to +that buffer. Otherwise, `kill-buffer' has `quit-restore-window' deal +with any window showing the buffer to be killed. That function may +delete such a window even if it's not dedicated to its buffer. Also, +`delete-windows-on' will use `quit-restore-window' as fallback when a +window cannot be deleted otherwise." + :type 'boolean + :version "31.1" + :group 'windows) + (defun delete-windows-on (&optional buffer-or-name frame) "Delete all windows showing BUFFER-OR-NAME. BUFFER-OR-NAME may be a buffer or the name of an existing buffer @@ -5075,21 +5101,22 @@ Interactively, FRAME is the prefix argument, so you can use \\[universal-argument] 0 to specify all windows only on the current terminal's frames. -If a frame's root window shows the buffer specified by -BUFFER-OR-NAME and is dedicated to that buffer and that frame -does not host the active minibuffer window and there is at least -one other frame on that frame's terminal, delete that frame. -Otherwise, do not delete a frame's root window if it shows the -buffer specified by BUFFER-OR-NAME and do not delete any frame's -main window showing that buffer either. Rather, in any such -case, call `switch-to-prev-buffer' to show another buffer in that -window and make sure the window is no more dedicated to its -buffer. - -If the buffer specified by BUFFER-OR-NAME is shown in a -minibuffer window, do nothing for that window. For any window -that does not show that buffer, remove the buffer from that -window's lists of previous and next buffers." +If a frame's root window shows the buffer specified by BUFFER-OR-NAME, +is dedicated to that buffer, that frame does not host the active +minibuffer window and there is at least one other frame on that frame's +terminal, delete that frame. Otherwise, do not delete a frame's root +window if it shows the buffer specified by BUFFER-OR-NAME and do not +delete any frame's main window showing that buffer either. Rather, in +any such case, call either `quit-restore-window' (provided +`kill-buffer-quit-windows' is non-nil) or `switch-to-prev-buffer' to +show another buffer in that window and make sure the window is no more +dedicated to its buffer. + +If the buffer specified by BUFFER-OR-NAME is shown in a minibuffer +window, do nothing for that window. For any window that does not show +that buffer, remove the buffer from that window's lists of previous and +next buffers and remove any `quit-restore' and `quit-restore-prev' +parameters naming it." (interactive (let ((frame (cond ((and (numberp current-prefix-arg) @@ -5107,11 +5134,12 @@ window's lists of previous and next buffers." frame))) (let ((buffer (window-normalize-buffer buffer-or-name)) ;; Handle the "inverted" meaning of the FRAME argument wrt other - ;; `window-list-1' based function. - (all-frames (cond ((not frame) t) ((eq frame t) nil) (t frame)))) - (dolist (window (window-list-1 nil nil all-frames)) + ;; `window-list-1' based functions. + (frames (cond ((not frame) t) ((eq frame t) nil) (t frame)))) + (dolist (window (window-list-1 nil 'nomini frames)) (if (eq (window-buffer window) buffer) - (let ((deletable (window-deletable-p window)) + ;; Don't run 'window-deletable-functions'. + (let ((deletable (window-deletable-p window t)) (dedicated (window-dedicated-p window))) (cond ((and (eq deletable 'frame) dedicated) @@ -5120,43 +5148,77 @@ window's lists of previous and next buffers." ((eq deletable t) ;; Delete window. (delete-window window)) + (kill-buffer-quit-windows + (quit-restore-window window 'bury) + (when (window-live-p window) + ;; Unrecord BUFFER in this window. + (unrecord-window-buffer window buffer t))) (t ;; In window switch to previous buffer. (set-window-dedicated-p window nil) (switch-to-prev-buffer window 'bury) - ;; Restore the dedicated 'side' flag. - (when (eq dedicated 'side) - (set-window-dedicated-p window 'side))))) + ;; Restore the dedicated 'side' flag. + (when (eq dedicated 'side) + (set-window-dedicated-p window 'side)) + (when (window-live-p window) + ;; Unrecord BUFFER in this window. + (unrecord-window-buffer window buffer t))))) ;; If a window doesn't show BUFFER, unrecord BUFFER in it. - (unrecord-window-buffer window buffer))))) + (unrecord-window-buffer window buffer t))))) (defun replace-buffer-in-windows (&optional buffer-or-name) "Replace BUFFER-OR-NAME with some other buffer in all windows showing it. -BUFFER-OR-NAME may be a buffer or the name of an existing buffer -and defaults to the current buffer. - -With the exception of side windows, when a window showing BUFFER-OR-NAME -is dedicated, that window is deleted. If that window is the only window -on its frame, the frame is deleted too when there are other frames left. -If there are no other frames left, some other buffer is displayed in that +BUFFER-OR-NAME may be a buffer or the name of an existing buffer and +defaults to the current buffer. Minibuffer windows are not considered. + +If the option `kill-buffer-quit-windows' is nil, behave as follows: With +the exception of side windows, when a window showing BUFFER-OR-NAME is +dedicated, delete that window. If that window is the only window on its +frame, delete its frame when there are other frames left. In any other +case, call `switch-to-prev-buffer' to display some other buffer in that window. -This function removes the buffer denoted by BUFFER-OR-NAME from -all window-local buffer lists." +If `kill-buffer-quit-windows' is non-nil, call `quit-restore-window' for +any window showing BUFFER-OR-NAME with the argument BURY-OR-KILL set to +`killing' to avoid that the latter kills the buffer prematurely. + +In either case, remove the buffer denoted by BUFFER-OR-NAME from the +lists of previous and next buffers of all windows and remove any +`quit-restore' or `quit-restore-prev' parameters mentioning it. + +If, for any window showing BUFFER-OR-NAME running the abnormal hook +`window-deletable-functions' returns nil, do not delete that window but +show some other buffer in that window. + +This function is called by `kill-buffer' which kills the buffer +specified by `buffer-or-name' afterwards. It never kills a buffer by +itself." (interactive "bBuffer to replace: ") (let ((buffer (window-normalize-buffer buffer-or-name))) + ;; Scan all windows. We have to unrecord BUFFER-OR-NAME in those + ;; not showing it. (dolist (window (window-list-1 nil nil t)) - (if (eq (window-buffer window) buffer) - ;; Delete a dedicated window unless it is a side window. - (let ((dedicated-side (eq (window-dedicated-p window) 'side))) - (when (or dedicated-side (not (window--delete window t t))) - ;; Switch to another buffer in that window. - (set-window-dedicated-p window nil) - (if (switch-to-prev-buffer window 'kill) + (when (eq (window-buffer window) buffer) + (if kill-buffer-quit-windows + (quit-restore-window window 'killing) + (let ((dedicated-side (eq (window-dedicated-p window) 'side))) + (when (or dedicated-side (not (window--delete window t 'kill))) + ;; Switch to another buffer in that window. + (set-window-dedicated-p window nil) + (if (switch-to-prev-buffer window 'kill) (and dedicated-side (set-window-dedicated-p window 'side)) - (window--delete window nil 'kill)))) - ;; Unrecord BUFFER in WINDOW. - (unrecord-window-buffer window buffer))))) + (window--delete window nil 'kill)))))) + + (when (window-live-p window) + ;; If the fourth elements of the 'quit-restore' or + ;; 'quit-restore-prev' parameters equal BUFFER, these + ;; parameters become useless - in 'quit-restore-window' the + ;; fourth element must equal the buffer of WINDOW in order to + ;; use that parameter. If BUFFER is mentioned in the second + ;; element of the parameter, 'quit-restore-window' cannot + ;; possibly show BUFFER instead; so this parameter becomes + ;; useless too. + (unrecord-window-buffer window buffer t))))) (defcustom quit-window-hook nil "Hook run before performing any other actions in the `quit-window' command." @@ -5164,6 +5226,23 @@ all window-local buffer lists." :version "27.1" :group 'windows) +(defcustom quit-restore-window-no-switch nil + "Non-nil means `quit-restore-window' preferably won't switch buffers. +If this is nil, `quit-restore-window' unconditionally calls +`switch-to-prev-buffer' unless the window is dedicated or has been made +by `display-buffer'. If this is t, `quit-restore-window' will try to +delete the window unless a live buffer exists that was previously shown +in that window. If this is the symbol `skip-first', it will switch to a +previous buffer only if there are at least two of them. + +The net effect of making this non-nil is that if `quit-restore-window' +doesn't find a suitable buffer previously shown in the window, it will +rather try to delete the window (and maybe its frame) than show a buffer +the window has never shown before." + :type 'boolean + :version "31.1" + :group 'windows) + (defun window--quit-restore-select-window (window) "Select WINDOW after having quit another one. Do not select an inactive minibuffer window." @@ -5176,17 +5255,21 @@ Do not select an inactive minibuffer window." "Quit WINDOW and deal with its buffer. WINDOW must be a live window and defaults to the selected one. -According to information stored in WINDOW's `quit-restore' window -parameter either (1) delete WINDOW and its frame, (2) delete -WINDOW but leave its frame alone, (3) restore the buffer -previously shown in WINDOW, or (4) make WINDOW display some other -buffer. If WINDOW is not deleted, reset its `quit-restore' -parameter to nil. See Info node `(elisp) Quitting Windows' for -more details. +According to information stored in WINDOW's `quit-restore' and +`quit-restore-prev' parameters either (1) delete WINDOW and its +frame, (2) delete WINDOW but leave its frame alone, (3) restore the +buffer previously shown in WINDOW, or (4) make WINDOW display some other +buffer. In case (3) set any of these parameters to nil if it has been +used to restore the previously shown buffer. See Info node `(elisp) +Quitting Windows' for more details. -If WINDOW's dedicated flag is t, try to delete WINDOW. If it -equals the value `side', restore that value when WINDOW is not -deleted. +If WINDOW's dedicated flag is t, try to delete WINDOW. If it equals the +value `side', restore that value when WINDOW is not deleted. Whether +WINDOW or its frame get deleted can be further controlled via the option +`quit-restore-window-no-switch'. + +If running the abnormal hook `window-deletable-functions' returns nil, +do not delete WINDOW but show some other buffer in it. Optional second argument BURY-OR-KILL tells how to proceed with the buffer of WINDOW. The following values are handled: @@ -5206,21 +5289,31 @@ nil means to not handle the buffer in a particular way. This most reliable remedy to not have `switch-to-prev-buffer' switch to this buffer again without killing the buffer. -`kill' means to kill WINDOW's buffer." +`kill' means to kill WINDOW's buffer. + +`killing' is like `kill' but means that WINDOW's buffer will get killed +elsewhere. This value is used by `replace-buffer-in-windows' and +`quit-windows-on'. + +`burying' is like `bury' but means that WINDOW's buffer will get buried +elsewhere. This value is used by `quit-windows-on'." (setq window (window-normalize-window window t)) (let* ((buffer (window-buffer window)) (quit-restore (window-parameter window 'quit-restore)) + (quit-restore-prev (window-parameter window 'quit-restore-prev)) (quit-restore-2 (nth 2 quit-restore)) + (quit-restore-prev-2 (nth 2 quit-restore-prev)) (prev-buffer (catch 'prev-buffer (dolist (buf (window-prev-buffers window)) (unless (eq (car buf) buffer) (throw 'prev-buffer (car buf)))))) (dedicated (window-dedicated-p window)) - quad entry) + quad entry reset-prev) (cond ;; First try to delete dedicated windows that are not side windows. ((and dedicated (not (eq dedicated 'side)) - (window--delete window 'dedicated (eq bury-or-kill 'kill))) + (window--delete + window 'dedicated (memq bury-or-kill '(kill killing)))) ;; If the previously selected window is still alive, select it. (window--quit-restore-select-window quit-restore-2)) ((and (not prev-buffer) @@ -5241,10 +5334,27 @@ nil means to not handle the buffer in a particular way. This (window--delete window nil (eq bury-or-kill 'kill))) ;; If the previously selected window is still alive, select it. (window--quit-restore-select-window quit-restore-2)) - ((and (listp (setq quad (nth 1 quit-restore))) - (buffer-live-p (car quad)) - (eq (nth 3 quit-restore) buffer)) - ;; Show another buffer stored in quit-restore parameter. + ((and (or (and quit-restore-window-no-switch (not prev-buffer)) + ;; Ignore first of the previous buffers if + ;; 'quit-restore-window-no-switch' says so. + (and (eq quit-restore-window-no-switch 'skip-first) + (not (cdr (window-prev-buffers window))))) + ;; Delete WINDOW if possible. + (window--delete + window nil (memq bury-or-kill '(kill killing)))) + ;; If the previously selected window is still alive, select it. + (window--quit-restore-select-window quit-restore-2)) + ((or (and (listp (setq quad (nth 1 quit-restore-prev))) + (buffer-live-p (car quad)) + (eq (nth 3 quit-restore-prev) buffer) + ;; Use selected window from quit-restore-prev. + (setq quit-restore-2 quit-restore-prev-2) + ;; We want to reset quit-restore-prev only. + (setq reset-prev t)) + (and (listp (setq quad (nth 1 quit-restore))) + (buffer-live-p (car quad)) + (eq (nth 3 quit-restore) buffer))) + ;; Show another buffer stored in quit-restore(-prev) parameter. (when (and (integerp (nth 3 quad)) (if (window-combined-p window) (/= (nth 3 quad) (window-total-height window)) @@ -5269,27 +5379,26 @@ nil means to not handle the buffer in a particular way. This ;; Deal with the buffer we just removed from WINDOW. (setq entry (and (eq bury-or-kill 'append) (assq buffer (window-prev-buffers window)))) - (when bury-or-kill + (when (memq bury-or-kill '(bury burying kill killing)) ;; Remove buffer from WINDOW's previous and next buffers. - (set-window-prev-buffers - window (assq-delete-all buffer (window-prev-buffers window))) - (set-window-next-buffers - window (delq buffer (window-next-buffers window)))) + (unrecord-window-buffer window buffer)) (when entry ;; Append old buffer's entry to list of WINDOW's previous ;; buffers so it's less likely to get switched to soon but ;; `display-buffer-in-previous-window' can nevertheless find it. (set-window-prev-buffers window (append (window-prev-buffers window) (list entry)))) - ;; Reset the quit-restore parameter. - (set-window-parameter window 'quit-restore nil) - ;; Select old window. + ;; Reset the quit-restore(-prev) parameter. + (set-window-parameter window 'quit-restore-prev nil) + (unless reset-prev + ;; If quit-restore-prev was not used, reset the quit-restore + ;; parameter + (set-window-parameter window 'quit-restore nil)) ;; If the previously selected window is still alive, select it. (window--quit-restore-select-window quit-restore-2)) (t - ;; Show some other buffer in WINDOW and reset the quit-restore - ;; parameter. - (set-window-parameter window 'quit-restore nil) + ;; Show some other buffer in WINDOW and leave the + ;; quit-restore(-prev) parameters alone (Juri's idea). ;; Make sure that WINDOW is no more dedicated. (set-window-dedicated-p window nil) ;; Try to switch to a previous buffer. Delete the window only if @@ -5297,16 +5406,14 @@ nil means to not handle the buffer in a particular way. This (if (switch-to-prev-buffer window bury-or-kill) (when (eq dedicated 'side) (set-window-dedicated-p window 'side)) - (window--delete window nil (eq bury-or-kill 'kill)) - ;; If the previously selected window is still alive, select it. - (window--quit-restore-select-window quit-restore-2)))) - + (window--delete + window nil (memq bury-or-kill '(kill killing)))))) ;; Deal with the buffer. (cond ((not (buffer-live-p buffer))) ((eq bury-or-kill 'kill) (kill-buffer buffer)) - (bury-or-kill + ((eq bury-or-kill 'bury) (bury-buffer-internal buffer))))) (defun quit-window (&optional kill window) @@ -5336,18 +5443,31 @@ non-nil means to kill BUFFER-OR-NAME. KILL nil means to bury BUFFER-OR-NAME. Optional argument FRAME is handled as by `delete-windows-on'. -This function calls `quit-window' on all candidate windows -showing BUFFER-OR-NAME." +This function calls `quit-restore-window' on all candidate windows +showing BUFFER-OR-NAME. In addition, it removes the buffer denoted by +BUFFER-OR-NAME from all window-local buffer lists and removes any +`quit-restore' or `quit-restore-prev' parameters mentioning it." (interactive "bQuit windows on (buffer):\nP") (let ((buffer (window-normalize-buffer buffer-or-name)) ;; Handle the "inverted" meaning of the FRAME argument wrt other - ;; `window-list-1' based function. - (all-frames (cond ((not frame) t) ((eq frame t) nil) (t frame)))) - (dolist (window (window-list-1 nil nil all-frames)) - (if (eq (window-buffer window) buffer) - (quit-window kill window) - ;; If a window doesn't show BUFFER, unrecord BUFFER in it. - (unrecord-window-buffer window buffer))))) + ;; `window-list' based function. + (frames (cond ((not frame) t) ((eq frame t) nil) (t frame)))) + (dolist (window (window-list-1 nil nil frames)) + (when (eq (window-buffer window) buffer) + (with-current-buffer buffer + (run-hooks 'quit-window-hook)) + (quit-restore-window + window (if kill 'killing 'burying))) + + (when (window-live-p window) + ;; Unrecord BUFFER in this window. + (unrecord-window-buffer window buffer t))) + + ;; Deal with BUFFER-OR-NAME. + (cond + ((not (buffer-live-p buffer))) + (kill (kill-buffer buffer)) + (t (bury-buffer-internal buffer))))) (defun window--combination-resizable (parent &optional horizontal) "Return number of pixels recoverable from height of window PARENT. @@ -6657,34 +6777,42 @@ or `other'. The second element is either one of the symbols previously shown in the window, that buffer's window start and window point, and the window's height. The third element is the window selected at the time the parameter was created. The -fourth element is BUFFER." +fourth element is BUFFER. + +If TYPE is `reuse', BUFFER is different from the one currently displayed +in WINDOW, and WINDOW already has a `quit-restore' parameter, install or +update a `quit-restore-prev' parameter for this window. This allows for +quitting WINDOW in a similar fashion but also keeps the very first +`quit-restore' parameter stored for this window around. Consequently, +WINDOW (or its frame) can be eventually deleted by `quit-restore-widow' +if that parameter's fourth element equals WINDOW's buffer." (cond ((eq type 'reuse) - (if (eq (window-buffer window) buffer) - ;; WINDOW shows BUFFER already. Update WINDOW's quit-restore - ;; parameter, if any. - (let ((quit-restore (window-parameter window 'quit-restore))) + (let ((quit-restore (window-parameter window 'quit-restore))) + (if (eq (window-buffer window) buffer) + ;; WINDOW shows BUFFER already. Update WINDOW's quit-restore + ;; parameter, if any. (when (consp quit-restore) (setcar quit-restore 'same) ;; The selected-window might have changed in ;; between (Bug#20353). (unless (or (eq window (selected-window)) - (eq window (nth 2 quit-restore))) - (setcar (cddr quit-restore) (selected-window))))) - ;; WINDOW shows another buffer. - (with-current-buffer (window-buffer window) - (set-window-parameter - window 'quit-restore - (list 'other - ;; A quadruple of WINDOW's buffer, start, point and height. - (list (current-buffer) (window-start window) - ;; Preserve window-point-insertion-type (Bug#12855). - (copy-marker - (window-point window) window-point-insertion-type) - (if (window-combined-p window) - (window-total-height window) - (window-total-width window))) - (selected-window) buffer))))) + (eq window (nth 2 quit-restore))) + (setcar (cddr quit-restore) (selected-window)))) + ;; WINDOW shows another buffer. + (with-current-buffer (window-buffer window) + (set-window-parameter + window (if quit-restore 'quit-restore-prev 'quit-restore) + (list 'other + ;; A quadruple of WINDOW's buffer, start, point and height. + (list (current-buffer) (window-start window) + ;; Preserve window-point-insertion-type (Bug#12855). + (copy-marker + (window-point window) window-point-insertion-type) + (if (window-combined-p window) + (window-total-height window) + (window-total-width window))) + (selected-window) buffer)))))) ((eq type 'window) ;; WINDOW has been created on an existing frame. (set-window-parameter @@ -9129,6 +9257,9 @@ the buffer in the selected window, window start and point are adjusted as prescribed by the option `switch-to-buffer-preserve-window-point'. Otherwise, these are left alone. +In either case, call `display-buffer-record-window' to avoid disrupting +a sequence of `display-buffer' operations using this window. + Return the buffer switched to." (interactive (let ((force-same-window @@ -9189,6 +9320,11 @@ Return the buffer switched to." buffer)) (displayed (and (eq preserve-win-point 'already-displayed) (get-buffer-window buffer 0)))) + + ;; Make sure quitting the window works. + (unless switch-to-buffer-obey-display-actions + (display-buffer-record-window 'reuse (selected-window) buffer)) + (set-window-buffer nil buffer) (when (and entry (or (eq preserve-win-point t) displayed)) ;; Try to restore start and point of buffer in the selected diff --git a/src/alloc.c b/src/alloc.c index 48b170b866f..06fe12cff3d 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -7009,33 +7009,6 @@ mark_face_cache (struct face_cache *c) } } -/* Remove killed buffers or items whose car is a killed buffer from - LIST, and mark other items. Return changed LIST, which is marked. */ - -static Lisp_Object -mark_discard_killed_buffers (Lisp_Object list) -{ - Lisp_Object tail, *prev = &list; - - for (tail = list; CONSP (tail) && !cons_marked_p (XCONS (tail)); - tail = XCDR (tail)) - { - Lisp_Object tem = XCAR (tail); - if (CONSP (tem)) - tem = XCAR (tem); - if (BUFFERP (tem) && !BUFFER_LIVE_P (XBUFFER (tem))) - *prev = XCDR (tail); - else - { - set_cons_marked (XCONS (tail)); - mark_object (XCAR (tail)); - prev = xcdr_addr (tail); - } - } - mark_object (tail); - return list; -} - static void mark_frame (struct Lisp_Vector *ptr) { @@ -7090,15 +7063,6 @@ mark_window (struct Lisp_Vector *ptr) mark_glyph_matrix (w->current_matrix); mark_glyph_matrix (w->desired_matrix); } - - /* Filter out killed buffers from both buffer lists - in attempt to help GC to reclaim killed buffers faster. - We can do it elsewhere for live windows, but this is the - best place to do it for dead windows. */ - wset_prev_buffers - (w, mark_discard_killed_buffers (w->prev_buffers)); - wset_next_buffers - (w, mark_discard_killed_buffers (w->next_buffers)); } /* Entry of the mark stack. */ diff --git a/src/buffer.c b/src/buffer.c index 744b0ef5548..6ec40aff646 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -2012,6 +2012,13 @@ cleaning up all windows currently displaying the buffer to be killed. */) buffer (bug#10114). */ replace_buffer_in_windows (buffer); + /* For dead windows that have not been collected yet, remove this + buffer from those windows' lists of previously and next shown + buffers and remove any 'quit-restore' or 'quit-restore-prev' + parameters mentioning the buffer. */ + if (XFIXNUM (BVAR (b, display_count)) > 0) + window_discard_buffer_from_dead_windows (buffer); + /* Exit if replacing the buffer in windows has killed our buffer. */ if (!BUFFER_LIVE_P (b)) return Qt; diff --git a/src/window.c b/src/window.c index 4bb36b6733a..559919689a3 100644 --- a/src/window.c +++ b/src/window.c @@ -3277,6 +3277,113 @@ window_pixel_to_total (Lisp_Object frame, Lisp_Object horizontal) } +/** Remove all occurrences of element whose car is BUFFER from ALIST. + Return changed ALIST. */ +static Lisp_Object +window_discard_buffer_from_alist (Lisp_Object buffer, Lisp_Object alist) +{ + Lisp_Object tail, *prev = &alist; + + for (tail = alist; CONSP (tail); tail = XCDR (tail)) + { + Lisp_Object tem = XCAR (tail); + + tem = XCAR (tem); + + if (EQ (tem, buffer)) + *prev = XCDR (tail); + else + prev = xcdr_addr (tail); + } + + return alist; +} + +/** Remove all occurrences of BUFFER from LIST. Return changed + LIST. */ +static Lisp_Object +window_discard_buffer_from_list (Lisp_Object buffer, Lisp_Object list) +{ + Lisp_Object tail, *prev = &list; + + for (tail = list; CONSP (tail); tail = XCDR (tail)) + if (EQ (XCAR (tail), buffer)) + *prev = XCDR (tail); + else + prev = xcdr_addr (tail); + + return list; +} + +/** Remove BUFFER from the lists of previous and next buffers of object + WINDOW. ALL true means remove any `quit-restore' and + `quit-restore-prev' parameter of WINDOW referencing BUFFER too. */ +static void +window_discard_buffer_from_window (Lisp_Object buffer, Lisp_Object window, bool all) +{ + struct window *w = XWINDOW (window); + + wset_prev_buffers + (w, window_discard_buffer_from_alist (buffer, w->prev_buffers)); + wset_next_buffers + (w, window_discard_buffer_from_list (buffer, w->next_buffers)); + + if (all) + { + Lisp_Object quit_restore = window_parameter (w, Qquit_restore); + Lisp_Object quit_restore_prev = window_parameter (w, Qquit_restore_prev); + Lisp_Object quad; + + if (EQ (buffer, Fnth (make_fixnum (3), quit_restore_prev)) + || (CONSP (quad = Fcar (Fcdr (quit_restore_prev))) + && EQ (Fcar (quad), buffer))) + Fset_window_parameter (window, Qquit_restore_prev, Qnil); + + if (EQ (buffer, Fnth (make_fixnum (3), quit_restore)) + || (CONSP (quad = Fcar (Fcdr (quit_restore))) + && EQ (Fcar (quad), buffer))) + { + Fset_window_parameter (window, Qquit_restore, + window_parameter (w, Qquit_restore_prev)); + Fset_window_parameter (window, Qquit_restore_prev, Qnil); + } + } +} + +/** Remove BUFFER from the lists of previous and next buffers and the + `quit-restore' and `quit-restore-prev' parameters of any dead + WINDOW. */ +void +window_discard_buffer_from_dead_windows (Lisp_Object buffer) +{ + struct Lisp_Hash_Table *h = XHASH_TABLE (window_dead_windows_table); + + DOHASH (h, k, v) + window_discard_buffer_from_window (buffer, v, true); +} + +DEFUN ("window-discard-buffer-from-window", Fwindow_discard_buffer, + Swindow_discard_buffer, 2, 3, 0, + doc: /* Discard BUFFER from WINDOW. +Discard specified live BUFFER from the lists of previous and next +buffers of specified live WINDOW. + +Optional argument ALL non-nil means discard any `quit-restore' and +`quit-restore-prev' parameters of WINDOW referencing BUFFER too. */) + (Lisp_Object buffer, Lisp_Object window, Lisp_Object all) +{ + if (!BUFFER_LIVE_P (XBUFFER (buffer))) + error ("Not a live buffer"); + + if (!WINDOW_LIVE_P (window)) + error ("Not a live window"); + + window_discard_buffer_from_window (buffer, window, !NILP (all)); + + return Qnil; +} + + DEFUN ("delete-other-windows-internal", Fdelete_other_windows_internal, Sdelete_other_windows_internal, 0, 2, "", doc: /* Make WINDOW fill its frame. @@ -4140,6 +4247,9 @@ set_window_buffer (Lisp_Object window, Lisp_Object buffer, w->window_end_vpos = 0; w->last_cursor_vpos = 0; + /* Discard BUFFER from WINDOW's previous and next buffers. */ + window_discard_buffer_from_window (buffer, window, false); + if (!(keep_margins_p && samebuf)) { /* If we're not actually changing the buffer, don't reset hscroll and vscroll. Resetting hscroll and vscroll here is problematic @@ -4402,6 +4512,10 @@ make_parent_window (Lisp_Object window, bool horflag) wset_buffer (p, Qnil); wset_combination (p, horflag, window); wset_combination_limit (p, Qnil); + /* Reset any previous and next buffers of p which have been installed + by the memcpy above. */ + wset_prev_buffers (p, Qnil); + wset_next_buffers (p, Qnil); wset_window_parameters (p, Qnil); } @@ -4426,10 +4540,6 @@ make_window (void) wset_vertical_scroll_bar_type (w, Qt); wset_horizontal_scroll_bar_type (w, Qt); wset_cursor_type (w, Qt); - /* These Lisp fields are marked specially so they're not set to nil by - allocate_window. */ - wset_prev_buffers (w, Qnil); - wset_next_buffers (w, Qnil); /* Initialize non-Lisp data. Note that allocate_window zeroes out all non-Lisp data, so do it only for slots which should not be zero. */ @@ -5252,6 +5362,11 @@ Signal an error when WINDOW is the only window on its frame. */) unchain_marker (XMARKER (w->old_pointm)); unchain_marker (XMARKER (w->start)); wset_buffer (w, Qnil); + /* Add WINDOW to table of dead windows so when killing a buffer + WINDOW mentions, all references to that buffer can be removed + and the buffer be collected. */ + Fputhash (make_fixnum (w->sequence_number), + window, window_dead_windows_table); } if (NILP (s->prev) && NILP (s->next)) @@ -7356,12 +7471,21 @@ the return value is nil. Otherwise the value is t. */) } } + /* Remove window from the table of dead windows. */ + Fremhash (make_fixnum (w->sequence_number), + window_dead_windows_table); + if ((NILP (dont_set_miniwindow) || !MINI_WINDOW_P (w)) && BUFFERP (p->buffer) && BUFFER_LIVE_P (XBUFFER (p->buffer))) /* If saved buffer is alive, install it, unless it's a minibuffer we explicitly prohibit. */ { - wset_buffer (w, p->buffer); + if (!EQ (w->contents, p->buffer)) + { + wset_buffer (w, p->buffer); + window_discard_buffer_from_window (w->contents, window, false); + } + w->start_at_line_beg = !NILP (p->start_at_line_beg); set_marker_restricted (w->start, p->start, w->contents); set_marker_restricted (w->pointm, p->pointm, w->contents); @@ -7406,6 +7530,7 @@ the return value is nil. Otherwise the value is t. */) recreate *scratch* in the course (part of Juanma's bs-show scenario from March 2011). */ wset_buffer (w, other_buffer_safely (Fcurrent_buffer ())); + window_discard_buffer_from_window (w->contents, window, false); /* This will set the markers to beginning of visible range. */ set_marker_restricted_both (w->start, w->contents, 0, 0); @@ -7585,6 +7710,11 @@ delete_all_child_windows (Lisp_Object window) possible resurrection in Fset_window_configuration. */ wset_combination_limit (w, w->contents); wset_buffer (w, Qnil); + /* Add WINDOW to table of dead windows so when killing a buffer + WINDOW mentions, all references to that buffer can be removed + and the buffer be collected. */ + Fputhash (make_fixnum (w->sequence_number), + window, window_dead_windows_table); } Vwindow_list = Qnil; @@ -8594,6 +8724,8 @@ syms_of_window (void) DEFSYM (Qconfiguration, "configuration"); DEFSYM (Qdelete, "delete"); DEFSYM (Qdedicated, "dedicated"); + DEFSYM (Qquit_restore, "quit-restore"); + DEFSYM (Qquit_restore_prev, "quit-restore-prev"); DEFVAR_LISP ("temp-buffer-show-function", Vtemp_buffer_show_function, doc: /* Non-nil means call as function to display a help buffer. @@ -8917,6 +9049,17 @@ Note that this optimization can cause the portion of the buffer displayed after a scrolling operation to be somewhat inaccurate. */); fast_but_imprecise_scrolling = false; + DEFVAR_LISP ("window-dead-windows-table", window_dead_windows_table, + doc: /* Hash table of dead windows. +Each entry in this table maps a window number to a window object. +Entries are added by `delete-window-internal' and are removed by the +garbage collector. + +This table is maintained by code in window.c and is made visible in +Elisp for testing purposes only. */); + window_dead_windows_table + = CALLN (Fmake_hash_table, QCweakness, Qt); + defsubr (&Sselected_window); defsubr (&Sold_selected_window); defsubr (&Sminibuffer_window); @@ -9032,6 +9175,7 @@ displayed after a scrolling operation to be somewhat inaccurate. */); defsubr (&Swindow_parameters); defsubr (&Swindow_parameter); defsubr (&Sset_window_parameter); + defsubr (&Swindow_discard_buffer); defsubr (&Swindow_cursor_type); defsubr (&Sset_window_cursor_type); } diff --git a/src/window.h b/src/window.h index 86932181252..335e0a3453e 100644 --- a/src/window.h +++ b/src/window.h @@ -142,6 +142,12 @@ struct window as well. */ Lisp_Object contents; + /* A list of triples listing + buffers previously shown in this window. */ + Lisp_Object prev_buffers; + /* List of buffers re-shown in this window. */ + Lisp_Object next_buffers; + /* The old buffer of this window, set to this window's buffer by run_window_change_functions every time it sees this window. Unused for internal windows. */ @@ -218,14 +224,6 @@ struct window struct glyph_matrix *current_matrix; struct glyph_matrix *desired_matrix; - /* The two Lisp_Object fields below are marked in a special way, - which is why they're placed after `current_matrix'. */ - /* A list of triples listing - buffers previously shown in this window. */ - Lisp_Object prev_buffers; - /* List of buffers re-shown in this window. */ - Lisp_Object next_buffers; - /* Number saying how recently window was selected. */ EMACS_INT use_time; @@ -1228,6 +1226,7 @@ extern void replace_buffer_in_windows_safely (Lisp_Object); extern void wset_buffer (struct window *, Lisp_Object); extern bool window_outdated (struct window *); extern ptrdiff_t window_point (struct window *w); +extern void window_discard_buffer_from_dead_windows (Lisp_Object); extern void init_window_once (void); extern void init_window (void); extern void syms_of_window (void); commit efbeefd17e3e8a3dcc02439805e42b9d9cedded9 Author: Po Lu Date: Thu Aug 1 08:29:50 2024 +0800 Conclude previous change * lisp/international/fontset.el (script-representative-chars) : Remove practically unattested characters, since this variable is not used in font resolution on MS-Windows any longer. diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el index 3e16e1f35bd..f5b4b0b4aa4 100644 --- a/lisp/international/fontset.el +++ b/lisp/international/fontset.el @@ -209,8 +209,7 @@ (bopomofo #x3105) (kanbun #x319D) (han #x2e90 #x2f00 #x3010 #x3200 #x3300 #x3400 #x31c0 #x4e10 - #x5B57 #xfe30 #xf900 - #x1f210 #x20000 #x2a700 #x2b740 #x2b820 #x2ceb0 #x2f804) + #x5B57 #xfe30 #xf900) (yi #xA288) (syloti-nagri #xA807 #xA823 #xA82C) (rejang #xA930 #xA947 #xA95F) commit 96097d362322595e308157ff70f191ef2b49640d Merge: d00eb0468b1 1154d8aafe2 Author: Po Lu Date: Thu Aug 1 08:25:31 2024 +0800 Merge from savannah/emacs-30 1154d8aafe2 Better resolve bug#72188 ceb5a152227 MacOS: Let EmacsView implement NSTextInputClient 9f7c1ace9f8 NS: Set frame position when entering/exiting fullscreen (... 74fe889a93f Merge branch 'emacs-30' of git.savannah.gnu.org:/srv/git/... abefd9514bc * lisp/tab-bar.el (tab-bar-move-tab-to-group): Fix for a ... e09982f8f5a Merge branch 'emacs-30' of git.savannah.gnu.org:/srv/git/... 5cf64d8377a Fix sporadic crashes and `select' failures in dumped images a475360af98 Correct display of Doc View documents after tab switching b0d927e1dce Merge branch 'emacs-30' of git.savannah.gnu.org:/srv/git/... 469bc7c9686 Use 'kill-process' as a fallback when a pipe gets broken ... 158835668df ; * doc/lispref/modes.texi (Mode Line Data): Fix formatting. commit 1154d8aafe2f4702b8fc775835f830fd00cfbaaf Author: Po Lu Date: Thu Aug 1 08:23:36 2024 +0800 Better resolve bug#72188 * lisp/international/fontset.el (setup-default-fontset) : Don't search for fonts matching the `han' script elsewhere than on Android, which restores the status quo existing in Emacs 29. (bug#72188) diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el index 33e444507c4..d60349e05e3 100644 --- a/lisp/international/fontset.el +++ b/lisp/international/fontset.el @@ -697,10 +697,11 @@ (nil . "JISX0213.2004-1") ,(font-spec :registry "iso10646-1" :lang 'ja) ,(font-spec :registry "iso10646-1" :lang 'zh) - ;; This is required, as otherwise many TrueType fonts with - ;; CJK characters but no corresponding ``design language'' - ;; declaration can't be found. - ,(font-spec :registry "iso10646-1" :script 'han)) + ;; This is required on Android, as otherwise many TrueType + ;; fonts with CJK characters but no corresponding ``design + ;; language'' declaration can't be found. + ,@(and (featurep 'android) + (list (font-spec :registry "iso10646-1" :script 'han)))) (cjk-misc (nil . "GB2312.1980-0") (nil . "JISX0208*") commit d00eb0468b147f2bfcb58bc586801f0495f5973d Author: Eli Zaretskii Date: Wed Jul 31 18:36:41 2024 +0300 Revert "Re-enable displaying `han' characters on Android" This reverts commit bf0aeaa0d7a1581a095aa423e75d0d71cceb28cd. The characters removed by this commit cause Emacs to select sub-optimal fonts that lack many Chinese characters, because Emacs generally stops looking for fonts when it finds the first one that seems to match. diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el index d8c83c46e68..d4e24899d11 100644 --- a/lisp/international/fontset.el +++ b/lisp/international/fontset.el @@ -209,7 +209,8 @@ (bopomofo #x3105) (kanbun #x319D) (han #x2e90 #x2f00 #x3010 #x3200 #x3300 #x3400 #x31c0 #x4e10 - #x5B57 #xfe30 #xf900) + #x5B57 #xfe30 #xf900 + #x1f210 #x20000 #x2a700 #x2b740 #x2b820 #x2ceb0 #x2f804) (yi #xA288) (syloti-nagri #xA807 #xA823 #xA82C) (rejang #xA930 #xA947 #xA95F) commit 44c9c2c8456117625ec8a54d4a6908404e483f83 Author: Stefan Monnier Date: Wed Jul 31 04:52:08 2024 -0400 (vhdl-run-when-idle): Don't use `timer--triggered` * lisp/progmodes/vhdl-mode.el (vhdl-run-when-idle): Avoid relying needlessly on internal accessor and fix last change to make sure we always create a timer. diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index 2c4b83bed23..bf309500a38 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -2338,11 +2338,13 @@ Ignore byte-compiler warnings you might see." (defun vhdl-run-when-idle (secs repeat function) "Wait until idle, then run FUNCTION." - (if (fboundp 'start-itimer) + (if (fboundp 'start-itimer) ;;XEmacs (start-itimer "vhdl-mode" function secs repeat t) ;; explicitly activate timer (necessary when Emacs is already idle) - (when (featurep 'xemacs) - (aset (run-with-idle-timer secs repeat function) 0 nil)))) + (let ((timer (run-with-idle-timer secs repeat function))) + ;; `run-with-idle-timer' already sets the `triggered' flag to nil, + ;; at least since Emacs-24. + (if (< emacs-major-version 24) (aset timer 0 nil))))) (defun vhdl-warning-when-idle (&rest args) "Wait until idle, then print out warning STRING and beep." commit ceb5a1522270c41d0c9f5e6b52d61e3173f72f1d Author: Gerd Möllmann Date: Tue Jul 30 07:47:44 2024 +0200 MacOS: Let EmacsView implement NSTextInputClient * src/nsterm.h (@interface EmacsView): Implement NSTextInputClient protocol. * src/nsterm.m: Implement required NSTextInputClient methods, forwarding to existing NSTextInput methods. diff --git a/src/nsterm.h b/src/nsterm.h index e3f55c4e41c..a07829a36ec 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -463,7 +463,7 @@ enum ns_return_frame_mode @class EmacsLayer; #ifdef NS_IMPL_COCOA -@interface EmacsView : NSView +@interface EmacsView : NSView #else @interface EmacsView : NSView #endif diff --git a/src/nsterm.m b/src/nsterm.m index 8a0c12c7369..b56c587bc69 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -7032,9 +7032,48 @@ In that case we use UCKeyTranslate (ns_get_shifted_character) [nsEvArray removeObject: theEvent]; } +/*********************************************************************** + NSTextInputClient + ***********************************************************************/ -/* implementation (called through [super interpretKeyEvents:]). */ +#ifdef NS_IMPL_COCOA + +- (void) insertText: (id) string + replacementRange: (NSRange) replacementRange +{ + if ([string isKindOfClass:[NSAttributedString class]]) + string = [string string]; + [self unmarkText]; + [self insertText:string]; +} + +- (void) setMarkedText: (id) string + selectedRange: (NSRange) selectedRange + replacementRange: (NSRange) replacementRange +{ + [self setMarkedText: string selectedRange: selectedRange]; +} + +- (nullable NSAttributedString *) + attributedSubstringForProposedRange: (NSRange) range + actualRange: (nullable NSRangePointer) actualRange +{ + return nil; +} + +- (NSRect) firstRectForCharacterRange: (NSRange) range + actualRange: (nullable NSRangePointer) actualRange +{ + return NSZeroRect; +} +#endif /* NS_IMPL_COCOA */ + +/*********************************************************************** + NSTextInput + ***********************************************************************/ + +/* implementation (called through [super interpretKeyEvents:]). */ /* : called when done composing; NOTE: also called when we delete over working text, followed commit bf0aeaa0d7a1581a095aa423e75d0d71cceb28cd Author: Po Lu Date: Wed Jul 31 08:32:24 2024 +0800 Re-enable displaying `han' characters on Android * lisp/international/fontset.el (script-representative-chars) : Remove several characters that were just recently introduced into unicode and are consequently absent from many fonts, so that they may match font specs specifying scripts rather than QClang in the default fontset. diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el index d4e24899d11..d8c83c46e68 100644 --- a/lisp/international/fontset.el +++ b/lisp/international/fontset.el @@ -209,8 +209,7 @@ (bopomofo #x3105) (kanbun #x319D) (han #x2e90 #x2f00 #x3010 #x3200 #x3300 #x3400 #x31c0 #x4e10 - #x5B57 #xfe30 #xf900 - #x1f210 #x20000 #x2a700 #x2b740 #x2b820 #x2ceb0 #x2f804) + #x5B57 #xfe30 #xf900) (yi #xA288) (syloti-nagri #xA807 #xA823 #xA82C) (rejang #xA930 #xA947 #xA95F) commit a7e3181e2f7adb928d63a8878a11849818ba321c Author: Yuan Fu Date: Sat Jul 27 16:18:13 2024 -0700 New variable treesit-language-remap-alist (bug#72388) * doc/lispref/parsing.texi (Using Parser): Manual entry for the new variable. * src/treesit.c (resolve_language_symbol): New function. (Ftreesit_parser_create, Ftreesit_parser_list): Resolve language before using it. (Vtreesit_language_remap_alist): New variable. diff --git a/doc/lispref/parsing.texi b/doc/lispref/parsing.texi index a3d2a5ac71c..ddf02d9283b 100644 --- a/doc/lispref/parsing.texi +++ b/doc/lispref/parsing.texi @@ -531,6 +531,30 @@ symbol, rather than a lambda function. This function returns the list of @var{parser}'s notifier functions. @end defun +@heading Substitute parser for another language +@cindex remap language grammar, tree-sitter +@cindex replace language grammar, tree-sitter +@cindex replace parser language, tree-sitter +@cindex extended grammar, tree-sitter + +Sometimes, a grammar for language B is a strict superset of the grammar +of another language A. Then it makes sense to reuse configurations +(font-lock rules, indentation rules, etc.) of language A for language B. +For that purpose, @var{treesit-language-remap-alist} allows users to +remap language A into language B. + +@defvar treesit-language-remap-alist +The value of this variable should be an alist of +@w{@code{(@var{language-a} . @var{language-b})}}. When such pair exists +in the alist, creating a parser for @var{language-a} actually creates a +parser for @var{language-b}. By extension, anything that creates a node +or makes a query of @var{language-a} will be redirected to use +@var{language-b} instead. + +Note that calling @code{treesit-parser-language} on a parser for +@var{language-a} still returns @var{language-a}. +@end defvar + @node Retrieving Nodes @section Retrieving Nodes @cindex retrieve node, tree-sitter diff --git a/src/treesit.c b/src/treesit.c index 513d0d22c7f..27779692923 100644 --- a/src/treesit.c +++ b/src/treesit.c @@ -1326,6 +1326,17 @@ treesit_ensure_query_compiled (Lisp_Object query, Lisp_Object *signal_symbol, return treesit_query; } +/* Resolve language symbol LANG according to + treesit-language-remap-alist. */ +static +Lisp_Object resolve_language_symbol (Lisp_Object lang) +{ + Lisp_Object res = Fassoc (lang, Vtreesit_language_remap_alist, Qeq); + if (NILP (res)) + return lang; + return Fcdr (res); +} + /* Lisp definitions. */ @@ -1442,6 +1453,9 @@ an indirect buffer. */) treesit_check_buffer_size (buf); + language = resolve_language_symbol (language); + CHECK_SYMBOL (language); + /* See if we can reuse a parser. */ if (NILP (no_reuse)) { @@ -1531,6 +1545,8 @@ tag. */) if (buf->base_buffer) buf = buf->base_buffer; + language = resolve_language_symbol (language); + /* Return a fresh list so messing with that list doesn't affect our internal data. */ Lisp_Object return_list = Qnil; @@ -4157,6 +4173,19 @@ Finally, PRED can refer to other THINGs defined in this list by using the symbol of that THING. For example, (or sexp sentence). */); Vtreesit_thing_settings = Qnil; + DEFVAR_LISP ("treesit-language-remap-alist", + Vtreesit_language_remap_alist, + doc: + /* An alist remapping language symbols. + +The value should be an alist of (LANGUAGE-A . LANGUAGE-B). When such +pair exists in the alist, creating a parser for LANGUAGE-A actually +creates a parser for LANGUAGE-B. Basically, anything that requires or +applies to LANGUAGE-A will be redirected to LANGUAGE-B instead. */); + Vtreesit_language_remap_alist = Qnil; + DEFSYM (Qtreesit_language_remap_alist, "treesit-language-remap-alist"); + Fmake_variable_buffer_local (Qtreesit_language_remap_alist); + staticpro (&Vtreesit_str_libtree_sitter); Vtreesit_str_libtree_sitter = build_pure_c_string ("libtree-sitter-"); staticpro (&Vtreesit_str_tree_sitter); commit 74bb1e5897f4532fbdefddada28258a8d3d5c95f Author: Yuan Fu Date: Sat Jul 27 14:50:19 2024 -0700 Fix filling in c-ts-mode (bug#72116) The previous fix introduced a regression in the case when there's only a single line in the block comment. In that case we don't want to add a start at the second line: /* foo foo foo */ should => /* foo foo foo */ rather than /* foo foo * foo */ This commit fixes that. * lisp/progmodes/c-ts-common.el: (c-ts-common--fill-block-comment): Don't mask the /*. (c-ts-common--adaptive-fill-prefix): New function. (c-ts-common-comment-setup): Don't set adaptive-regexp, change adaptive-fill-first-line-regexp to work with the new adaptive-fill-function. * test/lisp/progmodes/c-ts-mode-resources/filling.erts: New tests diff --git a/lisp/progmodes/c-ts-common.el b/lisp/progmodes/c-ts-common.el index 6c0b1c9100d..022d21e11a1 100644 --- a/lisp/progmodes/c-ts-common.el +++ b/lisp/progmodes/c-ts-common.el @@ -153,16 +153,16 @@ comment." (end-marker nil) (end-len 0)) (move-marker start-marker start) - ;; We mask "/*" and the space before "*/" like - ;; `c-fill-paragraph' does. + ;; If the first line is /* followed by non-text, exclude this line + ;; from filling. (atomic-change-group - ;; Mask "/*". (goto-char start) (when (looking-at (rx (* (syntax whitespace)) - (group "/") "*")) - (goto-char (match-beginning 1)) - (move-marker start-marker (point)) - (replace-match " " nil nil nil 1)) + (group "/") "*" + (* (or "*" "=" "-" "/" (syntax whitespace))) + eol)) + (forward-line) + (move-marker start-marker (point))) ;; Include whitespaces before /*. (goto-char start) @@ -206,16 +206,63 @@ comment." (fill-region (max start-marker para-start) (min end para-end) arg)) ;; Unmask. - (when start-marker - (goto-char start-marker) - (delete-char 1) - (insert "/")) (when end-marker (goto-char end-marker) (delete-region (point) (+ end-len (point))) (insert (make-string end-len ?\s))) (goto-char orig-point)))) +(defun c-ts-common--adaptive-fill-prefix () + "Returns the appropriate fill-prefix for this paragraph. + +This function should be called at BOL. Used by +`adaptive-fill-function'." + (cond + ;; (1) + ;; If current line is /* and next line is * -> prefix is *. + ;; Eg: + ;; /* xxx => /* xxx + ;; * xxx xxx * xxx + ;; * xxx + ;; If current line is /* and next line isn't * or doesn't exist -> + ;; prefix is whitespace. + ;; Eg: + ;; /* xxx xxx */ => /* xxx + ;; xxx */ + ((and (looking-at (rx (* (syntax whitespace)) + "/*" + (* "*") + (* (syntax whitespace)))) + (let ((whitespaces (make-string (length (match-string 0)) ?\s))) + (save-excursion + (if (and (eq (forward-line) 0) + (looking-at (rx (* (syntax whitespace)) + "*" + (* (syntax whitespace))))) + (match-string 0) + whitespaces))))) + ;; (2) + ;; Current line: //, ///, ////... + ;; Prefix: same. + ((looking-at (rx (* (syntax whitespace)) + "//" + (* "/") + (* (syntax whitespace)))) + (match-string 0)) + ;; (3) + ;; Current line: *, |, - + ;; Prefix: same. + ;; This branch must return the same prefix as branch (1), as the + ;; second line in the paragraph; then the whole paragraph will use * + ;; as the prefix. + ((looking-at (rx (* (syntax whitespace)) + (or "*" "|" "-") + (* (syntax whitespace)))) + (match-string 0)) + ;; Other: let `adaptive-fill-regexp' and + ;; `adaptive-fill-first-line-regexp' decide. + (t nil))) + (defun c-ts-common-comment-setup () "Set up local variables for C-like comment. @@ -241,43 +288,15 @@ Set up: (group (or (syntax comment-end) (seq (+ "*") "/"))))) (setq-local adaptive-fill-mode t) - ;; This matches (1) empty spaces (the default), (2) "//", (3) "*", - ;; but do not match "/*", because we don't want to use "/*" as - ;; prefix when filling. (Actually, it doesn't matter, because - ;; `comment-start-skip' matches "/*" which will cause - ;; `fill-context-prefix' to use "/*" as a prefix for filling, that's - ;; why we mask the "/*" in `c-ts-common--fill-paragraph'.) - (setq-local adaptive-fill-regexp - (concat (rx (* (syntax whitespace)) - (group (or (seq "/" (+ "/")) (* "*")))) - adaptive-fill-regexp)) - ;; For (1): Note the missing * comparing to `adaptive-fill-regexp'. - ;; The reason for its absence is a bit convoluted to explain. Suffice - ;; to say that without it, filling a single line paragraph that starts - ;; with /* doesn't insert * at the beginning of each following line, - ;; and filling a multi-line paragraph whose first two lines start with - ;; * does insert * at the beginning of each following line. If you - ;; know how does adaptive filling work, you know what I mean. - ;; - ;; For (2): If we only have (1), filling a single line that starts - ;; with a single * (and not /*) in a block comment doesn't work as - ;; expected: the following lines won't be prefixed with *. So we add - ;; another rule to cover this case too. (See bug#72116.) I - ;; intentionally made the matching strict (it only matches if there - ;; are only a single * at the BOL) because I want to minimize the - ;; possibility of this new rule matching in unintended situations. + (setq-local adaptive-fill-function #'c-ts-common--adaptive-fill-prefix) + ;; Always accept * or | as prefix, even if there's only one line in + ;; the paragraph. (setq-local adaptive-fill-first-line-regexp (rx bos - ;; (1) - (or (seq (* (syntax whitespace)) - (group (seq "/" (+ "/"))) - (* (syntax whitespace))) - ;; (2) - (seq (* (syntax whitespace)) - (group "*") - (* (syntax whitespace)))) + (* (syntax whitespace)) + (or "*" "|") + (* (syntax whitespace)) eos)) - ;; Same as `adaptive-fill-regexp'. (setq-local paragraph-start (rx (or (seq (* (syntax whitespace)) (group (or (seq "/" (+ "/")) (* "*"))) diff --git a/test/lisp/progmodes/c-ts-mode-resources/filling.erts b/test/lisp/progmodes/c-ts-mode-resources/filling.erts index e51e3658c83..e58b8e91c90 100644 --- a/test/lisp/progmodes/c-ts-mode-resources/filling.erts +++ b/test/lisp/progmodes/c-ts-mode-resources/filling.erts @@ -6,6 +6,52 @@ Code: Point-Char: | +Name: Single line + +=-= +/* woooomy woooomy woooomy woooomy woooomy woooomy woooomy woooomy woooomy */ +=-= +/* woooomy woooomy woooomy woooomy woooomy woooomy woooomy woooomy + woooomy */ +=-=-= + +Name: Two lines + +=-= +/* woooomy woooomy woooomy woooomy woooomy woooomy woooomy woooomy + woooomy woooomy woooomy woooomy woooomy woooomy woooomy woooomy woooomy */ +=-= +/* woooomy woooomy woooomy woooomy woooomy woooomy woooomy woooomy + woooomy woooomy woooomy woooomy woooomy woooomy woooomy woooomy + woooomy */ +=-=-= + +Name: Two lines with star + +=-= +/* woooomy woooomy woooomy woooomy woooomy woooomy woooomy woooomy + * woooomy woooomy woooomy woooomy woooomy woooomy woooomy woooomy woooomy + */ +=-= +/* woooomy woooomy woooomy woooomy woooomy woooomy woooomy woooomy + * woooomy woooomy woooomy woooomy woooomy woooomy woooomy woooomy + * woooomy + */ +=-=-= + +Name: First line empty (bug#72116) + +=-= +/** + * rsite nrsoti ernsto ierntires ntoritsen roitsenrsoit enrstoi ensrotie nrsit ensroit enrsoi ensrien + */ +=-= +/** + * rsite nrsoti ernsto ierntires ntoritsen roitsenrsoit enrstoi + * ensrotie nrsit ensroit enrsoi ensrien + */ +=-=-= + Name: Type 1 =-= commit e4cd26defc0e1a6deafbe4b2310ebdb3ffa4578f Author: Yuan Fu Date: Fri Jul 26 22:33:17 2024 -0700 "Separate" tree-sitter parser list for indirect buffers When create a parser for the indirect buffer, set the buffer field of the parser to the indirect buffer, but add the parser to the base buffer's parser list. This way, all the parsers still get buffer updates, but indirect buffer's parsers can have different narrowing than the parsers of the base buffer. When returning the parser list of a buffer, do filtering and only return the parser for that buffer. From user's POV, indirect buffers appear to have their own parser list. * doc/lispref/parsing.texi (Using Parser): Remove the text describing indirect buffer's special case. * src/treesit.c (Ftreesit_parser_create): When create a parser for the indirect buffer, set the buffer field of the parser to the indirect buffer, but add the parser to the base buffer's parser list. (Ftreesit_parser_list): Filter parser list, only return parsers for this buffer. xx diff --git a/doc/lispref/parsing.texi b/doc/lispref/parsing.texi index 65549505b1e..a3d2a5ac71c 100644 --- a/doc/lispref/parsing.texi +++ b/doc/lispref/parsing.texi @@ -413,13 +413,6 @@ is non-@code{nil}, this function always creates a new parser. @var{tag} can be any symbol except @code{t}, and defaults to @code{nil}. Different parsers can have the same tag. - -If that buffer is an indirect buffer, its base buffer is used instead. -That is, indirect buffers use their base buffer's parsers. If the -base buffer is narrowed, an indirect buffer might not be able to -retrieve information of the portion of the buffer text that is -invisible in the base buffer. Lisp programs should widen as necessary -should they want to use a parser in an indirect buffer. @end defun Given a parser, we can query information about it. @@ -458,9 +451,7 @@ tree incrementally. @defun treesit-parser-list &optional buffer language tag This function returns the parser list of @var{buffer}, filtered by @var{language} and @var{tag}. If @var{buffer} is @code{nil} or -omitted, it defaults to the current buffer. If that buffer is an -indirect buffer, its base buffer is used instead. That is, indirect -buffers use their base buffer's parsers. +omitted, it defaults to the current buffer. If @var{language} is non-@var{nil}, only include parsers for that language, and only include parsers with @var{tag}. @var{tag} defaults diff --git a/etc/NEWS b/etc/NEWS index c907ec40fa1..3a07a75b42c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -194,6 +194,23 @@ authorize the invoked D-Bus method (for example via polkit). ** The customization group 'wp' has been removed. It has been obsolete since Emacs 26.1. Use the group 'text' instead. +** Tree-sitter changes + ++++ +*** Indirect buffers can have their own parser list. +Before, indirect buffers share their base buffer’s parser list and +parsers. Now they can have their own parser list. + ++++ +*** New variable 'treesit-language-remap-alist'. +This variable allows a user to remap one language into another, such +that creating a parser for language A actually creates a parser for +language B. By extension, any font-lock rules or indentation rules for +language A will be applied to language B instead. + +This is useful for reusing font-lock rules and indentation rules of +language A for language B, when language B is a strict superset of +language A. * Changes in Emacs 31.1 on Non-Free Operating Systems diff --git a/src/treesit.c b/src/treesit.c index 45db71bb5fd..513d0d22c7f 100644 --- a/src/treesit.c +++ b/src/treesit.c @@ -392,16 +392,20 @@ init_treesit_functions (void) These are all imaginary scenarios but they are not impossible :-) - Parsers in indirect buffers: We make indirect buffers to share the - parser of its base buffer. Indirect buffers and their base buffer + Parsers in indirect buffers: We make indirect buffers share the + parser of their base buffer. Indirect buffers and their base buffer share the same buffer content but not other buffer attributes. If they have separate parser lists, changes made in an indirect buffer - will only update parsers of that indirect buffer, and not parsers - in the base buffer or other indirect buffers, and vice versa. We - could keep track of all the base and indirect buffers, and update - all of their parsers, but ultimately decide to take a simpler - approach, which is to make indirect buffers share their base - buffer's parser list. The discussion can be found in bug#59693. */ + will only update parsers of that indirect buffer, and not parsers in + the base buffer or other indirect buffers, and vice versa. For that + reason, the base buffer and all ot its indirect buffers share a + single parser list. But each parser in this shared parser list still + points to their own buffer. On top of that, treesit-parser-list only + return parsers that belongs to the calling buffer. So ultimately, + from the user's POV, each buffer, regardless of indirect or not, + appears to have their own parser list. A discussion can be found in + bug#59693. Note that that discussion led to an earlier design, which + is different from the current one. */ /*** Initialization */ @@ -1416,13 +1420,20 @@ an indirect buffer. */) CHECK_SYMBOL (language); CHECK_SYMBOL (tag); struct buffer *buf; + Lisp_Object buf_orig; + if (NILP (buffer)) - buf = current_buffer; + { + buf = current_buffer; + XSETBUFFER (buf_orig, current_buffer); + } else { CHECK_BUFFER (buffer); buf = XBUFFER (buffer); + buf_orig = buffer; } + if (buf->base_buffer) buf = buf->base_buffer; @@ -1457,9 +1468,7 @@ an indirect buffer. */) ts_parser_set_language (parser, lang); /* Create parser. */ - Lisp_Object lisp_buf; - XSETBUFFER (lisp_buf, buf); - Lisp_Object lisp_parser = make_treesit_parser (lisp_buf, + Lisp_Object lisp_parser = make_treesit_parser (buf_orig, parser, NULL, language, tag); @@ -1505,13 +1514,20 @@ tag. */) (Lisp_Object buffer, Lisp_Object language, Lisp_Object tag) { struct buffer *buf; + Lisp_Object buf_orig; + if (NILP (buffer)) - buf = current_buffer; + { + buf = current_buffer; + XSETBUFFER (buf_orig, current_buffer); + } else { CHECK_BUFFER (buffer); buf = XBUFFER (buffer); + buf_orig = buffer; } + if (buf->base_buffer) buf = buf->base_buffer; @@ -1526,7 +1542,10 @@ tag. */) { struct Lisp_TS_Parser *parser = XTS_PARSER (XCAR (tail)); if ((NILP (language) || EQ (language, parser->language_symbol)) - && (EQ (tag, Qt) || EQ (tag, parser->tag))) + && (EQ (tag, Qt) || EQ (tag, parser->tag)) + /* Indirect buffers and base buffer shares the same parser + * list, so we need the filtering here. */ + && (EQ (parser->buffer, buf_orig))) return_list = Fcons (XCAR (tail), return_list); } commit a2c439db687774f7b57959c39560993579c5d1bd Author: Richard M. Stallman Date: Tue Jul 30 17:42:52 2024 -0400 Define custom var rmail-summary-starting-message. * lisp/mail/rmailsum.el (rmail-summary-starting-message): New custom variable. (rmail-new-summary-1): Use it. diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el index d2dcedce93e..38fded9b4c3 100644 --- a/lisp/mail/rmailsum.el +++ b/lisp/mail/rmailsum.el @@ -84,6 +84,11 @@ Message A is parent of message B if the id of A appears in the \"References\" or \"In-reply-to\" fields of B, or if A is the first message with the same \"Subject\" as B. First element is ignored.") +(defcustom rmail-summary-starting-message 1 + "Message number to start summarizing at." + :type 'integer + :group 'rmail-summary) + (defvar rmail-summary-message-descendants-vector nil "Vector that holds the direct descendants of each message. This is the antipode of `rmail-summary-message-parents-vector'. @@ -700,7 +705,7 @@ message." (sumbuf (rmail-get-create-summary-buffer))) ;; Scan the messages, getting their summary strings ;; and putting the list of them in SUMMARY-MSGS. - (let ((msgnum 1) + (let ((msgnum rmail-summary-starting-message) (main-buffer (current-buffer)) (total rmail-total-messages) (inhibit-read-only t)) commit b6c18817a259ec10df5bd741a6eef6842199e95b Author: Mattias Engdegård Date: Tue Jul 30 22:34:39 2024 +0200 vhdl-mode: don't use timer accessors in XEmacs * lisp/progmodes/vhdl-mode.el (vhdl-run-when-idle): No need to activate a newly created idle timer; keep it as compatibility (or voodoo) code for XEmacs which probably doesn't have the timer accessors anyway. diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index 22706be6bb5..2c4b83bed23 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -2341,7 +2341,8 @@ Ignore byte-compiler warnings you might see." (if (fboundp 'start-itimer) (start-itimer "vhdl-mode" function secs repeat t) ;; explicitly activate timer (necessary when Emacs is already idle) - (setf (timer--triggered (run-with-idle-timer secs repeat function)) nil))) + (when (featurep 'xemacs) + (aset (run-with-idle-timer secs repeat function) 0 nil)))) (defun vhdl-warning-when-idle (&rest args) "Wait until idle, then print out warning STRING and beep." commit a8ac8650abb440119becad64cfd5ee534c6e413e Author: Harald Jörg Date: Tue Jul 30 13:55:19 2024 +0200 ; Add Harald Jörg as maintainer of cperl-mode * admin/MAINTAINERS: Add Harald Jörg as maintainer of cperl-mode diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS index b073529e94b..de74a2b9a20 100644 --- a/admin/MAINTAINERS +++ b/admin/MAINTAINERS @@ -376,6 +376,9 @@ Juri Linkov Philip Kaludercic lisp/epa-ks.el +Harald Jörg + lisp/progmodes/cperl-mode.el + ============================================================================== 3. Externally maintained packages. ============================================================================== commit 9f7c1ace9f86e4b657030a6e94c5d6aadc586878 Author: Gerd Möllmann Date: Thu Jul 25 09:20:04 2024 +0200 NS: Set frame position when entering/exiting fullscreen (bug#71912) * src/nsterm.h ([EmacsView adjustEmacsRectRect]): Declare. * src/nsterm.m ([EmacsView windowDidEnterFullScreen]): New method. ([EmacsView windowDidEnterFullScreen]): Call it. ([EmacsView windowDidExitFullScreen]): Call it. diff --git a/src/nsterm.h b/src/nsterm.h index 3a713f8e8c9..e3f55c4e41c 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -522,6 +522,7 @@ enum ns_return_frame_mode - (void)copyRect:(NSRect)srcRect to:(NSPoint)dest; /* Non-notification versions of NSView methods. Used for direct calls. */ +- (void)adjustEmacsFrameRect; - (void)windowWillEnterFullScreen; - (void)windowDidEnterFullScreen; - (void)windowWillExitFullScreen; diff --git a/src/nsterm.m b/src/nsterm.m index d25f216edd4..8a0c12c7369 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -8318,6 +8318,15 @@ - (void)windowDidEnterFullScreen:(NSNotification *)notification [self windowDidEnterFullScreen]; } +- (void)adjustEmacsFrameRect +{ + struct frame *f = emacsframe; + NSWindow *frame_window = [FRAME_NS_VIEW (f) window]; + NSRect r = [frame_window frame]; + f->left_pos = NSMinX (r) - NS_PARENT_WINDOW_LEFT_POS (f); + f->top_pos = NS_PARENT_WINDOW_TOP_POS (f) - NSMaxY (r); +} + - (void)windowDidEnterFullScreen /* provided for direct calls */ { NSTRACE ("[EmacsView windowDidEnterFullScreen]"); @@ -8347,6 +8356,10 @@ - (void)windowDidEnterFullScreen /* provided for direct calls */ } #endif } + + /* Do what windowDidMove does which isn't called when entering/exiting + fullscreen mode. */ + [self adjustEmacsFrameRect]; } - (void)windowWillExitFullScreen:(NSNotification *)notification @@ -8389,6 +8402,10 @@ - (void)windowDidExitFullScreen /* provided for direct calls */ if (next_maximized != -1) [[self window] performZoom:self]; + + /* Do what windowDidMove does which isn't called when entering/exiting + fullscreen mode. */ + [self adjustEmacsFrameRect]; } - (BOOL)fsIsNative commit 74fe889a93ffefbc1e734a4e7d48073237e3d491 Merge: e09982f8f5a abefd9514bc Author: Eli Zaretskii Date: Mon Jul 29 21:52:05 2024 +0300 Merge branch 'emacs-30' of git.savannah.gnu.org:/srv/git/emacs into emacs-30 commit abefd9514bcf9d8de9d9e7f000ef55fad0d822fb Author: Juri Linkov Date: Mon Jul 29 21:16:16 2024 +0300 * lisp/tab-bar.el (tab-bar-move-tab-to-group): Fix for a new group's tab. Move tab with a new group to the end of the tab bar (bug#72352) Suggested by Ship Mints diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index edec6543a82..60d5bbf169b 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -2229,14 +2229,16 @@ function `tab-bar-tab-name-function'." (seq-position (nthcdr beg tabs) group (lambda (tb gr) (not (equal (alist-get 'group tb) gr)))))) - (pos (when beg - (cond - ;; Don't move tab when it's already inside group bounds - ((and len (>= tab-index beg) (<= tab-index (+ beg len))) nil) - ;; Move tab from the right to the group end - ((and len (> tab-index (+ beg len))) (+ beg len 1)) - ;; Move tab from the left to the group beginning - ((< tab-index beg) beg))))) + (pos (if beg + (cond + ;; Don't move tab when it's already inside group bounds + ((and len (>= tab-index beg) (<= tab-index (+ beg len))) nil) + ;; Move tab from the right to the group end + ((and len (> tab-index (+ beg len))) (+ beg len 1)) + ;; Move tab from the left to the group beginning + ((< tab-index beg) beg)) + ;; Move tab with a new group to the end + -1))) (when pos (tab-bar-move-tab-to pos (1+ tab-index))))) commit e09982f8f5a8580005594ad9ba939667fd6189f4 Merge: b0d927e1dce 5cf64d8377a Author: Eli Zaretskii Date: Mon Jul 29 13:57:01 2024 +0300 Merge branch 'emacs-30' of git.savannah.gnu.org:/srv/git/emacs into emacs-30 commit b0d927e1dcef524a178d92f3380f605504ae2ca1 Merge: 158835668df 469bc7c9686 Author: Eli Zaretskii Date: Sun Jul 28 07:30:32 2024 +0300 Merge branch 'emacs-30' of git.savannah.gnu.org:/srv/git/emacs into emacs-30 commit 158835668dffcad0c5668dd01200f2737972bb3e Author: Eli Zaretskii Date: Sat Jul 27 15:56:47 2024 +0300 ; * doc/lispref/modes.texi (Mode Line Data): Fix formatting. diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi index 7c7823b5f9b..27b74a9d233 100644 --- a/doc/lispref/modes.texi +++ b/doc/lispref/modes.texi @@ -2259,7 +2259,7 @@ space filled on the right if its width is less than @var{width}. When @minus{}@var{width} columns if its width exceeds @minus{}@var{width}. For example, the usual way to show what percentage of a buffer is above -the top of the window is to use a list like this: @code{(-3 "%p")}. +the top of the window is to use a list like this: @w{@code{(-3 "%p")}}. @end table @node Mode Line Top