From cdadb7a97cbed523af9f52705d8b03e91d17313f Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 4 Jun 2020 09:58:22 -0400 Subject: [PATCH 01/12] * lisp/font-lock.el (font-lock--syntax-table-affects-ppss): New var This tries to make `font-lock-syntax-table` work correctly even when it changes the parsing of strings and comments, as was the case in `font-latex.el`. We should probably deprecate the use of `font-lock-syntax-table` since the present fix is still not 100% and since it comes with performance problems in large files. (font-lock-set-defaults): Set it. (font-lock-fontify-syntactically-region): Don't use `syntax-ppss` when we think that `font-lock-syntax-table` would interfere. --- lisp/font-lock.el | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/lisp/font-lock.el b/lisp/font-lock.el index e0955b74abc..5cda4a693db 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -575,6 +575,7 @@ This is normally set via `font-lock-defaults'.") "Non-nil means use this syntax table for fontifying. If this is nil, the major mode's syntax table is used. This is normally set via `font-lock-defaults'.") +(defvar-local font-lock--syntax-table-affects-ppss nil) (defvar font-lock-mark-block-function nil "Non-nil means use this function to mark a block of text. @@ -1610,7 +1611,15 @@ START should be at the beginning of a line." (regexp-quote (replace-regexp-in-string "^ *" "" comment-end)))) ;; Find the `start' state. - (state (syntax-ppss start)) + (state (if (or syntax-ppss-table + (not font-lock--syntax-table-affects-ppss)) + (syntax-ppss start) + ;; If `syntax-ppss' doesn't have its own syntax-table and + ;; we have installed our own syntax-table which + ;; differs from the standard one in ways which affects PPSS, + ;; then we can't use `syntax-ppss' since that would pollute + ;; and be polluted by its cache. + (parse-partial-sexp (point-min) start))) face beg) (if loudly (message "Fontifying %s... (syntactically...)" (buffer-name))) ;; @@ -1907,6 +1916,7 @@ Sets various variables using `font-lock-defaults' and ;; Case fold during regexp fontification? (setq-local font-lock-keywords-case-fold-search (nth 2 defaults)) ;; Syntax table for regexp and syntactic fontification? + (kill-local-variable 'font-lock--syntax-table-affects-ppss) (if (null (nth 3 defaults)) (setq-local font-lock-syntax-table nil) (setq-local font-lock-syntax-table (copy-syntax-table (syntax-table))) @@ -1916,7 +1926,14 @@ Sets various variables using `font-lock-defaults' and (dolist (char (if (numberp (car selem)) (list (car selem)) (mapcar #'identity (car selem)))) - (modify-syntax-entry char syntax font-lock-syntax-table))))) + (unless (memq (car (aref font-lock-syntax-table char)) + '(1 2 3)) ;"." "w" "_" + (setq font-lock--syntax-table-affects-ppss t)) + (modify-syntax-entry char syntax font-lock-syntax-table) + (unless (memq (car (aref font-lock-syntax-table char)) + '(1 2 3)) ;"." "w" "_" + (setq font-lock--syntax-table-affects-ppss t)) + )))) ;; (nth 4 defaults) used to hold `font-lock-beginning-of-syntax-function', ;; but that was removed in 25.1, so if it's a cons cell, we assume that ;; it's part of the variable alist. From b41be0ee83bdcc7882b360b66105f192503f0dc7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Simen=20Heggest=C3=B8yl?= Date: Thu, 4 Jun 2020 19:29:10 +0200 Subject: [PATCH 02/12] ; Small cleanup in project.el * lisp/progmodes/project.el (project--add-to-project-list-front): Minor simplification after recent changes. --- lisp/progmodes/project.el | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index c701b801599..c5b6209d9b4 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -787,9 +787,8 @@ Arguments the same as in `compile'." "Add project PR to the front of the project list. Save the result to disk if the project list was changed." (project--ensure-read-project-list) - (let* ((dir (project-root pr)) - (do-write (not (equal (car project--list) dir)))) - (when do-write + (let ((dir (project-root pr))) + (unless (equal (car project--list) dir) (setq project--list (delete dir project--list)) (push dir project--list) (project--write-project-list)))) From e7fb0a48a65c986e75d39848cac3c4d2435f4baa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Simen=20Heggest=C3=B8yl?= Date: Thu, 4 Jun 2020 19:56:32 +0200 Subject: [PATCH 03/12] Use characters for keys in project-switch-commands * lisp/progmodes/project.el (project-switch-commands): Use characters for keys instead of string for better future compatibility with 'read-multiple-choice'. (project-switch-project): Adjust to above change. --- lisp/progmodes/project.el | 28 ++++++++++++---------------- 1 file changed, 12 insertions(+), 16 deletions(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index c5b6209d9b4..ad0bb6763ac 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -824,12 +824,12 @@ It's also possible to enter an arbitrary directory." ;;;###autoload (defvar project-switch-commands - '(("f" "Find file" project-find-file) - ("r" "Find regexp" project-find-regexp) - ("d" "Dired" project-dired) - ("v" "VC-Dir" project-vc-dir) - ("s" "Shell" project-shell) - ("e" "Eshell" project-eshell)) + '((?f "Find file" project-find-file) + (?r "Find regexp" project-find-regexp) + (?d "Dired" project-dired) + (?v "VC-Dir" project-vc-dir) + (?s "Shell" project-shell) + (?e "Eshell" project-eshell)) "Alist mapping keys to project switching menu entries. Used by `project-switch-project' to construct a dispatch menu of commands available upon \"switching\" to another project. @@ -856,16 +856,12 @@ and presented in a dispatch menu." (interactive) (let ((dir (project-prompt-project-dir)) (choice nil)) - (while (not (and choice - (or (equal choice (kbd "C-g")) - (assoc choice project-switch-commands)))) - (setq choice (read-key-sequence (project--keymap-prompt)))) - (if (equal choice (kbd "C-g")) - (message "Quit") - (let ((default-directory dir) - (project-current-inhibit-prompt t)) - (call-interactively - (nth 2 (assoc choice project-switch-commands))))))) + (while (not choice) + (setq choice (assq (read-event (project--keymap-prompt)) + project-switch-commands))) + (let ((default-directory dir) + (project-current-inhibit-prompt t)) + (call-interactively (nth 2 choice))))) (provide 'project) ;;; project.el ends here From f4568bac56968c2d7837d6f5be561f3cf4430388 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Simen=20Heggest=C3=B8yl?= Date: Thu, 4 Jun 2020 19:58:36 +0200 Subject: [PATCH 04/12] Change default project list filename to "projects" * lisp/progmodes/project.el (project-list-file): Change the default filename to "projects". --- lisp/progmodes/project.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index ad0bb6763ac..4d57fb25fda 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -747,7 +747,7 @@ Arguments the same as in `compile'." ;;; Project list -(defcustom project-list-file (locate-user-emacs-file "project-list") +(defcustom project-list-file (locate-user-emacs-file "projects") "File to save the list of known projects." :type 'file :version "28.1" From 25390b28c43401caee749554871217d3436ea9bd Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Fri, 5 Jun 2020 01:17:30 +0300 Subject: [PATCH 05/12] * lisp/dired.el (dired-toggle-marks): Use region for non-nil dired-mark-region (dired-mark--region-use-p, dired-mark--region-beginning) (dired-mark--region-end): New internal functions. (dired-mark-if): Use new functions. (Bug#39902) --- lisp/dired.el | 62 +++++++++++++++++++++++++++++++++------------------ 1 file changed, 40 insertions(+), 22 deletions(-) diff --git a/lisp/dired.el b/lisp/dired.el index aad44a6d698..1792250ac90 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -648,24 +648,10 @@ of the region if `dired-mark-region' is non-nil. Otherwise, operate on the whole buffer. Return value is the number of files marked, or nil if none were marked." - `(let* ((inhibit-read-only t) count - (use-region-p (and dired-mark-region - (region-active-p) - (> (region-end) (region-beginning)))) - (beg (if use-region-p - (save-excursion - (goto-char (region-beginning)) - (line-beginning-position)) - (point-min))) - (end (if use-region-p - (save-excursion - (goto-char (region-end)) - (if (if (eq dired-mark-region 'line) - (not (bolp)) - (get-text-property (1- (point)) 'dired-filename)) - (line-end-position) - (line-beginning-position))) - (point-max)))) + `(let ((inhibit-read-only t) count + (use-region-p (dired-mark--region-use-p)) + (beg (dired-mark--region-beginning)) + (end (dired-mark--region-end))) (save-excursion (setq count 0) (when ,msg @@ -817,6 +803,32 @@ ERROR can be a string with the error message." (user-error (if (stringp error) error "No files specified"))) result)) +(defun dired-mark--region-use-p () + "Whether Dired marking commands should act on region." + (and dired-mark-region + (region-active-p) + (> (region-end) (region-beginning)))) + +(defun dired-mark--region-beginning () + "Return the value of the region beginning aligned to Dired file lines." + (if (dired-mark--region-use-p) + (save-excursion + (goto-char (region-beginning)) + (line-beginning-position)) + (point-min))) + +(defun dired-mark--region-end () + "Return the value of the region end aligned to Dired file lines." + (if (dired-mark--region-use-p) + (save-excursion + (goto-char (region-end)) + (if (if (eq dired-mark-region 'line) + (not (bolp)) + (get-text-property (1- (point)) 'dired-filename)) + (line-end-position) + (line-beginning-position))) + (point-max))) + ;; The dired command @@ -3719,12 +3731,18 @@ in the active region." "Toggle marks: marked files become unmarked, and vice versa. Flagged files (indicated with flags such as `C' and `D', not with `*') are not affected, and `.' and `..' are never toggled. -As always, hidden subdirs are not affected." +As always, hidden subdirs are not affected. + +In Transient Mark mode, if the mark is active, operate on the contents +of the region if `dired-mark-region' is non-nil. Otherwise, operate +on the whole buffer." (interactive) (save-excursion - (goto-char (point-min)) - (let ((inhibit-read-only t)) - (while (not (eobp)) + (let ((inhibit-read-only t) + (beg (dired-mark--region-beginning)) + (end (dired-mark--region-end))) + (goto-char beg) + (while (< (point) end) (or (dired-between-files) (looking-at-p dired-re-dot) ;; use subst instead of insdel because it does not move From f51f9634788323b3bf2dde59d0d20a8ca8fbfeaf Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Thu, 4 Jun 2020 23:08:28 +0100 Subject: [PATCH 06/12] Fix some side-effecting uses of make-text-button For discussion, see the following thread: https://lists.gnu.org/archive/html/emacs-devel/2020-06/msg00117.html * lisp/apropos.el (apropos-library-button): * lisp/help-fns.el (help-fns--first-release): Return result of make-text-button instead of relying on its side effects. * lisp/ibuf-ext.el (ibuffer-old-saved-filters-warning): Avoid modifying an immutable string. --- lisp/apropos.el | 3 +-- lisp/help-fns.el | 3 +-- lisp/ibuf-ext.el | 2 +- 3 files changed, 3 insertions(+), 5 deletions(-) diff --git a/lisp/apropos.el b/lisp/apropos.el index 7cbda3cb678..22866cd2cc8 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -665,8 +665,7 @@ Return list of symbols and documentation found." (make-text-button name nil 'type 'apropos-library 'face 'apropos-symbol - 'apropos-symbol name) - name))) + 'apropos-symbol name)))) ;;;###autoload (defun apropos-library (file) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 63b066f3b85..b9536470631 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -647,8 +647,7 @@ FILE is the file where FUNCTION was probably defined." (setq place (list f pos)) (setq first version))))))))) (when first - (make-text-button first nil 'type 'help-news 'help-args place)) - first)) + (make-text-button first nil 'type 'help-news 'help-args place)))) (add-hook 'help-fns-describe-function-functions #'help-fns--mention-first-release) diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index bfb9787a96d..c39000b4886 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -202,7 +202,7 @@ The format has been repaired and the variable modified accordingly. You can save the current value through the customize system by either clicking or hitting return " (make-text-button - "here" nil + (copy-sequence "here") nil 'face '(:weight bold :inherit button) 'mouse-face '(:weight normal :background "gray50" :inherit button) 'follow-link t From 4dcf8f2205fcfb45b460a2256569e64a03f93b4a Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Thu, 4 Jun 2020 18:46:10 -0700 Subject: [PATCH 07/12] Make live_*_p more accurate * src/alloc.c (live_string_holding, live_cons_holding) (live_symbol_holding, live_vector_holding): Return a C pointer, not a Lisp_Object. All callers changed. This helps the compiler a bit. (live_string_p, live_cons_p, live_symbol_p, live_vector_p): Require that P point directly at the object, rather than somewhere within the object. This fixes some false positives with valid_lisp_object_p (used only in debugging). (mark_maybe_object): Rely on the new accuracy. --- src/alloc.c | 100 +++++++++++++++++++++++++++++++--------------------- 1 file changed, 60 insertions(+), 40 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index f44f22be1a7..5cb754d237b 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -4438,7 +4438,7 @@ mem_delete_fixup (struct mem_node *x) /* If P is a pointer into a live Lisp string object on the heap, - return the object. Otherwise, return nil. M is a pointer to the + return the object's address. Otherwise, return NULL. M points to the mem_block for P. This and other *_holding functions look for a pointer anywhere into @@ -4446,7 +4446,7 @@ mem_delete_fixup (struct mem_node *x) because some compilers sometimes optimize away the latter. See Bug#28213. */ -static Lisp_Object +static struct Lisp_String * live_string_holding (struct mem_node *m, void *p) { if (m->type == MEM_TYPE_STRING) @@ -4462,23 +4462,23 @@ live_string_holding (struct mem_node *m, void *p) cp = ptr_bounds_copy (cp, b); struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0]; if (s->u.s.data) - return make_lisp_ptr (s, Lisp_String); + return s; } } - return Qnil; + return NULL; } static bool live_string_p (struct mem_node *m, void *p) { - return !NILP (live_string_holding (m, p)); + return live_string_holding (m, p) == p; } /* If P is a pointer into a live Lisp cons object on the heap, return - the object. Otherwise, return nil. M is a pointer to the + the object's address. Otherwise, return NULL. M points to the mem_block for P. */ -static Lisp_Object +static struct Lisp_Cons * live_cons_holding (struct mem_node *m, void *p) { if (m->type == MEM_TYPE_CONS) @@ -4497,24 +4497,24 @@ live_cons_holding (struct mem_node *m, void *p) cp = ptr_bounds_copy (cp, b); struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0]; if (!deadp (s->u.s.car)) - return make_lisp_ptr (s, Lisp_Cons); + return s; } } - return Qnil; + return NULL; } static bool live_cons_p (struct mem_node *m, void *p) { - return !NILP (live_cons_holding (m, p)); + return live_cons_holding (m, p) == p; } /* If P is a pointer into a live Lisp symbol object on the heap, - return the object. Otherwise, return nil. M is a pointer to the + return the object's address. Otherwise, return NULL. M points to the mem_block for P. */ -static Lisp_Object +static struct Lisp_Symbol * live_symbol_holding (struct mem_node *m, void *p) { if (m->type == MEM_TYPE_SYMBOL) @@ -4533,16 +4533,16 @@ live_symbol_holding (struct mem_node *m, void *p) cp = ptr_bounds_copy (cp, b); struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0]; if (!deadp (s->u.s.function)) - return make_lisp_symbol (s); + return s; } } - return Qnil; + return NULL; } static bool live_symbol_p (struct mem_node *m, void *p) { - return !NILP (live_symbol_holding (m, p)); + return live_symbol_holding (m, p) == p; } @@ -4573,7 +4573,7 @@ live_float_p (struct mem_node *m, void *p) Otherwise, return nil. M is a pointer to the mem_block for P. */ -static Lisp_Object +static struct Lisp_Vector * live_vector_holding (struct mem_node *m, void *p) { struct Lisp_Vector *vp = p; @@ -4593,7 +4593,7 @@ live_vector_holding (struct mem_node *m, void *p) { struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE)) - return make_lisp_ptr (vector, Lisp_Vectorlike); + return vector; vector = next; } } @@ -4603,15 +4603,15 @@ live_vector_holding (struct mem_node *m, void *p) struct Lisp_Vector *vector = large_vector_vec (m->start); struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); if (vector <= vp && vp < next) - return make_lisp_ptr (vector, Lisp_Vectorlike); + return vector; } - return Qnil; + return NULL; } static bool live_vector_p (struct mem_node *m, void *p) { - return !NILP (live_vector_holding (m, p)); + return live_vector_holding (m, p) == p; } /* Mark OBJ if we can prove it's a Lisp_Object. */ @@ -4652,15 +4652,15 @@ mark_maybe_object (Lisp_Object obj) switch (XTYPE (obj)) { case Lisp_String: - mark_p = EQ (obj, live_string_holding (m, po)); + mark_p = live_string_p (m, po); break; case Lisp_Cons: - mark_p = EQ (obj, live_cons_holding (m, po)); + mark_p = live_cons_p (m, po); break; case Lisp_Symbol: - mark_p = EQ (obj, live_symbol_holding (m, po)); + mark_p = live_symbol_p (m, po); break; case Lisp_Float: @@ -4668,7 +4668,7 @@ mark_maybe_object (Lisp_Object obj) break; case Lisp_Vectorlike: - mark_p = (EQ (obj, live_vector_holding (m, po))); + mark_p = live_vector_p (m, po); break; default: @@ -4713,43 +4713,63 @@ mark_maybe_pointer (void *p) m = mem_find (p); if (m != MEM_NIL) { - Lisp_Object obj = Qnil; + Lisp_Object obj; switch (m->type) { case MEM_TYPE_NON_LISP: case MEM_TYPE_SPARE: /* Nothing to do; not a pointer to Lisp memory. */ - break; + return; case MEM_TYPE_CONS: - obj = live_cons_holding (m, p); + { + struct Lisp_Cons *h = live_cons_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_Cons); + } break; case MEM_TYPE_STRING: - obj = live_string_holding (m, p); + { + struct Lisp_String *h = live_string_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_String); + } break; case MEM_TYPE_SYMBOL: - obj = live_symbol_holding (m, p); + { + struct Lisp_Symbol *h = live_symbol_holding (m, p); + if (!h) + return; + obj = make_lisp_symbol (h); + } break; case MEM_TYPE_FLOAT: - if (live_float_p (m, p)) - obj = make_lisp_ptr (p, Lisp_Float); + if (! live_float_p (m, p)) + return; + obj = make_lisp_ptr (p, Lisp_Float); break; case MEM_TYPE_VECTORLIKE: case MEM_TYPE_VECTOR_BLOCK: - obj = live_vector_holding (m, p); + { + struct Lisp_Vector *h = live_vector_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_Vectorlike); + } break; default: emacs_abort (); } - if (!NILP (obj)) - mark_object (obj); + mark_object (obj); } } @@ -5679,7 +5699,7 @@ compact_font_cache_entry (Lisp_Object entry) struct font *font = GC_XFONT_OBJECT (val); if (!NILP (AREF (val, FONT_TYPE_INDEX)) - && vectorlike_marked_p(&font->header)) + && vectorlike_marked_p (&font->header)) break; } if (CONSP (objlist)) @@ -6518,7 +6538,7 @@ mark_object (Lisp_Object arg) structure allocated from the heap. */ #define CHECK_ALLOCATED() \ do { \ - if (pdumper_object_p(po)) \ + if (pdumper_object_p (po)) \ { \ if (!pdumper_object_p_precise (po)) \ emacs_abort (); \ @@ -6533,7 +6553,7 @@ mark_object (Lisp_Object arg) function LIVEP. */ #define CHECK_LIVE(LIVEP) \ do { \ - if (pdumper_object_p(po)) \ + if (pdumper_object_p (po)) \ break; \ if (!LIVEP (m, po)) \ emacs_abort (); \ @@ -6590,7 +6610,7 @@ mark_object (Lisp_Object arg) break; #ifdef GC_CHECK_MARKED_OBJECTS - if (!pdumper_object_p(po)) + if (!pdumper_object_p (po)) { m = mem_find (po); if (m == MEM_NIL && !SUBRP (obj) && !main_thread_p (po)) @@ -6642,7 +6662,7 @@ mark_object (Lisp_Object arg) /* bool vectors in a dump are permanently "marked", since they're in the old section and don't have mark bits. If we're looking at a dumped bool vector, we should - have aborted above when we called vector_marked_p(), so + have aborted above when we called vector_marked_p, so we should never get here. */ eassert (!pdumper_object_p (ptr)); set_vector_marked (ptr); @@ -6673,7 +6693,7 @@ mark_object (Lisp_Object arg) if (symbol_marked_p (ptr)) break; CHECK_ALLOCATED_AND_LIVE_SYMBOL (); - set_symbol_marked(ptr); + set_symbol_marked (ptr); /* Attempt to catch bogus objects. */ eassert (valid_lisp_object_p (ptr->u.s.function)); mark_object (ptr->u.s.function); From 8ee367fe864d131a9d7f87677b9418ac78c922fa Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Thu, 4 Jun 2020 18:46:11 -0700 Subject: [PATCH 08/12] Streamline live_*_holding (live_string_holding, live_cons_holding, live_symbol_holding) (live_float_p, live_vector_holding): Assert that m->type is correct, instead of testing this at runtime. All callers changed. (live_large_vector_holding, live_small_vector_holding): Now two functions instead of the old live_vector_holding. All callers changed. (live_large_vector_p, live_small_vector_p): Now two functions instead of the old live_vector_p. All callers changed. (mark_maybe_object): Ignore Lisp_Type_Unused0 quickly too, since that cannot possibly be an object. (CHECK_LIVE, CHECK_ALLOCATED_AND_LIVE): New arg MEM_TYPE. All callers changed. (CHECK_ALLOCATED_AND_LIVE_SYMBOL): Simplify by combining GC_CHECK_MARKED_OBJECTS code. --- src/alloc.c | 272 ++++++++++++++++++++++++++++------------------------ 1 file changed, 148 insertions(+), 124 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index 5cb754d237b..ed30c449785 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -4449,21 +4449,19 @@ mem_delete_fixup (struct mem_node *x) static struct Lisp_String * live_string_holding (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_STRING) - { - struct string_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->strings[0]; + eassert (m->type == MEM_TYPE_STRING); + struct string_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->strings[0]; - /* P must point into a Lisp_String structure, and it - must not be on the free-list. */ - if (0 <= offset && offset < sizeof b->strings) - { - cp = ptr_bounds_copy (cp, b); - struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0]; - if (s->u.s.data) - return s; - } + /* P must point into a Lisp_String structure, and it + must not be on the free-list. */ + if (0 <= offset && offset < sizeof b->strings) + { + cp = ptr_bounds_copy (cp, b); + struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0]; + if (s->u.s.data) + return s; } return NULL; } @@ -4481,24 +4479,22 @@ live_string_p (struct mem_node *m, void *p) static struct Lisp_Cons * live_cons_holding (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_CONS) - { - struct cons_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->conses[0]; + eassert (m->type == MEM_TYPE_CONS); + struct cons_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->conses[0]; - /* P must point into a Lisp_Cons, not be - one of the unused cells in the current cons block, - and not be on the free-list. */ - if (0 <= offset && offset < sizeof b->conses - && (b != cons_block - || offset / sizeof b->conses[0] < cons_block_index)) - { - cp = ptr_bounds_copy (cp, b); - struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0]; - if (!deadp (s->u.s.car)) - return s; - } + /* P must point into a Lisp_Cons, not be + one of the unused cells in the current cons block, + and not be on the free-list. */ + if (0 <= offset && offset < sizeof b->conses + && (b != cons_block + || offset / sizeof b->conses[0] < cons_block_index)) + { + cp = ptr_bounds_copy (cp, b); + struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0]; + if (!deadp (s->u.s.car)) + return s; } return NULL; } @@ -4517,24 +4513,22 @@ live_cons_p (struct mem_node *m, void *p) static struct Lisp_Symbol * live_symbol_holding (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_SYMBOL) - { - struct symbol_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->symbols[0]; + eassert (m->type == MEM_TYPE_SYMBOL); + struct symbol_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->symbols[0]; - /* P must point into the Lisp_Symbol, not be - one of the unused cells in the current symbol block, - and not be on the free-list. */ - if (0 <= offset && offset < sizeof b->symbols - && (b != symbol_block - || offset / sizeof b->symbols[0] < symbol_block_index)) - { - cp = ptr_bounds_copy (cp, b); - struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0]; - if (!deadp (s->u.s.function)) - return s; - } + /* P must point into the Lisp_Symbol, not be + one of the unused cells in the current symbol block, + and not be on the free-list. */ + if (0 <= offset && offset < sizeof b->symbols + && (b != symbol_block + || offset / sizeof b->symbols[0] < symbol_block_index)) + { + cp = ptr_bounds_copy (cp, b); + struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0]; + if (!deadp (s->u.s.function)) + return s; } return NULL; } @@ -4552,66 +4546,70 @@ live_symbol_p (struct mem_node *m, void *p) static bool live_float_p (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_FLOAT) - { - struct float_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->floats[0]; + eassert (m->type == MEM_TYPE_FLOAT); + struct float_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->floats[0]; - /* P must point to the start of a Lisp_Float and not be - one of the unused cells in the current float block. */ - return (0 <= offset && offset < sizeof b->floats - && offset % sizeof b->floats[0] == 0 - && (b != float_block - || offset / sizeof b->floats[0] < float_block_index)); - } - else - return 0; + /* P must point to the start of a Lisp_Float and not be + one of the unused cells in the current float block. */ + return (0 <= offset && offset < sizeof b->floats + && offset % sizeof b->floats[0] == 0 + && (b != float_block + || offset / sizeof b->floats[0] < float_block_index)); } -/* If P is a pointer to a live vector-like object, return the object. +/* If P is a pointer to a live, large vector-like object, return the object. Otherwise, return nil. M is a pointer to the mem_block for P. */ static struct Lisp_Vector * -live_vector_holding (struct mem_node *m, void *p) +live_large_vector_holding (struct mem_node *m, void *p) { + eassert (m->type == MEM_TYPE_VECTORLIKE); struct Lisp_Vector *vp = p; + struct Lisp_Vector *vector = large_vector_vec (m->start); + struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); + return vector <= vp && vp < next ? vector : NULL; +} - if (m->type == MEM_TYPE_VECTOR_BLOCK) - { - /* This memory node corresponds to a vector block. */ - struct vector_block *block = m->start; - struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data; +static bool +live_large_vector_p (struct mem_node *m, void *p) +{ + return live_large_vector_holding (m, p) == p; +} - /* P is in the block's allocation range. Scan the block - up to P and see whether P points to the start of some - vector which is not on a free list. FIXME: check whether - some allocation patterns (probably a lot of short vectors) - may cause a substantial overhead of this loop. */ - while (VECTOR_IN_BLOCK (vector, block) && vector <= vp) - { - struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); - if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE)) - return vector; - vector = next; - } - } - else if (m->type == MEM_TYPE_VECTORLIKE) +/* If P is a pointer to a live, small vector-like object, return the object. + Otherwise, return NULL. + M is a pointer to the mem_block for P. */ + +static struct Lisp_Vector * +live_small_vector_holding (struct mem_node *m, void *p) +{ + eassert (m->type == MEM_TYPE_VECTOR_BLOCK); + struct Lisp_Vector *vp = p; + struct vector_block *block = m->start; + struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data; + + /* P is in the block's allocation range. Scan the block + up to P and see whether P points to the start of some + vector which is not on a free list. FIXME: check whether + some allocation patterns (probably a lot of short vectors) + may cause a substantial overhead of this loop. */ + while (VECTOR_IN_BLOCK (vector, block) && vector <= vp) { - /* This memory node corresponds to a large vector. */ - struct Lisp_Vector *vector = large_vector_vec (m->start); struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); - if (vector <= vp && vp < next) + if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE)) return vector; + vector = next; } return NULL; } static bool -live_vector_p (struct mem_node *m, void *p) +live_small_vector_p (struct mem_node *m, void *p) { - return live_vector_holding (m, p) == p; + return live_small_vector_holding (m, p) == p; } /* Mark OBJ if we can prove it's a Lisp_Object. */ @@ -4623,10 +4621,24 @@ mark_maybe_object (Lisp_Object obj) VALGRIND_MAKE_MEM_DEFINED (&obj, sizeof (obj)); #endif - if (FIXNUMP (obj)) - return; + int type_tag = XTYPE (obj); + intptr_t offset; - void *po = XPNTR (obj); + switch (type_tag) + { + case_Lisp_Int: case Lisp_Type_Unused0: + return; + + case Lisp_Symbol: + offset = (intptr_t) lispsym; + break; + + default: + offset = 0; + break; + } + + void *po = (char *) XLP (obj) + (offset - LISP_WORD_TAG (type_tag)); /* If the pointer is in the dump image and the dump has a record of the object starting at the place where the pointer points, we @@ -4638,7 +4650,7 @@ mark_maybe_object (Lisp_Object obj) /* Don't use pdumper_object_p_precise here! It doesn't check the tag bits. OBJ here might be complete garbage, so we need to verify both the pointer and the tag. */ - if (XTYPE (obj) == pdumper_find_object_type (po)) + if (pdumper_find_object_type (po) == type_tag) mark_object (obj); return; } @@ -4649,30 +4661,33 @@ mark_maybe_object (Lisp_Object obj) { bool mark_p = false; - switch (XTYPE (obj)) + switch (type_tag) { case Lisp_String: - mark_p = live_string_p (m, po); + mark_p = m->type == MEM_TYPE_STRING && live_string_p (m, po); break; case Lisp_Cons: - mark_p = live_cons_p (m, po); + mark_p = m->type == MEM_TYPE_CONS && live_cons_p (m, po); break; case Lisp_Symbol: - mark_p = live_symbol_p (m, po); + mark_p = m->type == MEM_TYPE_SYMBOL && live_symbol_p (m, po); break; case Lisp_Float: - mark_p = live_float_p (m, po); + mark_p = m->type == MEM_TYPE_FLOAT && live_float_p (m, po); break; case Lisp_Vectorlike: - mark_p = live_vector_p (m, po); + mark_p = (m->type == MEM_TYPE_VECTOR_BLOCK + ? live_small_vector_p (m, po) + : (m->type == MEM_TYPE_VECTORLIKE + && live_large_vector_p (m, po))); break; default: - break; + eassume (false); } if (mark_p) @@ -4756,9 +4771,17 @@ mark_maybe_pointer (void *p) break; case MEM_TYPE_VECTORLIKE: + { + struct Lisp_Vector *h = live_large_vector_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_Vectorlike); + } + break; + case MEM_TYPE_VECTOR_BLOCK: { - struct Lisp_Vector *h = live_vector_holding (m, p); + struct Lisp_Vector *h = live_small_vector_holding (m, p); if (!h) return; obj = make_lisp_ptr (h, Lisp_Vectorlike); @@ -5176,8 +5199,10 @@ valid_lisp_object_p (Lisp_Object obj) return live_float_p (m, p); case MEM_TYPE_VECTORLIKE: + return live_large_vector_p (m, p); + case MEM_TYPE_VECTOR_BLOCK: - return live_vector_p (m, p); + return live_small_vector_p (m, p); default: break; @@ -6551,19 +6576,19 @@ mark_object (Lisp_Object arg) /* Check that the object pointed to by PO is live, using predicate function LIVEP. */ -#define CHECK_LIVE(LIVEP) \ +#define CHECK_LIVE(LIVEP, MEM_TYPE) \ do { \ if (pdumper_object_p (po)) \ break; \ - if (!LIVEP (m, po)) \ + if (! (m->type == MEM_TYPE && LIVEP (m, po))) \ emacs_abort (); \ } while (0) /* Check both of the above conditions, for non-symbols. */ -#define CHECK_ALLOCATED_AND_LIVE(LIVEP) \ +#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) \ do { \ CHECK_ALLOCATED (); \ - CHECK_LIVE (LIVEP); \ + CHECK_LIVE (LIVEP, MEM_TYPE); \ } while (false) /* Check both of the above conditions, for symbols. */ @@ -6572,15 +6597,14 @@ mark_object (Lisp_Object arg) if (!c_symbol_p (ptr)) \ { \ CHECK_ALLOCATED (); \ - CHECK_LIVE (live_symbol_p); \ + CHECK_LIVE (live_symbol_p, MEM_TYPE_SYMBOL); \ } \ } while (false) #else /* not GC_CHECK_MARKED_OBJECTS */ -#define CHECK_LIVE(LIVEP) ((void) 0) -#define CHECK_ALLOCATED_AND_LIVE(LIVEP) ((void) 0) -#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0) +#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) ((void) 0) +#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0) #endif /* not GC_CHECK_MARKED_OBJECTS */ @@ -6591,7 +6615,7 @@ mark_object (Lisp_Object arg) register struct Lisp_String *ptr = XSTRING (obj); if (string_marked_p (ptr)) break; - CHECK_ALLOCATED_AND_LIVE (live_string_p); + CHECK_ALLOCATED_AND_LIVE (live_string_p, MEM_TYPE_STRING); set_string_marked (ptr); mark_interval_tree (ptr->u.s.intervals); #ifdef GC_CHECK_STRING_BYTES @@ -6609,21 +6633,21 @@ mark_object (Lisp_Object arg) if (vector_marked_p (ptr)) break; -#ifdef GC_CHECK_MARKED_OBJECTS - if (!pdumper_object_p (po)) - { - m = mem_find (po); - if (m == MEM_NIL && !SUBRP (obj) && !main_thread_p (po)) - emacs_abort (); - } -#endif /* GC_CHECK_MARKED_OBJECTS */ - enum pvec_type pvectype = PSEUDOVECTOR_TYPE (ptr); - if (pvectype != PVEC_SUBR && - !main_thread_p (po)) - CHECK_LIVE (live_vector_p); +#ifdef GC_CHECK_MARKED_OBJECTS + if (!pdumper_object_p (po) && !SUBRP (obj) && !main_thread_p (po)) + { + m = mem_find (po); + if (m == MEM_NIL) + emacs_abort (); + if (m->type == MEM_TYPE_VECTORLIKE) + CHECK_LIVE (live_large_vector_p, MEM_TYPE_VECTORLIKE); + else + CHECK_LIVE (live_small_vector_p, MEM_TYPE_VECTOR_BLOCK); + } +#endif switch (pvectype) { @@ -6734,7 +6758,7 @@ mark_object (Lisp_Object arg) struct Lisp_Cons *ptr = XCONS (obj); if (cons_marked_p (ptr)) break; - CHECK_ALLOCATED_AND_LIVE (live_cons_p); + CHECK_ALLOCATED_AND_LIVE (live_cons_p, MEM_TYPE_CONS); set_cons_marked (ptr); /* If the cdr is nil, avoid recursion for the car. */ if (NILP (ptr->u.s.u.cdr)) @@ -6752,7 +6776,7 @@ mark_object (Lisp_Object arg) } case Lisp_Float: - CHECK_ALLOCATED_AND_LIVE (live_float_p); + CHECK_ALLOCATED_AND_LIVE (live_float_p, MEM_TYPE_FLOAT); /* Do not mark floats stored in a dump image: these floats are "cold" and do not have mark bits. */ if (pdumper_object_p (XFLOAT (obj))) From a984f39554cb33b9c2efbc843aabb283c69d503d Mon Sep 17 00:00:00 2001 From: Pip Cet Date: Thu, 4 Jun 2020 22:28:53 +0000 Subject: [PATCH 09/12] Avoid zero-width glyphs and the resulting cursor artifacts * src/xdisp.c (fill_gstring_glyph_string): Handle unavailable glyphs. (append_composite_glyph): Mark unavailable glyphs. (gui_produce_glyphs): Make glyphs unavailable for zero-width compositions. (Bug#41645) --- src/xdisp.c | 33 ++++++++++++++++++++++++++------- 1 file changed, 26 insertions(+), 7 deletions(-) diff --git a/src/xdisp.c b/src/xdisp.c index 327e8a183b1..52f6ab8e709 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -27689,10 +27689,12 @@ fill_gstring_glyph_string (struct glyph_string *s, int face_id, struct glyph *glyph, *last; Lisp_Object lgstring; int i; + bool glyph_not_available_p; s->for_overlaps = overlaps; glyph = s->row->glyphs[s->area] + start; last = s->row->glyphs[s->area] + end; + glyph_not_available_p = glyph->glyph_not_available_p; s->cmp_id = glyph->u.cmp.id; s->cmp_from = glyph->slice.cmp.from; s->cmp_to = glyph->slice.cmp.to + 1; @@ -27707,7 +27709,8 @@ fill_gstring_glyph_string (struct glyph_string *s, int face_id, && glyph->u.cmp.automatic && glyph->u.cmp.id == s->cmp_id && glyph->face_id == face_id - && s->cmp_to == glyph->slice.cmp.from) + && s->cmp_to == glyph->slice.cmp.from + && glyph->glyph_not_available_p == glyph_not_available_p) { s->width += glyph->pixel_width; s->cmp_to = (glyph++)->slice.cmp.to + 1; @@ -27722,6 +27725,12 @@ fill_gstring_glyph_string (struct glyph_string *s, int face_id, s->char2b[i] = code & 0xFFFF; } + /* If the specified font could not be loaded, record that fact in + S->font_not_found_p so that we can draw rectangles for the + characters of the glyph string. */ + if (glyph_not_available_p) + s->font_not_found_p = true; + return glyph - s->row->glyphs[s->area]; } @@ -28918,7 +28927,7 @@ append_composite_glyph (struct it *it) glyph->overlaps_vertically_p = (it->phys_ascent > it->ascent || it->phys_descent > it->descent); glyph->padding_p = false; - glyph->glyph_not_available_p = false; + glyph->glyph_not_available_p = it->glyph_not_available_p; glyph->face_id = it->face_id; glyph->font_type = FONT_TYPE_UNKNOWN; if (it->bidi_p) @@ -30626,11 +30635,21 @@ gui_produce_glyphs (struct it *it) it->pixel_width = composition_gstring_width (gstring, it->cmp_it.from, it->cmp_it.to, &metrics); - if (it->glyph_row - && (metrics.lbearing < 0 || metrics.rbearing > metrics.width)) - it->glyph_row->contains_overlapping_glyphs_p = true; - it->ascent = it->phys_ascent = metrics.ascent; - it->descent = it->phys_descent = metrics.descent; + if (it->pixel_width == 0) + { + it->glyph_not_available_p = true; + it->phys_ascent = it->ascent; + it->phys_descent = it->descent; + it->pixel_width = face->font->space_width; + } + else + { + if (it->glyph_row + && (metrics.lbearing < 0 || metrics.rbearing > metrics.width)) + it->glyph_row->contains_overlapping_glyphs_p = true; + it->ascent = it->phys_ascent = metrics.ascent; + it->descent = it->phys_descent = metrics.descent; + } IT_APPLY_FACE_BOX(it, face); /* If face has an overline, add the height of the overline From acd2cb28ef63188bff31fc167ab007a051f99c17 Mon Sep 17 00:00:00 2001 From: Ellington Santos Date: Tue, 26 May 2020 11:37:04 -0300 Subject: [PATCH 10/12] Improve battery status display via GNU/Linux sysfs * lisp/battery.el (battery-linux-sysfs): Support %b format. Improve the display of %p. (Bug#41542) Copyright-paperwork-exempt: yes --- lisp/battery.el | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/lisp/battery.el b/lisp/battery.el index 7027b254480..b8855a8ce37 100644 --- a/lisp/battery.el +++ b/lisp/battery.el @@ -441,13 +441,15 @@ The following %-sequences are provided: %c Current capacity (mAh or mWh) %r Current rate %B Battery status (verbose) +%b Battery status, empty means high, `-' means low, + `!' means critical, and `+' means charging %d Temperature (in degrees Celsius) %p Battery load percentage %L AC line status (verbose) %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours %t Remaining time (to charge or discharge) in the form `h:min'" - (let (charging-state temperature hours + (let (charging-state temperature hours percentage-now ;; Some batteries report charges and current, other energy and power. ;; In order to reliably be able to combine those data, we convert them ;; all to energy/power (since we can't combine different charges if @@ -515,6 +517,8 @@ The following %-sequences are provided: energy-now (- energy-full energy-now)))) (setq hours (/ remaining power-now))))))) + (when (and (> energy-full 0) (> energy-now 0)) + (setq percentage-now (/ (* 100 energy-now) energy-full))) (list (cons ?c (cond ((or (> energy-full 0) (> energy-now 0)) (number-to-string (/ energy-now voltage-now))) (t "N/A"))) @@ -528,10 +532,13 @@ The following %-sequences are provided: "N/A")) (cons ?d (or temperature "N/A")) (cons ?B (or charging-state "N/A")) - (cons ?p (cond ((and (> energy-full 0) (> energy-now 0)) - (format "%.1f" - (/ (* 100 energy-now) energy-full))) - (t "N/A"))) + (cons ?b (or (and (string= charging-state "Charging") "+") + (and percentage-now (< percentage-now battery-load-critical) "!") + (and percentage-now (< percentage-now battery-load-low) "-") + "")) + (cons ?p (cond + ((and percentage-now (format "%.1f" percentage-now))) + (t "N/A"))) (cons ?L (cond ((battery-search-for-one-match-in-files (list "/sys/class/power_supply/AC/online" From 8bcc781bc762b4082cfd678b88938e3d03465d91 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Wed, 3 Jun 2020 17:35:59 +0100 Subject: [PATCH 11/12] Un-deprecate oset and oset-default For discussion see the following threads: https://lists.gnu.org/archive/html/emacs-devel/2020-05/msg00630.html https://lists.gnu.org/archive/html/emacs-devel/2020-05/msg00674.html https://lists.gnu.org/archive/html/emacs-devel/2020-06/msg00099.html * lisp/emacs-lisp/eieio.el (oset, oset-default): Un-deprecate. * lisp/emacs-lisp/eieio-core.el (eieio-oref): Declare gv-setter here instead of in lisp/emacs-lisp/eieio.el. Suggested by Stefan Monnier . (eieio-oref-default): Add gv-setter declaration. * etc/NEWS: Announce these changes. * doc/misc/eieio.texi (Accessing Slots): Document oref and oref-default as generalized variables. Consistently document getters before setters. * test/lisp/emacs-lisp/eieio-tests/eieio-tests.el: Use lexical-binding. (eieio-test-13-init-methods): Simplify. (eieio-test-33-instance-tracker): Declare IT-list as special. --- doc/misc/eieio.texi | 32 ++++++++++++------- etc/NEWS | 7 +++- lisp/emacs-lisp/eieio-core.el | 4 ++- lisp/emacs-lisp/eieio.el | 14 ++------ .../emacs-lisp/eieio-tests/eieio-tests.el | 5 +-- 5 files changed, 35 insertions(+), 27 deletions(-) diff --git a/doc/misc/eieio.texi b/doc/misc/eieio.texi index 3943c544c7d..6e7d4386bec 100644 --- a/doc/misc/eieio.texi +++ b/doc/misc/eieio.texi @@ -698,6 +698,27 @@ and argument-order conventions are similar to those used for referencing vectors (@pxref{Vectors,,,elisp,GNU Emacs Lisp Reference Manual}). +@defmac oref obj slot +@anchor{oref} +This macro retrieves the value stored in @var{obj} in the named +@var{slot}. Slot names are determined by @code{defclass} which +creates the slot. + +This is a generalized variable that can be used with @code{setf} to +modify the value stored in @var{slot}. @xref{Generalized +Variables,,,elisp,GNU Emacs Lisp Reference Manual}. +@end defmac + +@defmac oref-default class slot +@anchor{oref-default} +This macro returns the value of the class-allocated @var{slot} from +@var{class}. + +This is a generalized variable that can be used with @code{setf} to +modify the value stored in @var{slot}. @xref{Generalized +Variables,,,elisp,GNU Emacs Lisp Reference Manual}. +@end defmac + @defmac oset object slot value This macro sets the value behind @var{slot} to @var{value} in @var{object}. It returns @var{value}. @@ -716,17 +737,6 @@ changed, this can be arranged by simply executing this bit of code: @end example @end defmac -@defmac oref obj slot -@anchor{oref} -Retrieve the value stored in @var{obj} in the slot named by @var{slot}. -Slot is the name of the slot when created by @dfn{defclass}. -@end defmac - -@defmac oref-default class slot -@anchor{oref-default} -Get the value of the class-allocated @var{slot} from @var{class}. -@end defmac - The following accessors are defined by CLOS to reference or modify slot values, and use the previously mentioned set/ref routines. diff --git a/etc/NEWS b/etc/NEWS index ed4722b27f5..27e511047e6 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -112,7 +112,12 @@ setting the variable 'auto-save-visited-mode' buffer-locally to nil. ** New bindings in occur-mode, 'next-error-no-select' bound to 'n' and 'previous-error-no-select' bound to 'p'. -** EIEIO: 'oset' and 'oset-default' are declared obsolete. +** EIEIO + ++++ +*** The macro 'oref-default' can now be used with 'setf'. +It is now defined as a generalized variable that can be used with +'setf' to modify the value stored in a given class slot. ** New minor mode 'cl-font-lock-built-in-mode' for `lisp-mode'. The mode provides refined highlighting of built-in functions, types, diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 1e53f30a2ae..3bc65d0d4c5 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -730,7 +730,8 @@ Argument FN is the function calling this verifier." (guard (not (memq name eieio--known-slot-names)))) (macroexp--warn-and-return (format-message "Unknown slot `%S'" name) exp 'compile-only)) - (_ exp))))) + (_ exp)))) + (gv-setter eieio-oset)) (cl-check-type slot symbol) (cl-check-type obj (or eieio-object class)) (let* ((class (cond ((symbolp obj) @@ -755,6 +756,7 @@ Argument FN is the function calling this verifier." (defun eieio-oref-default (obj slot) "Do the work for the macro `oref-default' with similar parameters. Fills in OBJ's SLOT with its default value." + (declare (gv-setter eieio-oset-default)) (cl-check-type obj (or eieio-object class)) (cl-check-type slot symbol) (let* ((cl (cond ((symbolp obj) (cl--find-class obj)) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index ee5dd2cccdb..b75410ee220 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -513,8 +513,7 @@ The CLOS function `class-direct-subclasses' is aliased to this function." "Set the value in OBJ for slot SLOT to VALUE. SLOT is the slot name as specified in `defclass' or the tag created with in the :initarg slot. VALUE can be any Lisp object." - (declare (obsolete "use (setf (oref ..) ..) instead" "28.1") - (debug (form symbolp form))) + (declare (debug (form symbolp form))) `(eieio-oset ,obj (quote ,slot) ,value)) (defmacro oset-default (class slot value) @@ -522,8 +521,7 @@ with in the :initarg slot. VALUE can be any Lisp object." The default value is usually set with the :initform tag during class creation. This allows users to change the default behavior of classes after they are created." - (declare (obsolete "use (setf (oref-default ..) ..) instead" "28.1") - (debug (form symbolp form))) + (declare (debug (form symbolp form))) `(eieio-oset-default ,class (quote ,slot) ,value)) ;;; CLOS queries into classes and slots @@ -647,14 +645,6 @@ If SLOT is unbound, do nothing." nil (eieio-oset object slot (delete item (eieio-oref object slot))))) -;;; Here are some CLOS items that need the CL package -;; - -;; FIXME: Shouldn't this be a more complex gv-expander which extracts the -;; common code between oref and oset, so as to reduce the redundant work done -;; in (push foo (oref bar baz)), like we do for the `nth' expander? -(gv-define-simple-setter eieio-oref eieio-oset) - ;;; ;; We want all objects created by EIEIO to have some default set of diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index 34c20b2003f..21adc91e555 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -1,4 +1,4 @@ -;;; eieio-tests.el -- eieio tests routines +;;; eieio-tests.el -- eieio test routines -*- lexical-binding: t -*- ;; Copyright (C) 1999-2003, 2005-2010, 2012-2020 Free Software ;; Foundation, Inc. @@ -356,7 +356,7 @@ METHOD is the method that was attempting to be called." (oset a test-tag 1)) (let ((ca (class-a))) - (should-not (/= (oref ca test-tag) 2)))) + (should (= (oref ca test-tag) 2)))) ;;; Perform slot testing @@ -852,6 +852,7 @@ Subclasses to override slot attributes.") "Instance Tracker test object.") (ert-deftest eieio-test-33-instance-tracker () + (defvar IT-list) (let (IT-list IT1) (should (setq IT1 (IT))) ;; The instance tracker must find this From 7ac79872aed63110c0d26c1e62e1838d6101c9bd Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Sat, 6 Jun 2020 12:05:10 -0700 Subject: [PATCH 12/12] make-text-button no longer modifies its string arg MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * etc/NEWS: Mention this. * lisp/apropos.el (apropos-library-button): * lisp/ibuf-ext.el (ibuffer-old-saved-filters-warning): There’s no longer a need copy make-text-button’s string arg. * lisp/button.el (make-text-button): Return a copy of a string arg. Delay making the copy until after error-checking. --- etc/NEWS | 5 +++++ lisp/apropos.el | 2 +- lisp/button.el | 9 ++++++--- lisp/ibuf-ext.el | 2 +- 4 files changed, 13 insertions(+), 5 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 27e511047e6..edad5b37d6c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -476,6 +476,11 @@ are 'eq'. To compare contents, use 'compare-window-configurations' instead. This change helps fix a bug in 'sxhash-equal', which returned incorrect hashes for window configurations and some other objects. +** When its first argument is a string, 'make-text-button' no longer +modifies the string's text properties; instead, it uses and returns +a copy of the string. This helps avoid trouble when strings are +shared or constants. + --- ** The obsolete function 'thread-alive-p' has been removed. diff --git a/lisp/apropos.el b/lisp/apropos.el index 22866cd2cc8..2566d44dfcf 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -661,7 +661,7 @@ Return list of symbols and documentation found." (defun apropos-library-button (sym) (if (null sym) "" - (let ((name (copy-sequence (symbol-name sym)))) + (let ((name (symbol-name sym))) (make-text-button name nil 'type 'apropos-library 'face 'apropos-symbol diff --git a/lisp/button.el b/lisp/button.el index 3a6a6de774c..d9c36a0375c 100644 --- a/lisp/button.el +++ b/lisp/button.el @@ -341,15 +341,14 @@ If the property `button-data' is present, it will later be used as the argument for the `action' callback function instead of the default argument, which is the button itself. -BEG can also be a string, in which case it is made into a button. +BEG can also be a string, in which case a copy of it is made into +a button and returned. Also see `insert-text-button'." (let ((object nil) (type-entry (or (plist-member properties 'type) (plist-member properties :type)))) - (when (stringp beg) - (setq object beg beg 0 end (length object))) ;; Disallow setting the `category' property directly. (when (plist-get properties 'category) (error "Button `category' property may not be set directly")) @@ -362,6 +361,10 @@ Also see `insert-text-button'." (setcar type-entry 'category) (setcar (cdr type-entry) (button-category-symbol (cadr type-entry)))) + (when (stringp beg) + (setq object (copy-sequence beg)) + (setq beg 0) + (setq end (length object))) ;; Now add all the text properties at once. (add-text-properties beg end ;; Each button should have a non-eq `button' diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index c39000b4886..bfb9787a96d 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -202,7 +202,7 @@ The format has been repaired and the variable modified accordingly. You can save the current value through the customize system by either clicking or hitting return " (make-text-button - (copy-sequence "here") nil + "here" nil 'face '(:weight bold :inherit button) 'mouse-face '(:weight normal :background "gray50" :inherit button) 'follow-link t