[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/native-comp ee3df14 1/6: Merge remote-tracking branch 'savannah/
|
From: |
Andrea Corallo |
|
Subject: |
feature/native-comp ee3df14 1/6: Merge remote-tracking branch 'savannah/master' into HEAD |
|
Date: |
Sat, 6 Jun 2020 17:38:09 -0400 (EDT) |
branch: feature/native-comp
commit ee3df1483a9e733c27629da7bcf515789df52ef8
Merge: 385d9e6 7ac7987
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>
Merge remote-tracking branch 'savannah/master' into HEAD
---
doc/misc/eieio.texi | 32 ++-
etc/NEWS | 12 +-
lisp/apropos.el | 5 +-
lisp/battery.el | 17 +-
lisp/button.el | 9 +-
lisp/dired.el | 62 +++--
lisp/emacs-lisp/eieio-core.el | 4 +-
lisp/emacs-lisp/eieio.el | 14 +-
lisp/font-lock.el | 21 +-
lisp/help-fns.el | 3 +-
lisp/progmodes/project.el | 35 +--
src/alloc.c | 350 +++++++++++++-----------
src/xdisp.c | 33 ++-
test/lisp/emacs-lisp/eieio-tests/eieio-tests.el | 5 +-
14 files changed, 358 insertions(+), 244 deletions(-)
diff --git a/doc/misc/eieio.texi b/doc/misc/eieio.texi
index 3943c54..6e7d438 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 ed4722b..edad5b3 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 7cbda3c..2566d44 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)
"<nothing>"
- (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 7027b25..b8855a8 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 3a6a6de..d9c36a0 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 aad44a6..1792250 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 1e53f30..3bc65d0 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 ee5dd2c..b75410e 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 e0955b7..5cda4a6 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 f2495d0..082a44d 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 c701b80..4d57fb2 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 281525b..9a9dbb5 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)
+ 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))
{
- 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);
- }
+ 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)
+ 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))
{
- 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);
- }
+ 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];
-
- /* 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;
+ 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));
}
-/* 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;
+ 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;
-
- /* 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)
+static bool
+live_large_vector_p (struct mem_node *m, void *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)
{
- /* 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);
+ if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE))
+ return vector;
+ vector = next;
}
- return Qnil;
+ return NULL;
}
static bool
-live_vector_p (struct mem_node *m, void *p)
+live_small_vector_p (struct mem_node *m, void *p)
{
- return !NILP (live_vector_holding (m, 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;
+
+ switch (type_tag)
+ {
+ case_Lisp_Int: case Lisp_Type_Unused0:
+ return;
+
+ case Lisp_Symbol:
+ offset = (intptr_t) lispsym;
+ break;
- void *po = XPNTR (obj);
+ 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;
+ enum pvec_type pvectype
+ = PSEUDOVECTOR_TYPE (ptr);
+
#ifdef GC_CHECK_MARKED_OBJECTS
- if (!pdumper_object_p(po))
+ if (!pdumper_object_p (po) && !SUBRP (obj) && !main_thread_p (po))
{
m = mem_find (po);
- if (m == MEM_NIL && !SUBRP (obj) && !main_thread_p (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 /* GC_CHECK_MARKED_OBJECTS */
-
- enum pvec_type pvectype
- = PSEUDOVECTOR_TYPE (ptr);
-
- if (pvectype != PVEC_SUBR &&
- !main_thread_p (po))
- CHECK_LIVE (live_vector_p);
+#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 327e8a1..52f6ab8 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 34c20b2..21adc91 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
- feature/native-comp updated (385d9e6 -> 489a79d), Andrea Corallo, 2020/06/06
- feature/native-comp e38678b 2/6: Reduce the number of files probed when finding a lisp file., Andrea Corallo, 2020/06/06
- feature/native-comp ee3df14 1/6: Merge remote-tracking branch 'savannah/master' into HEAD,
Andrea Corallo <=
- feature/native-comp dcfcbb1 5/6: * Allow for optimizing anonymous lambdas in call-optim, Andrea Corallo, 2020/06/06
- feature/native-comp e8ab017 3/6: Change 'direct-call' 'direct-callref' LIMPLE ops sematinc, Andrea Corallo, 2020/06/06
- feature/native-comp 6449a05 4/6: * Clean-up unnecessary lisp_X context definition, Andrea Corallo, 2020/06/06
- feature/native-comp 489a79d 6/6: * Mitigate possible speed 3 miss-optimization, Andrea Corallo, 2020/06/06