[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] feature/tramp-thread-safe c291336 1/3: Merge remote-tracki
|
From: |
Michael Albinus |
|
Subject: |
[Emacs-diffs] feature/tramp-thread-safe c291336 1/3: Merge remote-tracking branch 'origin/master' into feature/tramp-thread-safe |
|
Date: |
Mon, 10 Sep 2018 07:21:36 -0400 (EDT) |
branch: feature/tramp-thread-safe
commit c291336562fbf561c5d9825b48dd83b9c31af898
Merge: bedde1f 6a00f2b
Author: Michael Albinus <address@hidden>
Commit: Michael Albinus <address@hidden>
Merge remote-tracking branch 'origin/master' into feature/tramp-thread-safe
---
doc/lispref/control.texi | 7 +-
doc/lispref/edebug.texi | 2 +
doc/lispref/elisp.texi | 4 +-
doc/lispref/internals.texi | 4 +-
doc/lispref/threads.texi | 51 +++
doc/lispref/windows.texi | 8 +
etc/NEWS | 19 +
lisp/calendar/todo-mode.el | 4 +-
lisp/emacs-lisp/thread.el | 44 ---
lisp/emacs-lisp/timer.el | 10 +-
lisp/eshell/esh-proc.el | 7 +-
lisp/ldefs-boot.el | 81 +++-
lisp/mail/emacsbug.el | 17 +-
lisp/mh-e/mh-junk.el | 6 +-
lisp/net/tramp.el | 4 +-
lisp/server.el | 2 +-
lisp/thread.el | 200 ++++++++++
lisp/vc/vc-git.el | 10 +-
lisp/w32-fns.el | 99 +++--
src/alloc.c | 24 +-
src/bignum.c | 87 +++--
src/bignum.h | 21 +-
src/charset.c | 4 +-
src/data.c | 685 +++++++++++++---------------------
src/dbusbind.c | 30 +-
src/dired.c | 17 +-
src/dispextern.h | 4 +
src/dispnew.c | 29 +-
src/editfns.c | 49 +--
src/emacs-module.c | 12 +-
src/emacs.c | 1 +
src/eval.c | 69 +++-
src/fileio.c | 16 +-
src/floatfns.c | 127 ++++---
src/fns.c | 15 +-
src/font.c | 25 +-
src/frame.h | 2 +-
src/keymap.c | 4 +-
src/lisp.h | 142 +++++--
src/lread.c | 2 +-
src/process.c | 18 +-
src/process.h | 2 +-
src/puresize.h | 2 +-
src/scroll.c | 30 +-
src/termhooks.h | 2 +-
src/thread.h | 6 +-
src/w32fns.c | 17 +-
src/window.c | 50 ++-
src/window.h | 2 +-
src/xdisp.c | 8 +-
src/xselect.c | 15 +-
src/xterm.h | 2 +-
src/xwidget.h | 4 +-
test/lisp/autorevert-tests.el | 1 +
test/lisp/calendar/todo-mode-tests.el | 76 +++-
test/lisp/emacs-lisp/timer-tests.el | 5 +
test/lisp/thread-tests.el | 96 +++++
test/src/editfns-tests.el | 10 +
test/src/floatfns-tests.el | 5 +
59 files changed, 1409 insertions(+), 886 deletions(-)
diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index 975ab3d..8a6cf73 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -1878,9 +1878,10 @@ error occurs during @var{protected-form}.
Each of the @var{handlers} is a list of the form @code{(@var{conditions}
@address@hidden)}. Here @var{conditions} is an error condition name
to be handled, or a list of condition names (which can include @code{debug}
-to allow the debugger to run before the handler); @var{body} is one or more
-Lisp expressions to be executed when this handler handles an error.
-Here are examples of handlers:
+to allow the debugger to run before the handler). A condition name of
address@hidden matches any condition. @var{body} is one or more Lisp
+expressions to be executed when this handler handles an error. Here
+are examples of handlers:
@example
@group
diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi
index 54200b9..b1a6511 100644
--- a/doc/lispref/edebug.texi
+++ b/doc/lispref/edebug.texi
@@ -445,6 +445,8 @@ Display a backtrace, excluding Edebug's own functions for
clarity
@xref{Backtraces}, for a description of backtraces
and the commands which work on them.
address@hidden edebug-backtrace-show-instrumentation
address@hidden edebug-backtrace-hide-instrumentation
If you would like to see Edebug's functions in the backtrace,
use @kbd{M-x edebug-backtrace-show-instrumentation}. To hide them
again use @kbd{M-x edebug-backtrace-hide-instrumentation}.
diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi
index 3025934..6d8529d 100644
--- a/doc/lispref/elisp.texi
+++ b/doc/lispref/elisp.texi
@@ -655,7 +655,8 @@ The Lisp Debugger
* Function Debugging:: Entering it when a certain function is called.
* Variable Debugging:: Entering it when a variable is modified.
* Explicit Debug:: Entering it at a certain point in the program.
-* Using Debugger:: What the debugger does; what you see while in it.
+* Using Debugger:: What the debugger does.
+* Backtraces:: What you see while in the debugger.
* Debugger Commands:: Commands used while in the debugger.
* Invoking the Debugger:: How to call the function @code{debug}.
* Internals of Debugger:: Subroutines of the debugger, and global variables.
@@ -1346,6 +1347,7 @@ Threads
* Basic Thread Functions:: Basic thread functions.
* Mutexes:: Mutexes allow exclusive access to data.
* Condition Variables:: Inter-thread events.
+* The Thread List:: Show the active threads.
Processes
diff --git a/doc/lispref/internals.texi b/doc/lispref/internals.texi
index 3fe2844..d42e244 100644
--- a/doc/lispref/internals.texi
+++ b/doc/lispref/internals.texi
@@ -382,7 +382,7 @@ This is used for convenience and equals to @code{sizeof
(char)}.
The total size of all string data in bytes.
@item vector-size
-Internal size of a vector header, i.e., @code{sizeof (struct Lisp_Vector)}.
+Size in bytes of a vector of length 1, including its header.
@item used-vectors
The number of vector headers allocated from the vector blocks.
@@ -392,6 +392,8 @@ Internal size of a vector slot, always equal to
@code{sizeof (Lisp_Object)}.
@item used-slots
The number of slots in all used vectors.
+Slot counts might include some or all overhead from vector headers,
+depending on the platform.
@item free-slots
The number of free slots in all vector blocks.
diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi
index 9cdeb79..c9d5f79 100644
--- a/doc/lispref/threads.texi
+++ b/doc/lispref/threads.texi
@@ -45,6 +45,7 @@ closure are shared by any threads invoking the closure.
* Basic Thread Functions:: Basic thread functions.
* Mutexes:: Mutexes allow exclusive access to data.
* Condition Variables:: Inter-thread events.
+* The Thread List:: Show the active threads.
@end menu
@node Basic Thread Functions
@@ -271,3 +272,53 @@ Return the name of @var{cond}, as passed to
Return the mutex associated with @var{cond}. Note that the associated
mutex cannot be changed.
@end defun
+
address@hidden The Thread List
address@hidden The Thread List
+
address@hidden thread list
address@hidden list of threads
address@hidden list-threads
+The @code{list-threads} command lists all the currently alive threads.
+In the resulting buffer, each thread is identified either by the name
+passed to @code{make-thread} (@pxref{Basic Thread Functions}), or by
+its unique internal identifier if it was not created with a name. The
+status of each thread at the time of the creation or last update of
+the buffer is shown, in addition to the object the thread was blocked
+on at the time, if it was blocked.
+
address@hidden thread-list-refresh-seconds
+The @file{*Threads*} buffer will automatically update twice per
+second. You can make the refresh rate faster or slower by customizing
+this variable.
address@hidden defvar
+
+Here are the commands available in the thread list buffer:
+
address@hidden @kbd
+
address@hidden backtrace of thread
address@hidden thread backtrace
address@hidden b
+Show a backtrace of the thread at point. This will show where in its
+code the thread had yielded or was blocked at the moment you pressed
address@hidden Be aware that the backtrace is a snapshot; the thread could
+have meanwhile resumed execution, and be in a different state, or
+could have exited.
+
+You may use @kbd{g} in the thread's backtrace buffer to get an updated
+backtrace, as backtrace buffers do not automatically update.
address@hidden, for a description of backtraces and the other
+commands which work on them.
+
address@hidden s
+Signal the thread at point. After @kbd{s}, type @kbd{q} to send a
+quit signal or @kbd{e} to send an error signal. Threads may implement
+handling of signals, but the default behavior is to exit on any
+signal. Therefore you should only use this command if you understand
+how to restart the target thread, because your Emacs session may
+behave incorrectly if necessary threads are killed.
+
address@hidden g
+Update the list of threads and their statuses.
address@hidden table
diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi
index 3eaa15a..7cfa5ea 100644
--- a/doc/lispref/windows.texi
+++ b/doc/lispref/windows.texi
@@ -5205,6 +5205,14 @@ whether a specific window has changed size, compare the
return values of
@code{window-pixel-height-before-size-change} and
@code{window-pixel-height} for that window (@pxref{Window Sizes}).
+The buffer-local value of this hook is run once for the buffer and the
+frame in question, provided at least one window showing the buffer on
+that frame has changed its size. As it still receives the frame as
+its sole argument, any function called on a buffer-local basis will be
+oblivious to which window(s) showing the buffer changed its (their)
+size and has to check out these windows by using the method described
+in the previous paragraph.
+
These function are usually only called when at least one window was
added or has changed size since the last time this hook was run for the
associated frame. In some rare cases this hook also runs when a window
diff --git a/etc/NEWS b/etc/NEWS
index 970a422..f06d083 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -287,6 +287,10 @@ still be used if it exists.) Set the variable to nil to
get the
previous behavior of always creating a buffer that visits a ChangeLog
file.
+*** New customizable variable 'vc-git-grep-template'.
+This new variable allows customizing the default arguments passed to
+git-grep when 'vc-git-grep' is used.
+
** diff-mode
*** Hunks are now automatically refined by default.
To disable it, set the new defcustom 'diff-font-lock-refine' to nil.
@@ -746,6 +750,13 @@ Instead, error messages are just printed in the main
thread.
---
*** 'thread-alive-p' is now obsolete, use 'thread-live-p' instead.
++++
+*** New command 'list-threads' shows Lisp threads.
+See the current list of live threads in a tabulated-list buffer which
+automatically updates. In the buffer, you can use 's q' or 's e' to
+signal a thread with quit or error respectively, or get a snapshot
+backtrace with 'b'.
+
---
** thingatpt.el supports a new "thing" called 'uuid'.
A symbol 'uuid' can be passed to thing-at-point and it returns the
@@ -888,6 +899,9 @@ removed.
** lookup-key can take a list of keymaps as argument.
+++
+** 'condition-case' now accepts 't' to match any error symbol.
+
++++
** New function 'proper-list-p'.
Given a proper list as argument, this predicate returns its length;
otherwise, it returns nil. 'format-proper-list-p' is now an obsolete
@@ -963,6 +977,11 @@ displaying the same buffer. See the Info node "Face
Remapping" of the
Emacs Lisp Reference manual for more detail.
+++
+** Special handling of buffer-local 'window-size-change-functions'.
+A buffer-local value of this hook is now run only if at least one
+window showing the buffer has changed its size.
+
++++
** New function assoc-delete-all.
+++
diff --git a/lisp/calendar/todo-mode.el b/lisp/calendar/todo-mode.el
index 08da75d..7d01fe3 100644
--- a/lisp/calendar/todo-mode.el
+++ b/lisp/calendar/todo-mode.el
@@ -1106,7 +1106,9 @@ Noninteractively, return the name of the new file."
(progn
(set-window-buffer (selected-window)
(set-buffer (find-file-noselect file)))
- (setq todo-current-todo-file file)
+ ;; Since buffer is not yet in todo-mode, we need to
+ ;; explicitly make todo-current-todo-file buffer local.
+ (setq-local todo-current-todo-file file)
(todo-show))
file)))
diff --git a/lisp/emacs-lisp/thread.el b/lisp/emacs-lisp/thread.el
deleted file mode 100644
index 5d7b90c..0000000
--- a/lisp/emacs-lisp/thread.el
+++ /dev/null
@@ -1,44 +0,0 @@
-;;; thread.el --- List active threads in a buffer -*- lexical-binding: t -*-
-
-;; Copyright (C) 2018 Free Software Foundation, Inc.
-
-;; Author: Gemini Lasswell <address@hidden>
-;; Maintainer: address@hidden
-;; Keywords: lisp, tools, maint
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-;;;###autoload
-(defun thread-handle-event (event)
- "Handle thread events, propagated by `thread-signal'.
-An EVENT has the format
- (thread-event THREAD ERROR-SYMBOL DATA)"
- (interactive "e")
- (if (and (consp event)
- (eq (car event) 'thread-event)
- (= (length event) 4))
- (let ((thread (cadr event))
- (err (cddr event)))
- (message "Error %s: %S" thread err))))
-
-(make-obsolete 'thread-alive-p 'thread-live-p "27.1")
-
-(provide 'thread)
-;;; thread.el ends here
diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el
index 795554f..74d37b0 100644
--- a/lisp/emacs-lisp/timer.el
+++ b/lisp/emacs-lisp/timer.el
@@ -102,14 +102,14 @@ fire each time Emacs is idle for that many seconds."
"Yield the next value after TIME that is an integral multiple of SECS.
More precisely, the next value, after TIME, that is an integral multiple
of SECS seconds since the epoch. SECS may be a fraction."
- (let* ((trillion 1e12)
+ (let* ((trillion 1000000000000)
(time-sec (+ (nth 1 time)
- (* 65536.0 (nth 0 time))))
+ (* 65536 (nth 0 time))))
(delta-sec (mod (- time-sec) secs))
- (next-sec (+ time-sec (ffloor delta-sec)))
- (next-sec-psec (ffloor (* trillion (mod delta-sec 1))))
+ (next-sec (+ time-sec (floor delta-sec)))
+ (next-sec-psec (floor (* trillion (mod delta-sec 1))))
(sub-time-psec (+ (or (nth 3 time) 0)
- (* 1e6 (nth 2 time))))
+ (* 1000000 (nth 2 time))))
(psec-diff (- sub-time-psec next-sec-psec)))
(if (and (<= next-sec time-sec) (< 0 psec-diff))
(setq next-sec-psec (+ sub-time-psec
diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el
index a7855d8..3735f30 100644
--- a/lisp/eshell/esh-proc.el
+++ b/lisp/eshell/esh-proc.el
@@ -282,11 +282,10 @@ See `eshell-needs-pipe'."
(let ((process-connection-type
(unless (eshell-needs-pipe-p command)
process-connection-type))
- (command (file-local-name command)))
+ ;; `start-process' can't deal with relative filenames.
+ (command (file-local-name (expand-file-name command))))
(apply 'start-file-process
- (file-name-nondirectory command) nil
- ;; `start-process' can't deal with relative filenames.
- (append (list (expand-file-name command)) args))))
+ (file-name-nondirectory command) nil command args)))
(eshell-record-process-object proc)
(set-process-buffer proc (current-buffer))
(if (eshell-interactive-output-p)
diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el
index 3bd775f..bdf4c31 100644
--- a/lisp/ldefs-boot.el
+++ b/lisp/ldefs-boot.el
@@ -1900,6 +1900,21 @@ definition of \"random distance\".)
;;;***
+;;;### (autoloads nil "backtrace" "emacs-lisp/backtrace.el" (0 0
+;;;;;; 0 0))
+;;; Generated autoloads from emacs-lisp/backtrace.el
+(push (purecopy '(backtrace 1 0)) package--builtin-versions)
+
+(autoload 'backtrace "backtrace" "\
+Print a trace of Lisp function calls currently active.
+Output stream used is value of `standard-output'.
+
+\(fn)" nil nil)
+
+(if (fboundp 'register-definition-prefixes) (register-definition-prefixes
"backtrace" '("backtrace-")))
+
+;;;***
+
;;;### (autoloads nil "bat-mode" "progmodes/bat-mode.el" (0 0 0 0))
;;; Generated autoloads from progmodes/bat-mode.el
@@ -3850,6 +3865,7 @@ the absolute file name of the file if STYLE-NAME is nil.
;;;### (autoloads nil "cc-mode" "progmodes/cc-mode.el" (0 0 0 0))
;;; Generated autoloads from progmodes/cc-mode.el
+(push (purecopy '(cc-mode 5 33 1)) package--builtin-versions)
(autoload 'c-initialize-cc-mode "cc-mode" "\
Initialize CC Mode for use in the current buffer.
@@ -4998,6 +5014,13 @@ call other entry points instead, such as `cl-prin1'.
\(fn OBJECT STREAM)" nil nil)
+(autoload 'cl-print-expand-ellipsis "cl-print" "\
+Print the expansion of an ellipsis to STREAM.
+VALUE should be the value of the `cl-print-ellipsis' text property
+which was attached to the ellipsis by `cl-prin1'.
+
+\(fn VALUE STREAM)" nil nil)
+
(autoload 'cl-prin1 "cl-print" "\
Print OBJECT on STREAM according to its type.
Output is further controlled by the variables
@@ -5012,6 +5035,24 @@ Return a string containing the `cl-prin1'-printed
representation of OBJECT.
\(fn OBJECT)" nil nil)
+(autoload 'cl-print-to-string-with-limit "cl-print" "\
+Return a string containing a printed representation of VALUE.
+Attempt to get the length of the returned string under LIMIT
+characters with appropriate settings of `print-level' and
+`print-length.' Use PRINT-FUNCTION to print, which should take
+the arguments VALUE and STREAM and which should respect
+`print-length' and `print-level'. LIMIT may be nil or zero in
+which case PRINT-FUNCTION will be called with `print-level' and
+`print-length' bound to nil.
+
+Use this function with `cl-prin1' to print an object,
+abbreviating it with ellipses to fit within a size limit. Use
+this function with `cl-prin1-expand-ellipsis' to expand an
+ellipsis, abbreviating the expansion to stay within a size
+limit.
+
+\(fn PRINT-FUNCTION VALUE LIMIT)" nil nil)
+
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes
"cl-print" '("cl-print-" "help-byte-code")))
;;;***
@@ -11725,7 +11766,9 @@ This does nothing except loading eudc by autoload
side-effect.
\(fn)" t nil)
-(cond ((not (featurep 'xemacs)) (defvar eudc-tools-menu (let ((map
(make-sparse-keymap "Directory Servers"))) (define-key map [phone] `(menu-item
,(purecopy "Get Phone") eudc-get-phone :help ,(purecopy "Get the phone field of
name from the directory server"))) (define-key map [email] `(menu-item
,(purecopy "Get Email") eudc-get-email :help ,(purecopy "Get the email field of
NAME from the directory server"))) (define-key map [separator-eudc-email]
menu-bar-separator) (define-key map [expa [...]
+(defvar eudc-tools-menu (let ((map (make-sparse-keymap "Directory Servers")))
(define-key map [phone] `(menu-item ,(purecopy "Get Phone") eudc-get-phone
:help ,(purecopy "Get the phone field of name from the directory server")))
(define-key map [email] `(menu-item ,(purecopy "Get Email") eudc-get-email
:help ,(purecopy "Get the email field of NAME from the directory server")))
(define-key map [separator-eudc-email] menu-bar-separator) (define-key map
[expand-inline] `(menu-item ,(purecop [...]
+
+(fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu))
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes
"eudc" '("eudc-")))
@@ -16192,13 +16235,15 @@ highlighting will not update as you type.
(autoload 'hi-lock-face-buffer "hi-lock" "\
Set face of each match of REGEXP to FACE.
Interactively, prompt for REGEXP using `read-regexp', then FACE.
-Use the global history list for FACE.
+Use the global history list for FACE. Limit face setting to the
+corresponding SUBEXP (interactively, the prefix argument) of REGEXP.
+If SUBEXP is omitted or nil, the entire REGEXP is highlighted.
Use Font lock mode, if enabled, to highlight REGEXP. Otherwise,
use overlays for highlighting. If overlays are used, the
highlighting will not update as you type.
-\(fn REGEXP &optional FACE)" t nil)
+\(fn REGEXP &optional FACE SUBEXP)" t nil)
(defalias 'highlight-phrase 'hi-lock-face-phrase-buffer)
@@ -19201,7 +19246,7 @@ locally, like so:
;;;### (autoloads nil "jsonrpc" "jsonrpc.el" (0 0 0 0))
;;; Generated autoloads from jsonrpc.el
-(push (purecopy '(jsonrpc 1 0 0)) package--builtin-versions)
+(push (purecopy '(jsonrpc 1 0 6)) package--builtin-versions)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes
"jsonrpc" '("jrpc-default-request-timeout" "jsonrpc-")))
@@ -33694,7 +33739,7 @@ Compose Thai characters in the current buffer.
Move forward to the end of the Nth next THING.
THING should be a symbol specifying a type of syntactic entity.
Possibilities include `symbol', `list', `sexp', `defun',
-`filename', `url', `email', `word', `sentence', `whitespace',
+`filename', `url', `email', `uuid', `word', `sentence', `whitespace',
`line', and `page'.
\(fn THING &optional N)" nil nil)
@@ -33703,7 +33748,7 @@ Possibilities include `symbol', `list', `sexp', `defun',
Determine the start and end buffer locations for the THING at point.
THING should be a symbol specifying a type of syntactic entity.
Possibilities include `symbol', `list', `sexp', `defun',
-`filename', `url', `email', `word', `sentence', `whitespace',
+`filename', `url', `email', `uuid', `word', `sentence', `whitespace',
`line', and `page'.
See the file `thingatpt.el' for documentation on how to define a
@@ -33718,7 +33763,7 @@ positions of the thing found.
Return the THING at point.
THING should be a symbol specifying a type of syntactic entity.
Possibilities include `symbol', `list', `sexp', `defun',
-`filename', `url', `email', `word', `sentence', `whitespace',
+`filename', `url', `email', `uuid', `word', `sentence', `whitespace',
`line', `number', and `page'.
When the optional argument NO-PROPERTIES is non-nil,
@@ -33753,6 +33798,18 @@ Return the Lisp list at point, or nil if none is found.
;;;***
+;;;### (autoloads nil "thread" "emacs-lisp/thread.el" (0 0 0 0))
+;;; Generated autoloads from emacs-lisp/thread.el
+
+(autoload 'thread-handle-event "thread" "\
+Handle thread events, propagated by `thread-signal'.
+An EVENT has the format
+ (thread-event THREAD ERROR-SYMBOL DATA)
+
+\(fn EVENT)" t nil)
+
+;;;***
+
;;;### (autoloads nil "thumbs" "thumbs.el" (0 0 0 0))
;;; Generated autoloads from thumbs.el
@@ -34100,8 +34157,6 @@ The \"%z\" specifier does not print anything. When it
is used, specifiers
must be given in order of decreasing size. To the left of \"%z\", nothing
is output until the first non-zero unit is encountered.
-This function does not work for SECONDS greater than `most-positive-fixnum'.
-
\(fn STRING SECONDS)" nil nil)
(autoload 'seconds-to-string "time-date" "\
@@ -34569,6 +34624,7 @@ the output buffer or changing the window configuration.
;;;### (autoloads nil "tramp" "net/tramp.el" (0 0 0 0))
;;; Generated autoloads from net/tramp.el
+(push (purecopy '(tramp 2 4 1 -1)) package--builtin-versions)
(defvar tramp-mode t "\
Whether Tramp is enabled.
@@ -34719,7 +34775,6 @@ Reenable Ange-FTP, when Tramp is unloaded.
;;;### (autoloads nil "trampver" "net/trampver.el" (0 0 0 0))
;;; Generated autoloads from net/trampver.el
-(push (purecopy '(tramp 2 4 0)) package--builtin-versions)
(if (fboundp 'register-definition-prefixes) (register-definition-prefixes
"trampver" '("tramp-")))
@@ -38647,7 +38702,11 @@ Like `xref-find-definitions' but switch to the other
frame.
(autoload 'xref-find-references "xref" "\
Find references to the identifier at point.
-With prefix argument, prompt for the identifier.
+This command might prompt for the identifier as needed, perhaps
+offering the symbol at point as the default.
+With prefix argument, or if `xref-prompt-for-identifier' is t,
+always prompt for the identifier. If `xref-prompt-for-identifier'
+is nil, prompt only if there's no usable symbol at point.
\(fn IDENTIFIER)" t nil)
diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el
index 92b005d..8cacad8 100644
--- a/lisp/mail/emacsbug.el
+++ b/lisp/mail/emacsbug.el
@@ -134,22 +134,7 @@ This requires either the macOS \"open\" command, or the
freedesktop
os))
((eq system-type 'windows-nt)
(or report-emacs-bug--os-description
- (setq
- report-emacs-bug--os-description
- (let (os)
- (with-temp-buffer
- ;; Seems like this command can be slow, because it
- ;; unconditionally queries a bunch of other stuff
- ;; we don't care about.
- (when (eq 0 (ignore-errors
- (call-process "systeminfo" nil '(t nil) nil)))
- (dolist (s '("OS Name" "OS Version"))
- (goto-char (point-min))
- (if (re-search-forward
- (format "^%s\\s-*:\\s-+\\(.*\\)$" s)
- nil t)
- (setq os (concat os " " (match-string 1)))))))
- os))))
+ (setq report-emacs-bug--os-description (w32--os-description))))
((eq system-type 'berkeley-unix)
(with-temp-buffer
(when
diff --git a/lisp/mh-e/mh-junk.el b/lisp/mh-e/mh-junk.el
index 6122606..0a50e02 100644
--- a/lisp/mh-e/mh-junk.el
+++ b/lisp/mh-e/mh-junk.el
@@ -108,8 +108,7 @@ message(s) as specified by the option
`mh-junk-disposition'."
(mh-iterate-on-range msg range
(message "Blacklisting message %d..." msg)
(funcall (symbol-function blacklist-func) msg)
- (message "Blacklisting message %d...done" msg))
- (mh-next-msg)))
+ (message "Blacklisting message %d...done" msg))))
;;;###mh-autoload
(defun mh-junk-whitelist (range)
@@ -164,8 +163,7 @@ classified as spam (see the option `mh-junk-program')."
(mh-iterate-on-range msg range
(message "Whitelisting message %d..." msg)
(funcall (symbol-function whitelist-func) msg)
- (message "Whitelisting message %d...done" msg))
- (mh-next-msg)))
+ (message "Whitelisting message %d...done" msg))))
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index c87cb22..7425c8d 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -4664,8 +4664,10 @@ Only works for Bourne-like shells."
(defun tramp-eshell-directory-change ()
"Set `eshell-path-env' to $PATH of the host related to `default-directory'."
;; Remove last element of `(exec-path)', which is `exec-directory'.
+ ;; Use `path-separator' as it does eshell.
(setq eshell-path-env
- (mapconcat 'identity (butlast (tramp-compat-exec-path)) ":")))
+ (mapconcat
+ 'identity (butlast (tramp-compat-exec-path)) path-separator)))
(eval-after-load "esh-util"
'(progn
diff --git a/lisp/server.el b/lisp/server.el
index 77850e4..fd02448 100644
--- a/lisp/server.el
+++ b/lisp/server.el
@@ -1297,7 +1297,7 @@ The following commands are accepted by the client:
(server-execute-continuation proc))))
;; condition-case
- (error (server-return-error proc err))))
+ (t (server-return-error proc err))))
(defun server-execute (proc files nowait commands dontkill create-frame-func
tty-name)
;; This is run from timers and process-filters, i.e. "asynchronously".
diff --git a/lisp/thread.el b/lisp/thread.el
new file mode 100644
index 0000000..1c5dccf
--- /dev/null
+++ b/lisp/thread.el
@@ -0,0 +1,200 @@
+;;; thread.el --- Thread support in Emacs Lisp -*- lexical-binding: t -*-
+
+;; Copyright (C) 2018 Free Software Foundation, Inc.
+
+;; Author: Gemini Lasswell <address@hidden>
+;; Maintainer: address@hidden
+;; Keywords: thread, tools
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'backtrace)
+(require 'pcase)
+(require 'subr-x)
+
+;;;###autoload
+(defun thread-handle-event (event)
+ "Handle thread events, propagated by `thread-signal'.
+An EVENT has the format
+ (thread-event THREAD ERROR-SYMBOL DATA)"
+ (interactive "e")
+ (if (and (consp event)
+ (eq (car event) 'thread-event)
+ (= (length event) 4))
+ (let ((thread (cadr event))
+ (err (cddr event)))
+ (message "Error %s: %S" thread err))))
+
+(make-obsolete 'thread-alive-p 'thread-live-p "27.1")
+
+;;; The thread list buffer and list-threads command
+
+(defcustom thread-list-refresh-seconds 0.5
+ "Seconds between automatic refreshes of the *Threads* buffer."
+ :group 'thread-list
+ :type 'number
+ :version "27.1")
+
+(defvar thread-list-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map tabulated-list-mode-map)
+ (define-key map "b" #'thread-list-pop-to-backtrace)
+ (define-key map "s" nil)
+ (define-key map "sq" #'thread-list-send-quit-signal)
+ (define-key map "se" #'thread-list-send-error-signal)
+ (easy-menu-define nil map ""
+ '("Threads"
+ ["Show backtrace" thread-list-pop-to-backtrace t]
+ ["Send Quit Signal" thread-list-send-quit-signal t]
+ ["Send Error Signal" thread-list-send-error-signal t]))
+ map)
+ "Local keymap for `thread-list-mode' buffers.")
+
+(define-derived-mode thread-list-mode tabulated-list-mode "Thread-List"
+ "Major mode for monitoring Lisp threads."
+ (setq tabulated-list-format
+ [("Thread Name" 20 t)
+ ("Status" 10 t)
+ ("Blocked On" 30 t)])
+ (setq tabulated-list-sort-key (cons (car (aref tabulated-list-format 0))
nil))
+ (setq tabulated-list-entries #'thread-list--get-entries)
+ (tabulated-list-init-header))
+
+;;;###autoload
+(defun list-threads ()
+ "Display a list of threads."
+ (interactive)
+ ;; Threads may not exist, if Emacs was configured --without-threads.
+ (unless (bound-and-true-p main-thread)
+ (error "Threads are not supported in this configuration"))
+ ;; Generate the Threads list buffer, and switch to it.
+ (let ((buf (get-buffer-create "*Threads*")))
+ (with-current-buffer buf
+ (unless (derived-mode-p 'thread-list-mode)
+ (thread-list-mode)
+ (run-at-time thread-list-refresh-seconds nil
+ #'thread-list--timer-func buf))
+ (revert-buffer))
+ (switch-to-buffer buf)))
+;; This command can be destructive if they don't know what they are
+;; doing. Kids, don't try this at home!
+;;;###autoload (put 'list-threads 'disabled "Beware: manually canceling
threads can ruin your Emacs session.")
+
+(defun thread-list--timer-func (buffer)
+ "Revert BUFFER and set a timer to do it again."
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (revert-buffer))
+ (run-at-time thread-list-refresh-seconds nil
+ #'thread-list--timer-func buffer)))
+
+(defun thread-list--get-entries ()
+ "Return tabulated list entries for the currently live threads."
+ (let (entries)
+ (dolist (thread (all-threads))
+ (pcase-let ((`(,status ,blocker) (thread-list--get-status thread)))
+ (push `(,thread [,(thread-list--name thread)
+ ,status ,blocker])
+ entries)))
+ entries))
+
+(defun thread-list--get-status (thread)
+ "Describe the status of THREAD.
+Return a list of two strings, one describing THREAD's status, the
+other describing THREAD's blocker, if any."
+ (cond
+ ((not (thread-live-p thread)) '("Finished" ""))
+ ((eq thread (current-thread)) '("Running" ""))
+ (t (if-let ((blocker (thread--blocker thread)))
+ `("Blocked" ,(prin1-to-string blocker))
+ '("Yielded" "")))))
+
+(defun thread-list-send-quit-signal ()
+ "Send a quit signal to the thread at point."
+ (interactive)
+ (thread-list--send-signal 'quit))
+
+(defun thread-list-send-error-signal ()
+ "Send an error signal to the thread at point."
+ (interactive)
+ (thread-list--send-signal 'error))
+
+(defun thread-list--send-signal (signal)
+ "Send the specified SIGNAL to the thread at point.
+Ask for user confirmation before signaling the thread."
+ (let ((thread (tabulated-list-get-id)))
+ (if (thread-live-p thread)
+ (when (y-or-n-p (format "Send %s signal to %s? " signal thread))
+ (if (thread-live-p thread)
+ (thread-signal thread signal nil)
+ (message "This thread is no longer alive")))
+ (message "This thread is no longer alive"))))
+
+(defvar-local thread-list-backtrace--thread nil
+ "Thread whose backtrace is displayed in the current buffer.")
+
+(defun thread-list-pop-to-backtrace ()
+ "Display the backtrace for the thread at point."
+ (interactive)
+ (let ((thread (tabulated-list-get-id)))
+ (if (thread-live-p thread)
+ (let ((buffer (get-buffer-create "*Thread Backtrace*")))
+ (pop-to-buffer buffer)
+ (unless (derived-mode-p 'backtrace-mode)
+ (backtrace-mode)
+ (add-hook 'backtrace-revert-hook
+ #'thread-list-backtrace--revert-hook-function)
+ (setq backtrace-insert-header-function
+ #'thread-list-backtrace--insert-header))
+ (setq thread-list-backtrace--thread thread)
+ (thread-list-backtrace--revert-hook-function)
+ (backtrace-print)
+ (goto-char (point-min)))
+ (message "This thread is no longer alive"))))
+
+(defun thread-list-backtrace--revert-hook-function ()
+ (setq backtrace-frames
+ (when (thread-live-p thread-list-backtrace--thread)
+ (mapcar #'thread-list--make-backtrace-frame
+ (backtrace--frames-from-thread
+ thread-list-backtrace--thread)))))
+
+(cl-defun thread-list--make-backtrace-frame ((evald fun &rest args))
+ (backtrace-make-frame :evald evald :fun fun :args args))
+
+(defun thread-list-backtrace--insert-header ()
+ (let ((name (thread-list--name thread-list-backtrace--thread)))
+ (if (thread-live-p thread-list-backtrace--thread)
+ (progn
+ (insert (substitute-command-keys "Backtrace for thread `"))
+ (insert name)
+ (insert (substitute-command-keys "':\n")))
+ (insert (substitute-command-keys "Thread `"))
+ (insert name)
+ (insert (substitute-command-keys "' is no longer running\n")))))
+
+(defun thread-list--name (thread)
+ (or (thread-name thread)
+ (and (eq thread main-thread) "Main")
+ (prin1-to-string thread)))
+
+(provide 'thread)
+;;; thread.el ends here
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index 96c2f38..69d6295 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -179,6 +179,14 @@ Should be consistent with the Git config value
i18n.logOutputEncoding."
:type '(coding-system :tag "Coding system to decode Git log output")
:version "25.1")
+(defcustom vc-git-grep-template "git --no-pager grep -n -e <R> -- <F>"
+ "The default command to run for \\[vc-git-grep].
+The following place holders should be present in the string:
+ <F> - file names and wildcards to search.
+ <R> - the regular expression searched for."
+ :type 'string
+ :version "27.1")
+
;; History of Git commands.
(defvar vc-git-history nil)
@@ -1449,7 +1457,7 @@ This command shares argument histories with \\[rgrep] and
\\[grep]."
(setq command nil))
(setq dir (file-name-as-directory (expand-file-name dir)))
(setq command
- (grep-expand-template "git --no-pager grep -n -e <R> -- <F>"
+ (grep-expand-template vc-git-grep-template
regexp files))
(when command
(if (equal current-prefix-arg '(4))
diff --git a/lisp/w32-fns.el b/lisp/w32-fns.el
index a8a41c4..91fe518 100644
--- a/lisp/w32-fns.el
+++ b/lisp/w32-fns.el
@@ -39,6 +39,8 @@
;; same buffer.
(setq find-file-visit-truename t))
+;;;; Shells
+
(defun w32-shell-name ()
"Return the name of the shell being used."
(or (bound-and-true-p shell-file-name)
@@ -120,6 +122,8 @@ You should set this to t when using a non-system
shell.\n\n"))))
(add-hook 'after-init-hook 'w32-check-shell-configuration)
+;;;; Coding-systems, locales, etc.
+
;; Override setting chosen at startup.
(defun w32-set-default-process-coding-system ()
;; Most programs on Windows will accept Unix line endings on input
@@ -187,31 +191,6 @@ You should set this to t when using a non-system
shell.\n\n"))))
;; (setq source-directory (file-name-as-directory
;; (expand-file-name ".." exec-directory)))))
-(defun w32-convert-standard-filename (filename)
- "Convert a standard file's name to something suitable for MS-Windows.
-This means to guarantee valid names and perhaps to canonicalize
-certain patterns.
-
-This function is called by `convert-standard-filename'.
-
-Replace invalid characters and turn Cygwin names into native
-names."
- (save-match-data
- (let ((name
- (if (string-match "\\`/cygdrive/\\([a-zA-Z]\\)/" filename)
- (replace-match "\\1:/" t nil filename)
- (copy-sequence filename)))
- (start 0))
- ;; leave ':' if part of drive specifier
- (if (and (> (length name) 1)
- (eq (aref name 1) ?:))
- (setq start 2))
- ;; destructively replace invalid filename characters with !
- (while (string-match "[?*:<>|\"\000-\037]" name start)
- (aset name (match-beginning 0) ?!)
- (setq start (match-end 0)))
- name)))
-
(defun w32-set-system-coding-system (coding-system)
"Set the coding system used by the Windows system to CODING-SYSTEM.
This is used for things like passing font names with non-ASCII
@@ -297,6 +276,76 @@ bit output with no translation."
(w32-add-charset-info "tis620-0" 'w32-charset-thai 874)
(w32-add-charset-info "iso8859-1" 'w32-charset-ansi 1252))
+;;;; Standard filenames
+
+(defun w32-convert-standard-filename (filename)
+ "Convert a standard file's name to something suitable for MS-Windows.
+This means to guarantee valid names and perhaps to canonicalize
+certain patterns.
+
+This function is called by `convert-standard-filename'.
+
+Replace invalid characters and turn Cygwin names into native
+names."
+ (save-match-data
+ (let ((name
+ (if (string-match "\\`/cygdrive/\\([a-zA-Z]\\)/" filename)
+ (replace-match "\\1:/" t nil filename)
+ (copy-sequence filename)))
+ (start 0))
+ ;; leave ':' if part of drive specifier
+ (if (and (> (length name) 1)
+ (eq (aref name 1) ?:))
+ (setq start 2))
+ ;; destructively replace invalid filename characters with !
+ (while (string-match "[?*:<>|\"\000-\037]" name start)
+ (aset name (match-beginning 0) ?!)
+ (setq start (match-end 0)))
+ name)))
+
+;;;; System name and version for emacsbug.el
+
+(defun w32--os-description ()
+ "Return a string describing the underlying OS and its version."
+ (let* ((w32ver (car (w32-version)))
+ (w9x-p (< w32ver 5))
+ (key (if w9x-p
+ "SOFTWARE/Microsoft/Windows/CurrentVersion"
+ "SOFTWARE/Microsoft/Windows NT/CurrentVersion"))
+ (os-name (w32-read-registry 'HKLM key "ProductName"))
+ (os-version (if w9x-p
+ (w32-read-registry 'HKLM key "VersionNumber")
+ (let ((vmajor
+ (w32-read-registry 'HKLM key
+ "CurrentMajorVersionNumber"))
+ (vminor
+ (w32-read-registry 'HKLM key
+ "CurrentMinorVersionNumber")))
+ (if (and vmajor vmajor)
+ (format "%d.%d" vmajor vminor)
+ (w32-read-registry 'HKLM key "CurrentVersion")))))
+ (os-csd (w32-read-registry 'HKLM key "CSDVersion"))
+ (os-rel (or (w32-read-registry 'HKLM key "ReleaseID")
+ (w32-read-registry 'HKLM key "CSDBuildNumber")
+ "0")) ; No Release ID before Windows Vista
+ (os-build (w32-read-registry 'HKLM key "CurrentBuildNumber"))
+ (os-rev (w32-read-registry 'HKLM key "UBR"))
+ (os-rev (if os-rev (format "%d" os-rev))))
+ (if w9x-p
+ (concat
+ (if (not (string-match "\\`Microsoft " os-name)) "Microsoft ")
+ os-name
+ " (v" os-version ")")
+ (concat
+ (if (not (string-match "\\`Microsoft " os-name)) "Microsoft ")
+ os-name ; Windows 7 Enterprise
+ " "
+ os-csd ; Service Pack 1
+ (if (and os-csd (> (length os-csd) 0)) " " "")
+ "(v"
+ os-version "." os-rel "." os-build (if os-rev (concat "." os-rev))
+ ")"))))
+
;;;; Support for build process
diff --git a/src/alloc.c b/src/alloc.c
index 1eab82d..abb98a9 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -641,9 +641,11 @@ buffer_memory_full (ptrdiff_t nbytes)
implement Lisp objects; since pseudovectors can contain any C type,
this is max_align_t. On recent GNU/Linux x86 and x86-64 this can
often waste up to 8 bytes, since alignof (max_align_t) is 16 but
- typical vectors need only an alignment of 8. However, it is not
- worth the hassle to avoid this waste. */
-enum { LISP_ALIGNMENT = alignof (union { max_align_t x; GCALIGNED_UNION }) };
+ typical vectors need only an alignment of 8. Although shrinking
+ the alignment to 8 would save memory, it cost a 20% hit to Emacs
+ CPU performance on Fedora 28 x86-64 when compiled with gcc -m32. */
+enum { LISP_ALIGNMENT = alignof (union { max_align_t x;
+ GCALIGNED_UNION_MEMBER }) };
verify (LISP_ALIGNMENT % GCALIGNMENT == 0);
/* True if malloc (N) is known to return storage suitably aligned for
@@ -7126,18 +7128,6 @@ range_error (void)
xsignal0 (Qrange_error);
}
-static void *
-xrealloc_for_gmp (void *ptr, size_t ignore, size_t size)
-{
- return xrealloc (ptr, size);
-}
-
-static void
-xfree_for_gmp (void *ptr, size_t ignore)
-{
- xfree (ptr);
-}
-
/* Initialization. */
void
@@ -7171,10 +7161,6 @@ init_alloc_once (void)
void
init_alloc (void)
{
- eassert (mp_bits_per_limb == GMP_NUMB_BITS);
- integer_width = 1 << 16;
- mp_set_memory_functions (xmalloc, xrealloc_for_gmp, xfree_for_gmp);
-
Vgc_elapsed = make_float (0.0);
gcs_done = 0;
diff --git a/src/bignum.c b/src/bignum.c
index b18cecc..35894f5 100644
--- a/src/bignum.c
+++ b/src/bignum.c
@@ -25,6 +25,38 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include <stdlib.h>
+/* mpz global temporaries. Making them global saves the trouble of
+ properly using mpz_init and mpz_clear on temporaries even when
+ storage is exhausted. Admittedly this is not ideal. An mpz value
+ in a temporary is made permanent by mpz_swapping it with a bignum's
+ value. Although typically at most two temporaries are needed,
+ rounding_driver and rounddiv_q need four altogther. */
+
+mpz_t mpz[4];
+
+static void *
+xrealloc_for_gmp (void *ptr, size_t ignore, size_t size)
+{
+ return xrealloc (ptr, size);
+}
+
+static void
+xfree_for_gmp (void *ptr, size_t ignore)
+{
+ xfree (ptr);
+}
+
+void
+init_bignum (void)
+{
+ eassert (mp_bits_per_limb == GMP_NUMB_BITS);
+ integer_width = 1 << 16;
+ mp_set_memory_functions (xmalloc, xrealloc_for_gmp, xfree_for_gmp);
+
+ for (int i = 0; i < ARRAYELTS (mpz); i++)
+ mpz_init (mpz[i]);
+}
+
/* Return the value of the Lisp bignum N, as a double. */
double
bignum_to_double (Lisp_Object n)
@@ -36,17 +68,14 @@ bignum_to_double (Lisp_Object n)
Lisp_Object
double_to_bignum (double d)
{
- mpz_t z;
- mpz_init_set_d (z, d);
- Lisp_Object result = make_integer (z);
- mpz_clear (z);
- return result;
+ mpz_set_d (mpz[0], d);
+ return make_integer_mpz ();
}
-/* Return a Lisp integer equal to OP, which has BITS bits and which
- must not be in fixnum range. */
+/* Return a Lisp integer equal to mpz[0], which has BITS bits and which
+ must not be in fixnum range. Set mpz[0] to a junk value. */
static Lisp_Object
-make_bignum_bits (mpz_t const op, size_t bits)
+make_bignum_bits (size_t bits)
{
/* The documentation says integer-width should be nonnegative, so
a single comparison suffices even though 'bits' is unsigned. */
@@ -55,18 +84,17 @@ make_bignum_bits (mpz_t const op, size_t bits)
struct Lisp_Bignum *b = ALLOCATE_PSEUDOVECTOR (struct Lisp_Bignum, value,
PVEC_BIGNUM);
- /* We could mpz_init + mpz_swap here, to avoid a copy, but the
- resulting API seemed possibly confusing. */
- mpz_init_set (b->value, op);
-
+ mpz_init (b->value);
+ mpz_swap (b->value, mpz[0]);
return make_lisp_ptr (b, Lisp_Vectorlike);
}
-/* Return a Lisp integer equal to OP, which must not be in fixnum range. */
+/* Return a Lisp integer equal to mpz[0], which must not be in fixnum range.
+ Set mpz[0] to a junk value. */
static Lisp_Object
-make_bignum (mpz_t const op)
+make_bignum (void)
{
- return make_bignum_bits (op, mpz_sizeinbase (op, 2));
+ return make_bignum_bits (mpz_sizeinbase (mpz[0], 2));
}
static void mpz_set_uintmax_slow (mpz_t, uintmax_t);
@@ -86,30 +114,23 @@ Lisp_Object
make_bigint (intmax_t n)
{
eassert (FIXNUM_OVERFLOW_P (n));
- mpz_t z;
- mpz_init (z);
- mpz_set_intmax (z, n);
- Lisp_Object result = make_bignum (z);
- mpz_clear (z);
- return result;
+ mpz_set_intmax (mpz[0], n);
+ return make_bignum ();
}
Lisp_Object
make_biguint (uintmax_t n)
{
eassert (FIXNUM_OVERFLOW_P (n));
- mpz_t z;
- mpz_init (z);
- mpz_set_uintmax (z, n);
- Lisp_Object result = make_bignum (z);
- mpz_clear (z);
- return result;
+ mpz_set_uintmax (mpz[0], n);
+ return make_bignum ();
}
-/* Return a Lisp integer with value taken from OP. */
+/* Return a Lisp integer with value taken from mpz[0].
+ Set mpz[0] to a junk value. */
Lisp_Object
-make_integer (mpz_t const op)
+make_integer_mpz (void)
{
- size_t bits = mpz_sizeinbase (op, 2);
+ size_t bits = mpz_sizeinbase (mpz[0], 2);
if (bits <= FIXNUM_BITS)
{
@@ -118,20 +139,20 @@ make_integer (mpz_t const op)
do
{
- EMACS_INT limb = mpz_getlimbn (op, i++);
+ EMACS_INT limb = mpz_getlimbn (mpz[0], i++);
v += limb << shift;
shift += GMP_NUMB_BITS;
}
while (shift < bits);
- if (mpz_sgn (op) < 0)
+ if (mpz_sgn (mpz[0]) < 0)
v = -v;
if (!FIXNUM_OVERFLOW_P (v))
return make_fixnum (v);
}
- return make_bignum_bits (op, bits);
+ return make_bignum_bits (bits);
}
/* Set RESULT to V. This code is for when intmax_t is wider than long. */
diff --git a/src/bignum.h b/src/bignum.h
index a368333..6551549 100644
--- a/src/bignum.h
+++ b/src/bignum.h
@@ -39,9 +39,12 @@ struct Lisp_Bignum
{
union vectorlike_header header;
mpz_t value;
-};
+} GCALIGNED_STRUCT;
-extern Lisp_Object make_integer (mpz_t const) ARG_NONNULL ((1));
+extern mpz_t mpz[4];
+
+extern void init_bignum (void);
+extern Lisp_Object make_integer_mpz (void);
extern void mpz_set_intmax_slow (mpz_t, intmax_t) ARG_NONNULL ((1));
INLINE_HEADER_BEGIN
@@ -65,6 +68,20 @@ mpz_set_intmax (mpz_t result, intmax_t v)
mpz_set_intmax_slow (result, v);
}
+/* Return a pointer to an mpz_t that is equal to the Lisp integer I.
+ If I is a bignum this returns a pointer to I's representation;
+ otherwise this sets *TMP to I's value and returns TMP. */
+INLINE mpz_t *
+bignum_integer (mpz_t *tmp, Lisp_Object i)
+{
+ if (FIXNUMP (i))
+ {
+ mpz_set_intmax (*tmp, XFIXNUM (i));
+ return tmp;
+ }
+ return &XBIGNUM (i)->value;
+}
+
INLINE_HEADER_END
#endif /* BIGNUM_H */
diff --git a/src/charset.c b/src/charset.c
index 7b272a2..e11a836 100644
--- a/src/charset.c
+++ b/src/charset.c
@@ -1870,7 +1870,9 @@ although this usage is obsolescent. */)
DEFUN ("encode-char", Fencode_char, Sencode_char, 2, 2, 0,
doc: /* Encode the character CH into a code-point of CHARSET.
-Return nil if CHARSET doesn't include CH. */)
+Return the encoded code-point, a fixnum if its value is small enough,
+otherwise a bignum.
+Return nil if CHARSET doesn't support CH. */)
(Lisp_Object ch, Lisp_Object charset)
{
int c, id;
diff --git a/src/data.c b/src/data.c
index 6afda1e..66f69e7 100644
--- a/src/data.c
+++ b/src/data.c
@@ -2653,17 +2653,7 @@ cons_to_unsigned (Lisp_Object c, uintmax_t max)
else
{
Lisp_Object hi = CONSP (c) ? XCAR (c) : c;
-
- if (FIXNUMP (hi))
- {
- val = XFIXNUM (hi);
- valid = 0 <= val;
- }
- else
- {
- val = bignum_to_uintmax (hi);
- valid = val != 0;
- }
+ valid = integer_to_uintmax (hi, &val);
if (valid && CONSP (c))
{
@@ -2724,17 +2714,7 @@ cons_to_signed (Lisp_Object c, intmax_t min, intmax_t
max)
else
{
Lisp_Object hi = CONSP (c) ? XCAR (c) : c;
-
- if (FIXNUMP (hi))
- {
- val = XFIXNUM (hi);
- valid = true;
- }
- else if (BIGNUMP (hi))
- {
- val = bignum_to_intmax (hi);
- valid = val != 0;
- }
+ valid = integer_to_intmax (hi, &val);
if (valid && CONSP (c))
{
@@ -2832,232 +2812,178 @@ enum arithop
Alogior,
Alogxor
};
-
-enum { FIXNUMS_FIT_IN_LONG = (LONG_MIN <= MOST_NEGATIVE_FIXNUM
- && MOST_POSITIVE_FIXNUM <= LONG_MAX) };
-
-static void
-free_mpz_value (void *value_ptr)
+static bool
+floating_point_op (enum arithop code)
{
- mpz_clear (*(mpz_t *) value_ptr);
+ return code <= Adiv;
}
-static Lisp_Object float_arith_driver (double, ptrdiff_t, enum arithop,
- ptrdiff_t, Lisp_Object *);
+/* Return the result of applying the floating-point operation CODE to
+ the NARGS arguments starting at ARGS. If ARGNUM is positive,
+ ARGNUM of the arguments were already consumed, yielding ACCUM.
+ 0 <= ARGNUM < NARGS, 2 <= NARGS, and NEXT is the value of
+ ARGS[ARGSNUM], converted to double. */
static Lisp_Object
-arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args)
+floatop_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args,
+ ptrdiff_t argnum, double accum, double next)
{
- Lisp_Object val = Qnil;
- ptrdiff_t argnum;
- ptrdiff_t count = SPECPDL_INDEX ();
- mpz_t accum;
-
- mpz_init (accum);
- record_unwind_protect_ptr (free_mpz_value, &accum);
-
- switch (code)
+ if (argnum == 0)
{
- case Alogior:
- case Alogxor:
- case Aadd:
- case Asub:
- /* ACCUM is already 0. */
- break;
- case Amult:
- case Adiv:
- mpz_set_si (accum, 1);
- break;
- case Alogand:
- mpz_set_si (accum, -1);
- break;
- default:
- break;
+ accum = next;
+ goto next_arg;
}
- for (argnum = 0; argnum < nargs; argnum++)
+ while (true)
{
- /* Using args[argnum] as argument to CHECK_NUMBER... */
- val = args[argnum];
- CHECK_NUMBER_COERCE_MARKER (val);
-
- if (FLOATP (val))
- return unbind_to (count,
- float_arith_driver (mpz_get_d (accum), argnum, code,
- nargs, args));
switch (code)
{
- case Aadd:
- if (BIGNUMP (val))
- mpz_add (accum, accum, XBIGNUM (val)->value);
- else if (! FIXNUMS_FIT_IN_LONG)
- {
- mpz_t tem;
- mpz_init (tem);
- mpz_set_intmax (tem, XFIXNUM (val));
- mpz_add (accum, accum, tem);
- mpz_clear (tem);
- }
- else if (XFIXNUM (val) < 0)
- mpz_sub_ui (accum, accum, - XFIXNUM (val));
- else
- mpz_add_ui (accum, accum, XFIXNUM (val));
- break;
- case Asub:
- if (! argnum)
- {
- if (BIGNUMP (val))
- mpz_set (accum, XBIGNUM (val)->value);
- else
- mpz_set_intmax (accum, XFIXNUM (val));
- if (nargs == 1)
- mpz_neg (accum, accum);
- }
- else if (BIGNUMP (val))
- mpz_sub (accum, accum, XBIGNUM (val)->value);
- else if (! FIXNUMS_FIT_IN_LONG)
- {
- mpz_t tem;
- mpz_init (tem);
- mpz_set_intmax (tem, XFIXNUM (val));
- mpz_sub (accum, accum, tem);
- mpz_clear (tem);
- }
- else if (XFIXNUM (val) < 0)
- mpz_add_ui (accum, accum, - XFIXNUM (val));
- else
- mpz_sub_ui (accum, accum, XFIXNUM (val));
- break;
- case Amult:
- if (BIGNUMP (val))
- emacs_mpz_mul (accum, accum, XBIGNUM (val)->value);
- else if (! FIXNUMS_FIT_IN_LONG)
- {
- mpz_t tem;
- mpz_init (tem);
- mpz_set_intmax (tem, XFIXNUM (val));
- emacs_mpz_mul (accum, accum, tem);
- mpz_clear (tem);
- }
- else
- mpz_mul_si (accum, accum, XFIXNUM (val));
- break;
+ case Aadd : accum += next; break;
+ case Asub : accum -= next; break;
+ case Amult: accum *= next; break;
case Adiv:
- if (! (argnum || nargs == 1))
- {
- if (BIGNUMP (val))
- mpz_set (accum, XBIGNUM (val)->value);
- else
- mpz_set_intmax (accum, XFIXNUM (val));
- }
- else
- {
- /* Note that a bignum can never be 0, so we don't need
- to check that case. */
- if (BIGNUMP (val))
- mpz_tdiv_q (accum, accum, XBIGNUM (val)->value);
- else if (XFIXNUM (val) == 0)
- xsignal0 (Qarith_error);
- else if (ULONG_MAX < -MOST_NEGATIVE_FIXNUM)
- {
- mpz_t tem;
- mpz_init (tem);
- mpz_set_intmax (tem, XFIXNUM (val));
- mpz_tdiv_q (accum, accum, tem);
- mpz_clear (tem);
- }
- else
- {
- EMACS_INT value = XFIXNUM (val);
- mpz_tdiv_q_ui (accum, accum, eabs (value));
- if (value < 0)
- mpz_neg (accum, accum);
- }
- }
- break;
- case Alogand:
- if (BIGNUMP (val))
- mpz_and (accum, accum, XBIGNUM (val)->value);
- else
- {
- mpz_t tem;
- mpz_init (tem);
- mpz_set_intmax (tem, XFIXNUM (val));
- mpz_and (accum, accum, tem);
- mpz_clear (tem);
- }
- break;
- case Alogior:
- if (BIGNUMP (val))
- mpz_ior (accum, accum, XBIGNUM (val)->value);
- else
- {
- mpz_t tem;
- mpz_init (tem);
- mpz_set_intmax (tem, XFIXNUM (val));
- mpz_ior (accum, accum, tem);
- mpz_clear (tem);
- }
- break;
- case Alogxor:
- if (BIGNUMP (val))
- mpz_xor (accum, accum, XBIGNUM (val)->value);
- else
- {
- mpz_t tem;
- mpz_init (tem);
- mpz_set_intmax (tem, XFIXNUM (val));
- mpz_xor (accum, accum, tem);
- mpz_clear (tem);
- }
+ if (! IEEE_FLOATING_POINT && next == 0)
+ xsignal0 (Qarith_error);
+ accum /= next;
break;
+ default: eassume (false);
}
+
+ next_arg:
+ argnum++;
+ if (argnum == nargs)
+ return make_float (accum);
+ Lisp_Object val = args[argnum];
+ CHECK_NUMBER_COERCE_MARKER (val);
+ next = XFLOATINT (val);
}
+}
- return unbind_to (count, make_integer (accum));
+/* Like floatop_arith_driver, except CODE might not be a floating-point
+ operation, and NEXT is a Lisp float rather than a C double. */
+
+static Lisp_Object
+float_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args,
+ ptrdiff_t argnum, double accum, Lisp_Object next)
+{
+ if (! floating_point_op (code))
+ wrong_type_argument (Qinteger_or_marker_p, next);
+ return floatop_arith_driver (code, nargs, args, argnum, accum,
+ XFLOAT_DATA (next));
}
+/* Return the result of applying the arithmetic operation CODE to the
+ NARGS arguments starting at ARGS. If ARGNUM is positive, ARGNUM of
+ the arguments were already consumed, yielding IACCUM. 0 <= ARGNUM
+ < NARGS, 2 <= NARGS, and VAL is the value of ARGS[ARGSNUM],
+ converted to integer. */
+
static Lisp_Object
-float_arith_driver (double accum, ptrdiff_t argnum, enum arithop code,
- ptrdiff_t nargs, Lisp_Object *args)
+bignum_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args,
+ ptrdiff_t argnum, intmax_t iaccum, Lisp_Object val)
{
- for (; argnum < nargs; argnum++)
+ mpz_t *accum;
+ if (argnum == 0)
{
- Lisp_Object val = args[argnum];
- CHECK_NUMBER_COERCE_MARKER (val);
- double next = (FIXNUMP (val) ? XFIXNUM (val)
- : FLOATP (val) ? XFLOAT_DATA (val)
- : mpz_get_d (XBIGNUM (val)->value));
+ accum = bignum_integer (&mpz[0], val);
+ goto next_arg;
+ }
+ mpz_set_intmax (mpz[0], iaccum);
+ accum = &mpz[0];
+
+ while (true)
+ {
+ mpz_t *next = bignum_integer (&mpz[1], val);
switch (code)
{
- case Aadd:
- accum += next;
- break;
- case Asub:
- accum = argnum ? accum - next : nargs == 1 ? - next : next;
- break;
- case Amult:
- accum *= next;
- break;
+ case Aadd : mpz_add (mpz[0], *accum, *next); break;
+ case Asub : mpz_sub (mpz[0], *accum, *next); break;
+ case Amult : emacs_mpz_mul (mpz[0], *accum, *next); break;
+ case Alogand: mpz_and (mpz[0], *accum, *next); break;
+ case Alogior: mpz_ior (mpz[0], *accum, *next); break;
+ case Alogxor: mpz_xor (mpz[0], *accum, *next); break;
case Adiv:
- if (! (argnum || nargs == 1))
- accum = next;
- else
- {
- if (! IEEE_FLOATING_POINT && next == 0)
- xsignal0 (Qarith_error);
- accum /= next;
- }
+ if (mpz_sgn (*next) == 0)
+ xsignal0 (Qarith_error);
+ mpz_tdiv_q (mpz[0], *accum, *next);
break;
- case Alogand:
- case Alogior:
- case Alogxor:
- wrong_type_argument (Qinteger_or_marker_p, val);
+ default:
+ eassume (false);
}
+ accum = &mpz[0];
+
+ next_arg:
+ argnum++;
+ if (argnum == nargs)
+ return make_integer_mpz ();
+ val = args[argnum];
+ CHECK_NUMBER_COERCE_MARKER (val);
+ if (FLOATP (val))
+ float_arith_driver (code, nargs, args, argnum,
+ mpz_get_d (*accum), val);
}
+}
+
+/* Return the result of applying the arithmetic operation CODE to the
+ NARGS arguments starting at ARGS, with the first argument being the
+ number VAL. 2 <= NARGS. Check that the remaining arguments are
+ numbers or markers. */
+
+static Lisp_Object
+arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args,
+ Lisp_Object val)
+{
+ eassume (2 <= nargs);
+
+ ptrdiff_t argnum = 0;
+ /* Set ACCUM to VAL's value if it is a fixnum, otherwise to some
+ ignored value to avoid using an uninitialized variable later. */
+ intmax_t accum = XFIXNUM (val);
- return make_float (accum);
+ if (FIXNUMP (val))
+ while (true)
+ {
+ argnum++;
+ if (argnum == nargs)
+ return make_int (accum);
+ val = args[argnum];
+ CHECK_NUMBER_COERCE_MARKER (val);
+
+ /* Set NEXT to the next value if it fits, else exit the loop. */
+ intmax_t next;
+ if (! (INTEGERP (val) && integer_to_intmax (val, &next)))
+ break;
+
+ /* Set ACCUM to the next operation's result if it fits,
+ else exit the loop. */
+ bool overflow = false;
+ intmax_t a;
+ switch (code)
+ {
+ case Aadd : overflow = INT_ADD_WRAPV (accum, next, &a); break;
+ case Amult: overflow = INT_MULTIPLY_WRAPV (accum, next, &a); break;
+ case Asub : overflow = INT_SUBTRACT_WRAPV (accum, next, &a); break;
+ case Adiv:
+ if (next == 0)
+ xsignal0 (Qarith_error);
+ overflow = INT_DIVIDE_OVERFLOW (accum, next);
+ if (!overflow)
+ a = accum / next;
+ break;
+ case Alogand: accum &= next; continue;
+ case Alogior: accum |= next; continue;
+ case Alogxor: accum ^= next; continue;
+ default: eassume (false);
+ }
+ if (overflow)
+ break;
+ accum = a;
+ }
+
+ return (FLOATP (val)
+ ? float_arith_driver (code, nargs, args, argnum, accum, val)
+ : bignum_arith_driver (code, nargs, args, argnum, accum, val));
}
@@ -3066,7 +2992,11 @@ DEFUN ("+", Fplus, Splus, 0, MANY, 0,
usage: (+ &rest NUMBERS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- return arith_driver (Aadd, nargs, args);
+ if (nargs == 0)
+ return make_fixnum (0);
+ Lisp_Object a = args[0];
+ CHECK_NUMBER_COERCE_MARKER (a);
+ return nargs == 1 ? a : arith_driver (Aadd, nargs, args, a);
}
DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
@@ -3076,7 +3006,20 @@ subtracts all but the first from the first.
usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- return arith_driver (Asub, nargs, args);
+ if (nargs == 0)
+ return make_fixnum (0);
+ Lisp_Object a = args[0];
+ CHECK_NUMBER_COERCE_MARKER (a);
+ if (nargs == 1)
+ {
+ if (FIXNUMP (a))
+ return make_int (-XFIXNUM (a));
+ if (FLOATP (a))
+ return make_float (-XFLOAT_DATA (a));
+ mpz_neg (mpz[0], XBIGNUM (a)->value);
+ return make_integer_mpz ();
+ }
+ return arith_driver (Asub, nargs, args, a);
}
DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
@@ -3084,7 +3027,11 @@ DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
usage: (* &rest NUMBERS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- return arith_driver (Amult, nargs, args);
+ if (nargs == 0)
+ return make_fixnum (1);
+ Lisp_Object a = args[0];
+ CHECK_NUMBER_COERCE_MARKER (a);
+ return nargs == 1 ? a : arith_driver (Amult, nargs, args, a);
}
DEFUN ("/", Fquo, Squo, 1, MANY, 0,
@@ -3095,11 +3042,31 @@ The arguments must be numbers or markers.
usage: (/ NUMBER &rest DIVISORS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- ptrdiff_t argnum;
- for (argnum = 2; argnum < nargs; argnum++)
+ Lisp_Object a = args[0];
+ CHECK_NUMBER_COERCE_MARKER (a);
+ if (nargs == 1)
+ {
+ if (FIXNUMP (a))
+ {
+ if (XFIXNUM (a) == 0)
+ xsignal0 (Qarith_error);
+ return make_fixnum (1 / XFIXNUM (a));
+ }
+ if (FLOATP (a))
+ {
+ if (! IEEE_FLOATING_POINT && XFLOAT_DATA (a) == 0)
+ xsignal0 (Qarith_error);
+ return make_float (1 / XFLOAT_DATA (a));
+ }
+ /* Dividing 1 by any bignum yields 0. */
+ return make_fixnum (0);
+ }
+
+ /* Do all computation in floating-point if any arg is a float. */
+ for (ptrdiff_t argnum = 2; argnum < nargs; argnum++)
if (FLOATP (args[argnum]))
- return float_arith_driver (0, 0, Adiv, nargs, args);
- return arith_driver (Adiv, nargs, args);
+ return floatop_arith_driver (Adiv, nargs, args, 0, 0, XFLOATINT (a));
+ return arith_driver (Adiv, nargs, args, a);
}
DEFUN ("%", Frem, Srem, 2, 2, 0,
@@ -3107,52 +3074,22 @@ DEFUN ("%", Frem, Srem, 2, 2, 0,
Both must be integers or markers. */)
(register Lisp_Object x, Lisp_Object y)
{
- Lisp_Object val;
-
CHECK_INTEGER_COERCE_MARKER (x);
CHECK_INTEGER_COERCE_MARKER (y);
- /* Note that a bignum can never be 0, so we don't need to check that
- case. */
+ /* A bignum can never be 0, so don't check that case. */
if (FIXNUMP (y) && XFIXNUM (y) == 0)
xsignal0 (Qarith_error);
if (FIXNUMP (x) && FIXNUMP (y))
- XSETINT (val, XFIXNUM (x) % XFIXNUM (y));
+ return make_fixnum (XFIXNUM (x) % XFIXNUM (y));
else
{
- mpz_t xm, ym, *xmp, *ymp;
- mpz_t result;
-
- if (BIGNUMP (x))
- xmp = &XBIGNUM (x)->value;
- else
- {
- mpz_init (xm);
- mpz_set_intmax (xm, XFIXNUM (x));
- xmp = &xm;
- }
-
- if (BIGNUMP (y))
- ymp = &XBIGNUM (y)->value;
- else
- {
- mpz_init (ym);
- mpz_set_intmax (ym, XFIXNUM (y));
- ymp = &ym;
- }
-
- mpz_init (result);
- mpz_tdiv_r (result, *xmp, *ymp);
- val = make_integer (result);
- mpz_clear (result);
-
- if (xmp == &xm)
- mpz_clear (xm);
- if (ymp == &ym)
- mpz_clear (ym);
+ mpz_tdiv_r (mpz[0],
+ *bignum_integer (&mpz[0], x),
+ *bignum_integer (&mpz[1], y));
+ return make_integer_mpz ();
}
- return val;
}
DEFUN ("mod", Fmod, Smod, 2, 2, 0,
@@ -3161,9 +3098,6 @@ The result falls between zero (inclusive) and Y
(exclusive).
Both X and Y must be numbers or markers. */)
(register Lisp_Object x, Lisp_Object y)
{
- Lisp_Object val;
- EMACS_INT i1, i2;
-
CHECK_NUMBER_COERCE_MARKER (x);
CHECK_NUMBER_COERCE_MARKER (y);
@@ -3177,8 +3111,7 @@ Both X and Y must be numbers or markers. */)
if (FIXNUMP (x) && FIXNUMP (y))
{
- i1 = XFIXNUM (x);
- i2 = XFIXNUM (y);
+ EMACS_INT i1 = XFIXNUM (x), i2 = XFIXNUM (y);
if (i2 == 0)
xsignal0 (Qarith_error);
@@ -3189,51 +3122,21 @@ Both X and Y must be numbers or markers. */)
if (i2 < 0 ? i1 > 0 : i1 < 0)
i1 += i2;
- XSETINT (val, i1);
+ return make_fixnum (i1);
}
else
{
- mpz_t xm, ym, *xmp, *ymp;
- mpz_t result;
- int cmpr, cmpy;
-
- if (BIGNUMP (x))
- xmp = &XBIGNUM (x)->value;
- else
- {
- mpz_init (xm);
- mpz_set_intmax (xm, XFIXNUM (x));
- xmp = &xm;
- }
-
- if (BIGNUMP (y))
- ymp = &XBIGNUM (y)->value;
- else
- {
- mpz_init (ym);
- mpz_set_intmax (ym, XFIXNUM (y));
- ymp = &ym;
- }
-
- mpz_init (result);
- mpz_mod (result, *xmp, *ymp);
+ mpz_t *ym = bignum_integer (&mpz[1], y);
+ bool neg_y = mpz_sgn (*ym) < 0;
+ mpz_mod (mpz[0], *bignum_integer (&mpz[0], x), *ym);
/* Fix the sign if needed. */
- cmpr = mpz_sgn (result);
- cmpy = mpz_sgn (*ymp);
- if (cmpy < 0 ? cmpr > 0 : cmpr < 0)
- mpz_add (result, result, *ymp);
-
- val = make_integer (result);
- mpz_clear (result);
-
- if (xmp == &xm)
- mpz_clear (xm);
- if (ymp == &ym)
- mpz_clear (ym);
- }
+ int sgn_r = mpz_sgn (mpz[0]);
+ if (neg_y ? sgn_r > 0 : sgn_r < 0)
+ mpz_add (mpz[0], mpz[0], *ym);
- return val;
+ return make_integer_mpz ();
+ }
}
static Lisp_Object
@@ -3278,7 +3181,11 @@ Arguments may be integers, or markers converted to
integers.
usage: (logand &rest INTS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- return arith_driver (Alogand, nargs, args);
+ if (nargs == 0)
+ return make_fixnum (-1);
+ Lisp_Object a = args[0];
+ CHECK_INTEGER_COERCE_MARKER (a);
+ return nargs == 1 ? a : arith_driver (Alogand, nargs, args, a);
}
DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
@@ -3287,7 +3194,11 @@ Arguments may be integers, or markers converted to
integers.
usage: (logior &rest INTS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- return arith_driver (Alogior, nargs, args);
+ if (nargs == 0)
+ return make_fixnum (0);
+ Lisp_Object a = args[0];
+ CHECK_INTEGER_COERCE_MARKER (a);
+ return nargs == 1 ? a : arith_driver (Alogior, nargs, args, a);
}
DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
@@ -3296,7 +3207,11 @@ Arguments may be integers, or markers converted to
integers.
usage: (logxor &rest INTS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- return arith_driver (Alogxor, nargs, args);
+ if (nargs == 0)
+ return make_fixnum (0);
+ Lisp_Object a = args[0];
+ CHECK_INTEGER_COERCE_MARKER (a);
+ return nargs == 1 ? a : arith_driver (Alogxor, nargs, args, a);
}
DEFUN ("logcount", Flogcount, Slogcount, 1, 1, 0,
@@ -3310,14 +3225,13 @@ representation. */)
if (BIGNUMP (value))
{
- if (mpz_sgn (XBIGNUM (value)->value) >= 0)
- return make_fixnum (mpz_popcount (XBIGNUM (value)->value));
- mpz_t tem;
- mpz_init (tem);
- mpz_com (tem, XBIGNUM (value)->value);
- Lisp_Object result = make_fixnum (mpz_popcount (tem));
- mpz_clear (tem);
- return result;
+ mpz_t *nonneg = &XBIGNUM (value)->value;
+ if (mpz_sgn (*nonneg) < 0)
+ {
+ mpz_com (mpz[0], *nonneg);
+ nonneg = &mpz[0];
+ }
+ return make_fixnum (mpz_popcount (*nonneg));
}
eassume (FIXNUMP (value));
@@ -3335,8 +3249,6 @@ If COUNT is negative, shifting is actually to the right.
In this case, the sign bit is duplicated. */)
(Lisp_Object value, Lisp_Object count)
{
- Lisp_Object val;
-
/* The negative of the minimum value of COUNT that fits into a fixnum,
such that mpz_fdiv_q_exp supports -COUNT. */
EMACS_INT minus_count_min = min (-MOST_NEGATIVE_FIXNUM,
@@ -3344,48 +3256,27 @@ In this case, the sign bit is duplicated. */)
CHECK_INTEGER (value);
CHECK_RANGED_INTEGER (count, - minus_count_min, TYPE_MAXIMUM (mp_bitcnt_t));
- if (BIGNUMP (value))
+ if (XFIXNUM (count) <= 0)
{
if (XFIXNUM (count) == 0)
return value;
- mpz_t result;
- mpz_init (result);
- if (XFIXNUM (count) > 0)
- emacs_mpz_mul_2exp (result, XBIGNUM (value)->value, XFIXNUM (count));
- else
- mpz_fdiv_q_2exp (result, XBIGNUM (value)->value, - XFIXNUM (count));
- val = make_integer (result);
- mpz_clear (result);
- }
- else if (XFIXNUM (count) <= 0)
- {
- /* This code assumes that signed right shifts are arithmetic. */
- verify ((EMACS_INT) -1 >> 1 == -1);
-
- EMACS_INT shift = -XFIXNUM (count);
- EMACS_INT result = (shift < EMACS_INT_WIDTH ? XFIXNUM (value) >> shift
- : XFIXNUM (value) < 0 ? -1 : 0);
- val = make_fixnum (result);
- }
- else
- {
- /* Just do the work as bignums to make the code simpler. */
- mpz_t result;
- eassume (FIXNUMP (value));
- mpz_init (result);
-
- mpz_set_intmax (result, XFIXNUM (value));
- if (XFIXNUM (count) >= 0)
- emacs_mpz_mul_2exp (result, result, XFIXNUM (count));
- else
- mpz_fdiv_q_2exp (result, result, - XFIXNUM (count));
-
- val = make_integer (result);
- mpz_clear (result);
+ if ((EMACS_INT) -1 >> 1 == -1 && FIXNUMP (value))
+ {
+ EMACS_INT shift = -XFIXNUM (count);
+ EMACS_INT result
+ = (shift < EMACS_INT_WIDTH ? XFIXNUM (value) >> shift
+ : XFIXNUM (value) < 0 ? -1 : 0);
+ return make_fixnum (result);
+ }
}
- return val;
+ mpz_t *zval = bignum_integer (&mpz[0], value);
+ if (XFIXNUM (count) < 0)
+ mpz_fdiv_q_2exp (mpz[0], *zval, - XFIXNUM (count));
+ else
+ emacs_mpz_mul_2exp (mpz[0], *zval, XFIXNUM (count));
+ return make_integer_mpz ();
}
/* Return X ** Y as an integer. X and Y must be integers, and Y must
@@ -3403,16 +3294,8 @@ expt_integer (Lisp_Object x, Lisp_Object y)
else
range_error ();
- mpz_t val;
- mpz_init (val);
- emacs_mpz_pow_ui (val,
- (FIXNUMP (x)
- ? (mpz_set_intmax (val, XFIXNUM (x)), val)
- : XBIGNUM (x)->value),
- exp);
- Lisp_Object res = make_integer (val);
- mpz_clear (val);
- return res;
+ emacs_mpz_pow_ui (mpz[0], *bignum_integer (&mpz[0], x), exp);
+ return make_integer_mpz ();
}
DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
@@ -3422,32 +3305,12 @@ Markers are converted to integers. */)
{
CHECK_NUMBER_COERCE_MARKER (number);
+ if (FIXNUMP (number))
+ return make_int (XFIXNUM (number) + 1);
if (FLOATP (number))
return (make_float (1.0 + XFLOAT_DATA (number)));
-
- if (BIGNUMP (number))
- {
- mpz_t num;
- mpz_init (num);
- mpz_add_ui (num, XBIGNUM (number)->value, 1);
- number = make_integer (num);
- mpz_clear (num);
- }
- else
- {
- eassume (FIXNUMP (number));
- if (XFIXNUM (number) < MOST_POSITIVE_FIXNUM)
- XSETINT (number, XFIXNUM (number) + 1);
- else
- {
- mpz_t num;
- mpz_init (num);
- mpz_set_intmax (num, XFIXNUM (number) + 1);
- number = make_integer (num);
- mpz_clear (num);
- }
- }
- return number;
+ mpz_add_ui (mpz[0], XBIGNUM (number)->value, 1);
+ return make_integer_mpz ();
}
DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
@@ -3457,32 +3320,12 @@ Markers are converted to integers. */)
{
CHECK_NUMBER_COERCE_MARKER (number);
+ if (FIXNUMP (number))
+ return make_int (XFIXNUM (number) - 1);
if (FLOATP (number))
return (make_float (-1.0 + XFLOAT_DATA (number)));
-
- if (BIGNUMP (number))
- {
- mpz_t num;
- mpz_init (num);
- mpz_sub_ui (num, XBIGNUM (number)->value, 1);
- number = make_integer (num);
- mpz_clear (num);
- }
- else
- {
- eassume (FIXNUMP (number));
- if (XFIXNUM (number) > MOST_NEGATIVE_FIXNUM)
- XSETINT (number, XFIXNUM (number) - 1);
- else
- {
- mpz_t num;
- mpz_init (num);
- mpz_set_intmax (num, XFIXNUM (number) - 1);
- number = make_integer (num);
- mpz_clear (num);
- }
- }
- return number;
+ mpz_sub_ui (mpz[0], XBIGNUM (number)->value, 1);
+ return make_integer_mpz ();
}
DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
@@ -3490,20 +3333,10 @@ DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
(register Lisp_Object number)
{
CHECK_INTEGER (number);
- if (BIGNUMP (number))
- {
- mpz_t value;
- mpz_init (value);
- mpz_com (value, XBIGNUM (number)->value);
- number = make_integer (value);
- mpz_clear (value);
- }
- else
- {
- eassume (FIXNUMP (number));
- XSETINT (number, ~XFIXNUM (number));
- }
- return number;
+ if (FIXNUMP (number))
+ return make_fixnum (~XFIXNUM (number));
+ mpz_com (mpz[0], XBIGNUM (number)->value);
+ return make_integer_mpz ();
}
DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0,
diff --git a/src/dbusbind.c b/src/dbusbind.c
index 47346a7..9bc344e 100644
--- a/src/dbusbind.c
+++ b/src/dbusbind.c
@@ -520,12 +520,13 @@ static intmax_t
xd_extract_signed (Lisp_Object x, intmax_t lo, intmax_t hi)
{
CHECK_NUMBER (x);
- if (FIXNUMP (x))
+ if (INTEGERP (x))
{
- if (lo <= XFIXNUM (x) && XFIXNUM (x) <= hi)
- return XFIXNUM (x);
+ intmax_t i;
+ if (integer_to_intmax (x, &i) && lo <= i && i <= hi)
+ return i;
}
- else if (FLOATP (x))
+ else
{
double d = XFLOAT_DATA (x);
if (lo <= d && d < 1.0 + hi)
@@ -535,12 +536,6 @@ xd_extract_signed (Lisp_Object x, intmax_t lo, intmax_t hi)
return n;
}
}
- else if (! (MOST_NEGATIVE_FIXNUM <= lo && hi <= MOST_POSITIVE_FIXNUM))
- {
- intmax_t i = bignum_to_intmax (x);
- if (i != 0 && lo <= i && i <= hi)
- return i;
- }
if (xd_in_read_queued_messages)
Fthrow (Qdbus_error, Qnil);
@@ -553,12 +548,13 @@ static uintmax_t
xd_extract_unsigned (Lisp_Object x, uintmax_t hi)
{
CHECK_NUMBER (x);
- if (FIXNUMP (x))
+ if (INTEGERP (x))
{
- if (0 <= XFIXNUM (x) && XFIXNUM (x) <= hi)
- return XFIXNUM (x);
+ uintmax_t i;
+ if (integer_to_uintmax (x, &i) && i <= hi)
+ return i;
}
- else if (FLOATP (x))
+ else
{
double d = XFLOAT_DATA (x);
if (0 <= d && d < 1.0 + hi)
@@ -568,12 +564,6 @@ xd_extract_unsigned (Lisp_Object x, uintmax_t hi)
return n;
}
}
- else if (! (hi <= MOST_POSITIVE_FIXNUM))
- {
- uintmax_t i = bignum_to_uintmax (x);
- if (i != 0 && i <= hi)
- return i;
- }
if (xd_in_read_queued_messages)
Fthrow (Qdbus_error, Qnil);
diff --git a/src/dired.c b/src/dired.c
index c4cda40..70c5bb2 100644
--- a/src/dired.c
+++ b/src/dired.c
@@ -867,7 +867,8 @@ Elements of the attribute list are:
0. t for directory, string (name linked to) for symbolic link, or nil.
1. Number of links to file.
2. File uid as a string or a number. If a string value cannot be
- looked up, an integer value is returned.
+ looked up, an integer value is returned, which could be a fixnum,
+ if it's small enough, otherwise a bignum.
3. File gid, likewise.
4. Last access time, as a list of integers (HIGH LOW USEC PSEC) in the
same style as (current-time).
@@ -876,16 +877,14 @@ Elements of the attribute list are:
change to the file's contents.
6. Last status change time, likewise. This is the time of last change
to the file's attributes: owner and group, access mode bits, etc.
- 7. Size in bytes.
+ 7. Size in bytes, which could be a fixnum, if it's small enough,
+ otherwise a bignum.
8. File modes, as a string of ten letters or dashes as in ls -l.
9. An unspecified value, present only for backward compatibility.
-10. inode number. If it is larger than what an Emacs integer can hold,
- this is of the form (HIGH . LOW): first the high bits, then the low 16 bits.
- If even HIGH is too large for an Emacs integer, this is instead of the form
- (HIGH MIDDLE . LOW): first the high bits, then the middle 24 bits,
- and finally the low 16 bits.
-11. Filesystem device number. If it is larger than what the Emacs
- integer can hold, this is a cons cell, similar to the inode number.
+10. inode number, which could be a fixnum, if it's small enough,
+ otherwise a bignum.
+11. Filesystem device number. If it is larger than what a fixnum
+ can hold, it is a bignum.
On most filesystems, the combination of the inode and the device
number uniquely identifies the file.
diff --git a/src/dispextern.h b/src/dispextern.h
index 9cc65f6..579665c 100644
--- a/src/dispextern.h
+++ b/src/dispextern.h
@@ -3569,6 +3569,10 @@ extern void create_tty_output (struct frame *);
extern struct terminal *init_tty (const char *, const char *, bool);
extern void tty_append_glyph (struct it *);
+/* All scrolling costs measured in characters.
+ So no cost can exceed the area of a frame, measured in characters.
+ Let's hope this is never more than 1000000 characters. */
+enum { SCROLL_INFINITY = 1000000 };
/* Defined in scroll.c */
diff --git a/src/dispnew.c b/src/dispnew.c
index 61ca717..798413d 100644
--- a/src/dispnew.c
+++ b/src/dispnew.c
@@ -4677,8 +4677,7 @@ scrolling (struct frame *frame)
{
/* This line cannot be redrawn, so don't let scrolling mess it. */
new_hash[i] = old_hash[i];
-#define INFINITY 1000000 /* Taken from scroll.c */
- draw_cost[i] = INFINITY;
+ draw_cost[i] = SCROLL_INFINITY;
}
else
{
@@ -5766,20 +5765,20 @@ sit_for (Lisp_Object timeout, bool reading, int
display_option)
if (display_option > 1)
redisplay_preserve_echo_area (2);
- if (FIXNUMP (timeout))
+ if (INTEGERP (timeout))
{
- sec = XFIXNUM (timeout);
- if (sec <= 0)
- return Qt;
- nsec = 0;
- }
- else if (BIGNUMP (timeout))
- {
- if (NILP (Fnatnump (timeout)))
- return Qt;
- sec = bignum_to_intmax (timeout);
- if (sec == 0)
- sec = WAIT_READING_MAX;
+ if (integer_to_intmax (timeout, &sec))
+ {
+ if (sec <= 0)
+ return Qt;
+ sec = min (sec, WAIT_READING_MAX);
+ }
+ else
+ {
+ if (NILP (Fnatnump (timeout)))
+ return Qt;
+ sec = WAIT_READING_MAX;
+ }
nsec = 0;
}
else if (FLOATP (timeout))
diff --git a/src/editfns.c b/src/editfns.c
index 3b1c21a..f19c3f1 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -1377,7 +1377,8 @@ This ignores the environment variables LOGNAME and USER,
so it differs from
}
DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0,
- doc: /* Return the effective uid of Emacs. */)
+ doc: /* Return the effective uid of Emacs.
+Value is a fixnum, if it's small enough, otherwise a bignum. */)
(void)
{
uid_t euid = geteuid ();
@@ -1385,7 +1386,8 @@ DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0,
}
DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0,
- doc: /* Return the real uid of Emacs. */)
+ doc: /* Return the real uid of Emacs.
+Value is a fixnum, if it's small enough, otherwise a bignum. */)
(void)
{
uid_t uid = getuid ();
@@ -1393,7 +1395,8 @@ DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid,
0, 0, 0,
}
DEFUN ("group-gid", Fgroup_gid, Sgroup_gid, 0, 0, 0,
- doc: /* Return the effective gid of Emacs. */)
+ doc: /* Return the effective gid of Emacs.
+Value is a fixnum, if it's small enough, otherwise a bignum. */)
(void)
{
gid_t egid = getegid ();
@@ -1401,7 +1404,8 @@ DEFUN ("group-gid", Fgroup_gid, Sgroup_gid, 0, 0, 0,
}
DEFUN ("group-real-gid", Fgroup_real_gid, Sgroup_real_gid, 0, 0, 0,
- doc: /* Return the real gid of Emacs. */)
+ doc: /* Return the real gid of Emacs.
+Value is a fixnum, if it's small enough, otherwise a bignum. */)
(void)
{
gid_t gid = getgid ();
@@ -1481,7 +1485,8 @@ DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0,
}
DEFUN ("emacs-pid", Femacs_pid, Semacs_pid, 0, 0, 0,
- doc: /* Return the process ID of Emacs, as a number. */)
+ doc: /* Return the process ID of Emacs, as a number.
+Value is a fixnum, if it's small enough, otherwise a bignum. */)
(void)
{
pid_t pid = getpid ();
@@ -1743,10 +1748,10 @@ disassemble_lisp_time (Lisp_Object specified_time,
Lisp_Object *phigh,
/* When combining components, require LOW to be an integer,
as otherwise it would be a pain to add up times. */
- if (! FIXNUMP (low))
+ if (! INTEGERP (low))
return 0;
}
- else if (FIXNUMP (specified_time))
+ else if (INTEGERP (specified_time))
len = 2;
*phigh = high;
@@ -1807,11 +1812,12 @@ decode_time_components (Lisp_Object high, Lisp_Object
low, Lisp_Object usec,
Lisp_Object psec,
struct lisp_time *result, double *dresult)
{
- EMACS_INT hi, lo, us, ps;
+ EMACS_INT hi, us, ps;
+ intmax_t lo;
if (! (FIXNUMP (high)
&& FIXNUMP (usec) && FIXNUMP (psec)))
return 0;
- if (! FIXNUMP (low))
+ if (! INTEGERP (low))
{
if (FLOATP (low))
{
@@ -1841,7 +1847,8 @@ decode_time_components (Lisp_Object high, Lisp_Object
low, Lisp_Object usec,
}
hi = XFIXNUM (high);
- lo = XFIXNUM (low);
+ if (! integer_to_intmax (low, &lo))
+ return -1;
us = XFIXNUM (usec);
ps = XFIXNUM (psec);
@@ -1849,7 +1856,8 @@ decode_time_components (Lisp_Object high, Lisp_Object
low, Lisp_Object usec,
each overflow into the next higher-order component. */
us += ps / 1000000 - (ps % 1000000 < 0);
lo += us / 1000000 - (us % 1000000 < 0);
- hi += lo >> LO_TIME_BITS;
+ if (INT_ADD_WRAPV (lo >> LO_TIME_BITS, hi, &hi))
+ return -1;
ps = ps % 1000000 + 1000000 * (ps % 1000000 < 0);
us = us % 1000000 + 1000000 * (us % 1000000 < 0);
lo &= (1 << LO_TIME_BITS) - 1;
@@ -4691,21 +4699,16 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool
message)
}
else
{
- if (FIXNUMP (arg))
- ldarg = XFIXNUM (arg);
- else
+ if (INTEGERP (arg))
{
- intmax_t iarg = bignum_to_intmax (arg);
- if (iarg != 0)
+ intmax_t iarg;
+ uintmax_t uarg;
+ if (integer_to_intmax (arg, &iarg))
ldarg = iarg;
+ else if (integer_to_uintmax (arg, &uarg))
+ ldarg = uarg;
else
- {
- uintmax_t uarg = bignum_to_uintmax (arg);
- if (uarg != 0)
- ldarg = uarg;
- else
- format_bignum_as_double = true;
- }
+ format_bignum_as_double = true;
}
if (!format_bignum_as_double)
{
diff --git a/src/emacs-module.c b/src/emacs-module.c
index 2ba5540..6155535 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -519,14 +519,10 @@ module_extract_integer (emacs_env *env, emacs_value n)
MODULE_FUNCTION_BEGIN (0);
Lisp_Object l = value_to_lisp (n);
CHECK_INTEGER (l);
- if (BIGNUMP (l))
- {
- intmax_t i = bignum_to_intmax (l);
- if (i == 0)
- xsignal1 (Qoverflow_error, l);
- return i;
- }
- return XFIXNUM (l);
+ intmax_t i;
+ if (! integer_to_intmax (l, &i))
+ xsignal1 (Qoverflow_error, l);
+ return i;
}
static emacs_value
diff --git a/src/emacs.c b/src/emacs.c
index 07a1aff..b1c96d1 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -1256,6 +1256,7 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
}
init_alloc ();
+ init_bignum ();
init_threads ();
if (do_initial_setlocale)
diff --git a/src/eval.c b/src/eval.c
index 50de60c..60dd6f1 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -204,6 +204,10 @@ bool
backtrace_p (union specbinding *pdl)
{ return pdl >= specpdl; }
+static bool
+backtrace_thread_p (struct thread_state *tstate, union specbinding *pdl)
+{ return pdl >= tstate->m_specpdl; }
+
union specbinding *
backtrace_top (void)
{
@@ -213,6 +217,15 @@ backtrace_top (void)
return pdl;
}
+static union specbinding *
+backtrace_thread_top (struct thread_state *tstate)
+{
+ union specbinding *pdl = tstate->m_specpdl_ptr - 1;
+ while (backtrace_thread_p (tstate, pdl) && pdl->kind != SPECPDL_BACKTRACE)
+ pdl--;
+ return pdl;
+}
+
union specbinding *
backtrace_next (union specbinding *pdl)
{
@@ -222,6 +235,15 @@ backtrace_next (union specbinding *pdl)
return pdl;
}
+static union specbinding *
+backtrace_thread_next (struct thread_state *tstate, union specbinding *pdl)
+{
+ pdl--;
+ while (backtrace_thread_p (tstate, pdl) && pdl->kind != SPECPDL_BACKTRACE)
+ pdl--;
+ return pdl;
+}
+
void
init_eval_once (void)
{
@@ -1215,9 +1237,9 @@ Executes BODYFORM and returns its value if no error
happens.
Each element of HANDLERS looks like (CONDITION-NAME BODY...)
where the BODY is made of Lisp expressions.
-A handler is applicable to an error
-if CONDITION-NAME is one of the error's condition names.
-If an error happens, the first applicable handler is run.
+A handler is applicable to an error if CONDITION-NAME is one of the
+error's condition names. A CONDITION-NAME of t applies to any error
+symbol. If an error happens, the first applicable handler is run.
The car of a handler may be a list of condition names instead of a
single condition name; then it handles all of them. If the special
@@ -1854,7 +1876,9 @@ find_handler_clause (Lisp_Object handlers, Lisp_Object
conditions)
for (h = handlers; CONSP (h); h = XCDR (h))
{
Lisp_Object handler = XCAR (h);
- if (!NILP (Fmemq (handler, conditions)))
+ if (!NILP (Fmemq (handler, conditions))
+ /* t is also used as a catch-all by Lisp code. */
+ || EQ (handler, Qt))
return handlers;
}
@@ -3728,6 +3752,42 @@ Return the result of FUNCTION, or nil if no matching
frame could be found. */)
return backtrace_frame_apply (function, get_backtrace_frame (nframes, base));
}
+DEFUN ("backtrace--frames-from-thread", Fbacktrace_frames_from_thread,
+ Sbacktrace_frames_from_thread, 1, 1, NULL,
+ doc: /* Return the list of backtrace frames from current execution
point in THREAD.
+If a frame has not evaluated the arguments yet (or is a special form),
+the value of the list element is (nil FUNCTION ARG-FORMS...).
+If a frame has evaluated its arguments and called its function already,
+the value of the list element is (t FUNCTION ARG-VALUES...).
+A &rest arg is represented as the tail of the list ARG-VALUES.
+FUNCTION is whatever was supplied as car of evaluated list,
+or a lambda expression for macro calls. */)
+ (Lisp_Object thread)
+{
+ struct thread_state *tstate;
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ union specbinding *pdl = backtrace_thread_top (tstate);
+ Lisp_Object list = Qnil;
+
+ while (backtrace_thread_p (tstate, pdl))
+ {
+ Lisp_Object frame;
+ if (backtrace_nargs (pdl) == UNEVALLED)
+ frame = Fcons (Qnil,
+ Fcons (backtrace_function (pdl), *backtrace_args (pdl)));
+ else
+ {
+ Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl));
+ frame = Fcons (Qt, Fcons (backtrace_function (pdl), tem));
+ }
+ list = Fcons (frame, list);
+ pdl = backtrace_thread_next (tstate, pdl);
+ }
+ return Fnreverse (list);
+}
+
/* For backtrace-eval, we want to temporarily unwind the last few elements of
the specpdl stack, and then rewind them. We store the pre-unwind values
directly in the pre-existing specpdl elements (i.e. we swap the current
@@ -4203,6 +4263,7 @@ alist of active lexical bindings. */);
DEFSYM (QCdebug_on_exit, ":debug-on-exit");
defsubr (&Smapbacktrace);
defsubr (&Sbacktrace_frame_internal);
+ defsubr (&Sbacktrace_frames_from_thread);
defsubr (&Sbacktrace_eval);
defsubr (&Sbacktrace__locals);
defsubr (&Sspecial_variable_p);
diff --git a/src/fileio.c b/src/fileio.c
index a91bdaa..5ca7c59 100644
--- a/src/fileio.c
+++ b/src/fileio.c
@@ -3394,9 +3394,9 @@ union read_non_regular
int fd;
ptrdiff_t inserted, trytry;
} s;
- GCALIGNED_UNION
+ GCALIGNED_UNION_MEMBER
};
-verify (alignof (union read_non_regular) % GCALIGNMENT == 0);
+verify (GCALIGNED (union read_non_regular));
static Lisp_Object
read_non_regular (Lisp_Object state)
@@ -3424,17 +3424,13 @@ read_non_regular_quit (Lisp_Object ignore)
static off_t
file_offset (Lisp_Object val)
{
- if (RANGED_FIXNUMP (0, val, TYPE_MAXIMUM (off_t)))
- return XFIXNUM (val);
-
- if (BIGNUMP (val))
+ if (INTEGERP (val))
{
- intmax_t v = bignum_to_intmax (val);
- if (0 < v && v <= TYPE_MAXIMUM (off_t))
+ intmax_t v;
+ if (integer_to_intmax (val, &v) && 0 <= v && v <= TYPE_MAXIMUM (off_t))
return v;
}
-
- if (FLOATP (val))
+ else if (FLOATP (val))
{
double v = XFLOAT_DATA (val);
if (0 <= v && v < 1.0 + TYPE_MAXIMUM (off_t))
diff --git a/src/floatfns.c b/src/floatfns.c
index 77e20d56..dc72363 100644
--- a/src/floatfns.c
+++ b/src/floatfns.c
@@ -270,11 +270,8 @@ DEFUN ("abs", Fabs, Sabs, 1, 1, 0,
{
if (mpz_sgn (XBIGNUM (arg)->value) < 0)
{
- mpz_t val;
- mpz_init (val);
- mpz_neg (val, XBIGNUM (arg)->value);
- arg = make_integer (val);
- mpz_clear (val);
+ mpz_neg (mpz[0], XBIGNUM (arg)->value);
+ arg = make_integer_mpz ();
}
}
@@ -342,6 +339,7 @@ static Lisp_Object
rounding_driver (Lisp_Object arg, Lisp_Object divisor,
double (*double_round) (double),
void (*int_divide) (mpz_t, mpz_t const, mpz_t const),
+ EMACS_INT (*fixnum_divide) (EMACS_INT, EMACS_INT),
const char *name)
{
CHECK_NUMBER (arg);
@@ -358,28 +356,27 @@ rounding_driver (Lisp_Object arg, Lisp_Object divisor,
CHECK_NUMBER (divisor);
if (!FLOATP (arg) && !FLOATP (divisor))
{
- if (EQ (divisor, make_fixnum (0)))
- xsignal0 (Qarith_error);
- mpz_t d, q;
- mpz_init (d);
- mpz_init (q);
- int_divide (q,
- (FIXNUMP (arg)
- ? (mpz_set_intmax (q, XFIXNUM (arg)), q)
- : XBIGNUM (arg)->value),
- (FIXNUMP (divisor)
- ? (mpz_set_intmax (d, XFIXNUM (divisor)), d)
- : XBIGNUM (divisor)->value));
- Lisp_Object result = make_integer (q);
- mpz_clear (d);
- mpz_clear (q);
- return result;
+ /* Divide as integers. Converting to double might lose
+ info, even for fixnums; also see the FIXME below. */
+ if (FIXNUMP (divisor))
+ {
+ if (XFIXNUM (divisor) == 0)
+ xsignal0 (Qarith_error);
+ if (FIXNUMP (arg))
+ return make_int (fixnum_divide (XFIXNUM (arg),
+ XFIXNUM (divisor)));
+ }
+ int_divide (mpz[0],
+ *bignum_integer (&mpz[0], arg),
+ *bignum_integer (&mpz[1], divisor));
+ return make_integer_mpz ();
}
- double f1 = FLOATP (arg) ? XFLOAT_DATA (arg) : XFIXNUM (arg);
- double f2 = FLOATP (divisor) ? XFLOAT_DATA (divisor) : XFIXNUM (divisor);
+ double f1 = XFLOATINT (arg);
+ double f2 = XFLOATINT (divisor);
if (! IEEE_FLOATING_POINT && f2 == 0)
xsignal0 (Qarith_error);
+ /* FIXME: This division rounds, so the result is double-rounded. */
d = f1 / f2;
}
@@ -397,40 +394,56 @@ rounding_driver (Lisp_Object arg, Lisp_Object divisor,
return double_to_bignum (dr);
}
+static EMACS_INT
+ceiling2 (EMACS_INT n, EMACS_INT d)
+{
+ return n / d + ((n % d != 0) & ((n < 0) == (d < 0)));
+}
+
+static EMACS_INT
+floor2 (EMACS_INT n, EMACS_INT d)
+{
+ return n / d - ((n % d != 0) & ((n < 0) != (d < 0)));
+}
+
+static EMACS_INT
+truncate2 (EMACS_INT n, EMACS_INT d)
+{
+ return n / d;
+}
+
+static EMACS_INT
+round2 (EMACS_INT n, EMACS_INT d)
+{
+ /* The C language's division operator gives us the remainder R
+ corresponding to truncated division, but we want the remainder R1
+ on the other side of 0 if R1 is closer to 0 than R is; because we
+ want to round to even, we also want R1 if R and R1 are the same
+ distance from 0 and if the truncated quotient is odd. */
+ EMACS_INT q = n / d;
+ EMACS_INT r = n % d;
+ bool neg_d = d < 0;
+ bool neg_r = r < 0;
+ EMACS_INT abs_r = eabs (r);
+ EMACS_INT abs_r1 = eabs (d) - abs_r;
+ if (abs_r1 < abs_r + (q & 1))
+ q += neg_d == neg_r ? 1 : -1;
+ return q;
+}
+
static void
rounddiv_q (mpz_t q, mpz_t const n, mpz_t const d)
{
- /* mpz_tdiv_qr gives us one remainder R, but we want the remainder
- R1 on the other side of 0 if R1 is closer to 0 than R is; because
- we want to round to even, we also want R1 if R and R1 are the
- same distance from 0 and if the quotient is odd.
-
- If we were using EMACS_INT arithmetic instead of bignums,
- the following code could look something like this:
-
- q = n / d;
- r = n % d;
- neg_d = d < 0;
- neg_r = r < 0;
- abs_r = eabs (r);
- abs_r1 = eabs (d) - abs_r;
- if (abs_r1 < abs_r + (q & 1))
- q += neg_d == neg_r ? 1 : -1; */
-
- mpz_t r, abs_r1;
- mpz_init (r);
- mpz_init (abs_r1);
- mpz_tdiv_qr (q, r, n, d);
+ /* Mimic the source code of round2, using mpz_t instead of EMACS_INT. */
+ mpz_t *r = &mpz[2], *abs_r = r, *abs_r1 = &mpz[3];
+ mpz_tdiv_qr (q, *r, n, d);
bool neg_d = mpz_sgn (d) < 0;
- bool neg_r = mpz_sgn (r) < 0;
- mpz_t *abs_r = &r;
- mpz_abs (*abs_r, r);
- mpz_abs (abs_r1, d);
- mpz_sub (abs_r1, abs_r1, *abs_r);
- if (mpz_cmp (abs_r1, *abs_r) < (mpz_odd_p (q) != 0))
+ bool neg_r = mpz_sgn (*r) < 0;
+ mpz_abs (*abs_r, *r);
+ mpz_abs (*abs_r1, d);
+ mpz_sub (*abs_r1, *abs_r1, *abs_r);
+ if (mpz_cmp (*abs_r1, *abs_r) < (mpz_odd_p (q) != 0))
(neg_d == neg_r ? mpz_add_ui : mpz_sub_ui) (q, q, 1);
- mpz_clear (r);
- mpz_clear (abs_r1);
}
/* The code uses emacs_rint, so that it works to undefine HAVE_RINT
@@ -461,7 +474,7 @@ This rounds the value towards +inf.
With optional DIVISOR, return the smallest integer no less than ARG/DIVISOR.
*/)
(Lisp_Object arg, Lisp_Object divisor)
{
- return rounding_driver (arg, divisor, ceil, mpz_cdiv_q, "ceiling");
+ return rounding_driver (arg, divisor, ceil, mpz_cdiv_q, ceiling2, "ceiling");
}
DEFUN ("floor", Ffloor, Sfloor, 1, 2, 0,
@@ -470,7 +483,7 @@ This rounds the value towards -inf.
With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR.
*/)
(Lisp_Object arg, Lisp_Object divisor)
{
- return rounding_driver (arg, divisor, floor, mpz_fdiv_q, "floor");
+ return rounding_driver (arg, divisor, floor, mpz_fdiv_q, floor2, "floor");
}
DEFUN ("round", Fround, Sround, 1, 2, 0,
@@ -483,7 +496,8 @@ your machine. For example, (round 2.5) can return 3 on some
systems, but 2 on others. */)
(Lisp_Object arg, Lisp_Object divisor)
{
- return rounding_driver (arg, divisor, emacs_rint, rounddiv_q, "round");
+ return rounding_driver (arg, divisor, emacs_rint, rounddiv_q, round2,
+ "round");
}
/* Since rounding_driver truncates anyway, no need to call 'trunc'. */
@@ -499,7 +513,8 @@ Rounds ARG toward zero.
With optional DIVISOR, truncate ARG/DIVISOR. */)
(Lisp_Object arg, Lisp_Object divisor)
{
- return rounding_driver (arg, divisor, identity, mpz_tdiv_q, "truncate");
+ return rounding_driver (arg, divisor, identity, mpz_tdiv_q, truncate2,
+ "truncate");
}
diff --git a/src/fns.c b/src/fns.c
index 17a869e..c9a6dd6 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -133,7 +133,8 @@ DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
doc: /* Return the length of a list, but avoid error or infinite loop.
This function never gets an error. If LIST is not really a list,
it returns 0. If LIST is circular, it returns an integer that is at
-least the number of distinct elements. */)
+least the number of distinct elements.
+Value is a fixnum, if it's small enough, otherwise a bignum. */)
(Lisp_Object list)
{
intptr_t len = 0;
@@ -1468,19 +1469,17 @@ DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
/* Undo any error introduced when LARGE_NUM was substituted for
N, by adding N - LARGE_NUM to NUM, using arithmetic modulo
CYCLE_LENGTH. */
- mpz_t z; /* N mod CYCLE_LENGTH. */
- mpz_init (z);
+ /* Add N mod CYCLE_LENGTH to NUM. */
if (cycle_length <= ULONG_MAX)
- num += mpz_mod_ui (z, XBIGNUM (n)->value, cycle_length);
+ num += mpz_tdiv_ui (XBIGNUM (n)->value, cycle_length);
else
{
- mpz_set_intmax (z, cycle_length);
- mpz_mod (z, XBIGNUM (n)->value, z);
+ mpz_set_intmax (mpz[0], cycle_length);
+ mpz_tdiv_r (mpz[0], XBIGNUM (n)->value, mpz[0]);
intptr_t iz;
- mpz_export (&iz, NULL, -1, sizeof iz, 0, 0, z);
+ mpz_export (&iz, NULL, -1, sizeof iz, 0, 0, mpz[0]);
num += iz;
}
- mpz_clear (z);
num += cycle_length - large_num % cycle_length;
}
num %= cycle_length;
diff --git a/src/font.c b/src/font.c
index e241458..799d5db 100644
--- a/src/font.c
+++ b/src/font.c
@@ -1289,8 +1289,9 @@ font_unparse_xlfd (Lisp_Object font, int pixel_size, char
*name, int nbytes)
1 + DBL_MAX_10_EXP + 1)];
if (INTEGERP (val))
{
- intmax_t v = FIXNUMP (val) ? XFIXNUM (val) : bignum_to_intmax (val);
- if (! (0 < v && v <= TYPE_MAXIMUM (uprintmax_t)))
+ intmax_t v;
+ if (! (integer_to_intmax (val, &v)
+ && 0 < v && v <= TYPE_MAXIMUM (uprintmax_t)))
v = pixel_size;
if (v > 0)
{
@@ -4484,7 +4485,8 @@ Each element of the value is a cons (VARIATION-SELECTOR .
GLYPH-ID),
where
VARIATION-SELECTOR is a character code of variation selection
(#xFE00..#xFE0F or #xE0100..#xE01EF)
- GLYPH-ID is a glyph code of the corresponding variation glyph. */)
+ GLYPH-ID is a glyph code of the corresponding variation glyph,
+a fixnum, if it's small enough, otherwise a bignum. */)
(Lisp_Object font_object, Lisp_Object character)
{
unsigned variations[256];
@@ -4521,7 +4523,8 @@ where
that apply to POSITION. POSITION may be nil, in which case,
FONT-SPEC is the font for displaying the character CH with the
default face. GLYPH-CODE is the glyph code in the font to use for
- the character.
+ the character, it is a fixnum, if it is small enough, otherwise a
+ bignum.
For a text terminal, return a nonnegative integer glyph code for
the character, or a negative integer if the character is not
@@ -4747,16 +4750,10 @@ DEFUN ("open-font", Fopen_font, Sopen_font, 1, 3, 0,
else
{
CHECK_NUMBER (size);
- if (BIGNUMP (size))
- {
- isize = bignum_to_intmax (size);
- if (isize == 0)
- args_out_of_range (font_entity, size);
- }
- else
- isize = (FLOATP (size)
- ? POINT_TO_PIXEL (XFLOAT_DATA (size), FRAME_RES_Y (f))
- : XFIXNUM (size));
+ if (FLOATP (size))
+ isize = POINT_TO_PIXEL (XFLOAT_DATA (size), FRAME_RES_Y (f));
+ else if (! integer_to_intmax (size, &isize))
+ args_out_of_range (font_entity, size);
if (! (INT_MIN <= isize && isize <= INT_MAX))
args_out_of_range (font_entity, size);
if (isize == 0)
diff --git a/src/frame.h b/src/frame.h
index a3bb633..ad7376a 100644
--- a/src/frame.h
+++ b/src/frame.h
@@ -578,7 +578,7 @@ struct frame
enum ns_appearance_type ns_appearance;
bool_bf ns_transparent_titlebar;
#endif
-};
+} GCALIGNED_STRUCT;
/* Most code should use these functions to set Lisp fields in struct frame. */
diff --git a/src/keymap.c b/src/keymap.c
index 52db7b4..79dce15 100644
--- a/src/keymap.c
+++ b/src/keymap.c
@@ -554,9 +554,9 @@ union map_keymap
Lisp_Object args;
void *data;
} s;
- GCALIGNED_UNION
+ GCALIGNED_UNION_MEMBER
};
-verify (alignof (union map_keymap) % GCALIGNMENT == 0);
+verify (GCALIGNED (union map_keymap));
static void
map_keymap_char_table_item (Lisp_Object args, Lisp_Object key, Lisp_Object val)
diff --git a/src/lisp.h b/src/lisp.h
index 36ca32c..f2a3ac9 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -229,7 +229,7 @@ extern bool suppress_checking EXTERNALLY_VISIBLE;
USE_LSB_TAG not only requires the least 3 bits of pointers returned by
malloc to be 0 but also needs to be able to impose a mult-of-8 alignment
on some non-GC Lisp_Objects, all of which are aligned via
- GCALIGNED_UNION at the end of a union. */
+ GCALIGNED_UNION_MEMBER, GCALIGNED_STRUCT_MEMBER, and GCALIGNED_STRUCT. */
enum Lisp_Bits
{
@@ -282,7 +282,35 @@ error !;
# define GCALIGNMENT 1
#endif
-#define GCALIGNED_UNION char alignas (GCALIGNMENT) gcaligned;
+/* If a struct is always allocated by the GC and is therefore always
+ GC-aligned, put GCALIGNED_STRUCT after its closing '}'; this can
+ help the compiler generate better code.
+
+ To cause a union to have alignment of at least GCALIGNMENT, put
+ GCALIGNED_UNION_MEMBER in its member list. Similarly for a struct
+ and GCALIGNED_STRUCT_MEMBER, although this may make the struct a
+ bit bigger on non-GCC platforms. Any struct using
+ GCALIGNED_STRUCT_MEMBER should also use GCALIGNED_STRUCT.
+
+ Although these macros are reasonably portable, they are not
+ guaranteed on non-GCC platforms, as C11 does not require support
+ for alignment to GCALIGNMENT and older compilers may ignore
+ alignment requests. For any type T where garbage collection
+ requires alignment, use verify (GCALIGNED (T)) to verify the
+ requirement on the current platform. Types need this check if
+ their objects can be allocated outside the garbage collector. For
+ example, struct Lisp_Symbol needs the check because of lispsym and
+ struct Lisp_Cons needs it because of STACK_CONS. */
+
+#define GCALIGNED_UNION_MEMBER char alignas (GCALIGNMENT) gcaligned;
+#if HAVE_STRUCT_ATTRIBUTE_ALIGNED
+# define GCALIGNED_STRUCT_MEMBER
+# define GCALIGNED_STRUCT __attribute__ ((aligned (GCALIGNMENT)))
+#else
+# define GCALIGNED_STRUCT_MEMBER GCALIGNED_UNION_MEMBER
+# define GCALIGNED_STRUCT
+#endif
+#define GCALIGNED(type) (alignof (type) % GCALIGNMENT == 0)
/* Lisp_Word is a scalar word suitable for holding a tagged pointer or
integer. Usually it is a pointer to a deliberately-incomplete type
@@ -751,10 +779,10 @@ struct Lisp_Symbol
/* Next symbol in obarray bucket, if the symbol is interned. */
struct Lisp_Symbol *next;
} s;
- GCALIGNED_UNION
+ GCALIGNED_UNION_MEMBER
} u;
};
-verify (alignof (struct Lisp_Symbol) % GCALIGNMENT == 0);
+verify (GCALIGNED (struct Lisp_Symbol));
/* Declare a Lisp-callable function. The MAXARGS parameter has the same
meaning as in the DEFUN macro, and is used to construct a prototype. */
@@ -843,7 +871,9 @@ typedef EMACS_UINT Lisp_Word_tag;
and PSEUDOVECTORP cast their pointers to union vectorlike_header *,
because when two such pointers potentially alias, a compiler won't
incorrectly reorder loads and stores to their size fields. See
- Bug#8546. */
+ Bug#8546. This union formerly contained more members, and there's
+ no compelling reason to change it to a struct merely because the
+ number of members has been reduced to one. */
union vectorlike_header
{
/* The main member contains various pieces of information:
@@ -866,11 +896,7 @@ union vectorlike_header
Current layout limits the pseudovectors to 63 PVEC_xxx subtypes,
4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */
ptrdiff_t size;
- /* Align the union so that there is no padding after it. */
- Lisp_Object align;
- GCALIGNED_UNION
};
-verify (alignof (union vectorlike_header) % GCALIGNMENT == 0);
INLINE bool
(SYMBOLP) (Lisp_Object x)
@@ -1242,10 +1268,10 @@ struct Lisp_Cons
struct Lisp_Cons *chain;
} u;
} s;
- GCALIGNED_UNION
+ GCALIGNED_UNION_MEMBER
} u;
};
-verify (alignof (struct Lisp_Cons) % GCALIGNMENT == 0);
+verify (GCALIGNED (struct Lisp_Cons));
INLINE bool
(NILP) (Lisp_Object x)
@@ -1364,10 +1390,10 @@ struct Lisp_String
unsigned char *data;
} s;
struct Lisp_String *next;
- GCALIGNED_UNION
+ GCALIGNED_UNION_MEMBER
} u;
};
-verify (alignof (struct Lisp_String) % GCALIGNMENT == 0);
+verify (GCALIGNED (struct Lisp_String));
INLINE bool
STRINGP (Lisp_Object x)
@@ -1498,7 +1524,7 @@ struct Lisp_Vector
{
union vectorlike_header header;
Lisp_Object contents[FLEXIBLE_ARRAY_MEMBER];
- };
+ } GCALIGNED_STRUCT;
INLINE bool
(VECTORLIKEP) (Lisp_Object x)
@@ -1590,10 +1616,19 @@ struct Lisp_Bool_Vector
The bits are in little-endian order in the bytes, and
the bytes are in little-endian order in the words. */
bits_word data[FLEXIBLE_ARRAY_MEMBER];
- };
+ } GCALIGNED_STRUCT;
/* Some handy constants for calculating sizes
- and offsets, mostly of vectorlike objects. */
+ and offsets, mostly of vectorlike objects.
+
+ The garbage collector assumes that the initial part of any struct
+ that starts with a union vectorlike_header followed by N
+ Lisp_Objects (some possibly in arrays and/or a trailing flexible
+ array) will be laid out like a struct Lisp_Vector with N
+ Lisp_Objects. This assumption is true in practice on known Emacs
+ targets even though the C standard does not guarantee it. This
+ header contains a few sanity checks that should suffice to detect
+ violations of this assumption on plausible practical hosts. */
enum
{
@@ -1601,7 +1636,6 @@ enum
bool_header_size = offsetof (struct Lisp_Bool_Vector, data),
word_size = sizeof (Lisp_Object)
};
-verify (header_size == sizeof (union vectorlike_header));
/* The number of data words and bytes in a bool vector with SIZE bits. */
@@ -1756,7 +1790,8 @@ memclear (void *p, ptrdiff_t nbytes)
ones that the GC needs to trace). */
#define PSEUDOVECSIZE(type, nonlispfield) \
- ((offsetof (type, nonlispfield) - header_size) / word_size)
+ (offsetof (type, nonlispfield) < header_size \
+ ? 0 : (offsetof (type, nonlispfield) - header_size) / word_size)
/* Compute A OP B, using the unsigned comparison operator OP. A and B
should be integer expressions. This is not the same as
@@ -1821,7 +1856,7 @@ struct Lisp_Char_Table
/* These hold additional data. It is a vector. */
Lisp_Object extras[FLEXIBLE_ARRAY_MEMBER];
- };
+ } GCALIGNED_STRUCT;
INLINE bool
CHAR_TABLE_P (Lisp_Object a)
@@ -1855,7 +1890,7 @@ struct Lisp_Sub_Char_Table
/* Use set_sub_char_table_contents to set this. */
Lisp_Object contents[FLEXIBLE_ARRAY_MEMBER];
- };
+ } GCALIGNED_STRUCT;
INLINE bool
SUB_CHAR_TABLE_P (Lisp_Object a)
@@ -1933,7 +1968,9 @@ struct Lisp_Subr
const char *symbol_name;
const char *intspec;
EMACS_INT doc;
- };
+ GCALIGNED_STRUCT_MEMBER
+ } GCALIGNED_STRUCT;
+verify (GCALIGNED (struct Lisp_Subr));
INLINE bool
SUBRP (Lisp_Object a)
@@ -1960,6 +1997,13 @@ enum char_table_specials
SUB_CHAR_TABLE_OFFSET = PSEUDOVECSIZE (struct Lisp_Sub_Char_Table,
contents)
};
+/* Sanity-check pseudovector layout. */
+verify (offsetof (struct Lisp_Char_Table, defalt) == header_size);
+verify (offsetof (struct Lisp_Char_Table, extras)
+ == header_size + CHAR_TABLE_STANDARD_SLOTS * sizeof (Lisp_Object));
+verify (offsetof (struct Lisp_Sub_Char_Table, contents)
+ == header_size + SUB_CHAR_TABLE_OFFSET * sizeof (Lisp_Object));
+
/* Return the number of "extra" slots in the char table CT. */
INLINE int
@@ -1969,11 +2013,6 @@ CHAR_TABLE_EXTRA_SLOTS (struct Lisp_Char_Table *ct)
- CHAR_TABLE_STANDARD_SLOTS);
}
-/* Make sure that sub char-table contents slot is where we think it is. */
-verify (offsetof (struct Lisp_Sub_Char_Table, contents)
- == (offsetof (struct Lisp_Vector, contents)
- + SUB_CHAR_TABLE_OFFSET * sizeof (Lisp_Object)));
-
/* Save and restore the instruction and environment pointers,
without affecting the signal mask. */
@@ -2185,8 +2224,10 @@ struct Lisp_Hash_Table
/* Next weak hash table if this is a weak hash table. The head
of the list is in weak_hash_tables. */
struct Lisp_Hash_Table *next_weak;
-};
+} GCALIGNED_STRUCT;
+/* Sanity-check pseudovector layout. */
+verify (offsetof (struct Lisp_Hash_Table, weak) == header_size);
INLINE bool
HASH_TABLE_P (Lisp_Object a)
@@ -2304,7 +2345,7 @@ struct Lisp_Marker
used to implement the functionality of markers, but rather to (ab)use
markers as a cache for char<->byte mappings). */
ptrdiff_t bytepos;
-};
+} GCALIGNED_STRUCT;
/* START and END are markers in the overlay's buffer, and
PLIST is the overlay's property list. */
@@ -2326,13 +2367,13 @@ struct Lisp_Overlay
Lisp_Object end;
Lisp_Object plist;
struct Lisp_Overlay *next;
- };
+ } GCALIGNED_STRUCT;
struct Lisp_Misc_Ptr
{
union vectorlike_header header;
void *pointer;
- };
+ } GCALIGNED_STRUCT;
extern Lisp_Object make_misc_ptr (void *);
@@ -2379,7 +2420,7 @@ struct Lisp_User_Ptr
union vectorlike_header header;
void (*finalizer) (void *);
void *p;
-};
+} GCALIGNED_STRUCT;
#endif
/* A finalizer sentinel. */
@@ -2395,7 +2436,7 @@ struct Lisp_Finalizer
/* Circular list of all active weak references. */
struct Lisp_Finalizer *prev;
struct Lisp_Finalizer *next;
- };
+ } GCALIGNED_STRUCT;
INLINE bool
FINALIZERP (Lisp_Object x)
@@ -2607,7 +2648,7 @@ struct Lisp_Float
double data;
struct Lisp_Float *chain;
} u;
- };
+ } GCALIGNED_STRUCT;
INLINE bool
(FLOATP) (Lisp_Object x)
@@ -3288,6 +3329,39 @@ extern Lisp_Object bignum_to_string (Lisp_Object, int);
extern Lisp_Object make_bignum_str (char const *, int);
extern Lisp_Object double_to_bignum (double);
+/* Converthe integer NUM to *N. Return true if successful, false
+ (possibly setting *N) otherwise. */
+INLINE bool
+integer_to_intmax (Lisp_Object num, intmax_t *n)
+{
+ if (FIXNUMP (num))
+ {
+ *n = XFIXNUM (num);
+ return true;
+ }
+ else
+ {
+ intmax_t i = bignum_to_intmax (num);
+ *n = i;
+ return i != 0;
+ }
+}
+INLINE bool
+integer_to_uintmax (Lisp_Object num, uintmax_t *n)
+{
+ if (FIXNUMP (num))
+ {
+ *n = XFIXNUM (num);
+ return 0 <= XFIXNUM (num);
+ }
+ else
+ {
+ uintmax_t i = bignum_to_uintmax (num);
+ *n = i;
+ return i != 0;
+ }
+}
+
/* Defined in data.c. */
extern _Noreturn void wrong_choice (Lisp_Object, Lisp_Object);
extern void notify_variable_watchers (Lisp_Object, Lisp_Object,
@@ -3904,7 +3978,7 @@ struct Lisp_Module_Function
ptrdiff_t min_arity, max_arity;
emacs_subr subr;
void *data;
-};
+} GCALIGNED_STRUCT;
INLINE bool
MODULE_FUNCTIONP (Lisp_Object o)
diff --git a/src/lread.c b/src/lread.c
index a7c5b0b..e43929a 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -3762,6 +3762,7 @@ string_to_number (char const *string, int base, int flags)
cp++;
while ('0' <= *cp && *cp <= '9');
}
+#if IEEE_FLOATING_POINT
else if (cp[-1] == '+'
&& cp[0] == 'I' && cp[1] == 'N' && cp[2] == 'F')
{
@@ -3769,7 +3770,6 @@ string_to_number (char const *string, int base, int flags)
cp += 3;
value = INFINITY;
}
-#if IEEE_FLOATING_POINT
else if (cp[-1] == '+'
&& cp[0] == 'N' && cp[1] == 'a' && cp[2] == 'N')
{
diff --git a/src/process.c b/src/process.c
index 29cedd7..ebaaf33 100644
--- a/src/process.c
+++ b/src/process.c
@@ -1157,6 +1157,7 @@ If PROCESS has not yet exited or died, return 0. */)
DEFUN ("process-id", Fprocess_id, Sprocess_id, 1, 1, 0,
doc: /* Return the process id of PROCESS.
This is the pid of the external process which PROCESS uses or talks to.
+It is a fixnum if the value is small enough, otherwise a bignum.
For a network, serial, and pipe connections, this value is nil. */)
(register Lisp_Object process)
{
@@ -5009,7 +5010,7 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
Lisp_Object proc;
struct timespec timeout, end_time, timer_delay;
struct timespec got_output_end_time = invalid_timespec ();
- enum { MINIMUM = -1, TIMEOUT, INFINITY } wait;
+ enum { MINIMUM = -1, TIMEOUT, FOREVER } wait;
int got_some_output = -1;
uintmax_t prev_wait_proc_nbytes_read = wait_proc ? wait_proc->nbytes_read :
0;
#if defined HAVE_GETADDRINFO_A || defined HAVE_GNUTLS
@@ -5048,7 +5049,7 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
end_time = timespec_add (now, make_timespec (time_limit, nsecs));
}
else
- wait = INFINITY;
+ wait = FOREVER;
while (1)
{
@@ -6410,7 +6411,7 @@ send_process (Lisp_Object proc, const char *buf,
ptrdiff_t len,
}
#endif /* BROKEN_PTY_READ_AFTER_EAGAIN */
- /* Put what we should have written in wait_queue. */
+ /* Put what we should have written in write_queue. */
write_queue_push (p, cur_object, cur_buf, cur_len, 1);
wait_reading_process_output (0, 20 * 1000 * 1000,
0, 0, Qnil, NULL, 0);
@@ -7055,8 +7056,9 @@ handle_child_signal (int sig)
xpid = XCAR (head);
if (all_pids_are_fixnums ? FIXNUMP (xpid) : INTEGERP (xpid))
{
- pid_t deleted_pid = (FIXNUMP (xpid) ? XFIXNUM (xpid)
- : bignum_to_intmax (xpid));
+ intmax_t deleted_pid;
+ bool ok = integer_to_intmax (xpid, &deleted_pid);
+ eassert (ok);
if (child_status_changed (deleted_pid, 0, 0))
{
if (STRINGP (XCDR (head)))
@@ -7515,7 +7517,7 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
{
register int nfds;
struct timespec end_time, timeout;
- enum { MINIMUM = -1, TIMEOUT, INFINITY } wait;
+ enum { MINIMUM = -1, TIMEOUT, FOREVER } wait;
if (TYPE_MAXIMUM (time_t) < time_limit)
time_limit = TYPE_MAXIMUM (time_t);
@@ -7529,7 +7531,7 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
make_timespec (time_limit, nsecs));
}
else
- wait = INFINITY;
+ wait = FOREVER;
/* Turn off periodic alarms (in case they are in use)
and then turn off any other atimers,
@@ -7635,7 +7637,7 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
/* If we woke up due to SIGWINCH, actually change size now. */
do_pending_window_change (0);
- if (wait < INFINITY && nfds == 0 && ! timeout_reduced_for_timers)
+ if (wait < FOREVER && nfds == 0 && ! timeout_reduced_for_timers)
/* We waited the full specified time, so return now. */
break;
diff --git a/src/process.h b/src/process.h
index 6bc2214..3c6dd7b 100644
--- a/src/process.h
+++ b/src/process.h
@@ -203,7 +203,7 @@ struct Lisp_Process
bool_bf gnutls_p : 1;
bool_bf gnutls_complete_negotiation_p : 1;
#endif
-};
+ } GCALIGNED_STRUCT;
INLINE bool
PROCESSP (Lisp_Object a)
diff --git a/src/puresize.h b/src/puresize.h
index e6319ff..b37ab97 100644
--- a/src/puresize.h
+++ b/src/puresize.h
@@ -47,7 +47,7 @@ INLINE_HEADER_BEGIN
#endif
#ifndef BASE_PURESIZE
-#define BASE_PURESIZE (1900000 + SYSTEM_PURESIZE_EXTRA +
SITELOAD_PURESIZE_EXTRA)
+#define BASE_PURESIZE (2000000 + SYSTEM_PURESIZE_EXTRA +
SITELOAD_PURESIZE_EXTRA)
#endif
/* Increase BASE_PURESIZE by a ratio depending on the machine's word size. */
diff --git a/src/scroll.c b/src/scroll.c
index 8a53f96..a29f2d3 100644
--- a/src/scroll.c
+++ b/src/scroll.c
@@ -28,12 +28,6 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "frame.h"
#include "termhooks.h"
-/* All costs measured in characters.
- So no cost can exceed the area of a frame, measured in characters.
- Let's hope this is never more than 1000000 characters. */
-
-#define INFINITY 1000000
-
struct matrix_elt
{
/* Cost of outputting through this line
@@ -120,8 +114,8 @@ calculate_scrolling (struct frame *frame,
/* initialize the top left corner of the matrix */
matrix->writecost = 0;
- matrix->insertcost = INFINITY;
- matrix->deletecost = INFINITY;
+ matrix->insertcost = SCROLL_INFINITY;
+ matrix->deletecost = SCROLL_INFINITY;
matrix->insertcount = 0;
matrix->deletecount = 0;
@@ -132,8 +126,8 @@ calculate_scrolling (struct frame *frame,
p = matrix + i * (window_size + 1);
cost += draw_cost[i] + next_insert_cost[i] + extra_cost;
p->insertcost = cost;
- p->writecost = INFINITY;
- p->deletecost = INFINITY;
+ p->writecost = SCROLL_INFINITY;
+ p->deletecost = SCROLL_INFINITY;
p->insertcount = i;
p->deletecount = 0;
}
@@ -144,8 +138,8 @@ calculate_scrolling (struct frame *frame,
{
cost += next_delete_cost[j];
matrix[j].deletecost = cost;
- matrix[j].writecost = INFINITY;
- matrix[j].insertcost = INFINITY;
+ matrix[j].writecost = SCROLL_INFINITY;
+ matrix[j].insertcost = SCROLL_INFINITY;
matrix[j].deletecount = j;
matrix[j].insertcount = 0;
}
@@ -465,8 +459,8 @@ calculate_direct_scrolling (struct frame *frame,
/* initialize the top left corner of the matrix */
matrix->writecost = 0;
- matrix->insertcost = INFINITY;
- matrix->deletecost = INFINITY;
+ matrix->insertcost = SCROLL_INFINITY;
+ matrix->deletecost = SCROLL_INFINITY;
matrix->writecount = 0;
matrix->insertcount = 0;
matrix->deletecount = 0;
@@ -478,8 +472,8 @@ calculate_direct_scrolling (struct frame *frame,
p = matrix + i * (window_size + 1);
cost += draw_cost[i];
p->insertcost = cost;
- p->writecost = INFINITY;
- p->deletecost = INFINITY;
+ p->writecost = SCROLL_INFINITY;
+ p->deletecost = SCROLL_INFINITY;
p->insertcount = i;
p->writecount = 0;
p->deletecount = 0;
@@ -489,8 +483,8 @@ calculate_direct_scrolling (struct frame *frame,
for (j = 1; j <= window_size; j++)
{
matrix[j].deletecost = 0;
- matrix[j].writecost = INFINITY;
- matrix[j].insertcost = INFINITY;
+ matrix[j].writecost = SCROLL_INFINITY;
+ matrix[j].insertcost = SCROLL_INFINITY;
matrix[j].deletecount = j;
matrix[j].writecount = 0;
matrix[j].insertcount = 0;
diff --git a/src/termhooks.h b/src/termhooks.h
index 8b5f648..2114291 100644
--- a/src/termhooks.h
+++ b/src/termhooks.h
@@ -661,7 +661,7 @@ struct terminal
frames on the terminal when it calls this hook, so infinite
recursion is prevented. */
void (*delete_terminal_hook) (struct terminal *);
-};
+} GCALIGNED_STRUCT;
INLINE bool
TERMINALP (Lisp_Object a)
diff --git a/src/thread.h b/src/thread.h
index 8ecb008..28d8d86 100644
--- a/src/thread.h
+++ b/src/thread.h
@@ -184,7 +184,7 @@ struct thread_state
/* Threads are kept on a linked list. */
struct thread_state *next_thread;
-};
+} GCALIGNED_STRUCT;
INLINE bool
THREADP (Lisp_Object a)
@@ -231,7 +231,7 @@ struct Lisp_Mutex
/* The lower-level mutex object. */
lisp_mutex_t mutex;
-};
+} GCALIGNED_STRUCT;
INLINE bool
MUTEXP (Lisp_Object a)
@@ -265,7 +265,7 @@ struct Lisp_CondVar
/* The lower-level condition variable object. */
sys_cond_t cond;
-};
+} GCALIGNED_STRUCT;
INLINE bool
CONDVARP (Lisp_Object a)
diff --git a/src/w32fns.c b/src/w32fns.c
index 153cba9..9a9789d 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -10100,19 +10100,16 @@ the return value depends on the type of the data
stored in Registry:
If the data type is REG_NONE, the function returns t.
If the data type is REG_DWORD or REG_QWORD, the function returns
- its integer value. If the value is too large for a Lisp integer,
- the function returns a cons (HIGH . LOW) of 2 integers, with LOW
- the low 16 bits and HIGH the high bits. If HIGH is too large for
- a Lisp integer, the function returns (HIGH MIDDLE . LOW), first
- the high bits, then the middle 24 bits, and finally the low 16 bits.
+ its integer value. If the value is too large for a fixnum,
+ the function returns a bignum.
If the data type is REG_BINARY, the function returns a vector whose
elements are individual bytes of the value.
If the data type is REG_SZ, the function returns a string.
- If the data type REG_EXPAND_SZ, the function returns a string with
- all the %..% references to environment variables replaced by the
- values of those variables. If the expansion fails, or some
- variables are not defined in the environment, some or all of
- the environment variables will remain unexpanded.
+ If the data type is REG_EXPAND_SZ, the function returns a string
+ with all the %..% references to environment variables replaced
+ by the values of those variables. If the expansion fails, or
+ some variables are not defined in the environment, some or all
+ of the environment variables will remain unexpanded.
If the data type is REG_MULTI_SZ, the function returns a list whose
elements are the individual strings.
diff --git a/src/window.c b/src/window.c
index d4fc556..b81469b 100644
--- a/src/window.c
+++ b/src/window.c
@@ -3442,7 +3442,11 @@ run_window_size_change_functions (Lisp_Object frame)
{
struct frame *f = XFRAME (frame);
struct window *r = XWINDOW (FRAME_ROOT_WINDOW (f));
- Lisp_Object functions = Vwindow_size_change_functions;
+
+ if (NILP (Vrun_hooks)
+ || !(f->can_x_set_window_size)
+ || !(f->after_make_frame))
+ return;
if (FRAME_WINDOW_CONFIGURATION_CHANGED (f)
/* Here we implicitly exclude the possibility that the height of
@@ -3450,11 +3454,44 @@ run_window_size_change_functions (Lisp_Object frame)
of FRAME's root window alone. */
|| window_size_changed (r))
{
- while (CONSP (functions))
+ Lisp_Object globals = Fdefault_value (Qwindow_size_change_functions);
+ Lisp_Object windows = Fwindow_list (frame, Qlambda, Qnil);
+ /* The buffers for which the local hook was already run. */
+ Lisp_Object buffers = Qnil;
+
+ for (; CONSP (windows); windows = XCDR (windows))
+ {
+ Lisp_Object window = XCAR (windows);
+ Lisp_Object buffer = Fwindow_buffer (window);
+
+ /* Run a buffer-local value only once for that buffer and
+ only if at least one window showing that buffer on FRAME
+ actually changed its size. Note that the function is run
+ with FRAME as its argument and as such oblivious to the
+ window checked below. */
+ if (window_size_changed (XWINDOW (window))
+ && !Fmemq (buffer, buffers)
+ && Flocal_variable_p (Qwindow_size_change_functions, buffer))
+ {
+ Lisp_Object locals
+ = Fbuffer_local_value (Qwindow_size_change_functions, buffer);
+
+ while (CONSP (locals))
+ {
+ if (!EQ (XCAR (locals), Qt))
+ safe_call1 (XCAR (locals), frame);
+ locals = XCDR (locals);
+ }
+
+ buffers = Fcons (buffer, buffers);
+ }
+ }
+
+ while (CONSP (globals))
{
- if (!EQ (XCAR (functions), Qt))
- safe_call1 (XCAR (functions), frame);
- functions = XCDR (functions);
+ if (!EQ (XCAR (globals), Qt))
+ safe_call1 (XCAR (globals), frame);
+ globals = XCDR (globals);
}
window_set_before_size_change_sizes (r);
@@ -6268,7 +6305,7 @@ struct save_window_data
/* These are currently unused. We need them as soon as we convert
to pixels. */
int frame_menu_bar_height, frame_tool_bar_height;
- };
+ } GCALIGNED_STRUCT;
/* This is saved as a Lisp_Vector. */
struct saved_window
@@ -7556,6 +7593,7 @@ syms_of_window (void)
Fput (Qscroll_down, Qscroll_command, Qt);
DEFSYM (Qwindow_configuration_change_hook,
"window-configuration-change-hook");
+ DEFSYM (Qwindow_size_change_functions, "window-size-change-functions");
DEFSYM (Qwindowp, "windowp");
DEFSYM (Qwindow_configuration_p, "window-configuration-p");
DEFSYM (Qwindow_live_p, "window-live-p");
diff --git a/src/window.h b/src/window.h
index 013083e..cc0b6b6 100644
--- a/src/window.h
+++ b/src/window.h
@@ -400,7 +400,7 @@ struct window
/* Z_BYTE - buffer position of the last glyph in the current matrix of W.
Should be nonnegative, and only valid if window_end_valid is true. */
ptrdiff_t window_end_bytepos;
- };
+ } GCALIGNED_STRUCT;
INLINE bool
WINDOWP (Lisp_Object a)
diff --git a/src/xdisp.c b/src/xdisp.c
index 0403366..47286e2 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -27910,10 +27910,12 @@ calc_line_height_property (struct it *it, Lisp_Object
val, struct font *font,
/* FIXME: Check for overflow in multiplication or conversion. */
if (FLOATP (val))
height = (int)(XFLOAT_DATA (val) * height);
- else if (FIXNUMP (val))
- height *= XFIXNUM (val);
else
- height *= bignum_to_intmax (val);
+ {
+ intmax_t v;
+ if (integer_to_intmax (val, &v))
+ height *= v;
+ }
return make_fixnum (height);
}
diff --git a/src/xselect.c b/src/xselect.c
index 53e7885..a87784f 100644
--- a/src/xselect.c
+++ b/src/xselect.c
@@ -1536,17 +1536,10 @@ x_get_window_property_as_lisp_data (struct
x_display_info *dpyinfo,
ATOM 32 > 1 Vector of Symbols
* 16 1 Integer
* 16 > 1 Vector of Integers
- * 32 1 if <=16 bits: Integer
- if > 16 bits: Cons of top16, bot16
+ * 32 1 if small enough: fixnum
+ otherwise: bignum
* 32 > 1 Vector of the above
- When converting a Lisp number to C, it is assumed to be of format 16 if
- it is an integer, and of format 32 if it is a cons of two integers.
-
- When converting a vector of numbers from Lisp to C, it is assumed to be
- of format 16 if every element in the vector is an integer, and is assumed
- to be of format 32 if any element is a cons of two integers.
-
When converting an object to C, it may be of the form (SYMBOL . <data>)
where SYMBOL is what we should claim that the type is. Format and
representation are as above.
@@ -1611,8 +1604,8 @@ selection_data_to_lisp_data (struct x_display_info
*dpyinfo,
}
/* Convert a single 16-bit number or a small 32-bit number to a Lisp_Int.
- If the number is 32 bits and won't fit in a Lisp_Int,
- convert it to a cons of integers, 16 bits in each half.
+ If the number is 32 bits and won't fit in a Lisp_Int, convert it
+ to a bignum.
INTEGER is a signed type, CARDINAL is unsigned.
Assume any other types are unsigned as well.
diff --git a/src/xterm.h b/src/xterm.h
index 1849a5c..2ea8a93 100644
--- a/src/xterm.h
+++ b/src/xterm.h
@@ -937,7 +937,7 @@ struct scroll_bar
/* True if the scroll bar is horizontal. */
bool horizontal;
-};
+} GCALIGNED_STRUCT;
/* Turning a lisp vector value into a pointer to a struct scroll_bar. */
#define XSCROLL_BAR(vec) ((struct scroll_bar *) XVECTOR (vec))
diff --git a/src/xwidget.h b/src/xwidget.h
index 89fc7ff..c203d4f 100644
--- a/src/xwidget.h
+++ b/src/xwidget.h
@@ -61,7 +61,7 @@ struct xwidget
/* Kill silently if Emacs is exited. */
bool_bf kill_without_query : 1;
-};
+} GCALIGNED_STRUCT;
struct xwidget_view
{
@@ -88,7 +88,7 @@ struct xwidget_view
int clip_left;
long handler_id;
-};
+} GCALIGNED_STRUCT;
#endif
/* Test for xwidget pseudovector. */
diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el
index 05d24b5..b378c9b 100644
--- a/test/lisp/autorevert-tests.el
+++ b/test/lisp/autorevert-tests.el
@@ -167,6 +167,7 @@ This expects `auto-revert--messages' to be bound by
(write-region "any text" nil tmpfile nil 'no-message)
(setq buf (find-file-noselect tmpfile))
(with-current-buffer buf
+ (should-not auto-revert-notify-watch-descriptor)
(should (string-equal (buffer-string) "any text"))
;; `buffer-stale--default-function' checks for
;; `verify-visited-file-modtime'. We must ensure that
diff --git a/test/lisp/calendar/todo-mode-tests.el
b/test/lisp/calendar/todo-mode-tests.el
index 6cd2bfe..015fbac 100644
--- a/test/lisp/calendar/todo-mode-tests.el
+++ b/test/lisp/calendar/todo-mode-tests.el
@@ -603,7 +603,7 @@ separator, otherwise, return the position at the beginning."
(forward-line -1))
(if eol (forward-char)))
-(ert-deftest todo-test-done-items-separator01-bol ()
+(ert-deftest todo-test-done-items-separator01-bol () ; bug#32343
"Test item copying and here insertion at BOL of separator.
Both should be user errors."
(with-todo-test
@@ -616,7 +616,7 @@ Both should be user errors."
(should (string= copy-err (cadr (funcall insert-item-test 'copy))))
(should (string= here-err (cadr (funcall insert-item-test 'here)))))))
-(ert-deftest todo-test-done-items-separator01-eol ()
+(ert-deftest todo-test-done-items-separator01-eol () ; bug#32343
"Test item copying and here insertion at EOL of separator.
Both should be user errors."
(with-todo-test
@@ -629,7 +629,7 @@ Both should be user errors."
(should (string= copy-err (cadr (funcall insert-item-test 'copy))))
(should (string= here-err (cadr (funcall insert-item-test 'here)))))))
-(ert-deftest todo-test-done-items-separator02-bol ()
+(ert-deftest todo-test-done-items-separator02-bol () ; bug#32343
"Test item editing commands at BOL of done items separator.
They should all be noops."
(with-todo-test
@@ -642,7 +642,7 @@ They should all be noops."
(should-not (called-interactively-p #'todo-delete-item))
(should-not (called-interactively-p #'todo-edit-item))))
-(ert-deftest todo-test-done-items-separator02-eol ()
+(ert-deftest todo-test-done-items-separator02-eol () ; bug#32343
"Test item editing command at EOL of done items separator.
They should all be noops."
(with-todo-test
@@ -655,7 +655,7 @@ They should all be noops."
(should-not (called-interactively-p #'todo-delete-item))
(should-not (called-interactively-p #'todo-edit-item))))
-(ert-deftest todo-test-done-items-separator03-bol ()
+(ert-deftest todo-test-done-items-separator03-bol () ; bug#32343
"Test item marking at BOL of done items separator.
This should be a noop, adding no marks to the category."
(with-todo-test
@@ -663,7 +663,7 @@ This should be a noop, adding no marks to the category."
(call-interactively #'todo-toggle-mark-item)
(should-not (assoc (todo-current-category) todo-categories-with-marks))))
-(ert-deftest todo-test-done-items-separator03-eol ()
+(ert-deftest todo-test-done-items-separator03-eol () ; bug#32343
"Test item marking at EOL of done items separator.
This should be a noop, adding no marks to the category."
(with-todo-test
@@ -671,7 +671,7 @@ This should be a noop, adding no marks to the category."
(call-interactively #'todo-toggle-mark-item)
(should-not (assoc (todo-current-category) todo-categories-with-marks))))
-(ert-deftest todo-test-done-items-separator04-bol ()
+(ert-deftest todo-test-done-items-separator04-bol () ; bug#32343
"Test moving to previous item from BOL of done items separator.
This should move point to the last not done todo item."
(with-todo-test
@@ -685,7 +685,7 @@ This should move point to the last not done todo item."
(todo-previous-item)
(todo-item-string)))))))
-(ert-deftest todo-test-done-items-separator04-eol ()
+(ert-deftest todo-test-done-items-separator04-eol () ; bug#32343
"Test moving to previous item from EOL of done items separator.
This should move point to the last not done todo item."
(with-todo-test
@@ -699,7 +699,7 @@ This should move point to the last not done todo item."
(todo-previous-item)
(todo-item-string)))))))
-(ert-deftest todo-test-done-items-separator05-bol ()
+(ert-deftest todo-test-done-items-separator05-bol () ; bug#32343
"Test moving to next item from BOL of done items separator.
This should move point to the first done todo item."
(with-todo-test
@@ -713,7 +713,7 @@ This should move point to the first done todo item."
(todo-next-item)
(todo-item-string)))))))
-(ert-deftest todo-test-done-items-separator05-eol ()
+(ert-deftest todo-test-done-items-separator05-eol () ; bug#32343
"Test moving to next item from EOL of done items separator.
This should move point to the first done todo item."
(with-todo-test
@@ -732,7 +732,7 @@ This should move point to the first done todo item."
;; hook function is not automatically run, so after enabling item
;; highlighting, use ert-simulate-command around the next command,
;; which explicitly runs the hook function.
-(ert-deftest todo-test-done-items-separator06-bol ()
+(ert-deftest todo-test-done-items-separator06-bol () ; bug#32343
"Test enabling item highlighting at BOL of done items separator.
Subsequently moving to an item should show it highlighted."
(with-todo-test
@@ -741,7 +741,7 @@ Subsequently moving to an item should show it highlighted."
(ert-simulate-command '(todo-previous-item))
(should (eq 'hl-line (get-char-property (point) 'face)))))
-(ert-deftest todo-test-done-items-separator06-eol ()
+(ert-deftest todo-test-done-items-separator06-eol () ; bug#32343
"Test enabling item highlighting at EOL of done items separator.
Subsequently moving to an item should show it highlighted."
(with-todo-test
@@ -751,7 +751,7 @@ Subsequently moving to an item should show it highlighted."
(ert-simulate-command '(todo-previous-item))
(should (eq 'hl-line (get-char-property (point) 'face)))))
-(ert-deftest todo-test-done-items-separator07 ()
+(ert-deftest todo-test-done-items-separator07 () ; bug#32343
"Test item highlighting when crossing done items separator.
The highlighting should remain enabled."
(with-todo-test
@@ -763,11 +763,11 @@ The highlighting should remain enabled."
(ert-simulate-command '(forward-line)) ; Now on first done item.
(should (eq 'hl-line (get-char-property (point) 'face)))))
-(ert-deftest todo-test-current-file-in-edit-mode ()
+(ert-deftest todo-test-current-file-in-edit-mode () ; bug#32437
"Test the value of todo-current-todo-file in todo-edit-mode."
(with-todo-test
(todo-test--show 1)
- ;; The preceding call todo-mode but does not run pre-command-hook
+ ;; The preceding calls todo-mode but does not run pre-command-hook
;; in the test environment, thus failing to set
;; todo-global-current-todo-file, which is needed for the test
;; after todo-edit-item--text. So force the hook function to run.
@@ -786,7 +786,7 @@ The highlighting should remain enabled."
(todo-edit-file)
(should (equal todo-current-todo-file curfile)))))
-(ert-deftest todo-test-edit-quit ()
+(ert-deftest todo-test-edit-quit () ; bug#32437
"Test result of exiting todo-edit-mode on a whole file.
Exiting should return to the same todo-mode or todo-archive-mode
buffer from which the editing command was invoked."
@@ -804,6 +804,50 @@ buffer from which the editing command was invoked."
(should (eq (current-buffer) buf))
(should (eq major-mode 'todo-archive-mode))))))
+(defun todo-test--add-file (file cat)
+ "Add file FILE with category CAT to todo-files and show it.
+This provides a noninteractive API for todo-add-file for use in
+automatic testing."
+ (let ((file0 (file-truename (concat todo-test-data-dir file ".todo")))
+ todo-add-item-if-new-category) ; Don't need an item in cat.
+ (cl-letf (((symbol-function 'todo-read-file-name)
+ (lambda (_prompt) file0))
+ ((symbol-function 'todo-read-category)
+ (lambda (_prompt &optional _match-type _file) (cons cat
file0))))
+ (call-interactively 'todo-add-file) ; Interactive to call todo-show.
+ (todo-add-category file0 cat))))
+
+(defun todo-test--delete-file ()
+ "Delete current todo file without prompting."
+ (cl-letf (((symbol-function 'yes-or-no-p)
+ (lambda (_prompt) t)))
+ (todo-delete-file)))
+
+(ert-deftest todo-test-add-and-delete-file () ; bug#32627
+ "Test adding a new todo file and then deleting it.
+Calling todo-show should display the last current todo file, not
+necessarily the new file. After deleting the new file, todo-show
+should display the previously current (or default) todo file."
+ (with-todo-test
+ (todo-show)
+ (should (equal todo-current-todo-file todo-test-file-1))
+ (let* ((file (concat todo-directory "todo-test-2.todo"))
+ (file-nb (file-name-base file))
+ (cat "cat21"))
+ (todo-test--add-file file-nb cat) ; Add new file and show it.
+ (should (equal todo-current-todo-file file))
+ (todo-quit) ; Quitting todo-mode displays previous buffer.
+ (should (equal todo-current-todo-file todo-test-file-1))
+ (switch-to-buffer "*scratch*")
+ (todo-show) ; Show the last current todo-file (not the new one).
+ (should (equal todo-current-todo-file todo-test-file-1))
+ (switch-to-buffer (get-file-buffer file)) ; Back to new file.
+ (should (equal todo-current-todo-file file))
+ (todo-test--delete-file)
+ (todo-show) ; Back to old file.
+ (should (equal todo-current-todo-file todo-test-file-1))
+ (delete-file (concat file "~")))))
+
(provide 'todo-mode-tests)
;;; todo-mode-tests.el ends here
diff --git a/test/lisp/emacs-lisp/timer-tests.el
b/test/lisp/emacs-lisp/timer-tests.el
index 65e5dc9..fa92c1b 100644
--- a/test/lisp/emacs-lisp/timer-tests.el
+++ b/test/lisp/emacs-lisp/timer-tests.el
@@ -39,4 +39,9 @@
(if (fboundp 'debug-timer-check)
(should (debug-timer-check)) t))
+(ert-deftest timer-test-multiple-of-time ()
+ (should (equal
+ (timer-next-integral-multiple-of-time '(0 0 0 1) (1+ (ash 1 53)))
+ (list (ash 1 (- 53 16)) 1 0 0))))
+
;;; timer-tests.el ends here
diff --git a/test/lisp/thread-tests.el b/test/lisp/thread-tests.el
new file mode 100644
index 0000000..0d57d38
--- /dev/null
+++ b/test/lisp/thread-tests.el
@@ -0,0 +1,96 @@
+;;; thread-tests.el --- Test suite for thread.el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018 Free Software Foundation, Inc.
+
+;; Author: Gemini Lasswell <address@hidden>
+;; Keywords: threads
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+
+;;; Code:
+
+(require 'ert)
+(require 'thread)
+
+;; Declare the functions used here in case Emacs has been configured
+;; --without-threads.
+(declare-function make-mutex "thread.c" (&optional name))
+(declare-function mutex-lock "thread.c" (mutex))
+(declare-function mutex-unlock "thread.c" (mutex))
+(declare-function make-thread "thread.c" (function &optional name))
+(declare-function thread-join "thread.c" (thread))
+(declare-function thread-yield "thread.c" ())
+
+(defvar thread-tests-flag)
+(defvar thread-tests-mutex (when (featurep 'threads) (make-mutex "mutex1")))
+
+(defun thread-tests--thread-function ()
+ (setq thread-tests-flag t)
+ (with-mutex thread-tests-mutex
+ (sleep-for 0.01)))
+
+(ert-deftest thread-tests-thread-list-send-error ()
+ "A thread can be sent an error signal from the *Thread List* buffer."
+ (skip-unless (featurep 'threads))
+ (cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) t)))
+ (with-mutex thread-tests-mutex
+ (setq thread-tests-flag nil)
+ (let ((thread (make-thread #'thread-tests--thread-function
+ "thread-tests-wait")))
+ (while (not thread-tests-flag)
+ (thread-yield))
+ (list-threads)
+ (goto-char (point-min))
+ (re-search-forward
+ "^thread-tests.+[[:blank:]]+Blocked[[:blank:]]+.+mutex1.+?")
+ (thread-list-send-error-signal)
+ (should-error (thread-join thread))
+ (list-threads)
+ (goto-char (point-min))
+ (should-error (re-search-forward "thread-tests"))))))
+
+(ert-deftest thread-tests-thread-list-show-backtrace ()
+ "Show a backtrace for another thread from the *Thread List* buffer."
+ (skip-unless (featurep 'threads))
+ (let (thread)
+ (with-mutex thread-tests-mutex
+ (setq thread-tests-flag nil)
+ (setq thread
+ (make-thread #'thread-tests--thread-function "thread-tests-back"))
+ (while (not thread-tests-flag)
+ (thread-yield))
+ (list-threads)
+ (goto-char (point-min))
+ (re-search-forward
+ "^thread-tests.+[[:blank:]]+Blocked[[:blank:]]+.+mutex1.+?")
+ (thread-list-pop-to-backtrace)
+ (goto-char (point-min))
+ (re-search-forward "thread-tests-back")
+ (re-search-forward "mutex-lock")
+ (re-search-forward "thread-tests--thread-function"))
+ (thread-join thread)))
+
+(ert-deftest thread-tests-list-threads-error-when-not-configured ()
+ "Signal an error running `list-threads' if threads are not configured."
+ (skip-unless (not (featurep 'threads)))
+ (should-error (list-threads)))
+
+(provide 'thread-tests)
+
+;;; thread-tests.el ends here
diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el
index 487f3aa..4a840c8 100644
--- a/test/src/editfns-tests.el
+++ b/test/src/editfns-tests.el
@@ -253,6 +253,16 @@
(format-time-string "%Y-%m-%d %H:%M:%S.%3N %z" nil
(concat (make-string 2048 ?X) "0")))))
+(defun editfns-tests--have-leap-seconds ()
+ (string-equal (format-time-string "%Y-%m-%d %H:%M:%S" 78796800 t)
+ "1972-06-30 23:59:60"))
+
+(ert-deftest format-time-string-with-bignum-on-32-bit ()
+ (should (or (string-equal
+ (format-time-string "%Y-%m-%d %H:%M:%S" (- (ash 1 31) 3600) t)
+ "2038-01-19 02:14:08")
+ (editfns-tests--have-leap-seconds))))
+
(ert-deftest format-with-field ()
(should (equal (format "First argument %2$s, then %3$s, then %1$s" 1 2 3)
"First argument 2, then 3, then 1"))
diff --git a/test/src/floatfns-tests.el b/test/src/floatfns-tests.el
index d41b08f..9a38205 100644
--- a/test/src/floatfns-tests.el
+++ b/test/src/floatfns-tests.el
@@ -70,6 +70,11 @@
(should (= n (floor n)))
(should (= n (round n)))
(should (= n (truncate n)))
+ (let ((-n (- n))
+ (f (float n))
+ (-f (- (float n))))
+ (should (= 1 (round n f) (round -n -f) (round f n) (round -f -n)))
+ (should (= -1 (round -n f) (round n -f) (round f -n) (round -f n))))
(dolist (d ns)
(let ((q (/ n d))
(r (% n d))