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..edad5b37d6c 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, @@ -471,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 7cbda3cb678..2566d44dfcf 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -661,12 +661,11 @@ 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 - 'apropos-symbol name) - name))) + 'apropos-symbol name)))) ;;;###autoload (defun apropos-library (file) 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" 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/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 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/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. diff --git a/lisp/help-fns.el b/lisp/help-fns.el index f2495d0909c..082a44d9bf5 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -654,8 +654,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/progmodes/project.el b/lisp/progmodes/project.el index c701b801599..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" @@ -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)))) @@ -825,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. @@ -857,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 diff --git a/src/alloc.c b/src/alloc.c index 281525b20e5..9a9dbb52e7b 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -4445,7 +4445,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 @@ -4453,103 +4453,97 @@ 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) - { - 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 make_lisp_ptr (s, Lisp_String); - } + /* 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 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) - { - 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 make_lisp_ptr (s, Lisp_Cons); - } + /* 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 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) - { - 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 make_lisp_symbol (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 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; } @@ -4559,66 +4553,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 Lisp_Object -live_vector_holding (struct mem_node *m, void *p) +static struct Lisp_Vector * +live_large_vector_holding (struct mem_node *m, void *p) { + eassert (m->type == MEM_TYPE_VECTORLIKE); struct Lisp_Vector *vp = p; - - 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; - - /* 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 make_lisp_ptr (vector, Lisp_Vectorlike); - vector = next; - } - } - else if (m->type == MEM_TYPE_VECTORLIKE) - { - /* 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) - return make_lisp_ptr (vector, Lisp_Vectorlike); - } - return Qnil; + 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; } static bool -live_vector_p (struct mem_node *m, void *p) +live_large_vector_p (struct mem_node *m, void *p) { - return !NILP (live_vector_holding (m, p)); + return live_large_vector_holding (m, p) == p; +} + +/* 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) + { + struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); + if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE)) + return vector; + vector = next; + } + return NULL; +} + +static bool +live_small_vector_p (struct mem_node *m, void *p) +{ + return live_small_vector_holding (m, p) == p; } /* Mark OBJ if we can prove it's a Lisp_Object. */ @@ -4630,10 +4628,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 @@ -4645,7 +4657,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; } @@ -4656,30 +4668,33 @@ mark_maybe_object (Lisp_Object obj) { bool mark_p = false; - switch (XTYPE (obj)) + switch (type_tag) { case Lisp_String: - mark_p = EQ (obj, live_string_holding (m, po)); + mark_p = m->type == MEM_TYPE_STRING && live_string_p (m, po); break; case Lisp_Cons: - mark_p = EQ (obj, live_cons_holding (m, po)); + mark_p = m->type == MEM_TYPE_CONS && live_cons_p (m, po); break; case Lisp_Symbol: - mark_p = EQ (obj, live_symbol_holding (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 = (EQ (obj, live_vector_holding (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) @@ -4720,43 +4735,71 @@ 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: + { + 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: - obj = 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); + } break; default: emacs_abort (); } - if (!NILP (obj)) - mark_object (obj); + mark_object (obj); } } @@ -5163,8 +5206,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; @@ -5686,7 +5731,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)) @@ -6525,7 +6570,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 (); \ @@ -6538,19 +6583,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)) \ + 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. */ @@ -6559,15 +6604,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 */ @@ -6578,7 +6622,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 @@ -6596,21 +6640,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) { @@ -6649,7 +6693,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); @@ -6687,7 +6731,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); @@ -6728,7 +6772,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)) @@ -6746,7 +6790,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))) 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 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