commit 1c4b1ce8fa7c752454c144d78d8ae14ee88150d3 (HEAD, refs/remotes/origin/master) Author: Po Lu Date: Sat May 11 14:38:54 2024 +0800 Improve documentation of p-s-p-scroll-down-page * lisp/pixel-scroll.el (pixel-scroll-precision-scroll-down-page): Document unit in which the height of the window is measured, and what manner of height applies. Reported by Eli Zaretskii . diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index 20c7f3fe596..1f963ee8114 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -502,7 +502,7 @@ Otherwise, redisplay will reset the window's vscroll." (defun pixel-scroll-precision-scroll-down-page (delta) "Scroll the current window down by DELTA pixels. Note that this function doesn't work if DELTA is larger than or -equal to the height of the current window." +equal to the text height of the current window in pixels." (let* ((desired-pos (posn-at-x-y 0 (+ delta (window-tab-line-height) (window-header-line-height)))) commit 3ff83246c86a64600712b48631b900d23c806244 Author: Po Lu Date: Sat May 11 14:34:32 2024 +0800 Delete unused functions * java/org/gnu/emacs/EmacsNative.java (dup, close): * src/android.c (dup, close): Delete functions no longer referenced. diff --git a/java/org/gnu/emacs/EmacsNative.java b/java/org/gnu/emacs/EmacsNative.java index b2764edad10..97415fcb876 100644 --- a/java/org/gnu/emacs/EmacsNative.java +++ b/java/org/gnu/emacs/EmacsNative.java @@ -36,12 +36,6 @@ public final class EmacsNative private static final String[] libraryDeps; - /* Like `dup' in C. */ - public static native int dup (int fd); - - /* Like `close' in C. */ - public static native int close (int fd); - /* Obtain the fingerprint of this build of Emacs. The fingerprint can be used to determine the dump file name. */ public static native String getFingerprint (); diff --git a/src/android.c b/src/android.c index d3b0bc21478..c25ecd88a5a 100644 --- a/src/android.c +++ b/src/android.c @@ -1307,22 +1307,6 @@ android_create_lib_link (void) #pragma GCC diagnostic ignored "-Wmissing-prototypes" #endif -JNIEXPORT jint JNICALL -NATIVE_NAME (dup) (JNIEnv *env, jobject object, jint fd) -{ - JNI_STACK_ALIGNMENT_PROLOGUE; - - return dup (fd); -} - -JNIEXPORT jint JNICALL -NATIVE_NAME (close) (JNIEnv *env, jobject object, jint fd) -{ - JNI_STACK_ALIGNMENT_PROLOGUE; - - return close (fd); -} - JNIEXPORT jstring JNICALL NATIVE_NAME (getFingerprint) (JNIEnv *env, jobject object) { commit 41bfca00051b590c24fca9e8614b67724fab272d Author: Eric Abrahamsen Date: Fri May 10 12:38:57 2024 -0700 Update gnus-draft-check-draft-articles to use find-buffer-visiting * lisp/gnus/gnus-draft.el (gnus-draft-check-draft-articles): Don't loop through all the buffers; this removes the need for the `file-remote-p' check. Also give the user some nicer feedback about what's going on. diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el index 7c52e8750e4..c4266a7060e 100644 --- a/lisp/gnus/gnus-draft.el +++ b/lisp/gnus/gnus-draft.el @@ -289,30 +289,25 @@ If DONT-POP is nil, display the buffer after setting it up." (defun gnus-draft-check-draft-articles (articles) "Check whether the draft articles ARTICLES are under edit." (when (equal gnus-newsgroup-name "nndraft:drafts") - (let ((buffers (buffer-list)) - file buffs buff) - (save-current-buffer - (while (and articles - (not buff)) - (setq file (nndraft-article-filename (pop articles)) - buffs buffers) - (while buffs - (set-buffer (setq buff (pop buffs))) - (if (and buffer-file-name - (equal (file-remote-p file) - (file-remote-p buffer-file-name)) - (string-equal (file-truename buffer-file-name) - (file-truename file)) - (buffer-modified-p)) - (setq buffs nil) - (setq buff nil))))) - (when buff - (let* ((window (get-buffer-window buff t)) - (frame (and window (window-frame window)))) - (if frame - (select-frame-set-input-focus frame) - (pop-to-buffer buff t))) - (error "The draft %s is under edit" file))))) + (let* ((files (mapcar #'nndraft-article-filename articles)) + (buffs (delq nil (mapcar (lambda (f) + (find-buffer-visiting + f (lambda (b) (buffer-modified-p b)))) + files)))) + (when buffs + (if (= 1 (length buffs)) + ;; We might have arrived here via `gnus-draft-edit-message'; + ;; either way show the user the draft with unsaved changes. + (let* ((window (get-buffer-window (car buffs) t)) + (frame (and window (window-frame window)))) + (if frame + (select-frame-set-input-focus frame) + (pop-to-buffer (car buffs) t)) + (error "Draft is already under edit")) + ;; Otherwise we got here from `gnus-draft-send-message', and + ;; the main thing is to interrupt the sending. + (display-buffer (list-buffers-noselect t buffs)) + (error "Some drafts have unsaved changes: %S" buffs)))))) (defun gnus-draft-clear-marks () (setq gnus-newsgroup-reads nil commit b1e94b7bd3b18fdae66d172c7c72398d6f0d5225 Author: Eric Abrahamsen Date: Fri May 10 08:49:57 2024 -0700 Remove extra message-set-auto-save-file-name call in Gnus drafts Bug#70579 * lisp/gnus/gnus-draft.el (gnus-draft-setup): This function is already being called as part of the message-mail -> message-mode call above. Running it twice results in a jump in assigned article numbers, and the corresponding active value of the drafts group. diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el index 1fc2b33fffb..7c52e8750e4 100644 --- a/lisp/gnus/gnus-draft.el +++ b/lisp/gnus/gnus-draft.el @@ -262,8 +262,7 @@ If DONT-POP is nil, display the buffer after setting it up." (setq ga (message-fetch-field gnus-draft-meta-information-header))) (insert mail-header-separator) - (forward-line 1) - (message-set-auto-save-file-name)))) + (forward-line 1)))) (gnus-backlog-remove-article group narticle) (when (and ga (ignore-errors (setq ga (car (read-from-string ga))))) commit 5d8c2bad21cc647b3462acfe8e970419354cde83 Author: Juri Linkov Date: Fri May 10 19:45:21 2024 +0300 Support customization of sorting order for Imenu completion candidates * lisp/imenu.el (imenu--completion-buffer): Set completion-extra-properties to '(:category imenu). (imenu--flatten-index-alist): Use imenu--subalist-p to handle newer format (INDEX-NAME INDEX-POSITION FUNCTION ARGUMENTS...) as well (bug#70846). * doc/emacs/misc.texi (DocView Navigation): Fix typo. diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi index 04e6138b692..3bee88bca86 100644 --- a/doc/emacs/misc.texi +++ b/doc/emacs/misc.texi @@ -590,7 +590,7 @@ even when @command{mutool} can be found on your system, customize the variable @code{doc-view-imenu-enabled} to the @code{nil} value. You can further customize how @code{imenu} items are formatted and displayed using the variables @code{doc-view-imenu-format} and -@code{doc-view-flatten}. +@code{doc-view-imenu-flatten}. @node DocView Searching @subsection DocView Searching diff --git a/lisp/imenu.el b/lisp/imenu.el index dd924b449cf..9c0c1ae144e 100644 --- a/lisp/imenu.el +++ b/lisp/imenu.el @@ -740,10 +740,12 @@ Return one of the entries in index-alist or nil." (imenu--in-alist name prepared-index-alist) ;; Default to `name' if it's in the alist. name)))) - (let ((minibuffer-setup-hook minibuffer-setup-hook)) - ;; Display the completion buffer. - (if (not imenu-eager-completion-buffer) - (add-hook 'minibuffer-setup-hook 'minibuffer-completion-help)) + ;; Display the completion buffer. + (minibuffer-with-setup-hook + (lambda () + (setq-local completion-extra-properties '(:category imenu)) + (unless imenu-eager-completion-buffer + (minibuffer-completion-help))) (setq name (completing-read prompt prepared-index-alist nil t nil 'imenu--history-list name))) @@ -784,7 +786,7 @@ Returns t for rescan and otherwise an element or subelement of INDEX-ALIST." (concat prefix imenu-level-separator name) name)))) (cond - ((or (markerp pos) (numberp pos)) + ((not (imenu--subalist-p item)) (list (cons new-prefix pos))) (t (imenu--flatten-index-alist pos concat-names new-prefix))))) commit ffc70962ca5fea86afcd984caa7770ab87a452a2 Author: Jim Porter Date: Fri May 10 09:27:30 2024 -0700 ; Clean up some 'require' and 'declare-function' calls in Eshell * lisp/eshell/em-ls.el: * lisp/eshell/esh-cmd.el: * lisp/eshell/esh-mode.el: * lisp/eshell/esh-ext.el: Remove superfluous 'declare-function' calls. * lisp/eshell/esh-proc.el (pcomplete): Require this explicitly instead of transitively. diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el index fd89a9f778e..62ad7ff72a1 100644 --- a/lisp/eshell/em-ls.el +++ b/lisp/eshell/em-ls.el @@ -293,7 +293,6 @@ instead." (eshell-do-ls (nconc switches (list target))))))))) -(declare-function eshell-extended-glob "em-glob" (glob)) (declare-function dired-read-dir-and-switches "dired" (str)) (declare-function dired-goto-next-file "dired" ()) diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index b220855299e..b489822f188 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el @@ -101,20 +101,18 @@ ;;; Code: (require 'esh-util) -(require 'eldoc) (require 'esh-arg) (require 'esh-proc) (require 'esh-module) (require 'esh-io) (require 'esh-ext) + +(require 'eldoc) (require 'generator) +(require 'pcomplete) (eval-when-compile - (require 'cl-lib) - (require 'pcomplete)) - -(declare-function pcomplete--here "pcomplete" - (&optional form stub paring form-only)) + (require 'cl-lib)) (defgroup eshell-cmd nil "Executing an Eshell command is as simple as typing it in and \ diff --git a/lisp/eshell/esh-ext.el b/lisp/eshell/esh-ext.el index 44861c222b8..b4fce7a82a2 100644 --- a/lisp/eshell/esh-ext.el +++ b/lisp/eshell/esh-ext.el @@ -31,12 +31,12 @@ ;;; Code: -(require 'esh-util) - (eval-when-compile (require 'cl-lib)) (require 'esh-io) (require 'esh-arg) (require 'esh-opt) +(require 'esh-proc) +(require 'esh-util) (defgroup eshell-ext nil "External commands are invoked when operating system executables are @@ -90,10 +90,6 @@ but Eshell will be able to understand (setq list (cdr list))) file))) -;; This file provides itself then eval-when-compile loads files that require it. -;; This causes spurious "might not be defined at runtime" warnings. -(declare-function eshell-search-path "esh-ext" (name)) - (defcustom eshell-windows-shell-file (if (eshell-under-windows-p) (if (string-match "\\(cmdproxy\\|sh\\)\\.\\(com\\|exe\\)" @@ -244,8 +240,6 @@ An external command simply means external to Emacs." (cl-assert interp) (if (functionp (car interp)) (apply (car interp) (append (cdr interp) args)) - (require 'esh-proc) - (declare-function eshell-gather-process-output "esh-proc" (command args)) (eshell-gather-process-output (car interp) (append (cdr interp) args))))) diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index 5de200ce4b5..78a448a41a5 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -694,9 +694,6 @@ newline." (defun eshell-send-eof-to-process () "Send EOF to the currently-running \"head\" process." (interactive) - (require 'esh-mode) - (declare-function eshell-send-input "esh-mode" - (&optional use-region queue-p no-newline)) (eshell-send-input nil nil t) (when (eshell-head-process) (process-send-eof (eshell-head-process)))) diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el index 35c81f6a4b2..34db5e1c771 100644 --- a/lisp/eshell/esh-proc.el +++ b/lisp/eshell/esh-proc.el @@ -27,6 +27,8 @@ (require 'esh-io) (require 'esh-util) +(require 'pcomplete) + (defgroup eshell-proc nil "When Eshell invokes external commands, it always does so asynchronously, so that Emacs isn't tied up waiting for the process to commit 184d6e8c02345583264b053bb59ae031bb1c5a00 Author: Mattias Engdegård Date: Fri May 10 10:35:39 2024 +0200 Avoid resizing mutation in subst-char-in-string * lisp/subr.el (subst-char-in-string): Use string-replace to avoid resizing mutation and O(n^2) time. diff --git a/lisp/subr.el b/lisp/subr.el index 0ac71560c59..444afc0e486 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -5690,13 +5690,19 @@ The SEPARATOR regexp defaults to \"\\s-+\"." (defun subst-char-in-string (fromchar tochar string &optional inplace) "Replace FROMCHAR with TOCHAR in STRING each time it occurs. Unless optional argument INPLACE is non-nil, return a new string." - (let ((i (length string)) - (newstr (if inplace string (copy-sequence string)))) - (while (> i 0) - (setq i (1- i)) - (if (eq (aref newstr i) fromchar) - (aset newstr i tochar))) - newstr)) + (if (and (not inplace) + (if (multibyte-string-p string) + (> (max fromchar tochar) 127) + (> tochar 255))) + ;; Avoid quadratic behaviour from resizing replacement. + (string-replace (string fromchar) (string tochar) string) + (let ((i (length string)) + (newstr (if inplace string (copy-sequence string)))) + (while (> i 0) + (setq i (1- i)) + (if (eq (aref newstr i) fromchar) + (aset newstr i tochar))) + newstr))) (defun string-replace (from-string to-string in-string) "Replace FROM-STRING with TO-STRING in IN-STRING each time it occurs." commit 78761d699eed9e05bc4007927e63246c77c70ceb Author: Eli Zaretskii Date: Fri May 10 15:59:24 2024 +0300 ; * etc/NEWS: Announce user-level change in dictionary.el. diff --git a/etc/NEWS b/etc/NEWS index d2bedd64b2c..bd68cd6d751 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1471,6 +1471,13 @@ name as a string. The new function 'dictionary-completing-read-dictionary' can be used to prompt with completion based on dictionaries that the server supports. +--- +*** The default value of 'dictionary-tooltip-dictionary' has changed. +The new default value is t, which means use the same dictionary as the +value of 'dictionary-default-dictionary'. The previous default value +was nil, which effectively disabled 'dictionary-tooltip-mode', even if +the mode was turned on. + ** Pp *** New 'pp-default-function' user option replaces 'pp-use-max-width'. commit 3129fed4bec1137b7bb377594766b61ee76cd268 Author: Eli Zaretskii Date: Fri May 10 15:56:30 2024 +0300 Fix 'dictionary-tooltip-mode' * lisp/tooltip.el (tooltip-event-buffer): Make sure 'posn-window' returns a window before calling 'window-buffer'. * lisp/net/dictionary.el (dictionary-default-dictionary) (dictionary-tooltip-dictionary): Doc fixes. (dictionary-tooltip-dictionary): Change default value to t, which means the same dictionary as 'dictionary-default-dictionary'. (dictionary-do-search): If NOMATCHING is non-nil, do not insert anything into the current buffer, as that is unexpected when showing definitions in tooltips. (dictionary-word-at-mouse-event): Be defensive about the values returned by 'tooltip-event-buffer' and 'posn-point': they can be unexpected when the mouse pointer is on the tool bar or mode line etc. (dictionary-display-tooltip): Ignore errors in this function. (dictionary-tooltip-mode): Ignore mouse-movement events on tool bar and tab-bar. (dictionary-dictionaries): Decode the server response to present dictionaries in human-readable form. Document in the doc string the format of the return value. diff --git a/lisp/net/dictionary.el b/lisp/net/dictionary.el index d4dfa33716c..313e825b4d8 100644 --- a/lisp/net/dictionary.el +++ b/lisp/net/dictionary.el @@ -105,7 +105,10 @@ This port is probably always 2628 so there should be no need to modify it." "*" "The dictionary which is used for searching definitions and matching. * and ! have a special meaning, * search all dictionaries, ! search until -one dictionary yields matches." +one dictionary yields matches. +Otherwise, the value should be a string, the name of the dictionary to use. +Dictionary names are generally specific to the servers, and are obtained +via `dictionary-dictionaries'." :group 'dictionary :type 'string :version "28.1") @@ -784,10 +787,10 @@ FUNCTION is the callback which is called for each search result." (defun dictionary-do-search (word dictionary function &optional nomatching) "Search for WORD in DICTIONARY and call FUNCTION for each result. -Optional argument NOMATCHING controls whether to suppress the display -of matching words." - - (insert (format-message "Searching for `%s' in `%s'\n" word dictionary)) +Optional argument NOMATCHING, if non-nil, means suppress the display +of the \"Searching\" report and of the matching words." + (unless nomatching + (insert (format-message "Searching for `%s' in `%s'\n" word dictionary))) (dictionary-send-command (concat "define " (dictionary-encode-charset dictionary "") " \"" @@ -1356,11 +1359,22 @@ prompt for DICTIONARY." (nconc minor-mode-alist '((dictionary-tooltip-mode " Dict"))) (defcustom dictionary-tooltip-dictionary - nil - "This dictionary to lookup words for tooltips." + t + "The dictionary to lookup words for `dictionary-tooltip-mode'. +If this is nil, `dictionary-tooltip-mode' is effectively disabled: no tooltips +will be shown. +If the value is t, `dictionary-tooltip-mode' will use the same dictionary as +specified by `dictionary-default-dictionary'. +Otherwise, the value should be a string, the name of a dictionary to use, and +can use the same special values * and ! as for `dictionary-default-dictionary', +with the same meanings. +Dictionary names are generally specific to the servers, and are obtained +via `dictionary-dictionaries'." :group 'dictionary - :type '(choice (const :tag "None" nil) string) - :version "28.1") + :type '(choice (const :tag "None (disables Dictionary tooltips)" nil) + (const :tag "Same as `dictionary-default-dictionary'" t) + string) + :version "30.1") (defun dictionary-definition (word &optional dictionary) (unwind-protect @@ -1377,14 +1391,20 @@ prompt for DICTIONARY." nil) (defun dictionary-word-at-mouse-event (event) - (with-current-buffer (tooltip-event-buffer event) - (let ((point (posn-point (event-end event)))) - (if (use-region-p) - (when (and (<= (region-beginning) point) (<= point (region-end))) - (buffer-substring (region-beginning) (region-end))) - (save-excursion - (goto-char point) - (current-word)))))) + (let ((buf (tooltip-event-buffer event))) + (when (bufferp buf) + (with-current-buffer buf + (let ((point (posn-point (event-end event)))) + ;; posn-point can return something other than buffer position when + ;; the mouse pointer is over the menu bar or tool bar or tab-bar. + (when (number-or-marker-p point) + (if (use-region-p) + (when (and (<= (region-beginning) point) + (<= point (region-end))) + (buffer-substring (region-beginning) (region-end))) + (save-excursion + (goto-char point) + (current-word))))))))) (defvar dictionary-tooltip-mouse-event nil "Event that triggered the tooltip mode.") @@ -1393,15 +1413,24 @@ prompt for DICTIONARY." "Search the current word in the `dictionary-tooltip-dictionary'." (interactive "e") (if (and dictionary-tooltip-mode dictionary-tooltip-dictionary) - (let ((word (dictionary-word-at-mouse-event dictionary-tooltip-mouse-event))) - (if word - (let ((definition - (dictionary-definition word dictionary-tooltip-dictionary))) - (if definition - (tooltip-show (dictionary-decode-charset definition - dictionary-tooltip-dictionary))))) - t) - nil)) + ;; This function runs from the tooltip timer. We don't want to + ;; signal errors from the timer due to "Unknown server answers", + ;; we prefer not to show anything in that case. FIXME: Perhaps + ;; use with-demoted-errors, to show the unknonw answers in the + ;; echo-area? + (ignore-errors + (let* ((word (dictionary-word-at-mouse-event + dictionary-tooltip-mouse-event)) + (dict (if (eq dictionary-tooltip-dictionary t) + dictionary-default-dictionary + dictionary-tooltip-dictionary))) + (if word + (let ((definition (dictionary-definition word dict))) + (if definition + (tooltip-show (dictionary-decode-charset + definition dict))))) + t) + nil))) (defun dictionary-tooltip-track-mouse (event) "Called whenever a dictionary tooltip display is about to be triggered." @@ -1443,6 +1472,11 @@ active it will overwrite that mode for the current buffer." (if on (local-set-key [mouse-movement] 'dictionary-tooltip-track-mouse) (local-set-key [mouse-movement] 'ignore)) + ;; Unconditionally ignore mouse-movement events on the tool bar and + ;; tab-bar, since these are unrelated to the current buffer. + ;; FIXME: This disables help-echo for tab-bar and tool-bar buttons. + (local-set-key [tool-bar mouse-movement] 'ignore) + (local-set-key [tab-bar mouse-movement] 'ignore) on)) ;;;###autoload @@ -1536,11 +1570,18 @@ Further arguments are currently ignored." nil t nil 'dictionary-word-history default t))) (defun dictionary-dictionaries () - "Return the list of dictionaries the server supports." + "Return the list of dictionaries the server supports. +The elements of the list have the form (NAME . DESCRIPTION), +where NAME is the string that identifies the dictionary for +the server, and DESCRIPTION is its more detailed description, +which usually includes the languages it supports." (dictionary-send-command "show db") (when (and (= (read (dictionary-read-reply)) 110)) (with-temp-buffer (insert (dictionary-read-answer)) + ;; We query the server using 'raw-text', so decode now to present + ;; human-readable names to the user. + (decode-coding-region (point-min) (point-max) 'utf-8) (goto-char (point-min)) (let ((result '(("!" . "First matching dictionary") ("*" . "All dictionaries")))) diff --git a/lisp/tooltip.el b/lisp/tooltip.el index 4537fdf8087..6c2fe36ed9d 100644 --- a/lisp/tooltip.el +++ b/lisp/tooltip.el @@ -178,7 +178,7 @@ rest are not called.") "Return the buffer over which event EVENT occurred. This might return nil if the event did not occur over a buffer." (let ((window (posn-window (event-end event)))) - (and window (window-buffer window)))) + (and (windowp window) (window-buffer window)))) ;;; Timeout for tooltip display commit 0f67ddd8d9e855ce0b9c17a4a1410dbd40318055 Author: Po Lu Date: Fri May 10 16:44:35 2024 +0800 Implement dots and dashes on MS-Windows * src/haikuterm.c (haiku_draw_dash): Correct whitespace error. * src/w32term.c (w32_draw_dash, w32_fill_underline) (w32_draw_glyph_string): Port display of dash and dot underline styles from X. diff --git a/src/haikuterm.c b/src/haikuterm.c index 09d70230bab..c194a348df3 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -839,7 +839,7 @@ haiku_draw_dash (struct frame *f, struct glyph_string *s, int width, s->x + width - 1), y_center); - which = !which; + which = !which; } } diff --git a/src/w32term.c b/src/w32term.c index 9b10e4c3342..a9aff304771 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -2535,6 +2535,89 @@ w32_draw_stretch_glyph_string (struct glyph_string *s) s->background_filled_p = true; } +/* Draw a dashed underline of thickness THICKNESS and width WIDTH onto F + at a vertical offset of OFFSET from the position of the glyph string + S, with each segment SEGMENT pixels in length, and in the color + FOREGROUND. */ + +static void +w32_draw_dash (struct frame *f, struct glyph_string *s, + COLORREF foreground, int width, char segment, + int offset, int thickness) +{ + int y_base, which, length, x, doffset; + HDC hdc = s->hdc; + + /* A pen with PS_DASH (or PS_DOT) is unsuitable for two reasons: first + that PS_DASH does not accept width values greater than 1, with + itself considered equivalent to PS_SOLID if such a value be + specified, and second that it does not provide for an offset to be + applied to the pattern, absent which Emacs cannot align dashes that + are displayed at locations not multiples of each other. I can't be + bothered to research this matter further, so, for want of a better + option, draw the specified pattern manually. */ + + y_base = s->ybase + offset; + + /* Remove redundant portions of OFFSET. */ + doffset = s->x % (segment * 2); + + /* Set which to the phase of the first dash that ought to be drawn and + length to its length. */ + which = doffset < segment; + length = segment - (s->x % segment); + + /* Begin drawing this dash. */ + for (x = s->x; x < s->x + width; x += length, length = segment) + { + if (which) + w32_fill_area (f, hdc, foreground, x, y_base, length, + thickness); + + which = !which; + } +} + +/* Draw an underline of STYLE onto F at an offset of POSITION from the + baseline of the glyph string S, in the color FOREGROUND that is + THICKNESS in height. */ + +static void +w32_fill_underline (struct frame *f, struct glyph_string *s, + COLORREF foreground, + enum face_underline_type style, int position, + int thickness) +{ + int segment; + + segment = thickness * 3; + + switch (style) + { + /* FACE_UNDERLINE_DOUBLE_LINE is treated identically to SINGLE, as + the second line will be filled by another invocation of this + function. */ + case FACE_UNDERLINE_SINGLE: + case FACE_UNDERLINE_DOUBLE_LINE: + w32_fill_area (s->f, s->hdc, foreground, s->x, + s->ybase + position, s->width, thickness); + break; + + case FACE_UNDERLINE_DOTS: + segment = thickness; + FALLTHROUGH; + + case FACE_UNDERLINE_DASHES: + w32_draw_dash (f, s, foreground, s->width, segment, position, + thickness); + break; + + case FACE_NO_UNDERLINE: + case FACE_UNDERLINE_WAVE: + default: + emacs_abort (); + } +} /* Draw glyph string S. */ @@ -2652,17 +2735,14 @@ w32_draw_glyph_string (struct glyph_string *s) w32_draw_underwave (s, color); } - else if (s->face->underline == FACE_UNDERLINE_SINGLE - || s->face->underline == FACE_UNDERLINE_DOUBLE_LINE) + else if (s->face->underline >= FACE_UNDERLINE_SINGLE) { unsigned long thickness, position; - int y; COLORREF foreground; if (s->prev - && ((s->prev->face->underline == FACE_UNDERLINE_SINGLE) - || (s->prev->face->underline - == FACE_UNDERLINE_DOUBLE_LINE)) + && (s->prev->face->underline != FACE_UNDERLINE_WAVE + && s->prev->face->underline >= FACE_UNDERLINE_SINGLE) && (s->prev->face->underline_at_descent_line_p == s->face->underline_at_descent_line_p) && (s->prev->face->underline_pixels_above_descent_line @@ -2739,15 +2819,14 @@ w32_draw_glyph_string (struct glyph_string *s) thickness = (s->y + s->height) - (s->ybase + position); s->underline_thickness = thickness; s->underline_position = position; - y = s->ybase + position; if (s->face->underline_defaulted_p) foreground = s->gc->foreground; else foreground = s->face->underline_color; - w32_fill_area (s->f, s->hdc, foreground, s->x, y, - s->width, thickness); + w32_fill_underline (s->f, s, foreground, s->face->underline, + position, thickness); /* Place a second underline above the first if this was requested in the face specification. */ @@ -2756,9 +2835,8 @@ w32_draw_glyph_string (struct glyph_string *s) { /* Compute the position of the second underline. */ position = position - thickness - 1; - y = s->ybase + position; - w32_fill_area (s->f, s->hdc, foreground, s->x, y, - s->width, thickness); + w32_fill_underline (s->f, s, foreground, s->face->underline, + position, thickness); } } }