commit c00105626ace43919706819da4057a358e62bafe (HEAD, refs/remotes/origin/master) Author: Po Lu Date: Wed May 1 12:03:26 2024 +0800 ; * src/androidselect.c (extract_fd_offsets): Fix typos. diff --git a/src/androidselect.c b/src/androidselect.c index 04d04d326d9..d9c35746f11 100644 --- a/src/androidselect.c +++ b/src/androidselect.c @@ -457,9 +457,9 @@ extract_fd_offsets (jobject afd, int *fd, jlong *offset, jlong *length) RTLD_LAZY | RTLD_GLOBAL); if (!handle) goto failure; - jniGetFdFromFileDescriptor = dlsym (handle, + jniGetFDFromFileDescriptor = dlsym (handle, "jniGetFDFromFileDescriptor"); - if (!jniGetFdFromFileDescriptor) + if (!jniGetFDFromFileDescriptor) goto failure; } commit 2451456695d0e03b89365cbbe64effb2f99af2d5 Author: Po Lu Date: Wed May 1 11:45:53 2024 +0800 Fix compatibility issues with Android clipboards * java/org/gnu/emacs/EmacsClipboard.java (getClipboardData): Return an AssetFileDescriptor. * java/org/gnu/emacs/EmacsContextMenu.java (onMenuItemClick): Typo corrections in commentary. * java/org/gnu/emacs/EmacsOpenActivity.java (onCreate): Raise minimum version on which to read file descriptors from ParcelFileDescriptor objects to Honeycomb. * java/org/gnu/emacs/EmacsSdk11Clipboard.java (getClipboardData): Return the asset file descriptor. * java/org/gnu/emacs/EmacsSdk8Clipboard.java (getClipboardData): Adjust return type to match. * src/android.h (struct android_parcel_file_descriptor_class): Move from androidselect.c. * src/androidselect.c (fd_class): Export function. (android_init_emacs_clipboard): Adjust signature of getClipboardData. (android_init_asset_file_descriptor, close_asset_fd) (extract_fd_offsets): New functions. (Fandroid_get_clipboard_data): Extract file descriptor and offset from the AssetFileDescriptor here, rather than in getClipboardData. (init_androidselect): Call android_init_asset_file_descriptor. * src/androidvfs.c (android_init_fd_class): Export and enable calling this function more than once. diff --git a/java/org/gnu/emacs/EmacsClipboard.java b/java/org/gnu/emacs/EmacsClipboard.java index 9db436ca1e2..f27d96129ef 100644 --- a/java/org/gnu/emacs/EmacsClipboard.java +++ b/java/org/gnu/emacs/EmacsClipboard.java @@ -19,6 +19,7 @@ package org.gnu.emacs; +import android.content.res.AssetFileDescriptor; import android.os.Build; /* This class provides helper code for accessing the clipboard, @@ -32,7 +33,7 @@ public abstract class EmacsClipboard public abstract byte[] getClipboard (); public abstract byte[][] getClipboardTargets (); - public abstract long[] getClipboardData (byte[] target); + public abstract AssetFileDescriptor getClipboardData (byte[] target); /* Create the correct kind of clipboard for this system. */ diff --git a/java/org/gnu/emacs/EmacsContextMenu.java b/java/org/gnu/emacs/EmacsContextMenu.java index 2bbf2a313d6..0f52d45455f 100644 --- a/java/org/gnu/emacs/EmacsContextMenu.java +++ b/java/org/gnu/emacs/EmacsContextMenu.java @@ -108,8 +108,8 @@ private static final class Item implements MenuItem.OnMenuItemClickListener will normally confuse Emacs into thinking that the context menu has been dismissed. Wrong! - Setting this flag makes EmacsActivity to only handle - SubMenuBuilder being closed, which always means the menu + Setting this flag prompts EmacsActivity to only handle + SubMenuBuilders being closed, which always means the menu has actually been dismissed. However, these extraneous events aren't sent on devices diff --git a/java/org/gnu/emacs/EmacsOpenActivity.java b/java/org/gnu/emacs/EmacsOpenActivity.java index 327a53bc417..cdc68aea2bf 100644 --- a/java/org/gnu/emacs/EmacsOpenActivity.java +++ b/java/org/gnu/emacs/EmacsOpenActivity.java @@ -19,29 +19,23 @@ package org.gnu.emacs; -/* This class makes the Emacs server work reasonably on Android. +/* Opening external documents on Android. - There is no way to make the Unix socket publicly available on - Android. + This activity is registered as an application capable of opening text + files and files in several other formats that Emacs understands, and + assumes responsibility for deriving file names from the files + provided to `onCreate', potentially copying them to temporary + directories in the process, and invoking `emacsclient' with suitable + arguments to open the same. In this respect, it fills the role of + `etc/emacs.desktop' on XDG systems. - Instead, this activity tries to connect to the Emacs server, to - make it open files the system asks Emacs to open, and to emulate - some reasonable behavior when Emacs has not yet started. + It is also registered as a handler for mailto URIs, in which capacity + it constructs invocations of `emacsclient' so as to start + `message-mailto' with their contents and attachments, much like + `etc/emacs-mail.desktop'. - First, Emacs registers itself as an application that can open text - and image files. - - Then, when the user is asked to open a file and selects ``Emacs'' - as the application that will open the file, the system pops up a - window, this activity, and calls the `onCreate' function. - - `onCreate' then tries very to find the file name of the file that - was selected, and give it to emacsclient. - - If emacsclient successfully opens the file, then this activity - starts EmacsActivity (to bring it on to the screen); otherwise, it - displays the output of emacsclient or any error message that occurs - and exits. */ + As with all other activities, it is registered in the package + manifest file. */ import android.app.AlertDialog; import android.app.Activity; @@ -628,11 +622,12 @@ else if (scheme != null if (scheme.equals ("content") /* Retrieving the native file descriptor of a - ParcelFileDescriptor requires Honeycomb, and + ParcelFileDescriptor requires Honeycomb MR1, and proceeding without this capability is pointless on systems before KitKat, since Emacs doesn't support opening content files on those. */ - && Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB) + && (Build.VERSION.SDK_INT + >= Build.VERSION_CODES.HONEYCOMB_MR1)) { /* This is one of the annoying Android ``content'' URIs. Most of the time, there is actually an diff --git a/java/org/gnu/emacs/EmacsSdk11Clipboard.java b/java/org/gnu/emacs/EmacsSdk11Clipboard.java index 850bb6c8deb..71381b0f114 100644 --- a/java/org/gnu/emacs/EmacsSdk11Clipboard.java +++ b/java/org/gnu/emacs/EmacsSdk11Clipboard.java @@ -207,8 +207,9 @@ public final class EmacsSdk11Clipboard extends EmacsClipboard /* Return the clipboard data for the given target, or NULL if it does not exist. - Value is normally an array of three longs: the file descriptor, - the start offset of the data, and its length; length may be + Value is normally an asset file descriptor, which in turn holds + three important values: the file descriptor, the start offset of + the data, and its length; length may be AssetFileDescriptor.UNKNOWN_LENGTH, meaning that the data extends from that offset to the end of the file. @@ -217,15 +218,13 @@ public final class EmacsSdk11Clipboard extends EmacsClipboard solely of a URI. */ @Override - public long[] + public AssetFileDescriptor getClipboardData (byte[] target) { ClipData data; String mimeType; - int fd; AssetFileDescriptor assetFd; Uri uri; - long[] value; /* Decode the target given by Emacs. */ try @@ -245,8 +244,6 @@ public final class EmacsSdk11Clipboard extends EmacsClipboard if (data == null || data.getItemCount () < 1) return null; - fd = -1; - try { uri = data.getItemAt (0).getUri (); @@ -257,52 +254,15 @@ public final class EmacsSdk11Clipboard extends EmacsClipboard /* Now open the file descriptor. */ assetFd = resolver.openTypedAssetFileDescriptor (uri, mimeType, null); - - /* Duplicate the file descriptor. */ - fd = assetFd.getParcelFileDescriptor ().getFd (); - fd = EmacsNative.dup (fd); - - /* Return the relevant information. */ - value = new long[] { fd, assetFd.getStartOffset (), - assetFd.getLength (), }; - - /* Close the original offset. */ - assetFd.close (); + return assetFd; } catch (SecurityException e) { - /* Guarantee a file descriptor duplicated or detached is - ultimately closed if an error arises. */ - - if (fd != -1) - EmacsNative.close (fd); - return null; } catch (FileNotFoundException e) { - /* Guarantee a file descriptor duplicated or detached is - ultimately closed if an error arises. */ - - if (fd != -1) - EmacsNative.close (fd); - return null; } - catch (IOException e) - { - /* Guarantee a file descriptor duplicated or detached is - ultimately closed if an error arises. */ - - if (fd != -1) - EmacsNative.close (fd); - - return null; - } - - /* Don't return value if the file descriptor couldn't be - created. */ - - return fd != -1 ? value : null; } }; diff --git a/java/org/gnu/emacs/EmacsSdk8Clipboard.java b/java/org/gnu/emacs/EmacsSdk8Clipboard.java index 418f55c12c1..3d0504b1924 100644 --- a/java/org/gnu/emacs/EmacsSdk8Clipboard.java +++ b/java/org/gnu/emacs/EmacsSdk8Clipboard.java @@ -25,6 +25,8 @@ import android.text.*; import android.content.Context; +import android.content.res.AssetFileDescriptor; + import android.util.Log; import java.io.UnsupportedEncodingException; @@ -129,9 +131,10 @@ public final class EmacsSdk8Clipboard extends EmacsClipboard /* Return the clipboard data for the given target, or NULL if it does not exist. - Value is normally an array of three longs: the file descriptor, - the start offset of the data, and its length; length may be - AssetFileDescriptor.UNKOWN_LENGTH, meaning that the data extends + Value is normally an asset file descriptor, which in turn holds + three important values: the file descriptor, the start offset of + the data, and its length; length may be + AssetFileDescriptor.UNKNOWN_LENGTH, meaning that the data extends from that offset to the end of the file. Do not use this function to open text targets; use `getClipboard' @@ -139,7 +142,7 @@ public final class EmacsSdk8Clipboard extends EmacsClipboard solely of a URI. */ @Override - public long[] + public AssetFileDescriptor getClipboardData (byte[] target) { return null; diff --git a/src/android.h b/src/android.h index 19adfa38087..7074ca2630c 100644 --- a/src/android.h +++ b/src/android.h @@ -53,6 +53,22 @@ extern char *android_user_full_name (struct passwd *); +/* Structure describing the android.os.ParcelFileDescriptor class used + to wrap file descriptors sent over IPC. */ + +struct android_parcel_file_descriptor_class +{ + jclass class; + jmethodID close; + jmethodID get_fd; + jmethodID detach_fd; +}; + +/* The ParcelFileDescriptor class. */ +extern struct android_parcel_file_descriptor_class fd_class; + +extern void android_init_fd_class (JNIEnv *); + /* File I/O operations. Many of these are defined in androidvfs.c. */ diff --git a/src/androidselect.c b/src/androidselect.c index 2f6114d0fcb..04d04d326d9 100644 --- a/src/androidselect.c +++ b/src/androidselect.c @@ -21,6 +21,7 @@ along with GNU Emacs. If not, see . */ #include #include #include +#include #include #include @@ -100,7 +101,7 @@ android_init_emacs_clipboard (void) FIND_METHOD (get_clipboard_targets, "getClipboardTargets", "()[[B"); FIND_METHOD (get_clipboard_data, "getClipboardData", - "([B)[J"); + "([B)Landroid/content/res/AssetFileDescriptor;"); clipboard_class.make_clipboard = (*android_java_env)->GetStaticMethodID (android_java_env, @@ -340,6 +341,62 @@ data type available from the clipboard. */) return Qnil; } + + +struct android_asset_file_descriptor +{ + jclass class; + jmethodID close; + jmethodID get_length; + jmethodID get_start_offset; + jmethodID get_file_descriptor; + jmethodID get_parcel_file_descriptor; + jmethodID get_fd; +}; + +/* Methods associated with the AssetFileDescriptor class. */ +static struct android_asset_file_descriptor asset_fd_class; + +/* Initialize virtual function IDs and class pointers in connection with + the AssetFileDescriptor class. */ + +static void +android_init_asset_file_descriptor (void) +{ + jclass old; + + asset_fd_class.class + = (*android_java_env)->FindClass (android_java_env, + "android/content/res/" + "AssetFileDescriptor"); + eassert (asset_fd_class.class); + + old = asset_fd_class.class; + asset_fd_class.class + = (jclass) (*android_java_env)->NewGlobalRef (android_java_env, + old); + ANDROID_DELETE_LOCAL_REF (old); + + if (!asset_fd_class.class) + emacs_abort (); + +#define FIND_METHOD(c_name, name, signature) \ + asset_fd_class.c_name \ + = (*android_java_env)->GetMethodID (android_java_env, \ + asset_fd_class.class, \ + name, signature); \ + eassert (asset_fd_class.c_name); + + FIND_METHOD (close, "close", "()V"); + FIND_METHOD (get_length, "getLength", "()J"); + FIND_METHOD (get_start_offset, "getStartOffset", "()J"); + FIND_METHOD (get_file_descriptor, "getFileDescriptor", + "()Ljava/io/FileDescriptor;"); + FIND_METHOD (get_parcel_file_descriptor, "getParcelFileDescriptor", + "()Landroid/os/ParcelFileDescriptor;"); +#undef FIND_METHOD +} + /* Free the memory inside PTR, a pointer to a char pointer. */ static void @@ -348,6 +405,125 @@ android_xfree_inside (void *ptr) xfree (*(char **) ptr); } +/* Close the referent of, then delete, the local reference to an asset + file descriptor referenced by AFD. */ + +static void +close_asset_fd (void *afd) +{ + jobject *afd_1; + + afd_1 = afd; + (*android_java_env)->CallVoidMethod (android_java_env, *afd_1, + asset_fd_class.close); + (*android_java_env)->ExceptionClear (android_java_env); + ANDROID_DELETE_LOCAL_REF (*afd_1); +} + +/* Return the offset, file descriptor and length of the data contained + in the asset file descriptor AFD, in *FD, *OFFSET, and *LENGTH. + Value is 0 upon success, 1 otherwise. */ + +static int +extract_fd_offsets (jobject afd, int *fd, jlong *offset, jlong *length) +{ + jobject java_fd; + void *handle; +#if __ANDROID_API__ <= 11 + static int (*jniGetFDFromFileDescriptor) (JNIEnv *, jobject); +#endif /* __ANDROID_API__ <= 11 */ + static int (*AFileDescriptor_getFd) (JNIEnv *, jobject);; + jmethodID method; + + method = asset_fd_class.get_start_offset; + *offset = (*android_java_env)->CallLongMethod (android_java_env, + afd, method); + android_exception_check (); + method = asset_fd_class.get_length; + *length = (*android_java_env)->CallLongMethod (android_java_env, + afd, method); + android_exception_check (); + +#if __ANDROID_API__ <= 11 + if (android_get_current_api_level () <= 11) + { + /* Load libnativehelper and link to a private interface that is + the only means of retrieving the file descriptor from an asset + file descriptor on these systems. */ + + if (!jniGetFDFromFileDescriptor) + { + handle = dlopen ("libnativehelper.so", + RTLD_LAZY | RTLD_GLOBAL); + if (!handle) + goto failure; + jniGetFdFromFileDescriptor = dlsym (handle, + "jniGetFDFromFileDescriptor"); + if (!jniGetFdFromFileDescriptor) + goto failure; + } + + method = asset_fd_class.get_file_descriptor; + java_fd = (*android_java_env)->CallObjectMethod (android_java_env, + afd, method); + android_exception_check (); + *fd = (*jniGetFDFromFileDescriptor) (android_java_env, java_fd); + ANDROID_DELETE_LOCAL_REF (java_fd); + + if (*fd >= 0) + return 0; + } + else +#endif /* __ANDROID_API__ <= 11 */ +#if __ANDROID_API__ <= 30 + if (android_get_current_api_level () <= 30) + { + /* Convert this AssetFileDescriptor into a ParcelFileDescriptor, + whose getFd method will return its native file descriptor. */ + method = asset_fd_class.get_parcel_file_descriptor; + java_fd = (*android_java_env)->CallObjectMethod (android_java_env, + afd, method); + android_exception_check (); + + /* Initialize fd_class if not already complete. */ + android_init_fd_class (android_java_env); + *fd = (*android_java_env)->CallIntMethod (android_java_env, + java_fd, + fd_class.get_fd); + if (*fd >= 0) + return 0; + } + else +#endif /* __ANDROID_API__ <= 30 */ + { + /* Load libnativehelper (now a public interface) and link to + AFileDescriptor_getFd. */ + if (!AFileDescriptor_getFd) + { + handle = dlopen ("libnativehelper.so", + RTLD_LAZY | RTLD_GLOBAL); + if (!handle) + goto failure; + AFileDescriptor_getFd = dlsym (handle, "AFileDescriptor_getFd"); + if (!AFileDescriptor_getFd) + goto failure; + } + + method = asset_fd_class.get_file_descriptor; + java_fd = (*android_java_env)->CallObjectMethod (android_java_env, + afd, method); + android_exception_check (); + *fd = (*AFileDescriptor_getFd) (android_java_env, java_fd); + ANDROID_DELETE_LOCAL_REF (java_fd); + + if (*fd >= 0) + return 0; + } + + failure: + return 1; +} + DEFUN ("android-get-clipboard-data", Fandroid_get_clipboard_data, Sandroid_get_clipboard_data, 1, 1, 0, doc: /* Return the clipboard data of the given MIME TYPE. @@ -361,12 +537,12 @@ does not have any corresponding data. In that case, use `android-get-clipboard' instead. */) (Lisp_Object type) { - jlongArray array; + jobject afd; jbyteArray bytes; jmethodID method; int fd; ptrdiff_t rc; - jlong offset, length, *longs; + jlong offset, length; specpdl_ref ref; char *buffer, *start; @@ -387,36 +563,25 @@ does not have any corresponding data. In that case, use android_exception_check (); method = clipboard_class.get_clipboard_data; - array = (*android_java_env)->CallObjectMethod (android_java_env, - clipboard, method, - bytes); + afd = (*android_java_env)->CallObjectMethod (android_java_env, + clipboard, method, + bytes); android_exception_check_1 (bytes); ANDROID_DELETE_LOCAL_REF (bytes); - if (!array) + if (!afd) goto fail; - longs = (*android_java_env)->GetLongArrayElements (android_java_env, - array, NULL); - android_exception_check_nonnull (longs, array); - - /* longs[0] is the file descriptor. - longs[1] is an offset to apply to the file. - longs[2] is either -1, or the number of bytes to read from the - file. */ - fd = longs[0]; - offset = longs[1]; - length = longs[2]; + /* Extract the file descriptor from the AssetFileDescriptor + object. */ + ref = SPECPDL_INDEX (); + record_unwind_protect_ptr (close_asset_fd, &afd); - (*android_java_env)->ReleaseLongArrayElements (android_java_env, - array, longs, - JNI_ABORT); - ANDROID_DELETE_LOCAL_REF (array); + if (extract_fd_offsets (afd, &fd, &offset, &length)) + return unbind_to (ref, Qnil); unblock_input (); - /* Now begin reading from longs[0]. */ - ref = SPECPDL_INDEX (); - record_unwind_protect_int (close_file_unwind, fd); + /* Now begin reading from fd. */ if (length != -1) { @@ -1004,6 +1169,7 @@ init_androidselect (void) return; android_init_emacs_clipboard (); + android_init_asset_file_descriptor (); android_init_emacs_desktop_notification (); make_clipboard = clipboard_class.make_clipboard; diff --git a/src/androidvfs.c b/src/androidvfs.c index c4b3dba4af0..38bec7d349a 100644 --- a/src/androidvfs.c +++ b/src/androidvfs.c @@ -290,17 +290,6 @@ struct emacs_directory_entry_class jfieldID d_name; }; -/* Structure describing the android.os.ParcelFileDescriptor class used - to wrap file descriptors sent over IPC. */ - -struct android_parcel_file_descriptor_class -{ - jclass class; - jmethodID close; - jmethodID get_fd; - jmethodID detach_fd; -}; - /* The java.lang.String class. */ jclass java_string_class; @@ -313,7 +302,7 @@ static struct emacs_directory_entry_class entry_class; /* Fields and methods associated with the ParcelFileDescriptor class. */ -static struct android_parcel_file_descriptor_class fd_class; +struct android_parcel_file_descriptor_class fd_class; /* Global references to several exception classes. */ static jclass file_not_found_exception, security_exception; @@ -380,13 +369,18 @@ android_init_entry_class (JNIEnv *env) } -/* Initialize `fd_class' using the given JNI environment ENV. Calling - this function is not necessary on Android 4.4 and earlier. */ +/* Initialize `fd_class' using the given JNI environment ENV. Called on + API 12 (Android 3.1) and later by androidselect.c and on 5.0 and + later in this file. */ -static void +void android_init_fd_class (JNIEnv *env) { jclass old; + static bool fd_class_initialized; + + if (fd_class_initialized) + return; fd_class.class = (*env)->FindClass (env, "android/os/ParcelFileDescriptor"); @@ -409,6 +403,8 @@ android_init_fd_class (JNIEnv *env) FIND_METHOD (get_fd, "getFd", "()I"); FIND_METHOD (detach_fd, "detachFd", "()I"); #undef FIND_METHOD + + fd_class_initialized = true; } commit 294335b2304028cc97aca036bd37adf2f8e1c508 Author: Po Lu Date: Wed May 1 08:56:23 2024 +0800 ; Fix widget button press cancellation * lisp/wid-edit.el (widget-button--check-and-call-button): Throw nil if a mouse-button-derived press is canceled. Reported by David Ponce . diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 2d82fbe7c89..3b467434d29 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1153,7 +1153,7 @@ If nothing was called, return non-nil." (when (and mouse-1 (mouse-movement-p event)) (push event unread-command-events) (setq event oevent) - (throw 'button-press-cancelled t)) + (throw 'button-press-cancelled nil)) (unless (or (integerp event) (memq (car event) '(switch-frame select-window)) commit b094b2b9dc31c4dc03450b5905472a8e6dd531aa Author: Mattias Engdegård Date: Tue Apr 30 18:01:52 2024 +0200 Fix first appearance records for some misdated functions * etc/NEWS.unknown: Add approximate version records for defsubst, mark, nreverse, let*, rassq, >=, transpose-sexps, buffer-modified-p, current-column, downcase, previous-line, catch, throw, and count-lines, which all were given much more recent introduction versions by describe-function. diff --git a/etc/NEWS.unknown b/etc/NEWS.unknown index 4aca2525c3d..eafdc953cac 100644 --- a/etc/NEWS.unknown +++ b/etc/NEWS.unknown @@ -6,9 +6,26 @@ Since much of early Emacs source history is lost, these versions are conservative estimates: the actual version of first appearance may very well be much earlier. +* Changes in Emacs 19.7 +** 'defsubst' + +* Changes in Emacs 18.59 +** 'mark' + * Changes in Emacs 13.8 This may be the earliest surviving version with source code, although damaged. See https://github.com/larsbrinkhoff/emacs-history/decuslib.com/decus/vax85b/gnuemax ** 'nthcdr' +** 'nreverse +** 'let*' +** 'rassq' +** '>=' +** 'transpose-sexps' +** 'buffer-modified-p' +** 'current-column' +** 'downcase' +** 'previous-line' +** 'catch', 'throw' +** 'count-lines' commit c15d67ecfc8f586165674c289880618caf7f270e Author: Mattias Engdegård Date: Tue Apr 30 15:20:34 2024 +0200 * lisp/emacs-lisp/bytecomp.el (byte-compile-make-closure): Simplify. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 8e8fcea9b72..d9890b5c37a 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -4191,16 +4191,13 @@ This function is never called when `lexical-binding' is nil." ;; Nontrivial doc string expression: create a bytecode object ;; from small pieces at run time. `(make-byte-code - ',(aref fun 0) ; 15-bit form of arglist descriptor. - ',(aref fun 1) ; The byte-code. - (vconcat (vector . ,env) ',(aref fun 2)) ; constant vector. - ,@(let ((rest (nthcdr 3 (mapcar (lambda (x) `',x) fun)))) - (if docstring-exp - `(,(car rest) - ,(byte-run-strip-symbol-positions docstring-exp) - ,@(cddr rest)) - rest)))) - )))) + ,(aref fun 0) ; 15-bit form of arglist descriptor. + ,(aref fun 1) ; The byte-code. + (vconcat (vector . ,env) ,(aref fun 2)) ; constant vector + ,(aref fun 3) ; max stack depth + ,(byte-run-strip-symbol-positions docstring-exp) + ;; optional interactive spec and anything else, all quoted + ,@(mapcar (lambda (x) `',x) (drop 5 (append fun nil))))))))) (defun byte-compile-get-closed-var (form) "Byte-compile the special `internal-get-closed-var' form." commit c3c2e3b4d3e9eac09293fca23e93f644e00e9431 Author: Mattias Engdegård Date: Tue Apr 30 14:51:07 2024 +0200 * lisp/emacs-lisp/bytecomp.el (byte-compile-lambda): Simplify. Remove the add-lambda argument. All callers adapted. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 6b7b804d7de..8e8fcea9b72 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2841,7 +2841,7 @@ not to take responsibility for the actual compilation of the code." ;; Tell the caller that we didn't compile it yet. nil) - (let* ((code (byte-compile-lambda (cons arglist body) t))) + (let ((code (byte-compile-lambda `(lambda ,arglist . ,body)))) (if this-one ;; A definition in b-c-initial-m-e should always take precedence ;; during compilation, so don't let it be redefined. (Bug#8647) @@ -3069,14 +3069,12 @@ If FORM is a lambda or a macro, byte-compile it as a function." byte-compile--known-dynamic-vars) ", ")))) -(defun byte-compile-lambda (fun &optional add-lambda reserved-csts) +(defun byte-compile-lambda (fun &optional reserved-csts) "Byte-compile a lambda-expression and return a valid function. The value is usually a compiled function but may be the original lambda-expression." - (if add-lambda - (setq fun (cons 'lambda fun)) - (unless (eq 'lambda (car-safe fun)) - (error "Not a lambda list: %S" fun))) + (unless (eq 'lambda (car-safe fun)) + (error "Not a lambda list: %S" fun)) (byte-compile-check-lambda-list (nth 1 fun)) (let* ((arglist (nth 1 fun)) (bare-arglist (byte-run-strip-symbol-positions arglist)) ; for compile-defun. @@ -4158,7 +4156,7 @@ This function is never called when `lexical-binding' is nil." (docstring-exp (nth 3 form)) (body (nthcdr 4 form)) (fun - (byte-compile-lambda `(lambda ,vars . ,body) nil (length env)))) + (byte-compile-lambda `(lambda ,vars . ,body) (length env)))) (cl-assert (or (> (length env) 0) docstring-exp)) ;Otherwise, we don't need a closure. (cl-assert (byte-code-function-p fun)) commit b36fd07560fd12c5e819e808a6f0eb9579f77c25 Author: Po Lu Date: Tue Apr 30 18:26:39 2024 +0800 Fix deletion of text holding `inhibit-read-only' properties * src/intervals.h (INTERVAL_VISIBLE_P): Split into ... (INTERVAL_GENERALLY_WRITABLE_P, INTERVAL_EXPRESSLY_WRITABLE_P): ... two new macros. * src/textprop.c (verify_interval_modification): If the buffer is read only, verify not that there is only a single exempting interval spanning the area of a multiple-character operation, but that every intervening interval in such an operation exempts it from write restrictions, either by providing a read-only property that appears in Vinhibit_read_only, or by providing an inhibit-read-only property. * test/src/textprop-tests.el (textprop-interval-immutability): New test. diff --git a/src/intervals.h b/src/intervals.h index 610c803cc77..5c6ef33a3a9 100644 --- a/src/intervals.h +++ b/src/intervals.h @@ -204,14 +204,21 @@ set_interval_plist (INTERVAL i, Lisp_Object plist) #define INTERVAL_VISIBLE_P(i) \ (i && NILP (textget ((i)->plist, Qinvisible))) -/* Is this interval writable? Replace later with cache access. */ -#define INTERVAL_WRITABLE_P(i) \ - (NILP (textget ((i)->plist, Qread_only)) \ - || !NILP (textget ((i)->plist, Qinhibit_read_only)) \ - || ((CONSP (Vinhibit_read_only) \ - ? !NILP (Fmemq (textget ((i)->plist, Qread_only), \ - Vinhibit_read_only)) \ - : !NILP (Vinhibit_read_only)))) +/* Is this interval writable by virtue of not being marked read-only, or + a general value of Vinhibit_read_only? Replace later with cache + access. */ +#define INTERVAL_GENERALLY_WRITABLE_P(i, ro) \ + (NILP (ro) || (!NILP (Vinhibit_read_only) \ + && !CONSP (Vinhibit_read_only))) + +/* Is this interval writable by virtue of an explicit inhibit-read-only + property, or the specific presence of its Qread_only property in + Vinhibit_read_only? */ +#define INTERVAL_EXPRESSLY_WRITABLE_P(i, ro) \ + (!NILP (textget ((i)->plist, Qinhibit_read_only)) \ + || (!NILP (ro) \ + && CONSP (Vinhibit_read_only) \ + && !NILP (Fmemq ((ro), Vinhibit_read_only)))) /* Macros to tell whether insertions before or after this interval should stick to it. Now we have Vtext_property_default_nonsticky, diff --git a/src/textprop.c b/src/textprop.c index 7d9aae0d2c5..84d6b5f1545 100644 --- a/src/textprop.c +++ b/src/textprop.c @@ -2186,6 +2186,7 @@ verify_interval_modification (struct buffer *buf, { INTERVAL intervals = buffer_intervals (buf); INTERVAL i; + ptrdiff_t p; Lisp_Object hooks; Lisp_Object prev_mod_hooks; Lisp_Object mod_hooks; @@ -2314,14 +2315,30 @@ verify_interval_modification (struct buffer *buf, } else { + bool buffer_read_only; + /* Loop over intervals on or next to START...END, collecting their hooks. */ + /* Extent of last writable interval. */ i = find_interval (intervals, start); + p = 0; + buffer_read_only = (!NILP (BVAR (current_buffer, read_only)) + && NILP (Vinhibit_read_only)); do { - if (! INTERVAL_WRITABLE_P (i)) - text_read_only (textget (i->plist, Qread_only)); + bool implied, express; + Lisp_Object read_only; + + read_only = textget ((i)->plist, Qread_only); + implied = INTERVAL_GENERALLY_WRITABLE_P (i, read_only); + express = INTERVAL_EXPRESSLY_WRITABLE_P (i, read_only); + if (!implied && !express) + text_read_only (read_only); + /* If this interval is only implicitly read only and the + buffer is read only as a whole, signal an error. */ + else if (!express && buffer_read_only) + xsignal1 (Qbuffer_read_only, Fcurrent_buffer ()); if (!inhibit_modification_hooks) { @@ -2333,16 +2350,18 @@ verify_interval_modification (struct buffer *buf, } } - if (i->position + LENGTH (i) < end - && (!NILP (BVAR (current_buffer, read_only)) - && NILP (Vinhibit_read_only))) - xsignal1 (Qbuffer_read_only, Fcurrent_buffer ()); - + p = i->position + LENGTH (i); i = next_interval (i); } /* Keep going thru the interval containing the char before END. */ while (i && i->position < end); + /* Should the buffer be read only while the last interval with an + `inhibit-read-only' property does not enclose the entire change + under consideration, signal error. */ + if (p < end && buffer_read_only) + xsignal1 (Qbuffer_read_only, Fcurrent_buffer ()); + if (!inhibit_modification_hooks) { hooks = Fnreverse (hooks); diff --git a/test/src/textprop-tests.el b/test/src/textprop-tests.el index d728b539955..7c2aa13bb34 100644 --- a/test/src/textprop-tests.el +++ b/test/src/textprop-tests.el @@ -68,5 +68,56 @@ (should (and (equal-including-properties (pop stack) string) (null stack))))) +(ert-deftest textprop-interval-immutability () + "Test modification of text with properties affecting mutability." + (let ((template (concat + (propertize "12345" 'inhibit-read-only t) ; 1-5 + (propertize "67890" 'read-only 'abcdefg) ; 6-10 + (propertize "ABCDE" 'inhibit-read-only t) ; 11-15 + (propertize "FGHIJ" 'inhibit-read-only 'yes) ; 16-20 + "KLMNO" ; 21-25 + (propertize "PQRST" 'inhibit-read-only 't) ; 26-30 + (propertize "UVWXYZ" 'read-only 'not-suppressed))) + inhibit-read-only) + (with-temp-buffer + (insert template) + (setq buffer-read-only t) + ;; Delete an entire inhibit-read-only region. + (progn (should (equal (delete-and-extract-region 1 6) + "12345")) + (let ((inhibit-read-only t)) (erase-buffer) + (insert template))) + ;; Delete multiple characters inside an inhibit-read-only section. + (progn (should (equal (delete-and-extract-region 2 5) + "234")) + (let ((inhibit-read-only t)) (erase-buffer) + (insert template))) + ;; Attempt to delete characters across both an inhibit-read-only + ;; and a read only region. + (setq buffer-read-only nil) + (should-error (delete-and-extract-region 4 7)) + (setq inhibit-read-only '(abcdefg)) + ;; Attempt the same, but with the read-only property of the second + ;; section suppressed. + (progn (should (equal (delete-and-extract-region 4 7) "456")) + (let ((inhibit-read-only t)) (erase-buffer) + (insert template))) + (setq buffer-read-only t) + ;; Delete text across the suppressed read-only region and two + ;; other inhibit-read-only regions each with distinct intervals. + (progn (should (equal (delete-and-extract-region 7 17) + "7890ABCDEF")) + (let ((inhibit-read-only t)) (erase-buffer) + (insert template))) + (setq inhibit-read-only nil) + ;; Attempt to delete text spanning two inhibit-read-only sections + ;; separated by immutable text. + (should-error (delete-and-extract-region 17 27)) + (setq inhibit-read-only '(abcdefg)) + ;; Attempt to delete text from the start of an inhibit-read-only + ;; section extending into protected text exempt from + ;; `inhibit-read-only''s influence towards the end of the buffer. + (should-error (delete-and-extract-region 26 37))))) + (provide 'textprop-tests) ;;; textprop-tests.el ends here commit aad80e1934f09b643b93aeb3bf9c1d583af6e2ec Author: Paul Eggert Date: Tue Apr 30 01:20:13 2024 -0700 Work around bad GCC diagnostic in select_window * src/textconv.c (select_window): Add an eassume to work around GCC bug 114893. diff --git a/src/textconv.c b/src/textconv.c index 8850f3cc6be..06d9af335c5 100644 --- a/src/textconv.c +++ b/src/textconv.c @@ -141,6 +141,10 @@ select_window (Lisp_Object window, Lisp_Object norecord) w = XWINDOW (window); + /* Work around GCC bug 114893 + . */ + eassume (w); + if (MINI_WINDOW_P (w) && WINDOW_LIVE_P (window) && !EQ (window, Factive_minibuffer_window ())) commit c57a03c75e91a42c49a293a9466b087a1e1592da Author: Paul Eggert Date: Tue Apr 30 01:20:13 2024 -0700 Pacify GCC 14 -Wanalyzer-out-of-bounds in hbfont.c * src/hbfont.c (hbfont_shape): Add an eassume. diff --git a/src/hbfont.c b/src/hbfont.c index 40bb44c7d04..37ed4132492 100644 --- a/src/hbfont.c +++ b/src/hbfont.c @@ -552,6 +552,8 @@ hbfont_shape (Lisp_Object lgstring, Lisp_Object direction) cluster_offset = to - from; } + eassume (0 <= from); + /* All the glyphs in a cluster have the same values of FROM and TO. */ LGLYPH_SET_FROM (lglyph, from); /* This heuristic is for when the Lisp shape-gstring function commit 59a11116e013fb123ba074da9bca373c1aa03367 Author: Paul Eggert Date: Tue Apr 30 01:20:13 2024 -0700 Pacify GCC 14 -Wstring-operflow in ftfont.c * src/ftfont.c (ftfont_drive_otf): Do not crash if spec->features[i] is nonnull but is empty. Use gfeatures local to pacify GCC 14. diff --git a/src/ftfont.c b/src/ftfont.c index 0d10de5408f..2e37b62ea35 100644 --- a/src/ftfont.c +++ b/src/ftfont.c @@ -2030,7 +2030,6 @@ ftfont_drive_otf (MFLTFont *font, int i, j, gidx; OTF_Glyph *otfg; char script[5], *langsys = NULL; - char *gsub_features = NULL, *gpos_features = NULL; OTF_Feature *features; if (len == 0) @@ -2044,6 +2043,7 @@ ftfont_drive_otf (MFLTFont *font, OTF_tag_name (spec->langsys, langsys); } + char *gfeatures[2] = {NULL, NULL}; USE_SAFE_ALLOCA; for (i = 0; i < 2; i++) { @@ -2052,11 +2052,10 @@ ftfont_drive_otf (MFLTFont *font, if (spec->features[i] && spec->features[i][1] != 0xFFFFFFFF) { for (j = 0; spec->features[i][j]; j++); + if (j == 0) + continue; SAFE_NALLOCA (p, 6, j); - if (i == 0) - gsub_features = p; - else - gpos_features = p; + gfeatures[i] = p; for (j = 0; spec->features[i][j]; j++) { if (spec->features[i][j] == 0xFFFFFFFF) @@ -2071,6 +2070,7 @@ ftfont_drive_otf (MFLTFont *font, *--p = '\0'; } } + char *gsub_features = gfeatures[0], *gpos_features = gfeatures[1]; setup_otf_gstring (len); for (i = 0; i < len; i++) commit 750dbccc12415fe525111cd11811d809fc830610 Author: Paul Eggert Date: Tue Apr 30 01:20:12 2024 -0700 Pacify GCC 14 -Wnull-dereference in intervals.c * src/intervals.c (set_intervals_multibyte_1): Add an eassume to pacify GCC. Deparenthesisze. diff --git a/src/intervals.c b/src/intervals.c index 2ab19c2cc56..c7a1f81e4ee 100644 --- a/src/intervals.c +++ b/src/intervals.c @@ -2388,17 +2388,18 @@ set_intervals_multibyte_1 (INTERVAL i, bool multi_flag, to this interval. */ if (LEFT_TOTAL_LENGTH (i) + RIGHT_TOTAL_LENGTH (i) >= TOTAL_LENGTH (i)) { - if ((i)->left) + if (i->left) { set_interval_plist (i, i->left->plist); - (i)->left->total_length = 0; + i->left->total_length = 0; delete_interval ((i)->left); } else { + eassume (i->right); set_interval_plist (i, i->right->plist); - (i)->right->total_length = 0; - delete_interval ((i)->right); + i->right->total_length = 0; + delete_interval (i->right); } } } commit c2b2a38f70f6c4639903a014db5b835b37669ea7 Author: Paul Eggert Date: Tue Apr 30 01:20:12 2024 -0700 Pacify GCC 14 -Wnull-dereference in tim_sort * src/lisp.h (tim_sort): Require array arg to be nonnull. * src/sort.c (reverse_slice): Omit no-longer-needed eassert. (tim_sort): Avoid undefined behavior when length == 0, since reverse_slice would then compute &seq[-1]. diff --git a/src/lisp.h b/src/lisp.h index 4487948b007..bf928f51b17 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4301,7 +4301,8 @@ extern void mark_fns (void); /* Defined in sort.c */ extern void tim_sort (Lisp_Object, Lisp_Object, Lisp_Object *, const ptrdiff_t, - bool); + bool) + ARG_NONNULL ((3)); /* Defined in floatfns.c. */ verify (FLT_RADIX == 2 || FLT_RADIX == 16); diff --git a/src/sort.c b/src/sort.c index 808cd187dcf..02dad327cd4 100644 --- a/src/sort.c +++ b/src/sort.c @@ -38,8 +38,6 @@ along with GNU Emacs. If not, see . */ static void reverse_slice(Lisp_Object *lo, Lisp_Object *hi) { - eassert (lo && hi); - --hi; while (lo < hi) { Lisp_Object t = *lo; @@ -1095,7 +1093,7 @@ tim_sort (Lisp_Object predicate, Lisp_Object keyfunc, Lisp_Object *allocated_keys = NULL; merge_state ms; - if (reverse) + if (reverse && 0 < length) reverse_slice (seq, seq + length); /* preserve stability */ if (NILP (keyfunc)) commit 009a6ba71ea6741371e4799bdb475235a5b6da90 Author: Paul Eggert Date: Tue Apr 30 01:20:12 2024 -0700 Pacify GCC 14 -Wclobbered in eval.c * src/eval.c: Ignore -Wclobbered. diff --git a/src/eval.c b/src/eval.c index fd388706108..d3761c31f88 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1237,6 +1237,12 @@ usage: (catch TAG BODY...) */) return internal_catch (tag, Fprogn, XCDR (args)); } +/* Work around GCC bug 61118 + . */ +#if GNUC_PREREQ (4, 9, 0) +# pragma GCC diagnostic ignored "-Wclobbered" +#endif + /* Assert that E is true, but do not evaluate E. Use this instead of eassert (E) when E contains variables that might be clobbered by a longjmp. */ commit 62c2afe84107de96b850c1da7a2b80bcab6e588a Author: Paul Eggert Date: Tue Apr 30 01:20:12 2024 -0700 Pacify GCC 14 -Wnull-dereference * src/xterm.c (x_dpyinfo): New function, which acts like x_display_info_for_display except it always returns nonnull. This simplifies callers and pacifies GCC 14. All callers changed. diff --git a/src/xfaces.c b/src/xfaces.c index 56d067ade5b..d5079491258 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -504,7 +504,7 @@ void x_free_dpy_colors (Display *dpy, Screen *screen, Colormap cmap, unsigned long *pixels, int npixels) { - struct x_display_info *dpyinfo = x_display_info_for_display (dpy); + struct x_display_info *dpyinfo = x_dpyinfo (dpy); /* If display has an immutable color map, freeing colors is not necessary and some servers don't allow it. So don't do it. */ diff --git a/src/xfns.c b/src/xfns.c index 67db461a379..c48fa24b6be 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -6547,10 +6547,7 @@ void xlw_monitor_dimensions_at_pos (Display *dpy, Screen *screen, int src_x, int src_y, int *x, int *y, int *width, int *height) { - struct x_display_info *dpyinfo = x_display_info_for_display (dpy); - - if (!dpyinfo) - emacs_abort (); + struct x_display_info *dpyinfo = x_dpyinfo (dpy); block_input (); xlw_monitor_dimensions_at_pos_1 (dpyinfo, screen, src_x, src_y, @@ -10214,10 +10211,7 @@ XkbFreeNames (XkbDescPtr xkb, unsigned int which, Bool free_map) int XDisplayCells (Display *dpy, int screen_number) { - struct x_display_info *dpyinfo = x_display_info_for_display (dpy); - - if (!dpyinfo) - emacs_abort (); + struct x_display_info *dpyinfo = x_dpyinfo (dpy); /* Not strictly correct, since the display could be using a non-default visual, but it satisfies the callers we need to care diff --git a/src/xmenu.c b/src/xmenu.c index ef1eeb5925f..8682e67dad4 100644 --- a/src/xmenu.c +++ b/src/xmenu.c @@ -236,7 +236,7 @@ x_menu_translate_generic_event (XEvent *event) XEvent copy; XIDeviceEvent *xev; - dpyinfo = x_display_info_for_display (event->xgeneric.display); + dpyinfo = x_dpyinfo (event->xgeneric.display); if (event->xgeneric.extension == dpyinfo->xi2_opcode) { diff --git a/src/xterm.c b/src/xterm.c index 93d347a77ef..c6cc4a9cae6 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -2933,7 +2933,6 @@ x_dnd_free_toplevels (bool display_alive) unsigned long *prev_masks UNINIT; specpdl_ref count; Display *dpy UNINIT; - struct x_display_info *dpyinfo; if (!x_dnd_toplevels) /* Probably called inside an IO error handler. */ @@ -2995,25 +2994,21 @@ x_dnd_free_toplevels (bool display_alive) record_unwind_protect_ptr (xfree, destroy_windows); record_unwind_protect_ptr (xfree, prev_masks); - if (display_alive) + if (display_alive && n_windows) { - dpyinfo = x_display_info_for_display (dpy); + struct x_display_info *dpyinfo = x_dpyinfo (dpy); - if (n_windows) - { - eassume (dpyinfo); - x_ignore_errors_for_next_request (dpyinfo, 0); + x_ignore_errors_for_next_request (dpyinfo, 0); - for (i = 0; i < n_windows; ++i) - { - XSelectInput (dpy, destroy_windows[i], prev_masks[i]); + for (i = 0; i < n_windows; ++i) + { + XSelectInput (dpy, destroy_windows[i], prev_masks[i]); #ifdef HAVE_XSHAPE - XShapeSelectInput (dpy, destroy_windows[i], None); + XShapeSelectInput (dpy, destroy_windows[i], None); #endif - } - - x_stop_ignoring_errors (dpyinfo); } + + x_stop_ignoring_errors (dpyinfo); } unbind_to (count, Qnil); @@ -6881,7 +6876,20 @@ x_draw_horizontal_wave (struct frame *f, GC gc, int x, int y, #endif -/* Return the struct x_display_info corresponding to DPY. */ +/* Return the struct x_display_info corresponding to DPY, + when it is guaranteed that one will correspond. */ + +struct x_display_info * +x_dpyinfo (Display *dpy) +{ + for (struct x_display_info *dpyinfo = x_display_list; ; + dpyinfo = dpyinfo->next) + if (dpyinfo->display == dpy) + return dpyinfo; +} + +/* Return the struct x_display_info corresponding to DPY, + or a null pointer if none corresponds. */ struct x_display_info * x_display_info_for_display (Display *dpy) @@ -8895,7 +8903,7 @@ x_frame_of_widget (Widget widget) Lisp_Object tail, frame; struct frame *f; - dpyinfo = x_display_info_for_display (XtDisplay (widget)); + dpyinfo = x_dpyinfo (XtDisplay (widget)); /* Find the top-level shell of the widget. Note that this function can be called when the widget is not yet realized, so XtWindow @@ -9089,8 +9097,7 @@ cvt_pixel_dtor (XtAppContext app, XrmValuePtr to, XtPointer closure, XrmValuePtr static const XColor * x_color_cells (Display *dpy, int *ncells) { - struct x_display_info *dpyinfo = x_display_info_for_display (dpy); - eassume (dpyinfo); + struct x_display_info *dpyinfo = x_dpyinfo (dpy); if (dpyinfo->color_cells == NULL) { @@ -9365,16 +9372,13 @@ x_parse_color (struct frame *f, const char *color_name, static bool x_alloc_nearest_color_1 (Display *dpy, Colormap cmap, XColor *color) { - struct x_display_info *dpyinfo = x_display_info_for_display (dpy); - bool rc; - - eassume (dpyinfo); - rc = XAllocColor (dpy, cmap, color) != 0; + struct x_display_info *dpyinfo = x_dpyinfo (dpy); + bool rc = XAllocColor (dpy, cmap, color) != 0; if (dpyinfo->visual_info.class == DirectColor) return rc; - if (rc == 0) + if (!rc) { /* If we got to this point, the colormap is full, so we're going to try and get the next closest color. The algorithm used is @@ -9477,8 +9481,7 @@ x_alloc_nearest_color_1 (Display *dpy, Colormap cmap, XColor *color) /* If allocation succeeded, and the allocated pixel color is not equal to a cached pixel color recorded earlier, there was a change in the colormap, so clear the color cache. */ - struct x_display_info *dpyinfo = x_display_info_for_display (dpy); - eassume (dpyinfo); + struct x_display_info *dpyinfo = x_dpyinfo (dpy); if (dpyinfo->color_cells) { @@ -14607,12 +14610,7 @@ x_query_pointer (Display *dpy, Window w, Window *root_return, int *root_y_return, int *win_x_return, int *win_y_return, unsigned int *mask_return) { - struct x_display_info *dpyinfo; - - dpyinfo = x_display_info_for_display (dpy); - - if (!dpyinfo) - emacs_abort (); + struct x_display_info *dpyinfo = x_dpyinfo (dpy); #ifdef HAVE_XINPUT2 return x_query_pointer_1 (dpyinfo, dpyinfo->client_pointer_device, diff --git a/src/xterm.h b/src/xterm.h index 2c00b1e7bec..437ef281b0c 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -993,6 +993,8 @@ extern int popup_activated_flag; /* This is a chain of structures for all the X displays currently in use. */ extern struct x_display_info *x_display_list; +extern struct x_display_info *x_dpyinfo (Display *) + ATTRIBUTE_RETURNS_NONNULL; extern struct x_display_info *x_display_info_for_display (Display *); extern struct frame *x_top_window_to_frame (struct x_display_info *, int); extern struct x_display_info *x_term_init (Lisp_Object, char *, char *); commit 98d0fc989a00dda19412ec5cd3ebe9fb4f276521 Author: Paul Eggert Date: Tue Apr 30 01:20:12 2024 -0700 Pacify GCC 14 -Walloc-size * src/xfns.c (xic_string_conversion_callback): Allocate size 1, not 0. diff --git a/src/xfns.c b/src/xfns.c index d610c839bfc..67db461a379 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -3917,11 +3917,12 @@ xic_string_conversion_callback (XIC ic, XPointer client_data, return; failure: - /* Return a string of length 0 using the C library malloc. This + /* Return a string of length 0 using the C library malloc (1) + (not malloc (0), to pacify gcc -Walloc-size). This assumes XFree is able to free data allocated with our malloc wrapper. */ call_data->text->length = 0; - call_data->text->string.mbs = malloc (0); + call_data->text->string.mbs = malloc (1); } #endif /* HAVE_X_I18N */ commit ca4f0705be544986f11971bd8ee7dc30a8d444f1 Author: Paul Eggert Date: Tue Apr 30 01:20:12 2024 -0700 etags: work around GCC bug 114882 * lib-src/etags.c: Ignore -Wanalyzer-use-of-uninitialized-value. This applies to the whole source file, not just to areas where GCC has bugs, as it was too tricky to ignore more selectively. diff --git a/lib-src/etags.c b/lib-src/etags.c index 57ffbce380c..84dfa527e98 100644 --- a/lib-src/etags.c +++ b/lib-src/etags.c @@ -143,6 +143,12 @@ University of California, as described above. */ # define MERCURY_HEURISTICS_RATIO 0.5 #endif +/* Work around GCC bug 114882 + . */ +#if GNUC_PREREQ (14, 0, 0) +# pragma GCC diagnostic ignored "-Wanalyzer-use-of-uninitialized-value" +#endif + /* COPY to DEST from SRC (containing LEN bytes), and append a NUL byte. */ static void memcpyz (void *dest, void const *src, ptrdiff_t len) commit 7e2309c6fc67b8149cc4c75f8d7f5f93e60b86c7 Author: Paul Eggert Date: Tue Apr 30 01:20:12 2024 -0700 etags: fix #line parsing (\\", long lines) * lib-src/etags.c (readline): Don’t mishandle lines like ‘#line 1 "a//"’, which has an escaped backslash before ‘"’. Don’t mishandle lines so long that sscanf overflows %n. diff --git a/lib-src/etags.c b/lib-src/etags.c index c316b3c7649..57ffbce380c 100644 --- a/lib-src/etags.c +++ b/lib-src/etags.c @@ -7375,26 +7375,26 @@ readline (linebuffer *lbp, FILE *stream) /* Check whether this is a #line directive. */ if (result > 12 && strneq (lbp->buffer, "#line ", 6)) { - intmax_t lno; - int start = 0; + char *lno_start = lbp->buffer + 6; + char *lno_end; + intmax_t lno = strtoimax (lno_start, &lno_end, 10); + char *quoted_filename + = lno_start < lno_end ? skip_spaces (lno_end) : NULL; - if (sscanf (lbp->buffer, "#line %"SCNdMAX" \"%n", &lno, &start) >= 1 - && start > 0) /* double quote character found */ + if (quoted_filename && *quoted_filename == '"') { - char *endp = lbp->buffer + start; + char *endp = quoted_filename; + while (*++endp && *endp != '"') + endp += *endp == '\\' && endp[1]; - while ((endp = strchr (endp, '"')) != NULL - && endp[-1] == '\\') - endp++; - if (endp != NULL) + if (*endp) /* Ok, this is a real #line directive. Let's deal with it. */ { char *taggedabsname; /* absolute name of original file */ char *taggedfname; /* name of original file as given */ - char *name; /* temp var */ + char *name = quoted_filename + 1; discard_until_line_directive = false; /* found it */ - name = lbp->buffer + start; *endp = '\0'; canonicalize_filename (name); taggedabsname = absolute_filename (name, tagfiledir); commit de59c02c685189413c7c5a136224d10152dc8a61 Author: Paul Eggert Date: Tue Apr 30 01:20:12 2024 -0700 Simplify etags.c by omitting a macro * lib-src/etags.c (xnew): Remove. All uses removed. xnew was confusing, as sometimes it was used with n=1, sometimes with Type=char, and it’s easier just to use xmalloc or xnmalloc. diff --git a/lib-src/etags.c b/lib-src/etags.c index 032cfa8010b..c316b3c7649 100644 --- a/lib-src/etags.c +++ b/lib-src/etags.c @@ -243,12 +243,10 @@ endtoken (unsigned char c) } /* - * xnew, xrnew -- allocate, reallocate storage + * xrnew -- reallocate storage * - * SYNOPSIS: Type *xnew (ptrdiff_t n, Type); - * void xrnew (OldPointer, ptrdiff_t n, int multiplier); + * SYNOPSIS: void xrnew (OldPointer, ptrdiff_t n, int multiplier); */ -#define xnew(n, Type) ((Type *) xnmalloc (n, sizeof (Type))) #define xrnew(op, n, m) ((op) = xnrealloc (op, n, (m) * sizeof *(op))) typedef void Lang_function (FILE *); @@ -1125,13 +1123,13 @@ main (int argc, char **argv) progname = argv[0]; nincluded_files = 0; - included_files = xnew (argc, char *); + included_files = xnmalloc (argc, sizeof *included_files); current_arg = 0; file_count = 0; /* Allocate enough no matter what happens. Overkill, but each one is small. */ - argbuffer = xnew (argc, argument); + argbuffer = xnmalloc (argc, sizeof *argbuffer); /* * Always find typedefs and structure tags. @@ -1778,7 +1776,7 @@ process_file (FILE *fh, char *fn, language *lang) infilename = fn; /* Create a new input file description entry. */ - fdp = xnew (1, fdesc); + fdp = xmalloc (sizeof *fdp); *fdp = emptyfdesc; fdp->next = fdhead; fdp->infname = savestr (fn); @@ -2080,7 +2078,7 @@ pfnote (char *name, /* tag name, or NULL if unnamed */ || (!CTAGS && name && name[0] == '\0')) return; - np = xnew (1, node); + np = xmalloc (sizeof *np); /* If ctags mode, change name "main" to M. */ if (CTAGS && !cxref_style && streq (name, "main")) @@ -2135,7 +2133,7 @@ push_node (node *np, stkentry **stack_top) { if (np) { - stkentry *new = xnew (1, stkentry); + stkentry *new = xmalloc (sizeof *new); new->np = np; new->next = *stack_top; @@ -3425,8 +3423,8 @@ C_entries (int c_ext, /* extension of C */ { cstack.size = (DEBUG) ? 1 : 4; cstack.nl = 0; - cstack.cname = xnew (cstack.size, char *); - cstack.bracelev = xnew (cstack.size, ptrdiff_t); + cstack.cname = xnmalloc (cstack.size, sizeof *cstack.cname); + cstack.bracelev = xnmalloc (cstack.size, sizeof *cstack.bracelev); } tokoff = toklen = typdefbracelev = 0; /* keep compiler quiet */ @@ -5077,7 +5075,7 @@ Ruby_functions (FILE *inf) if (writer) { size_t name_len = cp - np + 1; - char *wr_name = xnew (name_len + 1, char); + char *wr_name = xmalloc (name_len + 1); strcpy (mempcpy (wr_name, np, name_len - 1), "="); pfnote (wr_name, true, lb.buffer, cp - lb.buffer + 1, @@ -5854,7 +5852,7 @@ TEX_decode_env (const char *evarname, const char *defenv) for (p = env; (p = strchr (p, ':')); ) if (*++p) len++; - TEX_toktab = xnew (len, linebuffer); + TEX_toktab = xnmalloc (len, sizeof *TEX_toktab); /* Unpack environment string into token table. Be careful about */ /* zero-length strings (leading ':', "::" and trailing ':') */ @@ -7033,7 +7031,7 @@ add_regex (char *regexp_pattern, language *lang) break; } - patbuf = xnew (1, struct re_pattern_buffer); + patbuf = xmalloc (sizeof *patbuf); *patbuf = zeropattern; if (ignore_case) { @@ -7064,7 +7062,7 @@ add_regex (char *regexp_pattern, language *lang) } rp = p_head; - p_head = xnew (1, regexp); + p_head = xmalloc (sizeof *p_head); p_head->pattern = savestr (regexp_pattern); p_head->p_next = rp; p_head->lang = lang; @@ -7104,7 +7102,7 @@ substitute (char *in, char *out, struct re_registers *regs) /* Allocate space and do the substitutions. */ assert (size >= 0); - result = xnew (size + 1, char); + result = xmalloc (size + 1); for (t = result; *out != '\0'; out++) if (*out == '\\' && c_isdigit (*++out)) @@ -7452,7 +7450,7 @@ readline (linebuffer *lbp, FILE *stream) if (fdp == NULL) /* not found */ { fdp = fdhead; - fdhead = xnew (1, fdesc); + fdhead = xmalloc (sizeof *fdhead); *fdhead = *curfdp; /* copy curr. file description */ fdhead->next = fdp; fdhead->infname = savestr (curfdp->infname); @@ -7552,7 +7550,7 @@ readline (linebuffer *lbp, FILE *stream) /* * Return a pointer to a space of size strlen(cp)+1 allocated - * with xnew where the string CP has been copied. + * with xmalloc where the string CP has been copied. */ static char * savestr (const char *cp) @@ -7561,13 +7559,13 @@ savestr (const char *cp) } /* - * Return a pointer to a space of size LEN+1 allocated with xnew + * Return a pointer to a space of size LEN+1 allocated with xmalloc * with a copy of CP (containing LEN bytes) followed by a NUL byte. */ static char * savenstr (const char *cp, ptrdiff_t len) { - char *dp = xnew (len + 1, char); + char *dp = xmalloc (len + 1); dp[len] = '\0'; return memcpy (dp, cp, len); } @@ -7650,7 +7648,7 @@ static char * concat (const char *s1, const char *s2, const char *s3) { ptrdiff_t len1 = strlen (s1), len2 = strlen (s2), len3 = strlen (s3); - char *result = xnew (len1 + len2 + len3 + 1, char); + char *result = xmalloc (len1 + len2 + len3 + 1); strcpy (stpcpy (stpcpy (result, s1), s2), s3); return result; } @@ -7662,7 +7660,7 @@ static char * etags_getcwd (void) { ptrdiff_t bufsize = 200; - char *path = xnew (bufsize, char); + char *path = xmalloc (bufsize); while (getcwd (path, bufsize) == NULL) { @@ -7748,7 +7746,7 @@ escape_shell_arg_string (char *str) p++; } - char *new_str = xnew (need_space + 1, char); + char *new_str = xmalloc (need_space + 1); new_str[0] = '\''; new_str[need_space-1] = '\''; @@ -7841,7 +7839,7 @@ relative_filename (char *file, char *dir) i = 0; while ((dp = strchr (dp + 1, '/')) != NULL) i += 1; - res = xnew (3*i + strlen (fp + 1) + 1, char); + res = xmalloc (3*i + strlen (fp + 1) + 1); char *z = res; while (i-- > 0) z = stpcpy (z, "../"); @@ -7996,7 +7994,7 @@ static void linebuffer_init (linebuffer *lbp) { lbp->size = (DEBUG) ? 3 : 200; - lbp->buffer = xnew (lbp->size, char); + lbp->buffer = xmalloc (lbp->size); lbp->buffer[0] = '\0'; lbp->len = 0; } commit d24981d27ceae404a1dbdc9dc8b0c0e94e63ed1a Author: Michael Albinus Date: Tue Apr 30 09:28:07 2024 +0200 ; etc/NEWS.unknown: Quote command invocation. diff --git a/etc/NEWS.unknown b/etc/NEWS.unknown index 4a6d68dcae0..4aca2525c3d 100644 --- a/etc/NEWS.unknown +++ b/etc/NEWS.unknown @@ -1,6 +1,6 @@ This file contains mentions of functions and variables whose version of introduction would otherwise be guessed incorrectly -by M-x describe-function. +by 'M-x describe-function'. Since much of early Emacs source history is lost, these versions are conservative estimates: the actual version of first appearance may very commit d844521abd586f7a42bf6f4f913d39e575f7a750 Author: Michael Albinus Date: Tue Apr 30 09:25:53 2024 +0200 Improve treesitter tests on EMBA * test/infra/Makefile.in (subdir_template): * test/infra/gitlab-ci.yml (.tree-sitter-template): Check also textmodes subdirectory for treesitter files. * test/infra/test-jobs.yml: Regenerate. diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in index 77ab1921212..9c32fd6a192 100644 --- a/test/infra/Makefile.in +++ b/test/infra/Makefile.in @@ -76,6 +76,15 @@ define subdir_template define changes @echo ' - lisp/so-long*.el' >>$(FILE) endef + else ifeq ($(findstring textmodes, $(1)), textmodes) + define changes + @echo ' - $(1)/*-ts-mode.el' >>$(FILE) + @echo ' - test/$(1)/*-ts-mode-resources/**' >>$(FILE) + @echo ' - test/$(1)/*-ts-mode-tests.el' >>$(FILE) + @echo ' when: never' >>$(FILE) + @echo ' - changes:' >>$(FILE) + @echo ' - $(1)/*.el' >>$(FILE) + endef else ifeq ($(findstring misc, $(1)), misc) define changes @echo ' - admin/*.el' >>$(FILE) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 49e2118761d..11ff0d1c738 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -186,12 +186,15 @@ default: - lisp/progmodes/*-ts-mode.el - lisp/progmodes/js.el - lisp/progmodes/python.el + - lisp/textmodes/*-ts-mode.el - src/treesit.{h,c} - test/infra/* - test/lisp/progmodes/*-ts-mode-resources/** - test/lisp/progmodes/*-ts-mode-tests.el - test/lisp/progmodes/js-tests.el - test/lisp/progmodes/python-tests.el + - test/lisp/textmodes/*-ts-mode-resources/** + - test/lisp/textmodes/*-ts-mode-tests.el - test/src/treesit-tests.el .native-comp-template: diff --git a/test/infra/test-jobs.yml b/test/infra/test-jobs.yml index d9ba2363c9e..0d9cbb029e5 100644 --- a/test/infra/test-jobs.yml +++ b/test/infra/test-jobs.yml @@ -475,6 +475,11 @@ test-lisp-textmodes-inotify: rules: - if: '$CI_PIPELINE_SOURCE == "schedule"' when: never + - changes: + - lisp/textmodes/*-ts-mode.el + - test/lisp/textmodes/*-ts-mode-resources/** + - test/lisp/textmodes/*-ts-mode-tests.el + when: never - changes: - lisp/textmodes/*.el - test/lisp/textmodes/*resources/** commit c4eecbf68410a7e7c301cc25291890d33a22be14 Author: Michael Albinus Date: Tue Apr 30 09:25:07 2024 +0200 * test/README (EMACS_EXTRAOPT): Add environment variable. diff --git a/test/README b/test/README index 7a3cf871a57..fb9f45490c5 100644 --- a/test/README +++ b/test/README @@ -109,6 +109,12 @@ debugging. To do that, use make TEST_INTERACTIVE=yes ... +Sometimes, some further settings are needed in order to run the batch +test. This can be indicated by the $EMACS_EXTRAOPT environment +variable, like + + make ... EMACS_EXTRAOPT="--eval '(setopt ert-batch-print-length nil ert-batch-print-level nil)'" + By default, ERT test failure summaries are quite brief in batch mode--only the names of the failed tests are listed. If the $EMACS_TEST_VERBOSE environment variable is set and non-empty, the commit 3555447b7e9b16ddf3b52091a23be1b91155854c Author: Po Lu Date: Tue Apr 30 13:21:59 2024 +0800 Minor adjustments to eww text field change handlers * lisp/net/eww.el (eww-check-text-conversion): Fix doc string. (eww-mode): Specify face, eww-form and field as nonsticky properties by default. (eww-tag-textarea, eww-form-text): Render properties front-sticky. (eww-process-text-input): Use field functions to compute field bounds. diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 5a138dcc46a..c3437ddd1d6 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -1308,7 +1308,7 @@ Set `text-conversion-style' to the value `action' if it isn't already and point is within the prompt field, or if `text-conversion-style' is `nil', so as to guarantee that the input method functions properly for the purpose of typing -within the ERC prompt." +within text input fields." (when (and (eq major-mode 'eww-mode) (fboundp 'set-text-conversion-style)) (if (eq (car-safe (get-text-property (point) 'field)) @@ -1347,7 +1347,11 @@ within the ERC prompt." (setq-local outline-search-function 'shr-outline-search outline-level 'shr-outline-level) (add-hook 'post-command-hook #'eww-check-text-conversion nil t) - (setq buffer-read-only t)) + (setq buffer-read-only t) + ;; Insertion at the first character of a field should inherit the + ;; field's face, form and field, not the previous character's. + (setq text-property-default-nonsticky '((face . t) (eww-form . t) + (field . t)))) (defvar text-scale-mode) (defvar text-scale-mode-amount) @@ -1685,6 +1689,7 @@ Interactively, EVENT is the value of `last-nonmenu-event'." (put-text-property start (point) readonly-property t) (put-text-property start (point) 'eww-form form) (put-text-property start (point) 'field form) + (put-text-property start (point) 'front-sticky t) (insert " "))) (defconst eww-text-input-types '("text" "password" "textarea" @@ -1695,13 +1700,7 @@ Interactively, EVENT is the value of `last-nonmenu-event'." See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (defun eww-process-text-input (beg end replace-length) - (when-let* ((pos (and (< (1+ end) (point-max)) - (> (1- end) (point-min)) - (cond - ((get-text-property (1+ end) 'eww-form) - (1+ end)) - ((get-text-property (1- end) 'eww-form) - (1- end)))))) + (when-let* ((pos (field-beginning (point)))) (let* ((form (get-text-property pos 'eww-form)) (properties (text-properties-at pos)) (buffer-undo-list t) @@ -1719,7 +1718,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (1- (line-end-position)) (eww-end-of-field))) (while (and (> length 0) - (eql (char-after (1- (point))) ? )) + (eq (char-after (1- (point))) ? )) (delete-region (1- (point)) (point)) (cl-decf length)))) ((< length 0) @@ -1743,6 +1742,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (when (string-match " +\\'" value) (setq value (substring value 0 (match-beginning 0)))) (plist-put form :value value) + (plist-put form :type type) (when (equal type "password") ;; Display passwords as asterisks. (let ((start (eww-beginning-of-field))) @@ -1780,6 +1780,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") :type "textarea" :name (dom-attr dom 'name))) (put-text-property start (point) 'eww-form form) + (put-text-property start (point) 'front-sticky t) (put-text-property start (point) 'field form) (put-text-property start (1+ start) 'shr-tab-stop t))) commit 3000edc6179dfe0b5f24ae2e472826530809dfd1 Author: Mattias Engdegård Date: Mon Apr 29 20:24:07 2024 +0200 Use the nthcdr byte-op for drop, and raise open-code limit * lisp/emacs-lisp/byte-opt.el (byte-optimize-nthcdr): Open-code for any integral N<5. Always use the byte-op otherwise. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 3d6b35422b8..4095726d276 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1512,13 +1512,15 @@ See Info node `(elisp) Integer Basics'." (put 'nthcdr 'byte-optimizer #'byte-optimize-nthcdr) (defun byte-optimize-nthcdr (form) (if (= (safe-length form) 3) - (if (memq (nth 1 form) '(0 1 2)) - (let ((count (nth 1 form))) - (setq form (nth 2 form)) - (while (>= (setq count (1- count)) 0) - (setq form (list 'cdr form))) - form) - form) + (let ((count (nth 1 form))) + (cond ((and (integerp count) (<= count 3)) + (setq form (nth 2 form)) + (while (>= (setq count (1- count)) 0) + (setq form (list 'cdr form))) + form) + ((not (eq (car form) 'nthcdr)) + (cons 'nthcdr (cdr form))) ; use the nthcdr byte-op + (t form))) form)) (put 'cons 'byte-optimizer #'byte-optimize-cons) commit 97a2710554fbd10a0c866e890f507e391620e769 Author: Eric Abrahamsen Date: Mon Apr 29 13:13:38 2024 -0700 Add (semi-redundant) fix to nnatom backend declaration * lisp/gnus/gnus.el (gnus-valid-select-methods): We need a value for post/mail/none in order to conform to the option type. * lisp/gnus/nnatom.el: This call to gnus-declare-backend does the exact same thing as above, and needs to be adjusted accordingly. diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index bc8819dc967..f1fc129a505 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -1360,7 +1360,7 @@ slower." ("nnimap" post-mail address prompt-address physical-address respool server-marks cloud) ("nnmaildir" mail respool address server-marks) - ("nnatom" address) + ("nnatom" none address) ("nnnil" none)) "An alist of valid select methods. The first element of each list lists should be a string with the name diff --git a/lisp/gnus/nnatom.el b/lisp/gnus/nnatom.el index e8dfa12aff5..add9ae2dff9 100644 --- a/lisp/gnus/nnatom.el +++ b/lisp/gnus/nnatom.el @@ -269,7 +269,7 @@ return the subject. Otherwise, return nil." (defvoo nnatom-read-parts-function #'nnatom--read-parts nil nnfeed-read-parts-function) -(gnus-declare-backend (symbol-name nnatom-backend) 'address) +(gnus-declare-backend (symbol-name nnatom-backend) 'none 'address) (provide 'nnatom) commit ccb49acd2afb8cec9cec1afba16e16420b9f9261 Author: Stefan Monnier Date: Mon Apr 29 13:47:15 2024 -0400 (disassemble-internal): Handle new function values * lisp/emacs-lisp/disass.el (disassemble-internal): Fix the `interpreted-function` case. diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 15caee9b29c..60881ab176b 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -115,16 +115,14 @@ redefine OBJECT if it is a symbol." obj (cdr obj))) (if (eq (car-safe obj) 'byte-code) (setq obj `(lambda () ,obj))) - (when (consp obj) + (when (or (consp obj) (interpreted-function-p obj)) (unless (functionp obj) (error "Not a function")) - (if (assq 'byte-code obj) - nil - (if interactive-p (message (if name - "Compiling %s's definition..." - "Compiling definition...") - name)) - (setq obj (byte-compile obj)) - (if interactive-p (message "Done compiling. Disassembling...")))) + (if interactive-p (message (if name + "Compiling %s's definition..." + "Compiling definition...") + name)) + (setq obj (byte-compile obj)) + (if interactive-p (message "Done compiling. Disassembling..."))) (cond ((consp obj) (setq args (help-function-arglist obj)) ;save arg list (setq obj (cdr obj)) ;throw lambda away @@ -171,9 +169,7 @@ redefine OBJECT if it is a symbol." (let ((print-escape-newlines t)) (prin1 interactive (current-buffer)))) (insert "\n")))) - (cond ((and (consp obj) (assq 'byte-code obj)) - (disassemble-1 (assq 'byte-code obj) indent)) - ((byte-code-function-p obj) + (cond ((byte-code-function-p obj) (disassemble-1 obj indent)) (t (insert "Uncompiled body: ") @@ -279,6 +275,8 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." arg (+ indent disassemble-recursive-indent))) ((eq (car-safe (car-safe arg)) 'byte-code) + ;; FIXME: I'm 99% sure bytecomp never generates + ;; this any more. (insert "(...)\n") (mapc ;Recurse on list of byte-code objects. (lambda (obj) commit 7c835291dde79b39323a4a2623a14cc7564164cb Author: Stefan Monnier Date: Mon Apr 29 13:34:23 2024 -0400 oclosure-tests.el: Adjust to new `interpreted-function` type * test/lisp/emacs-lisp/oclosure-tests.el (oclosure-test-gen): Adjust to new `interpreted-function` type. (oclosure-test): Tweak accordingly. diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el index 4760f403158..14c205631e0 100644 --- a/test/lisp/emacs-lisp/oclosure-tests.el +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -32,7 +32,7 @@ (cl-defmethod oclosure-test-gen ((_x compiled-function)) "#") -(cl-defmethod oclosure-test-gen ((_x cons)) "#") +(cl-defmethod oclosure-test-gen ((_x interpreted-function)) "#") (cl-defmethod oclosure-test-gen ((_x oclosure)) (format "#" (cl-call-next-method))) @@ -63,7 +63,7 @@ (should (cl-typep ocl1 'oclosure-test)) (should (cl-typep ocl1 'oclosure)) (should (member (oclosure-test-gen ocl1) - '("#>>" + '("#>>" "#>>"))) (should (stringp (documentation #'oclosure-test--fst))) )) commit 4d079209f0a020e87b38567fa0058f06da069867 Merge: f6ae5939b95 7cf767ef54f Author: Eli Zaretskii Date: Mon Apr 29 20:36:36 2024 +0300 Merge branch 'master' of git.savannah.gnu.org:/srv/git/emacs commit 7cf767ef54f2cf1d2873fe4dd07664b401d8044b Author: Stefan Monnier Date: Mon Apr 29 13:14:31 2024 -0400 (byte-compile): Fix interaction with old `advice.el` * lisp/emacs-lisp/bytecomp.el (byte-compile): Handle symbols whose function "value" is a bare lambda expression (bug#70368). diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 7aae87c50dc..6b7b804d7de 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2962,8 +2962,10 @@ If FORM is a lambda or a macro, byte-compile it as a function." (when (or (symbolp form) (interpreted-function-p fun)) ;; `fun' is a function *value*, so try to recover its ;; corresponding source code. - (setq lexical-binding (not (null (aref fun 2)))) - (setq fun (byte-compile--reify-function fun)) + (if (not (interpreted-function-p fun)) + (setq lexical-binding nil) + (setq lexical-binding (not (null (aref fun 2)))) + (setq fun (byte-compile--reify-function fun))) (setq need-a-value t)) ;; Expand macros. (setq fun (byte-compile-preprocess fun)) commit f6ae5939b950bdec86471b02e81d1b3827546a2d Author: Eli Zaretskii Date: Mon Apr 29 15:32:12 2024 +0300 ; Fix documentation of recent commits. * lisp/touch-screen.el (touch-screen-handle-point-up): Fix comments. * lisp/net/eww.el (eww-check-text-conversion, eww-select-file) (eww-toggle-checkbox, eww-submit): Doc fixes. * doc/emacs/input.texi (On-Screen Keyboards): Fix punctuation and wording. diff --git a/doc/emacs/input.texi b/doc/emacs/input.texi index d48c13355b3..b553c0895cd 100644 --- a/doc/emacs/input.texi +++ b/doc/emacs/input.texi @@ -127,9 +127,9 @@ minibuffer being brought into use (@pxref{Minibuffer}). @vindex touch-screen-set-point-commands When a ``tap'' gesture results in a command being executed, Emacs checks whether the command is meant to set the point by searching for it -in the list @code{touch-screen-set-point-commands}. If it is and the +in the list @code{touch-screen-set-point-commands}. If it is, and the text beneath the new point is not read-only, the virtual keyboard is -activated, in anticipation of the user entering text there. +activated, in anticipation of the user input there. The default value of @code{touch-screen-set-point-commands} holds only the command @code{mouse-set-point} (@pxref{Mouse Commands}), which is diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 4bb491b9970..5a138dcc46a 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -1304,10 +1304,11 @@ This consults the entries in `eww-readable-urls' (which see)." (defun eww-check-text-conversion () "Check if point is within a field and toggle text conversion. -If `text-conversion-style' is not `action' if point is within the -prompt or `nil' otherwise, set it to such a value, so as to -guarantee that the input method functions properly for the -purpose of typing within the ERC prompt." +Set `text-conversion-style' to the value `action' if it isn't +already and point is within the prompt field, or if +`text-conversion-style' is `nil', so as to guarantee that +the input method functions properly for the purpose of typing +within the ERC prompt." (when (and (eq major-mode 'eww-mode) (fboundp 'set-text-conversion-style)) (if (eq (car-safe (get-text-property (point) 'field)) @@ -1649,7 +1650,8 @@ just re-display the HTML already fetched." (defun eww-select-file (&optional event) "Change the value of the upload file menu under point. -EVENT, if non-nil, is the mouse event that preceded this command." +EVENT, if non-nil, is the mouse event that preceded this command. +Interactively, EVENT is the value of `last-nonmenu-event'." (interactive (list last-nonmenu-event) eww-mode) (when (and event (setq event (event-start event))) (goto-char (posn-point event))) @@ -1904,7 +1906,8 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (defun eww-toggle-checkbox (&optional event) "Toggle the value of the checkbox under point. -EVENT, if non-nil, is the mouse event that preceded this command." +EVENT, if non-nil, is the mouse event that preceded this command. +Interactively, EVENT is the value of `last-nonmenu-event'." (interactive (list last-nonmenu-event) eww-mode) (when (and event (setq event (event-start event))) (goto-char (posn-point event))) @@ -1977,7 +1980,8 @@ EVENT, if non-nil, is the mouse event that preceded this command." (defun eww-submit (&optional event) "Submit the form under point or EVENT. -EVENT, if non-nil, is the mouse event that preceded this command." +EVENT, if non-nil, is the mouse event that preceded this command. +Interactively, EVENT is the value of `last-nonmenu-event'." (interactive (list last-nonmenu-event) eww-mode) (when (and event (setq event (event-start event))) (goto-char (posn-point event))) diff --git a/lisp/touch-screen.el b/lisp/touch-screen.el index 537780eb708..e44b266a617 100644 --- a/lisp/touch-screen.el +++ b/lisp/touch-screen.el @@ -1360,18 +1360,19 @@ is not read-only." (when command (if (or (memq command touch-screen-set-point-commands) ;; Users of packages that redefine - ;; mouse-set-point, or other commands + ;; `mouse-set-point', or other commands ;; recognized as defining the point, should ;; not find the on screen keyboard - ;; inaccessible even with t-s-d-k enabled. + ;; inaccessible even with + ;; `touch-screen-display-keyboard' enabled. touch-screen-display-keyboard) (if touch-screen-translate-prompt ;; Forgo displaying the virtual keyboard - ;; should touch-screen-translate-prompt be + ;; should `touch-screen-translate-prompt' be ;; set, for then the key won't be delivered ;; to the command loop, but rather to a - ;; caller of read-key-sequence such as - ;; describe-key. + ;; caller of `read-key-sequence' such as + ;; `describe-key'. (throw 'input-event event) (if (and (or (not buffer-read-only) ;; Display the on screen commit 3be382311fa03b9ec9c571b5e5737ff2d51bc2d3 Author: Mattias Engdegård Date: Mon Apr 29 12:35:55 2024 +0200 Declare the variable `rx-constituents` obsolete. It has been effectively obsolete since Emacs 27, when the modern extension mechanism was introduced. * lisp/emacs-lisp/rx.el (rx-constituents): Make obsolete. * test/lisp/emacs-lisp/rx-tests.el (rx-constituents): Suppress warning. * etc/NEWS: Announce. diff --git a/etc/NEWS b/etc/NEWS index 3908c492253..4b0106fcb07 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2615,6 +2615,10 @@ buffer edits. This function helps user to add custom font-lock rules to a tree-sitter major mode. +--- +** The variable 'rx-constituents' is now obsolete. +Use 'rx-define', 'rx-let' and 'rx-let-eval' instead. + * Changes in Emacs 30.1 on Non-Free Operating Systems diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index 246e41cff0b..7113d5a6241 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -149,6 +149,13 @@ If DEF is a list on the form (FUN MIN-ARGS MAX-ARGS PRED), then If PRED is non-nil, it is a predicate that all actual arguments must satisfy.") +(make-obsolete-variable + 'rx-constituents + "use `rx-let', `rx-let-eval', or `rx-define' instead." + ;; Effectively obsolete since Emacs 27 but only formally declared + ;; obsolete in Emacs 30. + "30.1") + (defvar rx--local-definitions nil "Alist of dynamic local rx definitions. Each entry is: diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el index 072209bcbcc..1bb79f72671 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -619,18 +619,19 @@ "[^amz]\\S_")))) (ert-deftest rx-constituents () - (let ((rx-constituents - (append '((beta . gamma) - (gamma . "a*b") - (delta . ((lambda (form) - (regexp-quote (format "<%S>" form))) - 1 nil symbolp)) - (epsilon . delta)) - rx-constituents))) - (should (equal (rx-to-string '(seq (+ beta) nonl gamma) t) - "\\(?:a*b\\)+.\\(?:a*b\\)")) - (should (equal (rx-to-string '(seq (delta a b c) (* (epsilon d e))) t) - "\\(?:<(delta a b c)>\\)\\(?:<(epsilon d e)>\\)*")))) + (with-suppressed-warnings ((obsolete rx-constituents)) + (let ((rx-constituents + (append '((beta . gamma) + (gamma . "a*b") + (delta . ((lambda (form) + (regexp-quote (format "<%S>" form))) + 1 nil symbolp)) + (epsilon . delta)) + rx-constituents))) + (should (equal (rx-to-string '(seq (+ beta) nonl gamma) t) + "\\(?:a*b\\)+.\\(?:a*b\\)")) + (should (equal (rx-to-string '(seq (delta a b c) (* (epsilon d e))) t) + "\\(?:<(delta a b c)>\\)\\(?:<(epsilon d e)>\\)*"))))) (ert-deftest rx-compat () "Test old symbol retained for compatibility (bug#37517)." commit f906ce5543818f2cba08dd2c7b94e4ba566ce64c Author: Mattias Engdegård Date: Mon Apr 29 11:44:48 2024 +0200 ; * doc/lispref/objects.texi (Type Predicates): fix xrefs diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi index cf703aba9c8..ec6ab8204d6 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -2036,7 +2036,7 @@ with references to further information. @xref{Array Functions, arrayp}. @item bignump -@xref{Predicates on Numbers, floatp}. +@xref{Predicates on Numbers, bignump}. @item bool-vector-p @xref{Bool-Vectors, bool-vector-p}. @@ -2078,7 +2078,7 @@ with references to further information. @xref{Variable Definitions, custom-variable-p}. @item fixnump -@xref{Predicates on Numbers, floatp}. +@xref{Predicates on Numbers, fixnump}. @item floatp @xref{Predicates on Numbers, floatp}. commit 495bf22727a0e980c4677ad4acd229e125d69d03 Author: Mattias Engdegård Date: Sun Apr 28 19:42:44 2024 +0200 Add NEWS.unknown file to correct versions of introduction It is not intended for the human reader, but to give less wrong versions of first appearance displayed by `describe-function` or `describe-variable` that would otherwise be derived from a notice in a more recent NEWS* file. It is better to add items to this file than changing historical NEWS* files when the actual version of introduction is not known. * etc/NEWS.unknown: New file. Add entry for `nthcdr`. diff --git a/etc/NEWS.unknown b/etc/NEWS.unknown new file mode 100644 index 00000000000..4a6d68dcae0 --- /dev/null +++ b/etc/NEWS.unknown @@ -0,0 +1,14 @@ +This file contains mentions of functions and variables whose +version of introduction would otherwise be guessed incorrectly +by M-x describe-function. + +Since much of early Emacs source history is lost, these versions are +conservative estimates: the actual version of first appearance may very +well be much earlier. + +* Changes in Emacs 13.8 +This may be the earliest surviving version with source code, although +damaged. See +https://github.com/larsbrinkhoff/emacs-history/decuslib.com/decus/vax85b/gnuemax + +** 'nthcdr' commit 8718a7c7062eb562e2fda0dee5f7bfddb0861f1d Author: Mattias Engdegård Date: Sun Apr 28 18:38:44 2024 +0200 Add `drop` as alias for `nthcdr` It's a common name for this function and symmetric with respect to `take`. It's also a lot less awkward to type and say. * lisp/subr.el (drop): New alias. * doc/lispref/lists.texi (List Elements): Document. Mention the equation tying `take` and `drop` together. * etc/NEWS: Announce. diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi index ca42942250c..dce9115c61b 100644 --- a/doc/lispref/lists.texi +++ b/doc/lispref/lists.texi @@ -317,6 +317,7 @@ For historical reasons, it takes its arguments in the opposite order. @xref{Sequence Functions}. @end defun +@findex drop @defun nthcdr n list This function returns the @var{n}th @sc{cdr} of @var{list}. In other words, it skips past the first @var{n} links of @var{list} and returns @@ -327,6 +328,8 @@ If @var{n} is zero, @code{nthcdr} returns all of @var{list}. If the length of @var{list} is @var{n} or less, @code{nthcdr} returns @code{nil}. +An alias for @code{nthcdr} is @code{drop}. + @example @group (nthcdr 1 '(1 2 3 4)) @@ -350,6 +353,9 @@ it returns the part of @var{list} that @code{nthcdr} skips. @code{take} returns @var{list} if shorter than @var{n} elements; it returns @code{nil} if @var{n} is zero or negative. +In general, @code{(append (take @var{n} @var{list}) (drop @var{n} @var{list}))} +will return a list equal to @var{list}. + @example @group (take 3 '(a b c d)) diff --git a/etc/NEWS b/etc/NEWS index eceecc107fc..3908c492253 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2013,6 +2013,9 @@ precedence over the variable when present. Mostly used internally to do a kind of topological sort of inheritance hierarchies. ++++ +** 'drop' is now an alias for the function 'nthcdr'. + +++ ** New polymorphic comparison function 'value<'. This function returns non-nil if the first argument is less than the diff --git a/lisp/subr.el b/lisp/subr.el index fba70342154..352ecc315ef 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2036,6 +2036,7 @@ instead; it will indirectly limit the specpdl stack size as well.") ;;;; Alternate names for functions - these are not being phased out. +(defalias 'drop #'nthcdr) (defalias 'send-string #'process-send-string) (defalias 'send-region #'process-send-region) (defalias 'string= #'string-equal) commit 9b1e44c7fb5281688488ec077c048e268b716ad2 Author: Mattias Engdegård Date: Sun Apr 28 23:17:48 2024 +0200 Fix value< string comparison ungoodthink * src/fns.c (string_cmp): Fix bad comparisons for certain strings. This only affected `value<` for aggregates, not `string<`. * test/src/fns-tests.el (fns-value<-ordered): Add test cases. diff --git a/src/fns.c b/src/fns.c index e987d64319f..9be42aa8b68 100644 --- a/src/fns.c +++ b/src/fns.c @@ -481,7 +481,7 @@ string_cmp (Lisp_Object string1, Lisp_Object string2) int d = memcmp (SSDATA (string1), SSDATA (string2), n); if (d) return d; - return n < SCHARS (string2) ? -1 : n > SCHARS (string2); + return n < SCHARS (string2) ? -1 : n < SCHARS (string1); } else if (STRING_MULTIBYTE (string1) && STRING_MULTIBYTE (string2)) { @@ -515,7 +515,7 @@ string_cmp (Lisp_Object string1, Lisp_Object string2) if (b >= nb) /* One string is a prefix of the other. */ - return b < nb2 ? -1 : b > nb2; + return b < nb2 ? -1 : b < nb1; /* Now back up to the start of the differing characters: it's the last byte not having the bit pattern 10xxxxxx. */ @@ -540,7 +540,7 @@ string_cmp (Lisp_Object string1, Lisp_Object string2) if (c1 != c2) return c1 < c2 ? -1 : 1; } - return i1 < SCHARS (string2) ? -1 : i1 > SCHARS (string2); + return i1 < SCHARS (string2) ? -1 : i1 < SCHARS (string1); } else { @@ -553,7 +553,7 @@ string_cmp (Lisp_Object string1, Lisp_Object string2) if (c1 != c2) return c1 < c2 ? -1 : 1; } - return i1 < SCHARS (string2) ? -1 : i1 > SCHARS (string2); + return i1 < SCHARS (string2) ? -1 : i1 < SCHARS (string1); } } diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 5ba7e49324a..ca5b10db705 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -1614,6 +1614,12 @@ ;; strings ("" . "a") ("a" . "b") ("A" . "a") ("abc" . "abd") ("b" . "ba") + ;; strings again, but in a context where 3-way comparison + ;; matters + (("" . 2) . ("a" . 1)) + (("å" . 2) . ("åü" . 1)) + (("a" . 2) . ("aå" . 1)) + (("\x80" . 2) . ("\x80å" . 1)) ;; lists ((1 2 3) . (2 3 4)) ((2) . (2 1)) (() . (0)) commit 05215177a61437e864ef771afc99b130866fbcb5 Author: Visuwesh Date: Sun Apr 28 16:45:40 2024 +0530 Fix errors in 'shr-correct-dom-case' * lisp/net/shr.el (shr-correct-dom-case): Don't assume each CHILD is a cons cell. (Bug#70626) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 09df5f5a9bb..14b3f7aa163 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -1510,7 +1510,8 @@ Based on https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-infore (when-let ((rep (assoc-default (car attr) shr-correct-attribute-case))) (setcar attr rep))) (dolist (child (dom-children dom)) - (shr-correct-dom-case child)) + (when (consp child) + (shr-correct-dom-case child))) dom) (defun shr-tag-svg (dom) commit 4c46066cb6b3a9c87fb29be8cbdd4d90312f7020 Author: Po Lu Date: Mon Apr 29 20:01:59 2024 +0800 Adapt eww to touch screens, mice and text conversion * doc/emacs/input.texi (On-Screen Keyboards): Update conditions for displaying the virtual keyboard when t-s-d-k is enabled. * etc/NEWS (Announce): Document changes. * lisp/net/eww.el (eww-check-text-conversion): New function. (eww-mode): Install it as a local post-command-hook. (eww-submit-map, eww-submit-file, eww-checkbox-map): Bind suitable commands to mouse-2. (eww-form-submit, eww-form-checkbox, eww-form-file) (eww-tag-select): Disguise inserted forms as buttons, that touch event translation may prefer their bindings to mouse-2 over mouse-1. (eww-form-text, eww-tag-textarea): Insert field properties as well. (eww-select-file, eww-toggle-checkbox, eww-submit): New argument EVENT, to whose position point is set. * lisp/touch-screen.el (touch-screen-handle-point-up): Trivial adjustments to the criteria for selecting mouse commands and displaying the on screen keyboard. diff --git a/doc/emacs/input.texi b/doc/emacs/input.texi index 96a20a9bc1b..d48c13355b3 100644 --- a/doc/emacs/input.texi +++ b/doc/emacs/input.texi @@ -126,27 +126,26 @@ minibuffer being brought into use (@pxref{Minibuffer}). @vindex touch-screen-set-point-commands When a ``tap'' gesture results in a command being executed, Emacs -checks whether the command is meant to set the point by searching for -it in the list @code{touch-screen-set-point-commands}. If it is and -the text beneath the new point is not read-only, it activates the -virtual keyboard, in anticipation that the user is about to enter text -there. +checks whether the command is meant to set the point by searching for it +in the list @code{touch-screen-set-point-commands}. If it is and the +text beneath the new point is not read-only, the virtual keyboard is +activated, in anticipation of the user entering text there. - The default value of @code{touch-screen-set-point-commands} holds -only the command @code{mouse-set-point} (@pxref{Mouse Commands}), -which is the default binding of @code{mouse-1}, and thus of -touchscreen tap gestures as well. + The default value of @code{touch-screen-set-point-commands} holds only +the command @code{mouse-set-point} (@pxref{Mouse Commands}), which is +the default binding of @code{mouse-1}, and therefore of touchscreen tap +gestures as well. @vindex touch-screen-display-keyboard - The user option @code{touch-screen-display-keyboard} compels Emacs -to display the virtual keyboard on such taps even if the text is read -only; it may also be set buffer locally, in which case Emacs will -always display the keyboard in response to a tap on a window -displaying the buffer it is set in. - - There are moreover several functions to show or hide the on-screen -keyboard. For more details, @xref{On-Screen Keyboards,,, elisp, The -Emacs Lisp Reference Manual}. + The user option @code{touch-screen-display-keyboard} compels Emacs to +display the virtual keyboard on all tap gestures even if the text is +read only; it may also be set buffer locally, in which case Emacs will +always display the keyboard in response to a tap on a window displaying +the buffer it is set in. + + There are moreover several functions that display or hide the +on-screen keyboard. For more details, @xref{On-Screen Keyboards,,, +elisp, The Emacs Lisp Reference Manual}. @cindex quitting, without a keyboard Since it may not be possible for Emacs to display the virtual diff --git a/etc/NEWS b/etc/NEWS index d8bc3c9d725..eceecc107fc 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1120,6 +1120,20 @@ for setting the remote PATH environment variable. ** EWW +--- +*** New mouse bindings in EWW buffers. +Certain form elements that were displayed as buttons, yet could only be +activated by keyboard input, are now operable using 'mouse-2'. With +"Submit" buttons, this triggers submission of the form, while clicks on +other classes of buttons either toggle their values or prompt for user +input, as the case may be. + +--- +*** EWW text input fields and areas are now fields. +In consequence, movement commands and OS input method features now +recognize and confine their activities to the text input field around +point. See also (elisp)Fields. + +++ *** 'eww-open-file' can now display the file in a new buffer. By default, the command reuses the "*eww*" buffer, but if called with @@ -1153,7 +1167,7 @@ This is useful for continuing reading the URL in the current buffer when the new URL is fetched. --- -*** History navigation in EWW now works like other browsers. +*** History navigation in EWW now behaves as in other browsers. Previously, when navigating back and forward through page history, EWW would add a duplicate entry to the end of the history list each time. This made it impossible to navigate to the "end" of the history list. diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 39ea964d47a..4bb491b9970 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -1300,6 +1300,23 @@ This consults the entries in `eww-readable-urls' (which see)." map) "Tool bar for `eww-mode'.") +(declare-function set-text-conversion-style "textconv.c") + +(defun eww-check-text-conversion () + "Check if point is within a field and toggle text conversion. +If `text-conversion-style' is not `action' if point is within the +prompt or `nil' otherwise, set it to such a value, so as to +guarantee that the input method functions properly for the +purpose of typing within the ERC prompt." + (when (and (eq major-mode 'eww-mode) + (fboundp 'set-text-conversion-style)) + (if (eq (car-safe (get-text-property (point) 'field)) + :eww-form) + (unless (eq text-conversion-style 'action) + (set-text-conversion-style 'action)) + (unless (not text-conversion-style) + (set-text-conversion-style nil))))) + ;; Autoload cookie needed by desktop.el. ;;;###autoload (define-derived-mode eww-mode special-mode "eww" @@ -1328,6 +1345,7 @@ This consults the entries in `eww-readable-urls' (which see)." (add-hook 'text-scale-mode-hook #'eww--rescale-images nil t) (setq-local outline-search-function 'shr-outline-search outline-level 'shr-outline-level) + (add-hook 'post-command-hook #'eww-check-text-conversion nil t) (setq buffer-read-only t)) (defvar text-scale-mode) @@ -1487,16 +1505,19 @@ just re-display the HTML already fetched." (defvar-keymap eww-submit-map "RET" #'eww-submit - "C-c C-c" #'eww-submit) + "C-c C-c" #'eww-submit + "" #'eww-submit) (defvar-keymap eww-submit-file "RET" #'eww-select-file - "C-c C-c" #'eww-submit) + "C-c C-c" #'eww-submit + "" #'eww-select-file) (defvar-keymap eww-checkbox-map "SPC" #'eww-toggle-checkbox "RET" #'eww-toggle-checkbox - "C-c C-c" #'eww-submit) + "C-c C-c" #'eww-submit + "" #'eww-toggle-checkbox) (defvar-keymap eww-text-map :full t :parent text-mode-map @@ -1585,6 +1606,8 @@ just re-display the HTML already fetched." :type "submit" :name (dom-attr dom 'name))) (put-text-property start (point) 'keymap eww-submit-map) + ;; Pretend to touch-screen.el that this is a button. + (put-text-property start (point) 'button t) (insert " "))) (defun eww-form-checkbox (dom) @@ -1600,6 +1623,8 @@ just re-display the HTML already fetched." :checked (dom-attr dom 'checked) :name (dom-attr dom 'name))) (put-text-property start (point) 'keymap eww-checkbox-map) + ;; Pretend to touch-screen.el that this is a button. + (put-text-property start (point) 'button t) (insert " "))) (defun eww-form-file (dom) @@ -1618,11 +1643,16 @@ just re-display the HTML already fetched." :type (downcase (dom-attr dom 'type)) :name (dom-attr dom 'name))) (put-text-property start (point) 'keymap eww-submit-file) + ;; Pretend to touch-screen.el that this is a button. + (put-text-property start (point) 'button t) (insert " "))) -(defun eww-select-file () - "Change the value of the upload file menu under point." - (interactive nil eww-mode) +(defun eww-select-file (&optional event) + "Change the value of the upload file menu under point. +EVENT, if non-nil, is the mouse event that preceded this command." + (interactive (list last-nonmenu-event) eww-mode) + (when (and event (setq event (event-start event))) + (goto-char (posn-point event))) (let* ((input (get-text-property (point) 'eww-form))) (let ((filename (let ((insert-default-directory t)) @@ -1638,7 +1668,12 @@ just re-display the HTML already fetched." (readonly-property (if (or (dom-attr dom 'disabled) (dom-attr dom 'readonly)) 'read-only - 'inhibit-read-only))) + 'inhibit-read-only)) + form) + (setq form (list :eww-form eww-form + :value value + :type type + :name (dom-attr dom 'name))) (insert value) (when (< (length value) width) (insert (make-string (- width (length value)) ? ))) @@ -1646,11 +1681,8 @@ just re-display the HTML already fetched." (put-text-property start (point) 'inhibit-read-only t) (put-text-property start (point) 'local-map eww-text-map) (put-text-property start (point) readonly-property t) - (put-text-property start (point) 'eww-form - (list :eww-form eww-form - :value value - :type type - :name (dom-attr dom 'name))) + (put-text-property start (point) 'eww-form form) + (put-text-property start (point) 'field form) (insert " "))) (defconst eww-text-input-types '("text" "password" "textarea" @@ -1721,7 +1753,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (value (or (dom-text dom) "")) (lines (string-to-number (or (dom-attr dom 'rows) "10"))) (width (string-to-number (or (dom-attr dom 'cols) "10"))) - end) + end form) (shr-ensure-newline) (insert value) (shr-ensure-newline) @@ -1741,11 +1773,12 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (put-text-property (line-beginning-position) (point) 'local-map eww-textarea-map) (forward-line 1)) - (put-text-property start (point) 'eww-form - (list :eww-form eww-form - :value value - :type "textarea" - :name (dom-attr dom 'name))) + (setq form (list :eww-form eww-form + :value value + :type "textarea" + :name (dom-attr dom 'name))) + (put-text-property start (point) 'eww-form form) + (put-text-property start (point) 'field form) (put-text-property start (1+ start) 'shr-tab-stop t))) (defun eww-tag-input (dom) @@ -1809,6 +1842,8 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (put-text-property start (point) 'eww-form menu) (add-face-text-property start (point) 'eww-form-select) (put-text-property start (point) 'keymap eww-select-map) + ;; Pretend to touch-screen.el that this is a button. + (put-text-property start (point) 'button t) (unless (= start (point)) (put-text-property start (1+ start) 'help-echo "select field") (put-text-property start (1+ start) 'shr-tab-stop t)) @@ -1867,9 +1902,12 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (set-text-properties start new-end properties)) start)) -(defun eww-toggle-checkbox () - "Toggle the value of the checkbox under point." - (interactive nil eww-mode) +(defun eww-toggle-checkbox (&optional event) + "Toggle the value of the checkbox under point. +EVENT, if non-nil, is the mouse event that preceded this command." + (interactive (list last-nonmenu-event) eww-mode) + (when (and event (setq event (event-start event))) + (goto-char (posn-point event))) (let* ((input (get-text-property (point) 'eww-form)) (type (plist-get input :type))) (if (equal type "checkbox") @@ -1937,9 +1975,12 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (substring value 0 (match-beginning 0)) value))))) -(defun eww-submit () - "Submit the current form." - (interactive nil eww-mode) +(defun eww-submit (&optional event) + "Submit the form under point or EVENT. +EVENT, if non-nil, is the mouse event that preceded this command." + (interactive (list last-nonmenu-event) eww-mode) + (when (and event (setq event (event-start event))) + (goto-char (posn-point event))) (let* ((this-input (get-text-property (point) 'eww-form)) (form (plist-get this-input :eww-form)) values next-submit) diff --git a/lisp/touch-screen.el b/lisp/touch-screen.el index 52a36712c44..537780eb708 100644 --- a/lisp/touch-screen.el +++ b/lisp/touch-screen.el @@ -1339,7 +1339,9 @@ is not read-only." ;; Now simulate a mouse click there. If there is a ;; link or a button, use mouse-2 to push it. (let* ((event (list (if (or (mouse-on-link-p posn) - (and point (button-at point))) + (and point + (get-char-property + point 'button))) 'mouse-2 'mouse-1) posn)) @@ -1356,7 +1358,13 @@ is not read-only." ;; Figure out if the on screen keyboard needs to be ;; displayed. (when command - (if (memq command touch-screen-set-point-commands) + (if (or (memq command touch-screen-set-point-commands) + ;; Users of packages that redefine + ;; mouse-set-point, or other commands + ;; recognized as defining the point, should + ;; not find the on screen keyboard + ;; inaccessible even with t-s-d-k enabled. + touch-screen-display-keyboard) (if touch-screen-translate-prompt ;; Forgo displaying the virtual keyboard ;; should touch-screen-translate-prompt be @@ -1366,6 +1374,12 @@ is not read-only." ;; describe-key. (throw 'input-event event) (if (and (or (not buffer-read-only) + ;; Display the on screen + ;; keyboard even if just the + ;; text under point is not + ;; read-only. + (get-text-property point + 'inhibit-read-only) touch-screen-display-keyboard) ;; Detect the splash screen and ;; avoid displaying the on screen commit 430088c9ccec5fe9be57d267f45acdc87aa3b28e Author: Po Lu Date: Sun Apr 21 21:51:09 2024 +0800 Take fields into account during text conversion * lisp/cus-edit.el (Custom-mode): Enable text conversion, now that fields are correctly treated. * src/alloc.c (mark_frame): Mark f->conversion.field. * src/androidterm.c (android_update_selection): Adjust conversion region and selection position by the field start and end. * src/editfns.c (find_field): Export function. * src/frame.c (make_frame): Clear f->conversion.field. * src/frame.h (struct text_conversion_state) : New field. * src/lisp.h (find_fields, reset_frame_conversion): Export functions. * src/minibuf.c (Fread_from_minibuffer): Reset frame conversion if Voverriding_text_conversion_style is set. * src/textconv.c (textconv_query): Narrow to field. (reset_frame_conversion): New function. (reset_frame_state): Clear conversion field. (really_delete_surrounding_text): Narrow to field. (locate_and_save_position_in_field): New function. (really_request_point_update, really_set_point_and_mark) (complete_edit_check, handle_pending_conversion_events_1) (handle_pending_conversion_events, get_conversion_field) (set_composing_region, textconv_set_point_and_mark, replace_text) (get_extracted_text, get_surrounding_text, report_point_change): Compute, narrow to and offset by the currently active field whenever point is updated or a command is received. (syms_of_textconv): Revise doc strings. * src/textconv.h (get_conversion_field): Export function. diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 8915500a501..1659c285d84 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -5400,6 +5400,7 @@ if that value is non-nil." (setq-local custom--invocation-options nil custom--hidden-state 'hidden) (setq-local revert-buffer-function #'custom--revert-buffer) + (setq-local text-conversion-style 'action) (make-local-variable 'custom-options) (make-local-variable 'custom-local-buffer) (custom--initialize-widget-variables) diff --git a/src/alloc.c b/src/alloc.c index a8dfde56739..47a8e4f4bd2 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -7050,6 +7050,7 @@ mark_frame (struct Lisp_Vector *ptr) mark_object (f->conversion.compose_region_start); mark_object (f->conversion.compose_region_end); mark_object (f->conversion.compose_region_overlay); + mark_object (f->conversion.field); for (tem = f->conversion.actions; tem; tem = tem->next) mark_object (tem->data); diff --git a/src/androidterm.c b/src/androidterm.c index 4549941ee2e..f849f0d9919 100644 --- a/src/androidterm.c +++ b/src/androidterm.c @@ -6265,14 +6265,24 @@ android_update_selection (struct frame *f, struct window *w) jobject extracted; jstring string; bool mark_active; + ptrdiff_t field_start, field_end; + + /* Offset these values by the start offset of the field. */ + get_conversion_field (f, &field_start, &field_end); if (MARKERP (f->conversion.compose_region_start)) { eassert (MARKERP (f->conversion.compose_region_end)); /* Indexing in android starts from 0 instead of 1. */ - start = marker_position (f->conversion.compose_region_start) - 1; - end = marker_position (f->conversion.compose_region_end) - 1; + start = marker_position (f->conversion.compose_region_start); + end = marker_position (f->conversion.compose_region_end); + + /* Offset and detect underflow. */ + start = max (start, field_start) - field_start - 1; + end = min (end, field_end) - field_start - 1; + if (end < 0 || start < 0) + end = start = -1; } else start = -1, end = -1; @@ -6288,24 +6298,27 @@ android_update_selection (struct frame *f, struct window *w) /* Figure out where the point and mark are. If the mark is not active, then point is set to equal mark. */ b = XBUFFER (w->contents); - point = min (w->ephemeral_last_point, + point = min (min (max (w->ephemeral_last_point, + field_start), + field_end) - field_start, TYPE_MAXIMUM (jint)); mark = ((!NILP (BVAR (b, mark_active)) && w->last_mark != -1) - ? min (w->last_mark, TYPE_MAXIMUM (jint)) + ? min (min (max (w->last_mark, field_start), + field_end) - field_start, + TYPE_MAXIMUM (jint)) : point); - /* Send the update. Android doesn't employ a concept of ``point'' - and ``mark''; instead, it only has a selection, where the start - of the selection is less than or equal to the end, and the region - is ``active'' when those two values differ. Also, convert the - indices from 1-based Emacs indices to 0-based Android ones. */ - android_update_ic (FRAME_ANDROID_WINDOW (f), min (point, mark) - 1, - max (point, mark) - 1, start, end); + /* Send the update. Android doesn't employ a concept of "point" and + "mark"; instead, it only has a selection, where the start of the + selection is less than or equal to the end, and the region is + "active" when those two values differ. The indices will have been + converted from 1-based Emacs indices to 0-based Android ones. */ + android_update_ic (FRAME_ANDROID_WINDOW (f), min (point, mark), + max (point, mark), start, end); /* Update the extracted text as well, if the input method has asked - for updates. 1 is - InputConnection.GET_EXTRACTED_TEXT_MONITOR. */ + for updates. 1 is InputConnection.GET_EXTRACTED_TEXT_MONITOR. */ if (FRAME_ANDROID_OUTPUT (f)->extracted_text_flags & 1) { diff --git a/src/editfns.c b/src/editfns.c index 4ccf765bd4b..fbfaaf66644 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -370,7 +370,7 @@ at POSITION. */) Either BEG or END may be 0, in which case the corresponding value is not stored. */ -static void +void find_field (Lisp_Object pos, Lisp_Object merge_at_boundary, Lisp_Object beg_limit, ptrdiff_t *beg, Lisp_Object end_limit, ptrdiff_t *end) diff --git a/src/frame.c b/src/frame.c index ff99b0353af..a671dbaa31d 100644 --- a/src/frame.c +++ b/src/frame.c @@ -1001,6 +1001,7 @@ make_frame (bool mini_p) f->conversion.compose_region_start = Qnil; f->conversion.compose_region_end = Qnil; f->conversion.compose_region_overlay = Qnil; + f->conversion.field = Qnil; f->conversion.batch_edit_count = 0; f->conversion.batch_edit_flags = 0; f->conversion.actions = NULL; diff --git a/src/frame.h b/src/frame.h index e03362361a7..63bcce259af 100644 --- a/src/frame.h +++ b/src/frame.h @@ -126,6 +126,10 @@ struct text_conversion_state /* Overlay representing the composing region. */ Lisp_Object compose_region_overlay; + /* Cons of (START END . WINDOW) holding the field to which text + conversion should be confined, or nil if no such field exists. */ + Lisp_Object field; + /* The number of ongoing ``batch edits'' that are causing point reporting to be delayed. */ int batch_edit_count; diff --git a/src/lisp.h b/src/lisp.h index 526248dd2ba..4487948b007 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4933,6 +4933,8 @@ extern void unmark_main_thread (void); /* Defined in editfns.c. */ extern void insert1 (Lisp_Object); +extern void find_field (Lisp_Object, Lisp_Object, Lisp_Object, + ptrdiff_t *, Lisp_Object, ptrdiff_t *); extern void save_excursion_save (union specbinding *); extern void save_excursion_restore (Lisp_Object, Lisp_Object); extern Lisp_Object save_restriction_save (void); @@ -5496,6 +5498,7 @@ extern char *emacs_root_dir (void); #ifdef HAVE_TEXT_CONVERSION /* Defined in textconv.c. */ extern void reset_frame_state (struct frame *); +extern void reset_frame_conversion (struct frame *); extern void report_selected_window_change (struct frame *); extern void report_point_change (struct frame *, struct window *, struct buffer *); diff --git a/src/minibuf.c b/src/minibuf.c index 51816133fb2..1029fcdb1ba 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -1367,6 +1367,20 @@ and some related functions, which use zero-indexing for POSITION. */) if (NILP (histpos)) XSETFASTINT (histpos, 0); +#ifdef HAVE_TEXT_CONVERSION + /* If overriding-text-conversion-style is set, assume that it was + changed prior to this call and force text conversion to be reset, + since redisplay might conclude that the value was retained + unmodified from a previous call to Fread_from_minibuffer as the + selected window will not have changed. */ + if (!EQ (Voverriding_text_conversion_style, Qlambda) + /* Separate minibuffer frames are not material here, since they + will already be selected if the situation that this is meant to + prevent is possible. */ + && FRAME_WINDOW_P (SELECTED_FRAME ())) + reset_frame_conversion (SELECTED_FRAME ()); +#endif /* HAVE_TEXT_CONVERSION */ + val = read_minibuf (keymap, initial_contents, prompt, !NILP (read), histvar, histpos, default_value, diff --git a/src/textconv.c b/src/textconv.c index 9625c884e16..8850f3cc6be 100644 --- a/src/textconv.c +++ b/src/textconv.c @@ -195,6 +195,15 @@ textconv_query (struct frame *f, struct textconv_callback_struct *query, : f->selected_window), Qt); w = XWINDOW (selected_window); + /* Narrow to the field, if any. */ + if (!NILP (f->conversion.field)) + { + record_unwind_protect (save_restriction_restore, + save_restriction_save ()); + Fnarrow_to_region (XCAR (f->conversion.field), + XCAR (XCDR (f->conversion.field))); + } + /* Now find the appropriate text bounds for QUERY. First, move point QUERY->position steps forward or backwards. */ @@ -488,6 +497,17 @@ record_buffer_change (ptrdiff_t beg, ptrdiff_t end, Vtext_conversion_edits); } +/* Reset text conversion state of frame F, and resume text conversion. + Delete any overlays or markers inside. */ + +void +reset_frame_conversion (struct frame *f) +{ + reset_frame_state (f); + if (text_interface && FRAME_WINDOW_P (f) && FRAME_VISIBLE_P (f)) + text_interface->reset (f); +} + /* Reset text conversion state of frame F. Delete any overlays or markers inside. */ @@ -530,6 +550,15 @@ reset_frame_state (struct frame *f) /* Clear batch edit state. */ f->conversion.batch_edit_count = 0; f->conversion.batch_edit_flags = 0; + + /* Clear active field. */ + if (!NILP (f->conversion.field)) + { + Fset_marker (XCAR (f->conversion.field), Qnil, Qnil); + Fset_marker (XCAR (XCDR (f->conversion.field)), Qnil, + Qnil); + } + f->conversion.field = Qnil; } /* Return whether or not there are pending edits from an input method @@ -1012,6 +1041,15 @@ really_delete_surrounding_text (struct frame *f, ptrdiff_t left, redisplay. */ select_window (f->old_selected_window, Qt); + /* Narrow to the field, if any. */ + if (!NILP (f->conversion.field)) + { + record_unwind_protect (save_restriction_restore, + save_restriction_save ()); + Fnarrow_to_region (XCAR (f->conversion.field), + XCAR (XCDR (f->conversion.field))); + } + /* Figure out where to start deleting from. */ a = get_mark (); @@ -1078,6 +1116,115 @@ really_delete_surrounding_text (struct frame *f, ptrdiff_t left, unbind_to (count, Qnil); } +/* Save the confines of the field surrounding point in w into F's text + conversion state. If NOTIFY_COMPOSE, notify the input method of + changes to the composition region if they arise in this process. */ + +static void +locate_and_save_position_in_field (struct frame *f, struct window *w, + bool notify_compose) +{ + Lisp_Object pos, window, c1, c2; + specpdl_ref count; + ptrdiff_t beg, end, cstart, cend, newstart, newend; + + /* Set the current buffer to W's. */ + count = SPECPDL_INDEX (); + record_unwind_protect (restore_selected_window, selected_window); + XSETWINDOW (window, w); + select_window (window, Qt); + + /* Search for a field around the current editing position; this should + also serve to confine text conversion to the visible region. */ + XSETFASTINT (pos, min (max (w->ephemeral_last_point, BEGV), ZV)); + find_field (pos, Qnil, Qnil, &beg, Qnil, &end); + + /* If beg is 1 and end is ZV, disable the active field entirely. */ + if (beg == 1 && end == ZV) + { + f->conversion.field = Qnil; + goto exit; + } + + /* Don't cons if a pair already exists. */ + if (!NILP (f->conversion.field)) + { + c1 = f->conversion.field; + c2 = XCDR (c1); + Fset_marker (XCAR (c1), make_fixed_natnum (beg), Qnil); + Fset_marker (XCAR (c2), make_fixed_natnum (end), Qnil); + XSETCDR (c2, window); + } + else + { + c1 = build_marker (current_buffer, beg, CHAR_TO_BYTE (beg)); + c2 = build_marker (current_buffer, end, CHAR_TO_BYTE (end)); + Fset_marker_insertion_type (c2, Qt); + f->conversion.field = Fcons (c1, Fcons (c2, window)); + } + + /* If the composition region is active and oversteps the active field, + restrict it to the same. */ + + if (!NILP (f->conversion.compose_region_start)) + { + cstart = marker_position (f->conversion.compose_region_start); + cend = marker_position (f->conversion.compose_region_end); + + if (cend < beg || cstart > end) + { + /* Remove the composition region in whole. */ + /* Make the composition region markers point elsewhere. */ + + if (!NILP (f->conversion.compose_region_start)) + { + Fset_marker (f->conversion.compose_region_start, Qnil, Qnil); + Fset_marker (f->conversion.compose_region_end, Qnil, Qnil); + f->conversion.compose_region_start = Qnil; + f->conversion.compose_region_end = Qnil; + } + + /* Delete the composition region overlay. */ + + if (!NILP (f->conversion.compose_region_overlay)) + Fdelete_overlay (f->conversion.compose_region_overlay); + + TEXTCONV_DEBUG ("removing composing region outside active field"); + } + else + { + newstart = max (beg, min (cstart, end)); + newend = max (beg, min (cend, end)); + + if (newstart != cstart || newend != cend) + { + TEXTCONV_DEBUG ("confined composing region to %td, %td", + newstart, newend); + Fset_marker (f->conversion.compose_region_end, + make_fixed_natnum (newstart), Qnil); + Fset_marker (f->conversion.compose_region_end, + make_fixed_natnum (newend), Qnil); + } + else + notify_compose = false; + } + } + else + notify_compose = false; + + if (notify_compose + && text_interface->compose_region_changed) + { + if (f->conversion.batch_edit_count > 0) + f->conversion.batch_edit_flags |= PENDING_COMPOSE_CHANGE; + else + text_interface->compose_region_changed (f); + } + + exit: + unbind_to (count, Qnil); +} + /* Update the interface with frame F's new point and mark. If a batch edit is in progress, schedule the update for when it finishes instead. */ @@ -1085,6 +1232,8 @@ really_delete_surrounding_text (struct frame *f, ptrdiff_t left, static void really_request_point_update (struct frame *f) { + struct window *w; + /* If F's old selected window is no longer live, fail. */ if (!WINDOW_LIVE_P (f->old_selected_window)) @@ -1093,9 +1242,11 @@ really_request_point_update (struct frame *f) if (f->conversion.batch_edit_count > 0) f->conversion.batch_edit_flags |= PENDING_POINT_CHANGE; else if (text_interface && text_interface->point_changed) - text_interface->point_changed (f, - XWINDOW (f->old_selected_window), - current_buffer); + { + w = XWINDOW (f->old_selected_window); + locate_and_save_position_in_field (f, w, false); + text_interface->point_changed (f, w, current_buffer); + } } /* Set point in frame F's selected window to POSITION. If MARK is not @@ -1130,9 +1281,11 @@ really_set_point_and_mark (struct frame *f, ptrdiff_t point, if (f->conversion.batch_edit_count > 0) f->conversion.batch_edit_flags |= PENDING_POINT_CHANGE; else if (text_interface && text_interface->point_changed) - text_interface->point_changed (f, - XWINDOW (f->old_selected_window), - current_buffer); + { + w = XWINDOW (f->old_selected_window); + locate_and_save_position_in_field (f, w, false); + text_interface->point_changed (f, w, current_buffer); + } } else /* Set the point. */ @@ -1331,7 +1484,10 @@ complete_edit_check (void *ptr) if (f->conversion.batch_edit_count > 0) f->conversion.batch_edit_flags |= PENDING_POINT_CHANGE; else - text_interface->point_changed (f, context->w, NULL); + { + locate_and_save_position_in_field (f, context->w, false); + text_interface->point_changed (f, context->w, NULL); + } } } } @@ -1400,7 +1556,10 @@ handle_pending_conversion_events_1 (struct frame *f, break; if (f->conversion.batch_edit_flags & PENDING_POINT_CHANGE) - text_interface->point_changed (f, w, buffer); + { + locate_and_save_position_in_field (f, w, false); + text_interface->point_changed (f, w, buffer); + } if (f->conversion.batch_edit_flags & PENDING_COMPOSE_CHANGE) text_interface->compose_region_changed (f); @@ -1529,7 +1688,10 @@ handle_pending_conversion_events (void) if (f->conversion.batch_edit_count > 0) f->conversion.batch_edit_flags |= PENDING_POINT_CHANGE; else - text_interface->point_changed (f, NULL, NULL); + { + locate_and_save_position_in_field (f, w, false); + text_interface->point_changed (f, NULL, NULL); + } } last_point = w->ephemeral_last_point; @@ -1564,6 +1726,39 @@ handle_pending_conversion_events (void) unbind_to (count, Qnil); } +/* Return the confines of the field to which editing operations on frame + F should be constrained in *BEG and *END. Should no field be active, + set *END to MOST_POSITIVE_FIXNUM. */ + +void +get_conversion_field (struct frame *f, ptrdiff_t *beg, ptrdiff_t *end) +{ + Lisp_Object c1, c2; + struct window *w; + + if (!NILP (f->conversion.field)) + { + c1 = f->conversion.field; + c2 = XCDR (c1); + + if (!EQ (XCDR (c2), f->old_selected_window)) + { + /* Update this outdated field location. */ + w = XWINDOW (f->old_selected_window); + locate_and_save_position_in_field (f, w, true); + get_conversion_field (f, beg, end); + return; + } + + *beg = marker_position (XCAR (c1)); + *end = marker_position (XCAR (c2)); + return; + } + + *beg = 1; + *end = MOST_POSITIVE_FIXNUM; +} + /* Start a ``batch edit'' in frame F. During a batch edit, point_changed will not be called until the batch edit ends. @@ -1694,7 +1889,8 @@ set_composing_text (struct frame *f, Lisp_Object object, } /* Make the region between START and END the currently active - ``composing region'' on frame F. + ``composing region'' on frame F. Which of START and END is the + larger value is not significant. The ``composing region'' is a region of text in the buffer that is about to undergo editing by the input method. */ @@ -1704,14 +1900,22 @@ set_composing_region (struct frame *f, ptrdiff_t start, ptrdiff_t end, unsigned long counter) { struct text_conversion_action *action, **last; + ptrdiff_t field_start, field_end, temp; + + if (start > end) + { + temp = end; + end = start; + start = temp; + } - start = min (start, MOST_POSITIVE_FIXNUM); - end = min (end, MOST_POSITIVE_FIXNUM); + get_conversion_field (f, &field_start, &field_end); + start = min (start + field_start - 1, MOST_POSITIVE_FIXNUM); + end = max (start, min (end + field_start - 1, field_end)); action = xmalloc (sizeof *action); action->operation = TEXTCONV_SET_COMPOSING_REGION; - action->data = Fcons (make_fixnum (start), - make_fixnum (end)); + action->data = Fcons (make_fixnum (start), make_fixnum (end)); action->next = NULL; action->counter = counter; for (last = &f->conversion.actions; *last; last = &(*last)->next) @@ -1730,8 +1934,13 @@ textconv_set_point_and_mark (struct frame *f, ptrdiff_t point, ptrdiff_t mark, unsigned long counter) { struct text_conversion_action *action, **last; + ptrdiff_t field_start, field_end; - point = min (point, MOST_POSITIVE_FIXNUM); + get_conversion_field (f, &field_start, &field_end); + point = min (max (point + field_start - 1, field_start), + field_end); + mark = min (max (mark + field_start - 1, field_start), + field_end); action = xmalloc (sizeof *action); action->operation = TEXTCONV_SET_POINT_AND_MARK; @@ -1809,10 +2018,11 @@ textconv_barrier (struct frame *f, unsigned long counter) input_pending = true; } -/* Remove the composing region. Replace the text between START and - END within F's selected window with TEXT; deactivate the mark if it - is active. Subsequently, set point to POSITION relative to TEXT, - much as `commit_text' would. */ +/* Remove the composing region. Replace the text between START and END + (whose order, as in `set_composing_region', is not significant) + within F's selected window with TEXT; deactivate the mark if it is + active. Subsequently, set point to POSITION relative to TEXT, as + `commit_text' would. */ void replace_text (struct frame *f, ptrdiff_t start, ptrdiff_t end, @@ -1820,6 +2030,18 @@ replace_text (struct frame *f, ptrdiff_t start, ptrdiff_t end, unsigned long counter) { struct text_conversion_action *action, **last; + ptrdiff_t field_start, field_end, temp; + + if (start > end) + { + temp = end; + end = start; + start = temp; + } + + get_conversion_field (f, &field_start, &field_end); + start = min (start + field_start - 1, MOST_POSITIVE_FIXNUM); + end = max (start, min (end + field_start - 1, field_end)); action = xmalloc (sizeof *action); action->operation = TEXTCONV_REPLACE_TEXT; @@ -1858,6 +2080,7 @@ get_extracted_text (struct frame *f, ptrdiff_t n, specpdl_ref count; ptrdiff_t start, end, start_byte, end_byte, mark; char *buffer; + ptrdiff_t field_start, field_end; if (!WINDOW_LIVE_P (f->old_selected_window)) return NULL; @@ -1907,6 +2130,15 @@ get_extracted_text (struct frame *f, ptrdiff_t n, goto finish; } + /* Narrow to the field, if any. */ + if (!NILP (f->conversion.field)) + { + record_unwind_protect (save_restriction_restore, + save_restriction_save ()); + Fnarrow_to_region (XCAR (f->conversion.field), + XCAR (XCDR (f->conversion.field))); + } + start = max (start, BEGV); end = min (end, ZV); @@ -1935,7 +2167,8 @@ get_extracted_text (struct frame *f, ptrdiff_t n, } /* Return the offsets. */ - *start_return = start; + get_conversion_field (f, &field_start, &field_end); + *start_return = max (1, start - field_start + 1); *start_offset = min (mark - start, PT - start); *end_offset = max (mark - start, PT - start); *length = end - start; @@ -1968,6 +2201,7 @@ get_surrounding_text (struct frame *f, ptrdiff_t left, { specpdl_ref count; ptrdiff_t start, end, start_byte, end_byte, mark, temp; + ptrdiff_t field_start, field_end; char *buffer; if (!WINDOW_LIVE_P (f->old_selected_window)) @@ -2012,6 +2246,15 @@ get_surrounding_text (struct frame *f, ptrdiff_t left, || ckd_add (&end, end, right)) goto finish; + /* Narrow to the field, if any. */ + if (!NILP (f->conversion.field)) + { + record_unwind_protect (save_restriction_restore, + save_restriction_save ()); + Fnarrow_to_region (XCAR (f->conversion.field), + XCAR (XCDR (f->conversion.field))); + } + start = max (start, BEGV); end = min (end, ZV); @@ -2038,7 +2281,8 @@ get_surrounding_text (struct frame *f, ptrdiff_t left, /* Return the offsets. Unlike `get_extracted_text', this need not sort mark and point. */ - *offset = start; + get_conversion_field (f, &field_start, &field_end); + *offset = max (1, start - field_start + 1); *start_return = mark - start; *end_return = PT - start; *length = end - start; @@ -2110,7 +2354,10 @@ report_point_change (struct frame *f, struct window *window, if (f->conversion.batch_edit_count > 0) f->conversion.batch_edit_flags |= PENDING_POINT_CHANGE; else - text_interface->point_changed (f, window, buffer); + { + locate_and_save_position_in_field (f, window, false); + text_interface->point_changed (f, window, buffer); + } } /* Temporarily disable text conversion. Must be paired with a @@ -2348,8 +2595,9 @@ as indenting or automatically filling text, should not take place. Otherwise, it is either a string containing text that was inserted, text deleted before point, or nil if text was deleted after point. -The list contents are ordered in the reverse order of editing, i.e. -the latest edit first, so you must iterate through the list in reverse. */); +The list contents are arranged in the reverse of the order of editing, +i.e. latest edit first, so you must iterate through the list in +reverse. */); Vtext_conversion_edits = Qnil; DEFVAR_LISP ("overriding-text-conversion-style", diff --git a/src/textconv.h b/src/textconv.h index 61f13ebcb43..e87ff5cd1f8 100644 --- a/src/textconv.h +++ b/src/textconv.h @@ -155,6 +155,7 @@ extern char *get_surrounding_text (struct frame *, ptrdiff_t, extern bool conversion_disabled_p (void); extern void check_postponed_buffers (void); +extern void get_conversion_field (struct frame *, ptrdiff_t *, ptrdiff_t *); extern void register_textconv_interface (struct textconv_interface *); #endif /* _TEXTCONV_H_ */ commit ee2e0031d8cc32bb7837ea97ce07ef3b25463223 Author: Po Lu Date: Mon Apr 29 09:21:02 2024 +0800 ; Delete obsolete commentary * java/org/gnu/emacs/EmacsDrawLine.java (perform): Delete obsolete commentary. diff --git a/java/org/gnu/emacs/EmacsDrawLine.java b/java/org/gnu/emacs/EmacsDrawLine.java index a49fe96c26e..c3399b4a75e 100644 --- a/java/org/gnu/emacs/EmacsDrawLine.java +++ b/java/org/gnu/emacs/EmacsDrawLine.java @@ -143,12 +143,6 @@ else if (dy == 0f) if (canvas == null) return; - /* Since drawLine has PostScript style behavior, adjust the - coordinates appropriately. - - The leftmost pixel of a straight line is always partially filled. - Patch it in manually. */ - if (gc.clip_mask == null) { if (gc.line_style != EmacsGC.GC_LINE_ON_OFF_DASH) commit 8cd9ca22362f8646e7717d2a18bcdb86780f423a Author: Po Lu Date: Mon Apr 29 08:49:28 2024 +0800 Fix NEWS entries and documentation for underline styles * doc/lispref/display.texi (Face Attributes): * etc/NEWS: Revise to not mislead users as to where these attributes are available. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 8425aa23422..011738df268 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -2687,12 +2687,14 @@ meaning the foreground color of the face. Omitting the attribute @code{:color} means to use the foreground color of the face. @var{style} is a symbol which sets the line-style to of the underline. It should be one of @code{line}, @code{double-line}, @code{wave}, -@code{dots}, or @code{dashes}. GUI frames only support @code{line} and -@code{wave}. Terminal frames can support all aforementioned underline -styles. Omitting the attribute @code{:style} means to use a straight -line. @var{position}, if non-@code{nil}, means to display the underline -at the descent of the text, instead of at the baseline level. If it is -a number, then it specifies the amount of pixels above the descent to +@code{dots}, or @code{dashes}. GUI frames under most window systems +support all the aforementioned underline styles, while on text terminals +@code{double-line}, @code{wave} and @code{dots} are contingent on the +availability of the @code{Smulx} or @code{Su} terminfo capabilities. +Omitting the attribute @code{:style} means to use a straight line. +@var{position}, if non-@code{nil}, means to display the underline at the +descent of the text, instead of at the baseline level. If it is a +number, then it specifies the amount of pixels above the descent to display the underline. @end table diff --git a/etc/NEWS b/etc/NEWS index 7efb4110bcd..d8bc3c9d725 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -446,21 +446,19 @@ Use 'TAB' in the minibuffer to show or hide the password. Likewise, there is an icon on the mode-line, which toggles the visibility of the password when clicking with 'mouse-1'. -** Terminal Emacs ++++ +** Support for styled underline face attributes. +These are implemented as new values of the 'style' attribute in a face +underline specification, 'double-line', 'dots', and 'dashes', and are +available on GUI systems. If your terminal's termcap or terminfo +database entry defines the 'Su' or 'Smulx' capability, Emacs will also +emit the prescribed escape sequence to render faces with such styles on +TTY frames. --- -*** Support for 'styled' and 'colored' underline face attributes on TTY frames. -If your terminals termcap or terminfo database entry has the 'Su' or -'Smulx' capability defined, Emacs will now emit the prescribed escape -sequence necessary to render faces with styled underlines on TTY -frames. - -Styled underlines are any underlines containing a non-default -underline style or a color other than the foreground-color. -The available underline styles for TTY frames are 'single', -'double-line', 'wave', 'dots, and 'dashes'. These are currently -supported by Kitty, libvte, and st (through the undercurl patch) among -other terminals. +** Support for underline colors on TTY frames. +Colors specified in face underlines will now also be displayed in TTY +frames with the previously mentioned capabilities. * Editing Changes in Emacs 30.1 commit f2bccae22bd47a2e7e0937b78ea06131711b935a Author: Stefan Monnier Date: Mon Mar 11 16:12:26 2024 -0400 Use a dedicated type to represent interpreted-function values Change `function` so that when evaluating #'(lambda ...) we return an object of type `interpreted-function` rather than a list starting with one of `lambda` or `closure`. The new type reuses the existing PVEC_CLOSURE (nee PVEC_COMPILED) tag and tries to align the corresponding elements: - the arglist, the docstring, and the interactive-form go in the same slots as for byte-code functions. - the body of the function goes in the slot used for the bytecode string. - the lexical context goes in the slot used for the constants of bytecoded functions. The first point above means that `help-function-arglist`, `documentation`, and `interactive-form`s don't need to distinguish interpreted and bytecode functions any more. Main benefits of the change: - We can now reliably distinguish a list from a function value. - `cl-defmethod` can dispatch on `interactive-function` and `closure`. Dispatch on `function` also works now for interpreted functions but still won't work for functions represented as lists or as symbols, of course. - Function values are now self-evaluating. That was alrready the case when byte-compiled, but not when interpreted since (eval '(closure ...)) signals a void-function error. That also avoids false-positive warnings about "don't quote your lambdas" when doing things like `(mapcar ',func ...)`. * src/eval.c (Fmake_interpreted_closure): New function. (Ffunction): Use it and change calling convention of `Vinternal_make_interpreted_closure_function`. (FUNCTIONP, Fcommandp, eval_sub, funcall_general, funcall_lambda) (Ffunc_arity, lambda_arity): Simplify. (funcall_lambda): Adjust to new representation. (syms_of_eval): `defsubr` the new function. Remove definition of `Qclosure`. * lisp/emacs-lisp/cconv.el (cconv-make-interpreted-closure): Change calling convention and use `make-interpreted-closure`. * src/data.c (Fcl_type_of): Distinguish `byte-code-function`s from `interpreted-function`s. (Fclosurep, finterpreted_function_p): New functions. (Fbyte_code_function_p): Don't be confused by `interpreted-function`s. (Finteractive_form, Fcommand_modes): Simplify. (syms_of_data): Define new type symbols and `defsubr` the two new functions. * lisp/emacs-lisp/cl-print.el (cl-print-object) : New method. * lisp/emacs-lisp/oclosure.el (oclosure): Refine the parent to be `closure`. (oclosure--fix-type, oclosure-type): Simplify. (oclosure--copy, oclosure--get, oclosure--set): Adjust to new representation. * src/callint.c (Fcall_interactively): Adjust to new representation. * src/lread.c (bytecode_from_rev_list): * lisp/simple.el (function-documentation): * lisp/help.el (help-function-arglist): Remove the old `closure` case and adjust the byte-code case so it handles `interpreted-function`s. * lisp/emacs-lisp/cl-preloaded.el (closure): New type. (byte-code-function): Add it as a parent. (interpreted-function): Adjust parent (the type itself was already added earlier by accident). * lisp/emacs-lisp/bytecomp.el (byte-compile--reify-function): Adjust to new representation. (byte-compile): Use `interpreted-function-p`. * lisp/emacs-lisp/byte-opt.el (byte-compile-inline-expand): Adjust to new representation. (side-effect-free-fns): Add `interpreted-function-p` and `closurep`. * src/profiler.c (trace_hash, ffunction_equal): Simplify. * lisp/profiler.el (profiler-function-equal): Simplify. * lisp/emacs-lisp/nadvice.el (advice--interactive-form-1): Use `interpreted-function-p`; adjust to new representation; and take advantage of the fact that function values are now self-evaluating. * lisp/emacs-lisp/lisp-mode.el (closure): Remove `lisp-indent-function` property. * lisp/emacs-lisp/disass.el (disassemble-internal): Adjust to new representation. * lisp/emacs-lisp/edebug.el (edebug--strip-instrumentation): Use `interpreted-function-p`. * lisp/emacs-lisp/comp-common.el (comp-known-type-specifiers): Add `closurep` and `interpreted-function-p`. * test/lisp/help-fns-tests.el (help-fns-test-lisp-defun): Adjust to more precise type info in `describe-function`. * test/lisp/erc/resources/erc-d/erc-d-tests.el (erc-d--render-entries): Use `interpreted-function-p`. * test/lisp/emacs-lisp/macroexp-resources/vk.el (vk-f4, vk-f5): Don't hardcode function values. * doc/lispref/functions.texi (Anonymous Functions): Don't suggest that function values are lists. Reword "self-quoting" to reflect the fact that #' doesn't return the exact same object. Update examples with the new shape of the return value. * doc/lispref/variables.texi (Lexical Binding): * doc/lispref/lists.texi (Rearrangement): * doc/lispref/control.texi (Handling Errors): Update examples to reflect new representation of function values. diff --git a/doc/lispref/compile.texi b/doc/lispref/compile.texi index 08e824d2781..19451f31740 100644 --- a/doc/lispref/compile.texi +++ b/doc/lispref/compile.texi @@ -37,7 +37,7 @@ variable binding for @code{no-byte-compile} into it, like this: * Docs and Compilation:: Dynamic loading of documentation strings. * Eval During Compile:: Code to be evaluated when you compile. * Compiler Errors:: Handling compiler error messages. -* Byte-Code Objects:: The data type used for byte-compiled functions. +* Closure Objects:: The data type used for byte-compiled functions. * Disassembly:: Disassembling byte-code; how to read byte-code. @end menu @@ -120,7 +120,7 @@ replacing the previous definition with the compiled one. The function definition of @var{symbol} must be the actual code for the function; @code{byte-compile} does not handle function indirection. The return value is the byte-code function object which is the compiled -definition of @var{symbol} (@pxref{Byte-Code Objects}). +definition of @var{symbol} (@pxref{Closure Objects}). @example @group @@ -487,21 +487,22 @@ string for details. using @code{error}. If so, set @code{byte-compile-error-on-warn} to a non-@code{nil} value. -@node Byte-Code Objects -@section Byte-Code Function Objects +@node Closure Objects +@section Closure Function Objects @cindex compiled function @cindex byte-code function @cindex byte-code object - Byte-compiled functions have a special data type: they are -@dfn{byte-code function objects}. Whenever such an object appears as -a function to be called, Emacs uses the byte-code interpreter to -execute the byte-code. + Byte-compiled functions use a special data type: they are closures. +Closures are used both for byte-compiled Lisp functions as well as for +interpreted Lisp functions. Whenever such an object appears as +a function to be called, Emacs uses the appropriate interpreter to +execute either the byte-code or the non-compiled Lisp code. - Internally, a byte-code function object is much like a vector; its + Internally, a closure is much like a vector; its elements can be accessed using @code{aref}. Its printed representation is like that for a vector, with an additional @samp{#} -before the opening @samp{[}. It must have at least four elements; +before the opening @samp{[}. It must have at least three elements; there is no maximum number, but only the first six elements have any normal use. They are: @@ -515,20 +516,28 @@ zero to 6, and the maximum number of arguments in bits 8 to 14. If the argument list uses @code{&rest}, then bit 7 is set; otherwise it's cleared. -If @var{argdesc} is a list, the arguments will be dynamically bound +When the closure is a byte-code function, +if @var{argdesc} is a list, the arguments will be dynamically bound before executing the byte code. If @var{argdesc} is an integer, the arguments will be instead pushed onto the stack of the byte-code interpreter, before executing the code. -@item byte-code -The string containing the byte-code instructions. +@item code +For interpreted functions, this element is the (non-empty) list of Lisp +forms that make up the function's body. For byte-compiled functions, it +is the string containing the byte-code instructions. @item constants -The vector of Lisp objects referenced by the byte code. These include -symbols used as function names and variable names. +For byte-compiled functions, this holds the vector of Lisp objects +referenced by the byte code. These include symbols used as function +names and variable names. +For interpreted functions, this is @code{nil} if the function is using the old +dynamically scoped dialect of Emacs Lisp, and otherwise it holds the +function's lexical environment. @item stacksize -The maximum stack size this function needs. +The maximum stack size this function needs. This element is left unused +for interpreted functions. @item docstring The documentation string (if any); otherwise, @code{nil}. The value may @@ -558,8 +567,8 @@ representation. It is the definition of the command @code{make-byte-code}: @defun make-byte-code &rest elements -This function constructs and returns a byte-code function object -with @var{elements} as its elements. +This function constructs and returns a closure which represents the +byte-code function object with @var{elements} as its elements. @end defun You should not try to come up with the elements for a byte-code @@ -567,6 +576,20 @@ function yourself, because if they are inconsistent, Emacs may crash when you call the function. Always leave it to the byte compiler to create these objects; it makes the elements consistent (we hope). +The primitive way to create an interpreted function is with +@code{make-interpreted-closure}: + +@defun make-interpreted-closure args body env &optional docstring iform +This function constructs and returns a closure representing the +interpreted function with arguments @var{args} and whose body is made of +@var{body} which must be a non-@code{nil} list of Lisp forms. @var{env} is the +lexical environment in the same form as used with @code{eval} +(@pxref{Eval}). The documentation @var{docstring} if non-@code{nil} should be +a string, and the interactive form @var{iform} if non-@code{nil} should be of +the form @w{@code{(interactive @var{arg-descriptor})}} (@pxref{Using +Interactive}). +@end defun + @node Disassembly @section Disassembled Byte-Code @cindex disassembled byte-code @@ -595,7 +618,7 @@ name of an existing buffer. Then the output goes there, at point, and point is left before the output. The argument @var{object} can be a function name, a lambda expression -(@pxref{Lambda Expressions}), or a byte-code object (@pxref{Byte-Code +(@pxref{Lambda Expressions}), or a byte-code object (@pxref{Closure Objects}). If it is a lambda expression, @code{disassemble} compiles it and disassembles the resulting compiled code. @end deffn diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index 06bf51d8072..8b74b7cec5b 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -2412,7 +2412,7 @@ point where we signaled the original error: @group Debugger entered--Lisp error: (error "Oops") signal(error ("Oops")) - (closure (t) (err) (signal 'error (cdr err)))((user-error "Oops")) + #f(lambda (err) [t] (signal 'error (cdr err)))((user-error "Oops")) user-error("Oops") @dots{} eval((handler-bind ((user-error (lambda (err) @dots{} diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index ec93a0b9c8a..339272d1f05 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -323,7 +323,7 @@ Programming Types * Macro Type:: A method of expanding an expression into another expression, more fundamental but less pretty. * Primitive Function Type:: A function written in C, callable from Lisp. -* Byte-Code Type:: A function written in Lisp, then compiled. +* Closure Type:: A function written in Lisp, then compiled. * Record Type:: Compound objects with programmer-defined types. * Type Descriptors:: Objects holding information about types. * Autoload Type:: A type used for automatically loading seldom-used @@ -657,7 +657,7 @@ Byte Compilation * Docs and Compilation:: Dynamic loading of documentation strings. * Eval During Compile:: Code to be evaluated when you compile. * Compiler Errors:: Handling compiler error messages. -* Byte-Code Objects:: The data type used for byte-compiled functions. +* Closure Objects:: The data type used for byte-compiled functions. * Disassembly:: Disassembling byte-code; how to read byte-code. Native Compilation diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index ff635fc54b2..c57de08460f 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -130,7 +130,7 @@ it also encloses an environment of lexical variable bindings. @item byte-code function A function that has been compiled by the byte compiler. -@xref{Byte-Code Type}. +@xref{Closure Type}. @item autoload object @cindex autoload object @@ -227,6 +227,16 @@ Compilation}), or natively-compiled (@pxref{Native Compilation}), or a function loaded from a dynamic module (@pxref{Dynamic Modules}). @end defun +@defun interpreted-function-p object +This function returns @code{t} if @var{object} is an interpreted function. +@end defun + +@defun closurep object +This function returns @code{t} if @var{object} is a closure, which is +a particular kind of function object. Currently closures are used +for all byte-code functions and all interpreted functions. +@end defun + @defun subr-arity subr This works like @code{func-arity}, but only for built-in functions and without symbol indirection. It signals an error for non-built-in @@ -1136,8 +1146,7 @@ Functions}). @xref{describe-symbols example}, for a realistic example of this. When defining a lambda expression that is to be used as an anonymous -function, you can in principle use any method to construct the list. -But typically you should use the @code{lambda} macro, or the +function, you should use the @code{lambda} macro, or the @code{function} special form, or the @code{#'} read syntax: @defmac lambda args [doc] [interactive] body@dots{} @@ -1145,17 +1154,18 @@ This macro returns an anonymous function with argument list @var{args}, documentation string @var{doc} (if any), interactive spec @var{interactive} (if any), and body forms given by @var{body}. -Under dynamic binding, this macro effectively makes @code{lambda} -forms self-quoting: evaluating a form whose @sc{car} is @code{lambda} -yields the form itself: +For example, this macro makes @code{lambda} forms almost self-quoting: +evaluating a form whose @sc{car} is @code{lambda} yields a value that is +almost like the form itself: @example (lambda (x) (* x x)) - @result{} (lambda (x) (* x x)) + @result{} #f(lambda (x) :dynbind (* x x)) @end example -Note that when evaluating under lexical binding the result is a -closure object (@pxref{Closures}). +When evaluating under lexical binding the result is a similar +closure object, where the @code{:dynbind} marker is replaced by the +captured variables (@pxref{Closures}). The @code{lambda} form has one other effect: it tells the Emacs evaluator and byte-compiler that its argument is a function, by using @@ -1164,8 +1174,8 @@ evaluator and byte-compiler that its argument is a function, by using @defspec function function-object @cindex function quoting -This special form returns @var{function-object} without evaluating it. -In this, it is similar to @code{quote} (@pxref{Quoting}). But unlike +This special form returns the function value of the @var{function-object}. +In many ways, it is similar to @code{quote} (@pxref{Quoting}). But unlike @code{quote}, it also serves as a note to the Emacs evaluator and byte-compiler that @var{function-object} is intended to be used as a function. Assuming @var{function-object} is a valid lambda @@ -1495,7 +1505,7 @@ distinguish between a function cell that is void and one set to @group (defun bar (n) (+ n 2)) (symbol-function 'bar) - @result{} (lambda (n) (+ n 2)) + @result{} #f(lambda (n) [t] (+ n 2)) @end group @group (fset 'baz 'bar) @@ -1608,7 +1618,7 @@ argument list and body forms as the remaining elements: @example ;; @r{lexical binding is enabled.} (lambda (x) (* x x)) - @result{} (closure (t) (x) (* x x)) + @result{} #f(lambda (x) [t] (* x x)) @end example @noindent diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi index 14862bdfc2a..ca42942250c 100644 --- a/doc/lispref/lists.texi +++ b/doc/lispref/lists.texi @@ -1249,7 +1249,7 @@ this is not guaranteed to happen): @group (symbol-function 'add-foo) - @result{} (lambda (x) (nconc '(foo) x)) + @result{} #f(lambda (x) [t] (nconc '(foo) x)) @end group @group @@ -1267,7 +1267,7 @@ this is not guaranteed to happen): @group (symbol-function 'add-foo) - @result{} (lambda (x) (nconc '(foo 1 2 3 4) x)) + @result{} #f(lambda (x) [t] (nconc '(foo 1 2 3 4) x)) @end group @end smallexample @end defun diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi index aa1e073042f..cf703aba9c8 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -244,7 +244,7 @@ latter are unique to Emacs Lisp. * Macro Type:: A method of expanding an expression into another expression, more fundamental but less pretty. * Primitive Function Type:: A function written in C, callable from Lisp. -* Byte-Code Type:: A function written in Lisp, then compiled. +* Closure Type:: A function written in Lisp. * Record Type:: Compound objects with programmer-defined types. * Type Descriptors:: Objects holding information about types. * Autoload Type:: A type used for automatically loading seldom-used @@ -1458,18 +1458,24 @@ with the name of the subroutine. @end group @end example -@node Byte-Code Type -@subsection Byte-Code Function Type +@node Closure Type +@subsection Closure Function Type -@dfn{Byte-code function objects} are produced by byte-compiling Lisp -code (@pxref{Byte Compilation}). Internally, a byte-code function -object is much like a vector; however, the evaluator handles this data -type specially when it appears in a function call. @xref{Byte-Code -Objects}. +@dfn{Closures} are function objects produced when turning a function +definition into a function value. Closures are used both for +byte-compiled Lisp functions as well as for interpreted Lisp functions. +Closures can be produced by byte-compiling Lisp code (@pxref{Byte +Compilation}) or simply by evaluating a lambda expression without +compiling it, resulting in an interpreted function. Internally, +a closure is much like a vector; however, the evaluator +handles this data type specially when it appears in a function call. +@xref{Closure Objects}. The printed representation and read syntax for a byte-code function object is like that for a vector, with an additional @samp{#} before the -opening @samp{[}. +opening @samp{[}. When printed for human consumption, it is printed as +a special kind of list with an additional @samp{#f} before the opening +@samp{(}. @node Record Type @subsection Record Type @@ -2042,10 +2048,7 @@ with references to further information. @xref{Buffer Basics, bufferp}. @item byte-code-function-p -@xref{Byte-Code Type, byte-code-function-p}. - -@item compiled-function-p -@xref{Byte-Code Type, compiled-function-p}. +@xref{Closure Type, byte-code-function-p}. @item case-table-p @xref{Case Tables, case-table-p}. @@ -2056,9 +2059,15 @@ with references to further information. @item char-table-p @xref{Char-Tables, char-table-p}. +@item closurep +@xref{What Is a Function, closurep}. + @item commandp @xref{Interactive Call, commandp}. +@item compiled-function-p +@xref{Closure Type, compiled-function-p}. + @item condition-variable-p @xref{Condition Variables, condition-variable-p}. @@ -2098,6 +2107,9 @@ with references to further information. @item integerp @xref{Predicates on Numbers, integerp}. +@item interpreted-function-p +@xref{What Is a Function, interpreted-function-p}. + @item keymapp @xref{Creating Keymaps, keymapp}. diff --git a/doc/lispref/sequences.texi b/doc/lispref/sequences.texi index c9e47624878..4c5525f10c5 100644 --- a/doc/lispref/sequences.texi +++ b/doc/lispref/sequences.texi @@ -1583,7 +1583,7 @@ nonempty vector that is not @code{eq} to any existing vector. The @code{vconcat} function also allows byte-code function objects as arguments. This is a special feature to make it easy to access the entire -contents of a byte-code function object. @xref{Byte-Code Objects}. +contents of a byte-code function object. @xref{Closure Objects}. For other concatenation functions, see @code{mapconcat} in @ref{Mapping Functions}, @code{concat} in @ref{Creating Strings}, and @code{append} diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index 4d61d461deb..16b6b52e5f1 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -1079,7 +1079,7 @@ Here is an example: (let ((x 0)) ; @r{@code{x} is lexically bound.} (setq my-ticker (lambda () (setq x (1+ x))))) - @result{} (closure ((x . 0)) () + @result{} #f(lambda () [(x 0)] (setq x (1+ x))) (funcall my-ticker) diff --git a/etc/NEWS b/etc/NEWS index 9c356e64bde..7efb4110bcd 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1767,6 +1767,23 @@ documentation and examples. * Incompatible Lisp Changes in Emacs 30.1 ++++ +** Evaluating a 'lambda' returns an object of type 'interpreted-function'. +Instead of representing interpreted functions as lists that start with +either 'lambda' or 'closure', Emacs now represents them as objects +of their own 'interpreted-function' type, which is very similar +to 'byte-code-function' objects (the argument list, docstring, and +interactive forms are placed in the same slots). +Lists that start with 'lambda' are now used only for non-evaluated +functions (in other words, for source code), but for backward compatibility +reasons, 'functionp' still recognizes them as functions and you can +still call them as before. +Thus code that attempts to "dig" into the internal structure of an +interpreted function's object with the likes of 'car' or 'cdr' will +no longer work and will need to use 'aref' instead to extract its +various subparts (when 'interactive-form', 'documentation', and +'help-function-arglist' aren't adequate). + +++ ** 'define-globalized-minor-mode' requires that modes use 'run-mode-hooks'. Minor modes defined with 'define-globalized-minor-mode', such as @@ -1906,6 +1923,14 @@ unibyte string. * Lisp Changes in Emacs 30.1 +** New types 'closure' and 'interpreted-function'. +'interpreted-function' is the new type used for interpreted functions, +and 'closure' is the common parent type of 'interpreted-function' +and 'byte-code-function'. +Those new types come with the associated new predicates +'closurep' and `interpreted-function-p' as well as a new constructor +'make-interpreted-closure'. + ** New function 'help-fns-function-name'. For named functions, it just returns the name and otherwise it returns a short "unique" string that identifies the function. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index ea163723a3e..3d6b35422b8 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -164,7 +164,7 @@ Earlier variables shadow later ones with the same name.") ;; The byte-code will be really inlined in byte-compile-unfold-bcf. (byte-compile--check-arity-bytecode form fn) `(,fn ,@(cdr form))) - ((or `(lambda . ,_) `(closure . ,_)) + ((pred interpreted-function-p) ;; While byte-compile-unfold-bcf can inline dynbind byte-code into ;; letbind byte-code (or any other combination for that matter), we ;; can only inline dynbind source into dynbind source or lexbind @@ -1870,6 +1870,7 @@ See Info node `(elisp) Integer Basics'." charsetp ;; data.c arrayp atom bare-symbol-p bool-vector-p bufferp byte-code-function-p + interpreted-function-p closurep byteorder car-safe cdr-safe char-or-string-p char-table-p condition-variable-p consp eq floatp indirect-function integer-or-marker-p integerp keywordp listp markerp diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 2704378fc84..7aae87c50dc 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2915,9 +2915,14 @@ otherwise, print without quoting." (defun byte-compile--reify-function (fun) "Return an expression which will evaluate to a function value FUN. FUN should be an interpreted closure." - (pcase-let* ((`(closure ,env ,args . ,body) fun) - (`(,preamble . ,body) (macroexp-parse-body body)) - (renv ())) + (let* ((args (aref fun 0)) + (body (aref fun 1)) + (env (aref fun 2)) + (docstring (function-documentation fun)) + (iform (interactive-form fun)) + (preamble `(,@(if docstring (list docstring)) + ,@(if iform (list iform)))) + (renv ())) ;; Turn the function's closed vars (if any) into local let bindings. (dolist (binding env) (cond @@ -2954,11 +2959,11 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if (symbolp form) form "provided")) fun) (t - (when (or (symbolp form) (eq (car-safe fun) 'closure)) + (when (or (symbolp form) (interpreted-function-p fun)) ;; `fun' is a function *value*, so try to recover its ;; corresponding source code. - (when (setq lexical-binding (eq (car-safe fun) 'closure)) - (setq fun (byte-compile--reify-function fun))) + (setq lexical-binding (not (null (aref fun 2)))) + (setq fun (byte-compile--reify-function fun)) (setq need-a-value t)) ;; Expand macros. (setq fun (byte-compile-preprocess fun)) @@ -5148,7 +5153,6 @@ binding slots have been popped." ;; `arglist' is the list of arguments (or t if not recognized). ;; `body' is the body of `lam' (or t if not recognized). ((or `(lambda ,arglist . ,body) - ;; `(closure ,_ ,arglist . ,body) (and `(internal-make-closure ,arglist . ,_) (let body t)) (and (let arglist t) (let body t))) lam)) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 4ff47971351..e6a78f07762 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -902,7 +902,7 @@ lexically and dynamically bound symbols actually used by FORM." (delete-dups cconv--dynbindings))))) (cons fvs dyns))))) -(defun cconv-make-interpreted-closure (fun env) +(defun cconv-make-interpreted-closure (args body env docstring iform) "Make a closure for the interpreter. This is intended to be called at runtime by the ELisp interpreter (when the code has not been compiled). @@ -911,22 +911,27 @@ ENV is the runtime representation of the lexical environment, i.e. a list whose elements can be either plain symbols (which indicate that this symbol should use dynamic scoping) or pairs (SYMBOL . VALUE) for the lexical bindings." - (cl-assert (eq (car-safe fun) 'lambda)) + (cl-assert (consp body)) + (cl-assert (listp args)) (let ((lexvars (delq nil (mapcar #'car-safe env)))) - (if (or (null lexvars) - ;; Functions with a `:closure-dont-trim-context' marker - ;; should keep their whole context untrimmed (bug#59213). - (and (eq :closure-dont-trim-context (nth 2 fun)) - ;; Check the function doesn't just return the magic keyword. - (nthcdr 3 fun))) + (if (or + ;; Functions with a `:closure-dont-trim-context' marker + ;; should keep their whole context untrimmed (bug#59213). + (and (eq :closure-dont-trim-context (car body)) + ;; Check the function doesn't just return the magic keyword. + (cdr body) + ;; Drop the magic marker from the closure. + (setq body (cdr body))) + ;; There's no var to capture, so skip the analysis. + (null lexvars)) ;; The lexical environment is empty, or needs to be preserved, ;; so there's no need to look for free variables. - ;; Attempting to replace ,(cdr fun) by a macroexpanded version - ;; causes bootstrap to fail. - `(closure ,env . ,(cdr fun)) + ;; Attempting to replace body by a macroexpanded version + ;; caused bootstrap to fail. + (make-interpreted-closure args body env docstring iform) ;; We could try and cache the result of the macroexpansion and ;; `cconv-fv' analysis. Not sure it's worth the trouble. - (let* ((form `#',fun) + (let* ((form `#'(lambda ,args ,iform . ,body)) (expanded-form (let ((lexical-binding t) ;; Tell macros which dialect is in use. ;; Make the macro aware of any defvar declarations in scope. @@ -935,10 +940,10 @@ for the lexical bindings." (append env macroexp--dynvars) env))) (macroexpand-all form macroexpand-all-environment))) ;; Since we macroexpanded the body, we may as well use that. - (expanded-fun-cdr + (expanded-fun-body (pcase expanded-form - (`#'(lambda . ,cdr) cdr) - (_ (cdr fun)))) + (`#'(lambda ,_args ,_iform . ,newbody) newbody) + (_ body))) (dynvars (delq nil (mapcar (lambda (b) (if (symbolp b) b)) env))) (fvs (cconv-fv expanded-form lexvars dynvars)) @@ -946,7 +951,8 @@ for the lexical bindings." (cdr fvs)))) ;; Never return a nil env, since nil means to use the dynbind ;; dialect of ELisp. - `(closure ,(or newenv '(t)) . ,expanded-fun-cdr))))) + (make-interpreted-closure args expanded-fun-body (or newenv '(t)) + docstring iform))))) (provide 'cconv) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 83d9e6ee220..fa745396b02 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -444,13 +444,24 @@ For this build of Emacs it's %dbit." ) (cl--define-built-in-type compiled-function (function) "Abstract type of functions that have been compiled.") -(cl--define-built-in-type byte-code-function (compiled-function) +(cl--define-built-in-type closure (function) + "Abstract type of functions represented by a vector-like object. +You can access the object's internals with `aref'. +The fields are used as follows: + + 0 [args] Argument list (either a list or an integer) + 1 [code] Either a byte-code string or a list of Lisp forms + 2 [constants] Either vector of constants or a lexical environment + 3 [stackdepth] Maximum amount of stack depth used by the byte-code + 4 [docstring] The documentation, or a reference to it + 5 [iform] The interactive form (if present)") +(cl--define-built-in-type byte-code-function (compiled-function closure) "Type of functions that have been byte-compiled.") (cl--define-built-in-type subr (atom) "Abstract type of functions compiled to machine code.") (cl--define-built-in-type module-function (function) "Type of functions provided via the module API.") -(cl--define-built-in-type interpreted-function (function) +(cl--define-built-in-type interpreted-function (closure) "Type of functions that have not been compiled.") (cl--define-built-in-type special-form (subr) "Type of the core syntactic elements of the Emacs Lisp language.") diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 39688661eb1..e8e6502e66f 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -237,6 +237,38 @@ into a button whose action shows the function's disassembly.") 'byte-code-function object))))) (princ ")" stream))) +(cl-defmethod cl-print-object ((object interpreted-function) stream) + (unless stream (setq stream standard-output)) + (princ "#f(lambda " stream) + (let ((args (help-function-arglist object 'preserve-names))) + ;; It's tempting to print the arglist from the "usage" info in the + ;; doc (e.g. for `&key` args), but that only makes sense if we + ;; *don't* print the body, since otherwise the body will tend to + ;; refer to args that don't appear in the arglist. + (if args + (prin1 args stream) + (princ "()" stream))) + (let ((env (aref object 2))) + (if (null env) + (princ " :dynbind" stream) + (princ " " stream) + (cl-print-object + (vconcat (mapcar (lambda (x) (if (consp x) (list (car x) (cdr x)) x)) + env)) + stream))) + (let* ((doc (documentation object 'raw))) + (when doc + (princ " " stream) + (prin1 doc stream))) + (let ((inter (interactive-form object))) + (when inter + (princ " " stream) + (cl-print-object inter stream))) + (dolist (exp (aref object 1)) + (princ " " stream) + (cl-print-object exp stream)) + (princ ")" stream)) + ;; This belongs in oclosure.el, of course, but some load-ordering issues make it ;; complicated. (cl-defmethod cl-print-object ((object accessor) stream) diff --git a/lisp/emacs-lisp/comp-common.el b/lisp/emacs-lisp/comp-common.el index 4edfe811586..62fd28f772e 100644 --- a/lisp/emacs-lisp/comp-common.el +++ b/lisp/emacs-lisp/comp-common.el @@ -118,7 +118,9 @@ Used to modify the compiler environment." (buffer-substring (function ((or integer marker) (or integer marker)) string)) (bufferp (function (t) boolean)) + (closurep (function (t) boolean)) (byte-code-function-p (function (t) boolean)) + (interpreted-function-p (function (t) boolean)) (capitalize (function ((or integer string)) (or integer string))) (car (function (list) t)) (car-less-than-car (function (list list) boolean)) diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 850cc2085f7..15caee9b29c 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -129,7 +129,7 @@ redefine OBJECT if it is a symbol." (setq args (help-function-arglist obj)) ;save arg list (setq obj (cdr obj)) ;throw lambda away (setq obj (cdr obj))) - ((byte-code-function-p obj) + ((closurep obj) (setq args (help-function-arglist obj))) (t (error "Compilation failed"))) (if (zerop indent) ; not a nested function @@ -178,7 +178,9 @@ redefine OBJECT if it is a symbol." (t (insert "Uncompiled body: ") (let ((print-escape-newlines t)) - (prin1 (macroexp-progn obj) + (prin1 (macroexp-progn (if (interpreted-function-p obj) + (aref obj 1) + obj)) (current-buffer)))))) (if interactive-p (message ""))) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index b27ffbca908..3414bb592c0 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -4254,7 +4254,7 @@ code location is known." ((pred edebug--symbol-prefixed-p) nil) (_ (when (and skip-next-lambda - (not (memq (car-safe fun) '(closure lambda)))) + (not (interpreted-function-p fun))) (warn "Edebug--strip-instrumentation expected an interpreted function:\n%S" fun)) (unless skip-next-lambda (edebug--unwrap-frame new-frame) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 3475d944337..601cc7bf712 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -1347,7 +1347,6 @@ Lisp function does not specify a special indentation." (put 'condition-case 'lisp-indent-function 2) (put 'handler-case 'lisp-indent-function 1) ;CL (put 'unwind-protect 'lisp-indent-function 1) -(put 'closure 'lisp-indent-function 2) (defun indent-sexp (&optional endpos) "Indent each line of the list starting just after point. diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 5326c520601..36df143a82a 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -185,7 +185,7 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") (defun advice--interactive-form-1 (function) "Like `interactive-form' but preserves the static context if needed." (let ((if (interactive-form function))) - (if (or (null if) (not (eq 'closure (car-safe function)))) + (if (not (and if (interpreted-function-p function))) if (cl-assert (eq 'interactive (car if))) (let ((form (cadr if))) @@ -193,14 +193,14 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") if ;; The interactive is expected to be run in the static context ;; that the function captured. - (let ((ctx (nth 1 function))) + (let ((ctx (aref function 2))) `(interactive ,(let* ((f (if (eq 'function (car-safe form)) (cadr form) form))) ;; If the form jut returns a function, preserve the fact that ;; it just returns a function, which is an info we use in ;; `advice--make-interactive-form'. (if (eq 'lambda (car-safe f)) - `',(eval form ctx) + (eval form ctx) `(eval ',form ',ctx)))))))))) (defun advice--interactive-form (function) diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 4da8e61aaa7..165d7c4b6e8 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -146,7 +146,7 @@ (setf (cl--find-class 'oclosure) (oclosure--class-make 'oclosure "The root parent of all OClosure types" - nil (list (cl--find-class 'function)) + nil (list (cl--find-class 'closure)) '(oclosure))) (defun oclosure--p (oclosure) (not (not (oclosure-type oclosure)))) @@ -431,75 +431,57 @@ ARGS and BODY are the same as for `lambda'." (defun oclosure--fix-type (_ignore oclosure) "Helper function to implement `oclosure-lambda' via a macro. -This has 2 uses: -- For interpreted code, this converts the representation of type information - by moving it from the docstring to the environment. -- For compiled code, this is used as a marker which cconv uses to check that - immutable fields are indeed not mutated." - (if (byte-code-function-p oclosure) - ;; Actually, this should never happen since `cconv.el' should have - ;; optimized away the call to this function. - oclosure - ;; For byte-coded functions, we store the type as a symbol in the docstring - ;; slot. For interpreted functions, there's no specific docstring slot - ;; so `Ffunction' turns the symbol into a string. - ;; We thus have convert it back into a symbol (via `intern') and then - ;; stuff it into the environment part of the closure with a special - ;; marker so we can distinguish this entry from actual variables. - (cl-assert (eq 'closure (car-safe oclosure))) - (let ((typename (nth 3 oclosure))) ;; The "docstring". - (cl-assert (stringp typename)) - (push (cons :type (intern typename)) - (cadr oclosure)) - oclosure))) +This is used as a marker which cconv uses to check that +immutable fields are indeed not mutated." + (cl-assert (closurep oclosure)) + ;; This should happen only for interpreted closures since `cconv.el' + ;; should have optimized away the call to this function. + oclosure) (defun oclosure--copy (oclosure mutlist &rest args) + (cl-assert (closurep oclosure)) (if (byte-code-function-p oclosure) (apply #'make-closure oclosure (if (null mutlist) args (mapcar (lambda (arg) (if (pop mutlist) (list arg) arg)) args))) - (cl-assert (eq 'closure (car-safe oclosure)) - nil "oclosure not closure: %S" oclosure) - (cl-assert (eq :type (caar (cadr oclosure)))) - (let ((env (cadr oclosure))) - `(closure - (,(car env) - ,@(named-let loop ((env (cdr env)) (args args)) - (when args - (cons (cons (caar env) (car args)) - (loop (cdr env) (cdr args))))) - ,@(nthcdr (1+ (length args)) env)) - ,@(nthcdr 2 oclosure))))) + (cl-assert (consp (aref oclosure 1))) + (cl-assert (null (aref oclosure 3))) + (cl-assert (symbolp (aref oclosure 4))) + (let ((env (aref oclosure 2))) + (make-interpreted-closure + (aref oclosure 0) + (aref oclosure 1) + (named-let loop ((env env) (args args)) + (if (null args) env + (cons (cons (caar env) (car args)) + (loop (cdr env) (cdr args))))) + (aref oclosure 4) + (if (> (length oclosure) 5) + `(interactive ,(aref oclosure 5))))))) (defun oclosure--get (oclosure index mutable) - (if (byte-code-function-p oclosure) - (let* ((csts (aref oclosure 2)) - (v (aref csts index))) - (if mutable (car v) v)) - (cl-assert (eq 'closure (car-safe oclosure))) - (cl-assert (eq :type (caar (cadr oclosure)))) - (cdr (nth (1+ index) (cadr oclosure))))) + (cl-assert (closurep oclosure)) + (let* ((csts (aref oclosure 2))) + (if (vectorp csts) + (let ((v (aref csts index))) + (if mutable (car v) v)) + (cdr (nth index csts))))) (defun oclosure--set (v oclosure index) - (if (byte-code-function-p oclosure) - (let* ((csts (aref oclosure 2)) - (cell (aref csts index))) - (setcar cell v)) - (cl-assert (eq 'closure (car-safe oclosure))) - (cl-assert (eq :type (caar (cadr oclosure)))) - (setcdr (nth (1+ index) (cadr oclosure)) v))) + (cl-assert (closurep oclosure)) + (let ((csts (aref oclosure 2))) + (if (vectorp csts) + (let ((cell (aref csts index))) + (setcar cell v)) + (setcdr (nth index csts) v)))) (defun oclosure-type (oclosure) - "Return the type of OCLOSURE, or nil if the arg is not a OClosure." - (if (byte-code-function-p oclosure) - (let ((type (and (> (length oclosure) 4) (aref oclosure 4)))) - (if (symbolp type) type)) - (and (eq 'closure (car-safe oclosure)) - (let* ((env (car-safe (cdr oclosure))) - (first-var (car-safe env))) - (and (eq :type (car-safe first-var)) - (cdr first-var)))))) + "Return the type of OCLOSURE, or nil if the arg is not an OClosure." + (and (closurep oclosure) + (> (length oclosure) 4) + (let ((type (aref oclosure 4))) + (if (symbolp type) type)))) (defconst oclosure--accessor-prototype ;; Use `oclosure--lambda' to circumvent a bootstrapping problem: diff --git a/lisp/help.el b/lisp/help.el index e13c34b6a5b..616a45328fd 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -2355,9 +2355,8 @@ the same names as used in the original source code, when possible." ;; If definition is a macro, find the function inside it. (if (eq (car-safe def) 'macro) (setq def (cdr def))) (cond - ((and (byte-code-function-p def) (listp (aref def 0))) (aref def 0)) + ((and (closurep def) (listp (aref def 0))) (aref def 0)) ((eq (car-safe def) 'lambda) (nth 1 def)) - ((eq (car-safe def) 'closure) (nth 2 def)) ((and (featurep 'native-compile) (subrp def) (listp (subr-native-lambda-list def))) diff --git a/lisp/profiler.el b/lisp/profiler.el index 4e02cd1d890..eb72f128c07 100644 --- a/lisp/profiler.el +++ b/lisp/profiler.el @@ -275,10 +275,7 @@ Optional argument MODE means only check for the specified mode (cpu or mem)." (define-hash-table-test 'profiler-function-equal #'function-equal - (lambda (f) (cond - ((byte-code-function-p f) (aref f 1)) - ((eq (car-safe f) 'closure) (cddr f)) - (t f)))) + (lambda (f) (if (closurep f) (aref f 1) f))) (defun profiler-calltree-build-unified (tree log) ;; Let's try to unify all those partial backtraces into a single diff --git a/lisp/simple.el b/lisp/simple.el index e4629ce3db7..be64f3574e0 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2703,15 +2703,14 @@ function as needed." (or (stringp doc) (fixnump doc) (fixnump (cdr-safe doc)))))) (pcase function - ((pred byte-code-function-p) + ((pred closurep) (when (> (length function) 4) (let ((doc (aref function 4))) (when (funcall docstring-p doc) doc)))) ((or (pred stringp) (pred vectorp)) "Keyboard macro.") (`(keymap . ,_) "Prefix command (definition is a keymap associating keystrokes with commands).") - ((or `(lambda ,_args . ,body) `(closure ,_env ,_args . ,body) - `(autoload ,_file . ,body)) + ((or `(lambda ,_args . ,body) `(autoload ,_file . ,body)) (let ((doc (car body))) (when (funcall docstring-p doc) doc))) diff --git a/src/callint.c b/src/callint.c index b31faba8704..9d6f2ab2888 100644 --- a/src/callint.c +++ b/src/callint.c @@ -319,10 +319,10 @@ invoke it (via an `interactive' spec that contains, for instance, an { Lisp_Object funval = Findirect_function (function, Qt); uintmax_t events = num_input_events; + Lisp_Object env = CLOSUREP (funval) && CONSP (AREF (funval, CLOSURE_CODE)) + ? AREF (funval, CLOSURE_CONSTANTS) : Qnil; /* Compute the arg values using the user's expression. */ - specs = Feval (specs, - CONSP (funval) && EQ (Qclosure, XCAR (funval)) - ? CAR_SAFE (XCDR (funval)) : Qnil); + specs = Feval (specs, env); if (events != num_input_events || !NILP (record_flag)) { /* We should record this command on the command history. diff --git a/src/data.c b/src/data.c index 681054ff8cb..ea611ad1abf 100644 --- a/src/data.c +++ b/src/data.c @@ -248,7 +248,9 @@ a fixed set of types. */) return XSUBR (object)->max_args == UNEVALLED ? Qspecial_form : SUBR_NATIVE_COMPILEDP (object) ? Qsubr_native_elisp : Qprimitive_function; - case PVEC_CLOSURE: return Qcompiled_function; + case PVEC_CLOSURE: + return CONSP (AREF (object, CLOSURE_CODE)) + ? Qinterpreted_function : Qbyte_code_function; case PVEC_BUFFER: return Qbuffer; case PVEC_CHAR_TABLE: return Qchar_table; case PVEC_BOOL_VECTOR: return Qbool_vector; @@ -518,12 +520,32 @@ DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, return Qnil; } +DEFUN ("closurep", Fclosurep, Sclosurep, + 1, 1, 0, + doc: /* Return t if OBJECT is a function of type `closure'. */) + (Lisp_Object object) +{ + if (CLOSUREP (object)) + return Qt; + return Qnil; +} + DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p, 1, 1, 0, doc: /* Return t if OBJECT is a byte-compiled function object. */) (Lisp_Object object) { - if (CLOSUREP (object)) + if (CLOSUREP (object) && STRINGP (AREF (object, CLOSURE_CODE))) + return Qt; + return Qnil; +} + +DEFUN ("interpreted-function-p", Finterpreted_function_p, + Sinterpreted_function_p, 1, 1, 0, + doc: /* Return t if OBJECT is a function of type `interpreted-function'. */) + (Lisp_Object object) +{ + if (CLOSUREP (object) && CONSP (AREF (object, CLOSURE_CODE))) return Qt; return Qnil; } @@ -1174,17 +1196,11 @@ Value, if non-nil, is a list (interactive SPEC). */) else if (CONSP (fun)) { Lisp_Object funcar = XCAR (fun); - if (EQ (funcar, Qclosure) - || EQ (funcar, Qlambda)) + if (EQ (funcar, Qlambda)) { Lisp_Object form = Fcdr (XCDR (fun)); - if (EQ (funcar, Qclosure)) - form = Fcdr (form); Lisp_Object spec = Fassq (Qinteractive, form); - if (NILP (spec) && VALID_DOCSTRING_P (CAR_SAFE (form))) - /* A "docstring" is a sign that we may have an OClosure. */ - genfun = true; - else if (NILP (Fcdr (Fcdr (spec)))) + if (NILP (Fcdr (Fcdr (spec)))) return spec; else return list2 (Qinteractive, Fcar (Fcdr (spec))); @@ -1257,12 +1273,9 @@ The value, if non-nil, is a list of mode name symbols. */) else if (CONSP (fun)) { Lisp_Object funcar = XCAR (fun); - if (EQ (funcar, Qclosure) - || EQ (funcar, Qlambda)) + if (EQ (funcar, Qlambda)) { Lisp_Object form = Fcdr (XCDR (fun)); - if (EQ (funcar, Qclosure)) - form = Fcdr (form); return Fcdr (Fcdr (Fassq (Qinteractive, form))); } } @@ -4224,7 +4237,8 @@ syms_of_data (void) DEFSYM (Qspecial_form, "special-form"); DEFSYM (Qprimitive_function, "primitive-function"); DEFSYM (Qsubr_native_elisp, "subr-native-elisp"); - DEFSYM (Qcompiled_function, "compiled-function"); + DEFSYM (Qbyte_code_function, "byte-code-function"); + DEFSYM (Qinterpreted_function, "interpreted-function"); DEFSYM (Qbuffer, "buffer"); DEFSYM (Qframe, "frame"); DEFSYM (Qvector, "vector"); @@ -4289,6 +4303,8 @@ syms_of_data (void) defsubr (&Smarkerp); defsubr (&Ssubrp); defsubr (&Sbyte_code_function_p); + defsubr (&Sinterpreted_function_p); + defsubr (&Sclosurep); defsubr (&Smodule_function_p); defsubr (&Schar_or_string_p); defsubr (&Sthreadp); diff --git a/src/eval.c b/src/eval.c index a7d860114cf..fd388706108 100644 --- a/src/eval.c +++ b/src/eval.c @@ -510,6 +510,33 @@ usage: (quote ARG) */) return XCAR (args); } +DEFUN ("make-interpreted-closure", Fmake_interpreted_closure, + Smake_interpreted_closure, 3, 5, 0, + doc: /* Make an interpreted closure. +ARGS should be the list of formal arguments. +BODY should be a non-empty list of forms. +ENV should be a lexical environment, like the second argument of `eval'. +IFORM if non-nil should be of the form (interactive ...). */) + (Lisp_Object args, Lisp_Object body, Lisp_Object env, + Lisp_Object docstring, Lisp_Object iform) +{ + CHECK_CONS (body); /* Make sure it's not confused with byte-code! */ + CHECK_LIST (args); + CHECK_LIST (iform); + Lisp_Object ifcdr = Fcdr (iform); + Lisp_Object slots[] = { args, body, env, Qnil, docstring, + NILP (Fcdr (ifcdr)) + ? Fcar (ifcdr) + : CALLN (Fvector, XCAR (ifcdr), XCDR (ifcdr)) }; + /* Adjusting the size is indispensable since, as for byte-code objects, + we distinguish interactive functions by the presence or absence of the + iform slot. */ + Lisp_Object val + = Fvector (!NILP (iform) ? 6 : !NILP (docstring) ? 5 : 3, slots); + XSETPVECTYPE (XVECTOR (val), PVEC_CLOSURE); + return val; +} + DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0, doc: /* Like `quote', but preferred for objects which are functions. In byte compilation, `function' causes its argument to be handled by @@ -525,33 +552,55 @@ usage: (function ARG) */) if (!NILP (XCDR (args))) xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args)); - if (!NILP (Vinternal_interpreter_environment) - && CONSP (quoted) + if (CONSP (quoted) && EQ (XCAR (quoted), Qlambda)) { /* This is a lambda expression within a lexical environment; return an interpreted closure instead of a simple lambda. */ Lisp_Object cdr = XCDR (quoted); - Lisp_Object tmp = cdr; - if (CONSP (tmp) - && (tmp = XCDR (tmp), CONSP (tmp)) - && (tmp = XCAR (tmp), CONSP (tmp)) - && (EQ (QCdocumentation, XCAR (tmp)))) - { /* Handle the special (:documentation
) to build the docstring + Lisp_Object args = Fcar (cdr); + cdr = Fcdr (cdr); + Lisp_Object docstring = Qnil, iform = Qnil; + if (CONSP (cdr)) + { + docstring = XCAR (cdr); + if (STRINGP (docstring)) + { + Lisp_Object tmp = XCDR (cdr); + if (!NILP (tmp)) + cdr = tmp; + else /* It's not a docstring, it's a return value. */ + docstring = Qnil; + } + /* Handle the special (:documentation ) to build the docstring dynamically. */ - Lisp_Object docstring = eval_sub (Fcar (XCDR (tmp))); - if (SYMBOLP (docstring) && !NILP (docstring)) - /* Hack for OClosures: Allow the docstring to be a symbol - * (the OClosure's type). */ - docstring = Fsymbol_name (docstring); - CHECK_STRING (docstring); - cdr = Fcons (XCAR (cdr), Fcons (docstring, XCDR (XCDR (cdr)))); - } - if (NILP (Vinternal_make_interpreted_closure_function)) - return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, cdr)); + else if (CONSP (docstring) + && EQ (QCdocumentation, XCAR (docstring)) + && (docstring = eval_sub (Fcar (XCDR (docstring))), + true)) + cdr = XCDR (cdr); + else + docstring = Qnil; /* Not a docstring after all. */ + } + if (CONSP (cdr)) + { + iform = XCAR (cdr); + if (CONSP (iform) + && EQ (Qinteractive, XCAR (iform))) + cdr = XCDR (cdr); + else + iform = Qnil; /* Not an interactive-form after all. */ + } + if (NILP (cdr)) + cdr = Fcons (Qnil, Qnil); /* Make sure the body is never empty! */ + + if (NILP (Vinternal_interpreter_environment) + || NILP (Vinternal_make_interpreted_closure_function)) + return Fmake_interpreted_closure + (args, cdr, Vinternal_interpreter_environment, docstring, iform); else - return call2 (Vinternal_make_interpreted_closure_function, - Fcons (Qlambda, cdr), - Vinternal_interpreter_environment); + return call5 (Vinternal_make_interpreted_closure_function, + args, cdr, Vinternal_interpreter_environment, + docstring, iform); } else /* Simply quote the argument. */ @@ -2193,15 +2242,12 @@ then strings and vectors are not accepted. */) else { Lisp_Object body = CDR_SAFE (XCDR (fun)); - if (EQ (funcar, Qclosure)) - body = CDR_SAFE (body); - else if (!EQ (funcar, Qlambda)) + if (!EQ (funcar, Qlambda)) return Qnil; if (!NILP (Fassq (Qinteractive, body))) return Qt; - else if (VALID_DOCSTRING_P (CAR_SAFE (body))) - /* A "docstring" is a sign that we may have an OClosure. */ - genfun = true; + else + return Qnil; } } @@ -2611,8 +2657,7 @@ eval_sub (Lisp_Object form) exp = unbind_to (count1, exp); val = eval_sub (exp); } - else if (EQ (funcar, Qlambda) - || EQ (funcar, Qclosure)) + else if (EQ (funcar, Qlambda)) return apply_lambda (fun, original_args, count); else xsignal1 (Qinvalid_function, original_fun); @@ -2950,7 +2995,7 @@ FUNCTIONP (Lisp_Object object) else if (CONSP (object)) { Lisp_Object car = XCAR (object); - return EQ (car, Qlambda) || EQ (car, Qclosure); + return EQ (car, Qlambda); } else return false; @@ -2980,8 +3025,7 @@ funcall_general (Lisp_Object fun, ptrdiff_t numargs, Lisp_Object *args) Lisp_Object funcar = XCAR (fun); if (!SYMBOLP (funcar)) xsignal1 (Qinvalid_function, original_fun); - if (EQ (funcar, Qlambda) - || EQ (funcar, Qclosure)) + if (EQ (funcar, Qlambda)) return funcall_lambda (fun, numargs, args); else if (EQ (funcar, Qautoload)) { @@ -3165,16 +3209,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, Lisp_Object *arg_vector) if (CONSP (fun)) { - if (EQ (XCAR (fun), Qclosure)) - { - Lisp_Object cdr = XCDR (fun); /* Drop `closure'. */ - if (! CONSP (cdr)) - xsignal1 (Qinvalid_function, fun); - fun = cdr; - lexenv = XCAR (fun); - } - else - lexenv = Qnil; + lexenv = Qnil; syms_left = XCDR (fun); if (CONSP (syms_left)) syms_left = XCAR (syms_left); @@ -3189,10 +3224,12 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, Lisp_Object *arg_vector) engine directly. */ if (FIXNUMP (syms_left)) return exec_byte_code (fun, XFIXNUM (syms_left), nargs, arg_vector); - /* Otherwise the bytecode object uses dynamic binding and the - ARGLIST slot contains a standard formal argument list whose - variables are bound dynamically below. */ - lexenv = Qnil; + /* Otherwise the closure either is interpreted + or uses dynamic binding and the ARGLIST slot contains a standard + formal argument list whose variables are bound dynamically below. */ + lexenv = CONSP (AREF (fun, CLOSURE_CODE)) + ? AREF (fun, CLOSURE_CONSTANTS) + : Qnil; } #ifdef HAVE_MODULES else if (MODULE_FUNCTIONP (fun)) @@ -3280,7 +3317,14 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, Lisp_Object *arg_vector) val = XSUBR (fun)->function.a0 (); } else - val = exec_byte_code (fun, 0, 0, NULL); + { + eassert (CLOSUREP (fun)); + val = CONSP (AREF (fun, CLOSURE_CODE)) + /* Interpreted function. */ + ? Fprogn (AREF (fun, CLOSURE_CODE)) + /* Dynbound bytecode. */ + : exec_byte_code (fun, 0, 0, NULL); + } return unbind_to (count, val); } @@ -3330,8 +3374,7 @@ function with `&rest' args, or `unevalled' for a special form. */) funcar = XCAR (function); if (!SYMBOLP (funcar)) xsignal1 (Qinvalid_function, original); - if (EQ (funcar, Qlambda) - || EQ (funcar, Qclosure)) + if (EQ (funcar, Qlambda)) result = lambda_arity (function); else if (EQ (funcar, Qautoload)) { @@ -3352,11 +3395,6 @@ lambda_arity (Lisp_Object fun) if (CONSP (fun)) { - if (EQ (XCAR (fun), Qclosure)) - { - fun = XCDR (fun); /* Drop `closure'. */ - CHECK_CONS (fun); - } syms_left = XCDR (fun); if (CONSP (syms_left)) syms_left = XCAR (syms_left); @@ -4265,7 +4303,6 @@ before making `inhibit-quit' nil. */); DEFSYM (Qcommandp, "commandp"); DEFSYM (Qand_rest, "&rest"); DEFSYM (Qand_optional, "&optional"); - DEFSYM (Qclosure, "closure"); DEFSYM (QCdocumentation, ":documentation"); DEFSYM (Qdebug, "debug"); DEFSYM (Qdebug_early, "debug-early"); @@ -4423,6 +4460,7 @@ alist of active lexical bindings. */); defsubr (&Ssetq); defsubr (&Squote); defsubr (&Sfunction); + defsubr (&Smake_interpreted_closure); defsubr (&Sdefault_toplevel_value); defsubr (&Sset_default_toplevel_value); defsubr (&Sdefvar); diff --git a/src/lread.c b/src/lread.c index 8b614e6220e..983fdb883ff 100644 --- a/src/lread.c +++ b/src/lread.c @@ -3523,25 +3523,32 @@ bytecode_from_rev_list (Lisp_Object elems, Lisp_Object readcharfun) } } - if (!(size >= CLOSURE_STACK_DEPTH + 1 && size <= CLOSURE_INTERACTIVE + 1 + if (!(size >= CLOSURE_STACK_DEPTH && size <= CLOSURE_INTERACTIVE + 1 && (FIXNUMP (vec[CLOSURE_ARGLIST]) || CONSP (vec[CLOSURE_ARGLIST]) || NILP (vec[CLOSURE_ARGLIST])) - && STRINGP (vec[CLOSURE_CODE]) - && VECTORP (vec[CLOSURE_CONSTANTS]) - && FIXNATP (vec[CLOSURE_STACK_DEPTH]))) + && ((STRINGP (vec[CLOSURE_CODE]) /* Byte-code function. */ + && VECTORP (vec[CLOSURE_CONSTANTS]) + && size > CLOSURE_STACK_DEPTH + && (FIXNATP (vec[CLOSURE_STACK_DEPTH]))) + || (CONSP (vec[CLOSURE_CODE]) /* Interpreted function. */ + && (CONSP (vec[CLOSURE_CONSTANTS]) + || NILP (vec[CLOSURE_CONSTANTS])))))) invalid_syntax ("Invalid byte-code object", readcharfun); - if (STRING_MULTIBYTE (vec[CLOSURE_CODE])) - /* BYTESTR must have been produced by Emacs 20.2 or earlier - because it produced a raw 8-bit string for byte-code and - now such a byte-code string is loaded as multibyte with - raw 8-bit characters converted to multibyte form. - Convert them back to the original unibyte form. */ - vec[CLOSURE_CODE] = Fstring_as_unibyte (vec[CLOSURE_CODE]); - - /* Bytecode must be immovable. */ - pin_string (vec[CLOSURE_CODE]); + if (STRINGP (vec[CLOSURE_CODE])) + { + if (STRING_MULTIBYTE (vec[CLOSURE_CODE])) + /* BYTESTR must have been produced by Emacs 20.2 or earlier + because it produced a raw 8-bit string for byte-code and + now such a byte-code string is loaded as multibyte with + raw 8-bit characters converted to multibyte form. + Convert them back to the original unibyte form. */ + vec[CLOSURE_CODE] = Fstring_as_unibyte (vec[CLOSURE_CODE]); + + /* Bytecode must be immovable. */ + pin_string (vec[CLOSURE_CODE]); + } XSETPVECTYPE (XVECTOR (obj), PVEC_CLOSURE); return obj; diff --git a/src/profiler.c b/src/profiler.c index ac23a97b672..6e1dc46abd3 100644 --- a/src/profiler.c +++ b/src/profiler.c @@ -170,9 +170,7 @@ trace_hash (Lisp_Object *trace, int depth) { Lisp_Object f = trace[i]; EMACS_UINT hash1 - = (CLOSUREP (f) ? XHASH (AREF (f, CLOSURE_CODE)) - : (CONSP (f) && CONSP (XCDR (f)) && BASE_EQ (Qclosure, XCAR (f))) - ? XHASH (XCDR (XCDR (f))) : XHASH (f)); + = (CLOSUREP (f) ? XHASH (AREF (f, CLOSURE_CODE)) : XHASH (f)); hash = sxhash_combine (hash, hash1); } return hash; @@ -677,10 +675,6 @@ the same lambda expression, or are really unrelated function. */) res = true; else if (CLOSUREP (f1) && CLOSUREP (f2)) res = EQ (AREF (f1, CLOSURE_CODE), AREF (f2, CLOSURE_CODE)); - else if (CONSP (f1) && CONSP (f2) && CONSP (XCDR (f1)) && CONSP (XCDR (f2)) - && EQ (Qclosure, XCAR (f1)) - && EQ (Qclosure, XCAR (f2))) - res = EQ (XCDR (XCDR (f1)), XCDR (XCDR (f2))); else res = false; return res ? Qt : Qnil; diff --git a/test/lisp/emacs-lisp/macroexp-resources/vk.el b/test/lisp/emacs-lisp/macroexp-resources/vk.el index 5358bcaeb5c..c59a6b9f8f1 100644 --- a/test/lisp/emacs-lisp/macroexp-resources/vk.el +++ b/test/lisp/emacs-lisp/macroexp-resources/vk.el @@ -78,29 +78,31 @@ (defconst vk-val3 (eval-when-compile (vk-f3 0))) -(defconst vk-f4 '(lambda (x) - (defvar vk-v4) - (let ((vk-v4 31) - (y 32)) - (ignore vk-v4 x y) - (list - (vk-variable-kind vk-a) ; dyn - (vk-variable-kind vk-b) ; dyn - (vk-variable-kind vk-v4) ; dyn - (vk-variable-kind x) ; dyn - (vk-variable-kind y))))) ; dyn - -(defconst vk-f5 '(closure (t) (x) - (defvar vk-v5) - (let ((vk-v5 41) - (y 42)) - (ignore vk-v5 x y) - (list - (vk-variable-kind vk-a) ; dyn - (vk-variable-kind vk-b) ; dyn - (vk-variable-kind vk-v5) ; dyn - (vk-variable-kind x) ; lex - (vk-variable-kind y))))) ; lex +(defconst vk-f4 (eval '(lambda (x) + (defvar vk-v4) + (let ((vk-v4 31) + (y 32)) + (ignore vk-v4 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v4) ; dyn + (vk-variable-kind x) ; dyn + (vk-variable-kind y)))) ; dyn + nil)) + +(defconst vk-f5 (eval '(lambda (x) + (defvar vk-v5) + (let ((vk-v5 41) + (y 42)) + (ignore vk-v5 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v5) ; dyn + (vk-variable-kind x) ; lex + (vk-variable-kind y)))) ; lex + t)) (defun vk-f6 () (eval '(progn diff --git a/test/lisp/erc/resources/erc-d/erc-d-tests.el b/test/lisp/erc/resources/erc-d/erc-d-tests.el index 78f87399afb..dda1b1ced84 100644 --- a/test/lisp/erc/resources/erc-d/erc-d-tests.el +++ b/test/lisp/erc/resources/erc-d/erc-d-tests.el @@ -367,8 +367,9 @@ (should (equal (funcall it) "foo3foo"))) (ert-info ("Exits clean") - (when (listp (alist-get 'f (erc-d-dialog-vars dialog))) ; may be compiled - (should (eq 'closure (car (alist-get 'f (erc-d-dialog-vars dialog)))))) + (when (interpreted-function-p + (alist-get 'f (erc-d-dialog-vars dialog))) ; may be compiled + (should (aref (alist-get 'f (erc-d-dialog-vars dialog)) 2))) (should-not (funcall it)) (should (equal (erc-d-dialog-vars dialog) `((:a . 1) diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el index 1beeb77640c..82350a4bc71 100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@ -63,14 +63,14 @@ Return first line of the output of (describe-function-1 FUNC)." (should (string-match regexp result)))) (ert-deftest help-fns-test-lisp-defun () - (let ((regexp (if (featurep 'native-compile) - "a subr-native-elisp in .+subr\\.el" - "a compiled-function in .+subr\\.el")) + (let ((regexp "a \\([^ ]+\\) in .+subr\\.el") (result (help-fns-tests--describe-function 'last))) - (should (string-match regexp result)))) + (should (string-match regexp result)) + (should (member (match-string 1 result) + '("subr-native-elisp" "byte-code-function"))))) (ert-deftest help-fns-test-lisp-defsubst () - (let ((regexp "a compiled-function in .+subr\\.el") + (let ((regexp "a byte-code-function in .+subr\\.el") (result (help-fns-tests--describe-function 'posn-window))) (should (string-match regexp result)))) commit 2fa839c1886acd4a7b6c25c50877534fe1d669bb Author: Stefan Monnier Date: Sun Mar 24 18:32:25 2024 -0400 (COMPILED): Rename to CLOSURE In preparation for the use of `PVEC_COMPILED` objects for interpreted functions, rename them to use a more neutral name. * src/lisp.h (enum pvec_type): Rename `PVEC_COMPILED` to `PVEC_CLOSURE`. (enum Lisp_Compiled): Use `CLOSURE_` prefix i.s.o `COMPILED_`. Also use `CODE` rather than `BYTECODE`. (CLOSUREP): Rename from `COMPILEDP`. (enum Lisp_Closure): Rename from `Lisp_Compiled`. * src/alloc.c, src/bytecode.c, src/comp.c, src/data.c, src/eval.c, * src/fns.c, src/lisp.h, src/lread.c, src/pdumper.c, src/print.c, * src/profiler.c: Rename all uses accordingly. * src/.gdbinit (xclosure): Rename from `xcompiled`. (xcompiled): New obsolete alias. (xpr): Adjust accordingly. Also adjust to new PVEC_CLOSURE tag name. diff --git a/src/.gdbinit b/src/.gdbinit index 6c4dda67f06..7645d466a5e 100644 --- a/src/.gdbinit +++ b/src/.gdbinit @@ -822,15 +822,22 @@ Print $ as a frame pointer. This command assumes $ is an Emacs Lisp frame value. end -define xcompiled +define xclosure xgetptr $ print (struct Lisp_Vector *) $ptr output ($->contents[0])@($->header.size & 0xff) echo \n end +document xclosure +Print $ as a function pointer. +This command assumes that $ is an Emacs Lisp byte-code or interpreted function value. +end + +define xcompiled + xclosure +end document xcompiled -Print $ as a compiled function pointer. -This command assumes that $ is an Emacs Lisp compiled value. +Obsolete alias for "xclosure". end define xwindow @@ -1038,8 +1045,8 @@ define xpr if $vec == PVEC_FRAME xframe end - if $vec == PVEC_COMPILED - xcompiled + if $vec == PVEC_CLOSURE + xclosure end if $vec == PVEC_WINDOW xwindow diff --git a/src/alloc.c b/src/alloc.c index 6779d0ca9ce..a8dfde56739 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3481,7 +3481,7 @@ cleanup_vector (struct Lisp_Vector *vector) case PVEC_XWIDGET_VIEW: case PVEC_TS_NODE: case PVEC_SQLITE: - case PVEC_COMPILED: + case PVEC_CLOSURE: case PVEC_CHAR_TABLE: case PVEC_SUB_CHAR_TABLE: case PVEC_RECORD: @@ -3813,17 +3813,17 @@ stack before executing the byte-code. usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */) (ptrdiff_t nargs, Lisp_Object *args) { - if (! ((FIXNUMP (args[COMPILED_ARGLIST]) - || CONSP (args[COMPILED_ARGLIST]) - || NILP (args[COMPILED_ARGLIST])) - && STRINGP (args[COMPILED_BYTECODE]) - && !STRING_MULTIBYTE (args[COMPILED_BYTECODE]) - && VECTORP (args[COMPILED_CONSTANTS]) - && FIXNATP (args[COMPILED_STACK_DEPTH]))) + if (! ((FIXNUMP (args[CLOSURE_ARGLIST]) + || CONSP (args[CLOSURE_ARGLIST]) + || NILP (args[CLOSURE_ARGLIST])) + && STRINGP (args[CLOSURE_CODE]) + && !STRING_MULTIBYTE (args[CLOSURE_CODE]) + && VECTORP (args[CLOSURE_CONSTANTS]) + && FIXNATP (args[CLOSURE_STACK_DEPTH]))) error ("Invalid byte-code object"); /* Bytecode must be immovable. */ - pin_string (args[COMPILED_BYTECODE]); + pin_string (args[CLOSURE_CODE]); /* We used to purecopy everything here, if purify-flag was set. This worked OK for Emacs-23, but with Emacs-24's lexical binding code, it can be @@ -3833,7 +3833,7 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT just wasteful and other times plainly wrong (e.g. those free vars may want to be setcar'd). */ Lisp_Object val = Fvector (nargs, args); - XSETPVECTYPE (XVECTOR (val), PVEC_COMPILED); + XSETPVECTYPE (XVECTOR (val), PVEC_CLOSURE); return val; } @@ -3845,12 +3845,12 @@ usage: (make-closure PROTOTYPE &rest CLOSURE-VARS) */) (ptrdiff_t nargs, Lisp_Object *args) { Lisp_Object protofun = args[0]; - CHECK_TYPE (COMPILEDP (protofun), Qbyte_code_function_p, protofun); + CHECK_TYPE (CLOSUREP (protofun), Qbyte_code_function_p, protofun); /* Create a copy of the constant vector, filling it with the closure variables in the beginning. (The overwritten part should just contain placeholder values.) */ - Lisp_Object proto_constvec = AREF (protofun, COMPILED_CONSTANTS); + Lisp_Object proto_constvec = AREF (protofun, CLOSURE_CONSTANTS); ptrdiff_t constsize = ASIZE (proto_constvec); ptrdiff_t nvars = nargs - 1; if (nvars > constsize) @@ -3866,7 +3866,7 @@ usage: (make-closure PROTOTYPE &rest CLOSURE-VARS) */) struct Lisp_Vector *v = allocate_vectorlike (protosize, false); v->header = XVECTOR (protofun)->header; memcpy (v->contents, XVECTOR (protofun)->contents, protosize * word_size); - v->contents[COMPILED_CONSTANTS] = constvec; + v->contents[CLOSURE_CONSTANTS] = constvec; return make_lisp_ptr (v, Lisp_Vectorlike); } @@ -6046,7 +6046,7 @@ purecopy (Lisp_Object obj) obj = make_lisp_hash_table (purecopy_hash_table (table)); } - else if (COMPILEDP (obj) || VECTORP (obj) || RECORDP (obj)) + else if (CLOSUREP (obj) || VECTORP (obj) || RECORDP (obj)) { struct Lisp_Vector *objp = XVECTOR (obj); ptrdiff_t nbytes = vector_nbytes (objp); @@ -6059,7 +6059,7 @@ purecopy (Lisp_Object obj) for (i = 0; i < size; i++) vec->contents[i] = purecopy (vec->contents[i]); /* Byte code strings must be pinned. */ - if (COMPILEDP (obj) && size >= 2 && STRINGP (vec->contents[1]) + if (CLOSUREP (obj) && size >= 2 && STRINGP (vec->contents[1]) && !STRING_MULTIBYTE (vec->contents[1])) pin_string (vec->contents[1]); XSETVECTOR (obj, vec); @@ -8014,11 +8014,11 @@ symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj) return (EQ (val, obj) || EQ (sym->u.s.function, obj) || (!NILP (sym->u.s.function) - && COMPILEDP (sym->u.s.function) - && EQ (AREF (sym->u.s.function, COMPILED_BYTECODE), obj)) + && CLOSUREP (sym->u.s.function) + && EQ (AREF (sym->u.s.function, CLOSURE_CODE), obj)) || (!NILP (val) - && COMPILEDP (val) - && EQ (AREF (val, COMPILED_BYTECODE), obj))); + && CLOSUREP (val) + && EQ (AREF (val, CLOSURE_CODE), obj))); } /* Find at most FIND_MAX symbols which have OBJ as their value or @@ -8343,7 +8343,7 @@ union enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE; enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE; enum Lisp_Bits Lisp_Bits; - enum Lisp_Compiled Lisp_Compiled; + enum Lisp_Closure Lisp_Closure; enum maxargs maxargs; enum MAX_ALLOCA MAX_ALLOCA; enum More_Lisp_Bits More_Lisp_Bits; diff --git a/src/bytecode.c b/src/bytecode.c index de25069d94a..03443ed54ab 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -479,7 +479,7 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, Lisp_Object *top = NULL; unsigned char const *pc = NULL; - Lisp_Object bytestr = AREF (fun, COMPILED_BYTECODE); + Lisp_Object bytestr = AREF (fun, CLOSURE_CODE); setup_frame: ; eassert (!STRING_MULTIBYTE (bytestr)); @@ -489,8 +489,8 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, when returning, to detect unwind imbalances. This would require adding a field to the frame header. */ - Lisp_Object vector = AREF (fun, COMPILED_CONSTANTS); - Lisp_Object maxdepth = AREF (fun, COMPILED_STACK_DEPTH); + Lisp_Object vector = AREF (fun, CLOSURE_CONSTANTS); + Lisp_Object maxdepth = AREF (fun, CLOSURE_STACK_DEPTH); ptrdiff_t const_length = ASIZE (vector); ptrdiff_t bytestr_length = SCHARS (bytestr); Lisp_Object *vectorp = XVECTOR (vector)->contents; @@ -792,14 +792,14 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, /* Calls to symbols-with-pos don't need to be on the fast path. */ if (BARE_SYMBOL_P (call_fun)) call_fun = XBARE_SYMBOL (call_fun)->u.s.function; - if (COMPILEDP (call_fun)) + if (CLOSUREP (call_fun)) { - Lisp_Object template = AREF (call_fun, COMPILED_ARGLIST); + Lisp_Object template = AREF (call_fun, CLOSURE_ARGLIST); if (FIXNUMP (template)) { /* Fast path for lexbound functions. */ fun = call_fun; - bytestr = AREF (call_fun, COMPILED_BYTECODE), + bytestr = AREF (call_fun, CLOSURE_CODE), args_template = XFIXNUM (template); nargs = call_nargs; args = call_args; @@ -897,8 +897,8 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, bc->fp = fp; Lisp_Object fun = fp->fun; - Lisp_Object bytestr = AREF (fun, COMPILED_BYTECODE); - Lisp_Object vector = AREF (fun, COMPILED_CONSTANTS); + Lisp_Object bytestr = AREF (fun, CLOSURE_CODE); + Lisp_Object vector = AREF (fun, CLOSURE_CONSTANTS); bytestr_data = SDATA (bytestr); vectorp = XVECTOR (vector)->contents; if (BYTE_CODE_SAFE) @@ -974,8 +974,8 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, struct bc_frame *fp = bc->fp; Lisp_Object fun = fp->fun; - Lisp_Object bytestr = AREF (fun, COMPILED_BYTECODE); - Lisp_Object vector = AREF (fun, COMPILED_CONSTANTS); + Lisp_Object bytestr = AREF (fun, CLOSURE_CODE); + Lisp_Object vector = AREF (fun, CLOSURE_CONSTANTS); bytestr_data = SDATA (bytestr); vectorp = XVECTOR (vector)->contents; if (BYTE_CODE_SAFE) diff --git a/src/comp.c b/src/comp.c index 3ac6896aee1..4e779cdf898 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5199,7 +5199,7 @@ maybe_defer_native_compilation (Lisp_Object function_name, if (!native_comp_jit_compilation || noninteractive || !NILP (Vpurify_flag) - || !COMPILEDP (definition) + || !CLOSUREP (definition) || !STRINGP (Vload_true_file_name) || !suffix_p (Vload_true_file_name, ".elc") || !NILP (Fgethash (Vload_true_file_name, V_comp_no_native_file_h, Qnil))) diff --git a/src/data.c b/src/data.c index c4b9cff8ae0..681054ff8cb 100644 --- a/src/data.c +++ b/src/data.c @@ -248,7 +248,7 @@ a fixed set of types. */) return XSUBR (object)->max_args == UNEVALLED ? Qspecial_form : SUBR_NATIVE_COMPILEDP (object) ? Qsubr_native_elisp : Qprimitive_function; - case PVEC_COMPILED: return Qcompiled_function; + case PVEC_CLOSURE: return Qcompiled_function; case PVEC_BUFFER: return Qbuffer; case PVEC_CHAR_TABLE: return Qchar_table; case PVEC_BOOL_VECTOR: return Qbool_vector; @@ -523,7 +523,7 @@ DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p, doc: /* Return t if OBJECT is a byte-compiled function object. */) (Lisp_Object object) { - if (COMPILEDP (object)) + if (CLOSUREP (object)) return Qt; return Qnil; } @@ -1143,19 +1143,19 @@ Value, if non-nil, is a list (interactive SPEC). */) (*spec != '(') ? build_string (spec) : Fcar (Fread_from_string (build_string (spec), Qnil, Qnil))); } - else if (COMPILEDP (fun)) + else if (CLOSUREP (fun)) { - if (PVSIZE (fun) > COMPILED_INTERACTIVE) + if (PVSIZE (fun) > CLOSURE_INTERACTIVE) { - Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE); + Lisp_Object form = AREF (fun, CLOSURE_INTERACTIVE); /* The vector form is the new form, where the first element is the interactive spec, and the second is the command modes. */ return list2 (Qinteractive, VECTORP (form) ? AREF (form, 0) : form); } - else if (PVSIZE (fun) > COMPILED_DOC_STRING) + else if (PVSIZE (fun) > CLOSURE_DOC_STRING) { - Lisp_Object doc = AREF (fun, COMPILED_DOC_STRING); + Lisp_Object doc = AREF (fun, CLOSURE_DOC_STRING); /* An invalid "docstring" is a sign that we have an OClosure. */ genfun = !(NILP (doc) || VALID_DOCSTRING_P (doc)); } @@ -1225,11 +1225,11 @@ The value, if non-nil, is a list of mode name symbols. */) { return XSUBR (fun)->command_modes; } - else if (COMPILEDP (fun)) + else if (CLOSUREP (fun)) { - if (PVSIZE (fun) <= COMPILED_INTERACTIVE) + if (PVSIZE (fun) <= CLOSURE_INTERACTIVE) return Qnil; - Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE); + Lisp_Object form = AREF (fun, CLOSURE_INTERACTIVE); if (VECTORP (form)) /* New form -- the second element is the command modes. */ return AREF (form, 1); @@ -2546,7 +2546,7 @@ or a byte-code object. IDX starts at 0. */) ptrdiff_t size = 0; if (VECTORP (array)) size = ASIZE (array); - else if (COMPILEDP (array) || RECORDP (array)) + else if (CLOSUREP (array) || RECORDP (array)) size = PVSIZE (array); else wrong_type_argument (Qarrayp, array); diff --git a/src/doc.c b/src/doc.c index 10afda73458..b698591f704 100644 --- a/src/doc.c +++ b/src/doc.c @@ -519,15 +519,15 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) /* Lisp_Subrs have a slot for it. */ if (SUBRP (fun)) XSUBR (fun)->doc = offset; - else if (COMPILEDP (fun)) + else if (CLOSUREP (fun)) { /* This bytecode object must have a slot for the docstring, since we've found a docstring for it. */ - if (PVSIZE (fun) > COMPILED_DOC_STRING + if (PVSIZE (fun) > CLOSURE_DOC_STRING /* Don't overwrite a non-docstring value placed there, such as the symbols used for Oclosures. */ - && VALID_DOCSTRING_P (AREF (fun, COMPILED_DOC_STRING))) - ASET (fun, COMPILED_DOC_STRING, make_fixnum (offset)); + && VALID_DOCSTRING_P (AREF (fun, CLOSURE_DOC_STRING))) + ASET (fun, CLOSURE_DOC_STRING, make_fixnum (offset)); else { AUTO_STRING (format, "No doc string slot for compiled: %S"); diff --git a/src/eval.c b/src/eval.c index c5b8a375af4..a7d860114cf 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2151,15 +2151,15 @@ then strings and vectors are not accepted. */) return Qt; } /* Bytecode objects are interactive if they are long enough to - have an element whose index is COMPILED_INTERACTIVE, which is + have an element whose index is CLOSURE_INTERACTIVE, which is where the interactive spec is stored. */ - else if (COMPILEDP (fun)) + else if (CLOSUREP (fun)) { - if (PVSIZE (fun) > COMPILED_INTERACTIVE) + if (PVSIZE (fun) > CLOSURE_INTERACTIVE) return Qt; - else if (PVSIZE (fun) > COMPILED_DOC_STRING) + else if (PVSIZE (fun) > CLOSURE_DOC_STRING) { - Lisp_Object doc = AREF (fun, COMPILED_DOC_STRING); + Lisp_Object doc = AREF (fun, CLOSURE_DOC_STRING); /* An invalid "docstring" is a sign that we have an OClosure. */ genfun = !(NILP (doc) || VALID_DOCSTRING_P (doc)); } @@ -2567,7 +2567,7 @@ eval_sub (Lisp_Object form) } } } - else if (COMPILEDP (fun) + else if (CLOSUREP (fun) || SUBR_NATIVE_COMPILED_DYNP (fun) || MODULE_FUNCTIONP (fun)) return apply_lambda (fun, original_args, count); @@ -2945,7 +2945,7 @@ FUNCTIONP (Lisp_Object object) if (SUBRP (object)) return XSUBR (object)->max_args != UNEVALLED; - else if (COMPILEDP (object) || MODULE_FUNCTIONP (object)) + else if (CLOSUREP (object) || MODULE_FUNCTIONP (object)) return true; else if (CONSP (object)) { @@ -2967,7 +2967,7 @@ funcall_general (Lisp_Object fun, ptrdiff_t numargs, Lisp_Object *args) if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun)) return funcall_subr (XSUBR (fun), numargs, args); - else if (COMPILEDP (fun) + else if (CLOSUREP (fun) || SUBR_NATIVE_COMPILED_DYNP (fun) || MODULE_FUNCTIONP (fun)) return funcall_lambda (fun, numargs, args); @@ -3181,9 +3181,9 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, Lisp_Object *arg_vector) else xsignal1 (Qinvalid_function, fun); } - else if (COMPILEDP (fun)) + else if (CLOSUREP (fun)) { - syms_left = AREF (fun, COMPILED_ARGLIST); + syms_left = AREF (fun, CLOSURE_ARGLIST); /* Bytecode objects using lexical binding have an integral ARGLIST slot value: pass the arguments to the byte-code engine directly. */ @@ -3315,7 +3315,7 @@ function with `&rest' args, or `unevalled' for a special form. */) if (SUBRP (function)) result = Fsubr_arity (function); - else if (COMPILEDP (function)) + else if (CLOSUREP (function)) result = lambda_arity (function); #ifdef HAVE_MODULES else if (MODULE_FUNCTIONP (function)) @@ -3363,9 +3363,9 @@ lambda_arity (Lisp_Object fun) else xsignal1 (Qinvalid_function, fun); } - else if (COMPILEDP (fun)) + else if (CLOSUREP (fun)) { - syms_left = AREF (fun, COMPILED_ARGLIST); + syms_left = AREF (fun, CLOSURE_ARGLIST); if (FIXNUMP (syms_left)) return get_byte_code_arity (syms_left); } diff --git a/src/fns.c b/src/fns.c index db5e856d5bd..e987d64319f 100644 --- a/src/fns.c +++ b/src/fns.c @@ -152,7 +152,7 @@ efficient. */) val = MAX_CHAR; else if (BOOL_VECTOR_P (sequence)) val = bool_vector_size (sequence); - else if (COMPILEDP (sequence) || RECORDP (sequence)) + else if (CLOSUREP (sequence) || RECORDP (sequence)) val = PVSIZE (sequence); else wrong_type_argument (Qsequencep, sequence); @@ -1054,7 +1054,7 @@ concat_to_list (ptrdiff_t nargs, Lisp_Object *args, Lisp_Object last_tail) else if (NILP (arg)) ; else if (VECTORP (arg) || STRINGP (arg) - || BOOL_VECTOR_P (arg) || COMPILEDP (arg)) + || BOOL_VECTOR_P (arg) || CLOSUREP (arg)) { ptrdiff_t arglen = XFIXNUM (Flength (arg)); ptrdiff_t argindex_byte = 0; @@ -1114,7 +1114,7 @@ concat_to_vector (ptrdiff_t nargs, Lisp_Object *args) { Lisp_Object arg = args[i]; if (!(VECTORP (arg) || CONSP (arg) || NILP (arg) || STRINGP (arg) - || BOOL_VECTOR_P (arg) || COMPILEDP (arg))) + || BOOL_VECTOR_P (arg) || CLOSUREP (arg))) wrong_type_argument (Qsequencep, arg); EMACS_INT len = XFIXNAT (Flength (arg)); result_len += len; @@ -1170,7 +1170,7 @@ concat_to_vector (ptrdiff_t nargs, Lisp_Object *args) } else { - eassert (COMPILEDP (arg)); + eassert (CLOSUREP (arg)); ptrdiff_t size = PVSIZE (arg); memcpy (dst, XVECTOR (arg)->contents, size * sizeof *dst); dst += size; @@ -2949,7 +2949,7 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, if (size & PSEUDOVECTOR_FLAG) { if (((size & PVEC_TYPE_MASK) >> PSEUDOVECTOR_AREA_BITS) - < PVEC_COMPILED) + < PVEC_CLOSURE) return false; size &= PSEUDOVECTOR_SIZE_MASK; } @@ -3346,7 +3346,7 @@ mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) tail = XCDR (tail); } } - else if (VECTORP (seq) || COMPILEDP (seq)) + else if (VECTORP (seq) || CLOSUREP (seq)) { for (ptrdiff_t i = 0; i < leni; i++) { @@ -5512,7 +5512,7 @@ sxhash_obj (Lisp_Object obj, int depth) case Lisp_Vectorlike: { enum pvec_type pvec_type = PSEUDOVECTOR_TYPE (XVECTOR (obj)); - if (! (PVEC_NORMAL_VECTOR < pvec_type && pvec_type < PVEC_COMPILED)) + if (! (PVEC_NORMAL_VECTOR < pvec_type && pvec_type < PVEC_CLOSURE)) { /* According to the CL HyperSpec, two arrays are equal only if they are 'eq', except for strings and bit-vectors. In diff --git a/src/lisp.h b/src/lisp.h index 3cb4361e75e..526248dd2ba 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -1049,7 +1049,7 @@ enum pvec_type PVEC_SQLITE, /* These should be last, for internal_equal and sxhash_obj. */ - PVEC_COMPILED, + PVEC_CLOSURE, PVEC_CHAR_TABLE, PVEC_SUB_CHAR_TABLE, PVEC_RECORD, @@ -3223,16 +3223,16 @@ XFLOAT_DATA (Lisp_Object f) #define IEEE_FLOATING_POINT (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \ && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128) -/* Meanings of slots in a Lisp_Compiled: */ +/* Meanings of slots in a Lisp_Closure: */ -enum Lisp_Compiled +enum Lisp_Closure { - COMPILED_ARGLIST = 0, - COMPILED_BYTECODE = 1, - COMPILED_CONSTANTS = 2, - COMPILED_STACK_DEPTH = 3, - COMPILED_DOC_STRING = 4, - COMPILED_INTERACTIVE = 5 + CLOSURE_ARGLIST = 0, + CLOSURE_CODE = 1, + CLOSURE_CONSTANTS = 2, + CLOSURE_STACK_DEPTH = 3, + CLOSURE_DOC_STRING = 4, + CLOSURE_INTERACTIVE = 5 }; /* Flag bits in a character. These also get used in termhooks.h. @@ -3307,9 +3307,9 @@ WINDOW_CONFIGURATIONP (Lisp_Object a) } INLINE bool -COMPILEDP (Lisp_Object a) +CLOSUREP (Lisp_Object a) { - return PSEUDOVECTORP (a, PVEC_COMPILED); + return PSEUDOVECTORP (a, PVEC_CLOSURE); } INLINE bool diff --git a/src/lread.c b/src/lread.c index 09a5589fd0c..8b614e6220e 100644 --- a/src/lread.c +++ b/src/lread.c @@ -3498,52 +3498,52 @@ bytecode_from_rev_list (Lisp_Object elems, Lisp_Object readcharfun) Lisp_Object *vec = XVECTOR (obj)->contents; ptrdiff_t size = ASIZE (obj); - if (infile && size >= COMPILED_CONSTANTS) + if (infile && size >= CLOSURE_CONSTANTS) { /* Always read 'lazily-loaded' bytecode (generated by the `byte-compile-dynamic' feature prior to Emacs 30) eagerly, to avoid code in the fast path during execution. */ - if (CONSP (vec[COMPILED_BYTECODE]) - && FIXNUMP (XCDR (vec[COMPILED_BYTECODE]))) - vec[COMPILED_BYTECODE] = get_lazy_string (vec[COMPILED_BYTECODE]); + if (CONSP (vec[CLOSURE_CODE]) + && FIXNUMP (XCDR (vec[CLOSURE_CODE]))) + vec[CLOSURE_CODE] = get_lazy_string (vec[CLOSURE_CODE]); /* Lazily-loaded bytecode is represented by the constant slot being nil and the bytecode slot a (lazily loaded) string containing the print representation of (BYTECODE . CONSTANTS). Unpack the pieces by coerceing the string to unibyte and reading the result. */ - if (NILP (vec[COMPILED_CONSTANTS]) && STRINGP (vec[COMPILED_BYTECODE])) + if (NILP (vec[CLOSURE_CONSTANTS]) && STRINGP (vec[CLOSURE_CODE])) { - Lisp_Object enc = vec[COMPILED_BYTECODE]; + Lisp_Object enc = vec[CLOSURE_CODE]; Lisp_Object pair = Fread (Fcons (enc, readcharfun)); if (!CONSP (pair)) invalid_syntax ("Invalid byte-code object", readcharfun); - vec[COMPILED_BYTECODE] = XCAR (pair); - vec[COMPILED_CONSTANTS] = XCDR (pair); + vec[CLOSURE_CODE] = XCAR (pair); + vec[CLOSURE_CONSTANTS] = XCDR (pair); } } - if (!(size >= COMPILED_STACK_DEPTH + 1 && size <= COMPILED_INTERACTIVE + 1 - && (FIXNUMP (vec[COMPILED_ARGLIST]) - || CONSP (vec[COMPILED_ARGLIST]) - || NILP (vec[COMPILED_ARGLIST])) - && STRINGP (vec[COMPILED_BYTECODE]) - && VECTORP (vec[COMPILED_CONSTANTS]) - && FIXNATP (vec[COMPILED_STACK_DEPTH]))) + if (!(size >= CLOSURE_STACK_DEPTH + 1 && size <= CLOSURE_INTERACTIVE + 1 + && (FIXNUMP (vec[CLOSURE_ARGLIST]) + || CONSP (vec[CLOSURE_ARGLIST]) + || NILP (vec[CLOSURE_ARGLIST])) + && STRINGP (vec[CLOSURE_CODE]) + && VECTORP (vec[CLOSURE_CONSTANTS]) + && FIXNATP (vec[CLOSURE_STACK_DEPTH]))) invalid_syntax ("Invalid byte-code object", readcharfun); - if (STRING_MULTIBYTE (vec[COMPILED_BYTECODE])) + if (STRING_MULTIBYTE (vec[CLOSURE_CODE])) /* BYTESTR must have been produced by Emacs 20.2 or earlier because it produced a raw 8-bit string for byte-code and now such a byte-code string is loaded as multibyte with raw 8-bit characters converted to multibyte form. Convert them back to the original unibyte form. */ - vec[COMPILED_BYTECODE] = Fstring_as_unibyte (vec[COMPILED_BYTECODE]); + vec[CLOSURE_CODE] = Fstring_as_unibyte (vec[CLOSURE_CODE]); /* Bytecode must be immovable. */ - pin_string (vec[COMPILED_BYTECODE]); + pin_string (vec[CLOSURE_CODE]); - XSETPVECTYPE (XVECTOR (obj), PVEC_COMPILED); + XSETPVECTYPE (XVECTOR (obj), PVEC_CLOSURE); return obj; } @@ -4678,7 +4678,7 @@ substitute_object_recurse (struct subst *subst, Lisp_Object subtree) if (BOOL_VECTOR_P (subtree)) return subtree; /* No sub-objects anyway. */ else if (CHAR_TABLE_P (subtree) || SUB_CHAR_TABLE_P (subtree) - || COMPILEDP (subtree) || HASH_TABLE_P (subtree) + || CLOSUREP (subtree) || HASH_TABLE_P (subtree) || RECORDP (subtree)) length = PVSIZE (subtree); else if (VECTORP (subtree)) diff --git a/src/pdumper.c b/src/pdumper.c index ac8bf6f31f4..2963efc56ab 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -3068,7 +3068,7 @@ dump_vectorlike (struct dump_context *ctx, error_unsupported_dump_object(ctx, lv, "font"); FALLTHROUGH; case PVEC_NORMAL_VECTOR: - case PVEC_COMPILED: + case PVEC_CLOSURE: case PVEC_CHAR_TABLE: case PVEC_SUB_CHAR_TABLE: case PVEC_RECORD: diff --git a/src/print.c b/src/print.c index 0d867b89395..612d63b7e94 100644 --- a/src/print.c +++ b/src/print.c @@ -1299,7 +1299,7 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) (STRINGP (obj) \ || CONSP (obj) \ || (VECTORLIKEP (obj) \ - && (VECTORP (obj) || COMPILEDP (obj) \ + && (VECTORP (obj) || CLOSUREP (obj) \ || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \ || HASH_TABLE_P (obj) || FONTP (obj) \ || RECORDP (obj))) \ @@ -2091,7 +2091,7 @@ print_vectorlike_unreadable (Lisp_Object obj, Lisp_Object printcharfun, /* Types handled earlier. */ case PVEC_NORMAL_VECTOR: case PVEC_RECORD: - case PVEC_COMPILED: + case PVEC_CLOSURE: case PVEC_CHAR_TABLE: case PVEC_SUB_CHAR_TABLE: case PVEC_HASH_TABLE: @@ -2559,7 +2559,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) print_stack_push_vector ("#s(", ")", obj, 0, PVSIZE (obj), printcharfun); goto next_obj; - case PVEC_COMPILED: + case PVEC_CLOSURE: print_stack_push_vector ("#[", "]", obj, 0, PVSIZE (obj), printcharfun); goto next_obj; diff --git a/src/profiler.c b/src/profiler.c index 5a6a8b48f6b..ac23a97b672 100644 --- a/src/profiler.c +++ b/src/profiler.c @@ -170,7 +170,7 @@ trace_hash (Lisp_Object *trace, int depth) { Lisp_Object f = trace[i]; EMACS_UINT hash1 - = (COMPILEDP (f) ? XHASH (AREF (f, COMPILED_BYTECODE)) + = (CLOSUREP (f) ? XHASH (AREF (f, CLOSURE_CODE)) : (CONSP (f) && CONSP (XCDR (f)) && BASE_EQ (Qclosure, XCAR (f))) ? XHASH (XCDR (XCDR (f))) : XHASH (f)); hash = sxhash_combine (hash, hash1); @@ -675,8 +675,8 @@ the same lambda expression, or are really unrelated function. */) bool res; if (EQ (f1, f2)) res = true; - else if (COMPILEDP (f1) && COMPILEDP (f2)) - res = EQ (AREF (f1, COMPILED_BYTECODE), AREF (f2, COMPILED_BYTECODE)); + else if (CLOSUREP (f1) && CLOSUREP (f2)) + res = EQ (AREF (f1, CLOSURE_CODE), AREF (f2, CLOSURE_CODE)); else if (CONSP (f1) && CONSP (f2) && CONSP (XCDR (f1)) && CONSP (XCDR (f2)) && EQ (Qclosure, XCAR (f1)) && EQ (Qclosure, XCAR (f2))) commit 1e931f1c3db1588ba402d0eab60f03cc036f814a Author: Mattias Engdegård Date: Sun Apr 28 15:24:46 2024 +0200 * src/comp.c (comp_hash_string): Count bytes, not chars. diff --git a/src/comp.c b/src/comp.c index 99f51e07048..3ac6896aee1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -744,7 +744,7 @@ static Lisp_Object comp_hash_string (Lisp_Object string) { Lisp_Object digest = make_uninit_string (MD5_DIGEST_SIZE * 2); - md5_buffer (SSDATA (string), SCHARS (string), SSDATA (digest)); + md5_buffer (SSDATA (string), SBYTES (string), SSDATA (digest)); hexbuf_digest (SSDATA (digest), SDATA (digest), MD5_DIGEST_SIZE); return Fsubstring (digest, Qnil, make_fixnum (HASH_LENGTH)); commit 7341e600b7bc554df44784b6aa135bed8fcb61f1 Author: Po Lu Date: Sun Apr 28 21:30:52 2024 +0800 Implement dots and dashes on PGTK * src/image.c (image_create_bitmap_from_file) [HAVE_PGTK]: Remove unused variable. * src/pgtkterm.c (pgtk_draw_dash, pgtk_fill_underline) (pgtk_draw_glyph_string): New functions, ported from X. diff --git a/src/image.c b/src/image.c index ab61e49f695..b15d68bf9bf 100644 --- a/src/image.c +++ b/src/image.c @@ -766,7 +766,6 @@ image_create_bitmap_from_file (struct frame *f, Lisp_Object file) ptrdiff_t id, size; int fd, width, height, rc; char *contents, *data; - void *bitmap; if (!STRINGP (image_find_image_fd (file, &fd))) return -1; diff --git a/src/pgtkterm.c b/src/pgtkterm.c index 8441189ab8d..72bc636485a 100644 --- a/src/pgtkterm.c +++ b/src/pgtkterm.c @@ -53,7 +53,6 @@ along with GNU Emacs. If not, see . */ #include "termhooks.h" #include "termopts.h" #include "termchar.h" -#include "emacs-icon.h" #include "menu.h" #include "window.h" #include "keyboard.h" @@ -1239,7 +1238,7 @@ pgtk_set_glyph_string_gc (struct glyph_string *s) line or menu if we don't have X toolkit support. */ static void -pgtk_set_glyph_string_clipping (struct glyph_string *s, cairo_t * cr) +pgtk_set_glyph_string_clipping (struct glyph_string *s, cairo_t *cr) { XRectangle r[2]; int n = get_glyph_string_clip_rects (s, r, 2); @@ -1260,7 +1259,7 @@ pgtk_set_glyph_string_clipping (struct glyph_string *s, cairo_t * cr) static void pgtk_set_glyph_string_clipping_exactly (struct glyph_string *src, - struct glyph_string *dst, cairo_t * cr) + struct glyph_string *dst, cairo_t *cr) { dst->clip[0].x = src->x; dst->clip[0].y = src->y; @@ -2434,6 +2433,73 @@ pgtk_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. */ + +static void +pgtk_draw_dash (struct frame *f, struct glyph_string *s, + unsigned long foreground, int width, + char segment, int offset, int thickness) +{ + cairo_t *cr; + double cr_segment, y_center; + + cr = pgtk_begin_cr_clip (s->f); + pgtk_set_cr_source_with_color (f, foreground, false); + cr_segment = (double) segment; + y_center = s->ybase + offset + (thickness / 2.0); + + cairo_set_dash (cr, &cr_segment, 1, s->x); + cairo_set_line_width (cr, thickness); + cairo_move_to (cr, s->x, y_center); + cairo_line_to (cr, s->x + width, y_center); + cairo_stroke (cr); + pgtk_end_cr_clip (f); +} + +/* Draw an underline of STYLE onto F at an offset of POSITION from the + baseline of the glyph string S in the color provided by FOREGROUND, + DECORATION_WIDTH in length, and THICKNESS in height. */ + +static void +pgtk_fill_underline (struct frame *f, struct glyph_string *s, + unsigned long foreground, + enum face_underline_type style, int position, + int decoration_width, 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: + pgtk_fill_rectangle (f, foreground, s->x, s->ybase + position, + decoration_width, thickness, false); + break; + + case FACE_UNDERLINE_DOTS: + segment = thickness; + FALLTHROUGH; + + case FACE_UNDERLINE_DASHES: + pgtk_draw_dash (f, s, foreground, decoration_width, segment, + position, thickness); + break; + + case FACE_NO_UNDERLINE: + case FACE_UNDERLINE_WAVE: + default: + emacs_abort (); + } +} + static void pgtk_draw_glyph_string (struct glyph_string *s) { @@ -2553,17 +2619,14 @@ pgtk_draw_glyph_string (struct glyph_string *s) else pgtk_draw_underwave (s, s->face->underline_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; unsigned long 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 @@ -2619,15 +2682,14 @@ pgtk_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->xgcv.foreground; else foreground = s->face->underline_color; - pgtk_fill_rectangle (s->f, foreground, s->x, y, s->width, - thickness, false); + pgtk_fill_underline (s->f, s, foreground, s->face->underline, + position, s->width, thickness); /* Place a second underline above the first if this was requested in the face specification. */ @@ -2636,9 +2698,8 @@ pgtk_draw_glyph_string (struct glyph_string *s) { /* Compute the position of the second underline. */ position = position - thickness - 1; - y = s->ybase + position; - pgtk_fill_rectangle (s->f, foreground, s->x, y, s->width, - thickness, false); + pgtk_fill_underline (s->f, s, foreground, s->face->underline, + position, s->width, thickness); } } } commit 9d9881aceaefef56687baeb75eef94be1c7b22af Author: Po Lu Date: Sun Apr 28 12:57:33 2024 +0000 Implement dots and dashes on Haiku * src/doc.c (store_function_docstring): Re-enable loading doc strings of compiled functions from etc/DOC, which haiku-win, ns-win, and the like require. * src/haikuterm.c (haiku_draw_dash, haiku_fill_underline) (haiku_draw_text_decoration): Port underline code from X. diff --git a/src/doc.c b/src/doc.c index b5a9ed498af..10afda73458 100644 --- a/src/doc.c +++ b/src/doc.c @@ -517,11 +517,27 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) if (CONSP (fun) && EQ (XCAR (fun), Qmacro)) fun = XCDR (fun); /* Lisp_Subrs have a slot for it. */ - if (SUBRP (fun) && !SUBR_NATIVE_COMPILEDP (fun)) + if (SUBRP (fun)) XSUBR (fun)->doc = offset; + else if (COMPILEDP (fun)) + { + /* This bytecode object must have a slot for the docstring, since + we've found a docstring for it. */ + if (PVSIZE (fun) > COMPILED_DOC_STRING + /* Don't overwrite a non-docstring value placed there, such as + the symbols used for Oclosures. */ + && VALID_DOCSTRING_P (AREF (fun, COMPILED_DOC_STRING))) + ASET (fun, COMPILED_DOC_STRING, make_fixnum (offset)); + else + { + AUTO_STRING (format, "No doc string slot for compiled: %S"); + CALLN (Fmessage, format, obj); + } + } else { - AUTO_STRING (format, "Ignoring DOC string on non-subr: %S"); + AUTO_STRING (format, "Ignoring DOC string on non-compiled" + "non-subr: %S"); CALLN (Fmessage, format, obj); } } diff --git a/src/haikuterm.c b/src/haikuterm.c index 158ec68a44b..b960e36ef26 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -804,6 +804,86 @@ haiku_draw_underwave (struct glyph_string *s, int width, int x) BView_EndClip (view); } +/* 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. */ + +static void +haiku_draw_dash (struct frame *f, struct glyph_string *s, int width, + int segment, int offset, int thickness) +{ + int y_center, which, length, x, doffset; + void *view; + + /* Configure the thickness of the view's strokes. */ + view = FRAME_HAIKU_VIEW (s->f); + BView_SetPenSize (view, thickness); + + /* Offset the origin of the line by half the line width. */ + y_center = s->ybase + offset + thickness / 2; + + /* 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) + BView_StrokeLine (view, x, y_center, + min (x + length - 1, + s->x + width - 1), + y_center); + + which = !which; + } +} + +/* Draw an underline of STYLE onto F at an offset of POSITION from the + baseline of the glyph string S, S->WIDTH in length, and THICKNESS in + height. */ + +static void +haiku_fill_underline (struct frame *f, struct glyph_string *s, + enum face_underline_type style, int position, + int thickness) +{ + int segment; + void *view; + + segment = thickness * 3; + view = FRAME_HAIKU_VIEW (s->f); + + 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: + BView_FillRectangle (view, s->x, s->ybase + position, + s->width, thickness); + break; + + case FACE_UNDERLINE_DOTS: + segment = thickness; + FALLTHROUGH; + + case FACE_UNDERLINE_DASHES: + haiku_draw_dash (f, s, s->width, segment, position, thickness); + break; + + case FACE_NO_UNDERLINE: + case FACE_UNDERLINE_WAVE: + default: + emacs_abort (); + } +} + static void haiku_draw_text_decoration (struct glyph_string *s, struct face *face, int width, int x) @@ -829,15 +909,13 @@ haiku_draw_text_decoration (struct glyph_string *s, struct face *face, if (face->underline == FACE_UNDERLINE_WAVE) haiku_draw_underwave (s, width, x); - else if (face->underline == FACE_UNDERLINE_SINGLE - || face->underline == FACE_UNDERLINE_DOUBLE_LINE) + else if (face->underline >= FACE_UNDERLINE_SINGLE) { unsigned long thickness, position; - int y; 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 @@ -910,9 +988,9 @@ haiku_draw_text_decoration (struct glyph_string *s, struct face *face, thickness = (s->y + s->height) - (s->ybase + position); s->underline_thickness = thickness; s->underline_position = position; - y = s->ybase + position; - BView_FillRectangle (view, s->x, y, s->width, thickness); + haiku_fill_underline (view, s, s->face->underline, + position, thickness); /* Place a second underline above the first if this was requested in the face specification. */ @@ -921,8 +999,8 @@ haiku_draw_text_decoration (struct glyph_string *s, struct face *face, { /* Compute the position of the second underline. */ position = position - thickness - 1; - y = s->ybase + position; - BView_FillRectangle (view, s->x, y, s->width, thickness); + haiku_fill_underline (view, s, s->face->underline, + position, thickness); } } } commit 94a9e41a9d333f946b74b175a8a7133595498805 Author: Po Lu Date: Sun Apr 28 11:52:27 2024 +0000 Fix the Haiku build * src/haikuterm.c (haiku_draw_text_decoration): Remove stray closing parenthesis. diff --git a/src/haikuterm.c b/src/haikuterm.c index 4a03c4cb2d5..158ec68a44b 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -830,7 +830,7 @@ haiku_draw_text_decoration (struct glyph_string *s, struct face *face, if (face->underline == FACE_UNDERLINE_WAVE) haiku_draw_underwave (s, width, x); else if (face->underline == FACE_UNDERLINE_SINGLE - || face->underline == FACE_UNDERLINE_DOUBLE_LINE)) + || face->underline == FACE_UNDERLINE_DOUBLE_LINE) { unsigned long thickness, position; int y; commit e658a6938e3b7a8a7c0be8b74fbd885787c26df6 Author: Po Lu Date: Sun Apr 28 16:58:58 2024 +0800 Implement dots and dashes on Android * java/org/gnu/emacs/EmacsDrawLine.java (EmacsDrawLine) (measureLine, polyDashPattern): New function. (perform): Delegate to polyDashPattern if the line style is not LineSolid. Also simplify now that anti-aliasing need no longer be taken into account. * java/org/gnu/emacs/EmacsDrawRectangle.java (perform): Mention omission in commentary. * java/org/gnu/emacs/EmacsGC.java (EmacsGC): Disable anti-aliasing in default paint object. : New fields. (markDirty): Apply stroke width. * src/android.c (android_init_emacs_gc_class): Initialize new fields. (android_create_gc, android_free_gc, android_change_gc) (android_set_dashes, android_get_gc_values): * src/androidgui.h (enum android_line_style) (enum android_gc_value_mask, struct android_gc): Introduce line style, width, dash offset and dash GC attributes. * src/androidterm.c (android_draw_dash, android_fill_underline) (android_draw_glyph_string): Port from X. * src/xterm.c (x_draw_dash): Delete redundant code. diff --git a/java/org/gnu/emacs/EmacsDrawLine.java b/java/org/gnu/emacs/EmacsDrawLine.java index 61b7d54d63c..a49fe96c26e 100644 --- a/java/org/gnu/emacs/EmacsDrawLine.java +++ b/java/org/gnu/emacs/EmacsDrawLine.java @@ -25,6 +25,97 @@ public final class EmacsDrawLine { + /* Return the normalized slope and magnitude of a line whose extrema + are DX and DY removed, on the X and Y axes respectively, from its + origin point. */ + + private static float[] + measureLine (float dx, float dy) + { + float hypot; + + if (dx == 0f && dy == 0f) + return new float[] { 0f, 0f, 0f, }; + + if (dx == 0f) + return new float[] { 0f, dy > 0f ? 1f : -1f, Math.abs (dy), }; + else if (dy == 0f) + return new float[] { dx > 0f ? 1f : -1f, 0f, Math.abs (dx), }; + else + { + hypot = (float) Math.hypot (dx, dy); + return new float[] { dx / hypot, dy / hypot, hypot, }; + } + } + + private static void + polyDashPattern (EmacsGC gc, Canvas canvas, Paint paint, float x0, + float y0, float x1, float y1) + { + int patternTotal, i, offset; + float dx, dy, mag, dash_mag, rem, lx1, ly1; + float[] measured; + boolean which; + + /* Compute the total length of this pattern. */ + patternTotal = 0; + for (i = 0; i < gc.dashes.length; ++i) + patternTotal += gc.dashes[i]; + if ((gc.dashes.length & 1) != 0) + patternTotal += patternTotal; + + /* Subtract as much of the offset as does not contribute to the + phase at the first pixel of the line. */ + offset = gc.dash_offset % patternTotal; + + /* Set I to the first dash that ought to be drawn and WHICH to its + phase. */ + i = 0; + which = true; + while (offset >= gc.dashes[i]) + { + offset -= gc.dashes[i++]; + if (i >= gc.dashes.length) + i = 0; + which = !which; + } + + /* Compute the length of the first visible segment. */ + dash_mag = gc.dashes[i] - offset; + + /* Compute the slope of the line. */ + dx = x1 - x0; + dy = y1 - y0; + measured = measureLine (dx, dy); + dx = measured[0]; + dy = measured[1]; + rem = mag = measured[2]; + lx1 = x0; + ly1 = y0; + + while (rem > 0f) + { + dash_mag = Math.min (dash_mag, rem); + rem -= dash_mag; + + /* End of this segment. */ + x1 = (mag - rem) * dx + x0; + y1 = (mag - rem) * dy + y0; + + if (which) + canvas.drawLine (lx1, ly1, x1, y1, paint); + which = !which; + + /* Start of the next segment. */ + lx1 = x1; + ly1 = y1; + i++; + if (i >= gc.dashes.length) + i = 0; + dash_mag = gc.dashes[i]; + } + } + public static void perform (EmacsDrawable drawable, EmacsGC gc, int x, int y, int x2, int y2) @@ -52,22 +143,20 @@ public final class EmacsDrawLine if (canvas == null) return; - paint.setStyle (Paint.Style.FILL); - /* Since drawLine has PostScript style behavior, adjust the coordinates appropriately. - The left most pixel of a straight line is always partially - filled. Patch it in manually. */ + The leftmost pixel of a straight line is always partially filled. + Patch it in manually. */ if (gc.clip_mask == null) { - canvas.drawLine ((float) x + 0.5f, (float) y + 0.5f, - (float) x2 + 0.5f, (float) y2 + 0.5f, - paint); - - if (x2 > x) - canvas.drawRect (new Rect (x, y, x + 1, y + 1), paint); + if (gc.line_style != EmacsGC.GC_LINE_ON_OFF_DASH) + canvas.drawLine ((float) x, (float) y, (float) x2, (float) y2, + paint); + else + polyDashPattern (gc, canvas, paint, (float) x, (float) y, + (float) x2, (float) y2); } /* DrawLine with clip mask not implemented; it is not used by diff --git a/java/org/gnu/emacs/EmacsDrawRectangle.java b/java/org/gnu/emacs/EmacsDrawRectangle.java index a8f68c6530a..e40a7c16068 100644 --- a/java/org/gnu/emacs/EmacsDrawRectangle.java +++ b/java/org/gnu/emacs/EmacsDrawRectangle.java @@ -52,6 +52,9 @@ public final class EmacsDrawRectangle paint = gc.gcPaint; paint.setStyle (Paint.Style.STROKE); + /* This graphics request, in contrast to X, does not presently + respect the GC's line style. */ + if (gc.clip_mask == null) /* Use canvas.drawRect with a RectF. That seems to reliably get PostScript behavior. */ diff --git a/java/org/gnu/emacs/EmacsGC.java b/java/org/gnu/emacs/EmacsGC.java index b2474c5bd76..ec2b9c9e475 100644 --- a/java/org/gnu/emacs/EmacsGC.java +++ b/java/org/gnu/emacs/EmacsGC.java @@ -46,12 +46,17 @@ public final class EmacsGC extends EmacsHandleObject public static final int GC_FILL_SOLID = 0; public static final int GC_FILL_OPAQUE_STIPPLED = 1; + public static final int GC_LINE_SOLID = 0; + public static final int GC_LINE_ON_OFF_DASH = 1; + public static final Xfermode xorAlu, srcInAlu; public int function, fill_style; public int foreground, background; public int clip_x_origin, clip_y_origin; public int ts_origin_x, ts_origin_y; + public int line_style, line_width; + public int dashes[], dash_offset; public Rect clip_rects[], real_clip_rects[]; public EmacsPixmap clip_mask, stipple; public Paint gcPaint; @@ -89,6 +94,10 @@ public final class EmacsGC extends EmacsHandleObject foreground = 0; background = 0xffffff; gcPaint = new Paint (); + + /* Android S and above enable anti-aliasing unless explicitly told + otherwise. */ + gcPaint.setAntiAlias (false); } /* Mark this GC as dirty. Apply parameters to the paint and @@ -119,7 +128,8 @@ public final class EmacsGC extends EmacsHandleObject clipRectID = ++clip_serial; } - gcPaint.setStrokeWidth (1f); + /* A line_width of 0 is equivalent to that of 1. */ + gcPaint.setStrokeWidth (line_width < 1 ? 1 : line_width); gcPaint.setColor (foreground | 0xff000000); gcPaint.setXfermode (function == GC_XOR ? xorAlu : srcInAlu); diff --git a/src/android.c b/src/android.c index 00a77fc398d..2777add5059 100644 --- a/src/android.c +++ b/src/android.c @@ -177,7 +177,9 @@ static jfieldID emacs_gc_function, emacs_gc_clip_rects; static jfieldID emacs_gc_clip_x_origin, emacs_gc_clip_y_origin; static jfieldID emacs_gc_stipple, emacs_gc_clip_mask; static jfieldID emacs_gc_fill_style, emacs_gc_ts_origin_x; -static jfieldID emacs_gc_ts_origin_y; +static jfieldID emacs_gc_ts_origin_y, emacs_gc_line_style; +static jfieldID emacs_gc_line_width, emacs_gc_dash_offset; +static jfieldID emacs_gc_dashes; /* The constructor and one function. */ static jmethodID emacs_gc_constructor, emacs_gc_mark_dirty; @@ -3254,6 +3256,22 @@ android_init_emacs_gc_class (void) = (*android_java_env)->GetFieldID (android_java_env, emacs_gc_class, "ts_origin_y", "I"); + emacs_gc_line_style + = (*android_java_env)->GetFieldID (android_java_env, + emacs_gc_class, + "line_style", "I"); + emacs_gc_line_width + = (*android_java_env)->GetFieldID (android_java_env, + emacs_gc_class, + "line_width", "I"); + emacs_gc_dash_offset + = (*android_java_env)->GetFieldID (android_java_env, + emacs_gc_class, + "dash_offset", "I"); + emacs_gc_dashes + = (*android_java_env)->GetFieldID (android_java_env, + emacs_gc_class, + "dashes", "[I"); } struct android_gc * @@ -3285,6 +3303,11 @@ android_create_gc (enum android_gc_value_mask mask, gc->stipple = ANDROID_NONE; gc->ts_x_origin = 0; gc->ts_y_origin = 0; + gc->line_style = ANDROID_LINE_SOLID; + gc->line_width = 0; + gc->dash_offset = 0; + gc->dashes = NULL; + gc->n_segments = 0; if (!gc->gcontext) { @@ -3323,6 +3346,7 @@ android_free_gc (struct android_gc *gc) { android_destroy_handle (gc->gcontext); + xfree (gc->dashes); xfree (gc->clip_rects); xfree (gc); } @@ -3332,7 +3356,7 @@ android_change_gc (struct android_gc *gc, enum android_gc_value_mask mask, struct android_gc_values *values) { - jobject what, gcontext; + jobject what, gcontext, array; jboolean clip_changed; clip_changed = false; @@ -3448,6 +3472,59 @@ android_change_gc (struct android_gc *gc, gc->ts_y_origin = values->ts_y_origin; } + if (mask & ANDROID_GC_LINE_STYLE) + { + (*android_java_env)->SetIntField (android_java_env, + gcontext, + emacs_gc_line_style, + values->line_style); + gc->line_style = values->line_style; + } + + if (mask & ANDROID_GC_LINE_WIDTH) + { + (*android_java_env)->SetIntField (android_java_env, + gcontext, + emacs_gc_line_width, + values->line_width); + gc->line_width = values->line_width; + } + + if (mask & ANDROID_GC_DASH_OFFSET) + { + (*android_java_env)->SetIntField (android_java_env, + gcontext, + emacs_gc_dash_offset, + values->dash_offset); + gc->dash_offset = values->dash_offset; + } + + if (mask & ANDROID_GC_DASH_LIST) + { + /* Compare the new dash pattern with the old. */ + if (gc->dashes && gc->n_segments == 1 + && gc->dashes[0] == values->dash) + /* If they be identical, nothing needs to change. */ + mask &= ~ANDROID_GC_DASH_LIST; + else + { + if (gc->n_segments != 1) + gc->dashes = xrealloc (gc->dashes, sizeof *gc->dashes); + gc->n_segments = 1; + gc->dashes[0] = values->dash; + array = (*android_java_env)->NewIntArray (android_java_env, 1); + android_exception_check (); + (*android_java_env)->SetIntArrayRegion (android_java_env, + array, 0, 1, + (jint *) &values->dash); + (*android_java_env)->SetObjectField (android_java_env, + gcontext, + emacs_gc_dashes, + array); + ANDROID_DELETE_LOCAL_REF (array); + } + } + if (mask) { (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, @@ -3539,6 +3616,75 @@ android_set_clip_rectangles (struct android_gc *gc, int clip_x_origin, n_clip_rects * sizeof *gc->clip_rects); } +void +android_set_dashes (struct android_gc *gc, int dash_offset, + int *dash_list, int n) +{ + int i; + jobject array, gcontext; + + gcontext = android_resolve_handle (gc->gcontext, + ANDROID_HANDLE_GCONTEXT); + + if (n == gc->n_segments + && (!gc->dashes || !memcmp (gc->dashes, dash_list, + sizeof *dash_list * n))) + /* No change in the dash list. */ + goto set_offset; + + if (!n) + { + /* Reset the dash list to its initial empty state. */ + xfree (gc->dashes); + gc->dashes = NULL; + array = NULL; + } + else + { + /* If the size of the array has not changed, it can be reused. */ + + if (n != gc->n_segments) + { + gc->dashes = xrealloc (gc->dashes, sizeof *gc->dashes * n); + array = (*android_java_env)->NewIntArray (android_java_env, n); + android_exception_check (); + } + else + array = (*android_java_env)->GetObjectField (android_java_env, + gcontext, + emacs_gc_dashes); + + /* Copy the list of segments into both arrays. */ + for (i = 0; i < n; ++i) + gc->dashes[i] = dash_list[i]; + verify (sizeof (int) == sizeof (jint)); + (*android_java_env)->SetIntArrayRegion (android_java_env, + array, 0, n, + (jint *) dash_list); + } + + /* Replace the dash array in the GContext object if required. */ + if (n != gc->n_segments) + { + (*android_java_env)->SetObjectField (android_java_env, + gcontext, + emacs_gc_dashes, + array); + ANDROID_DELETE_LOCAL_REF (array); + } + + gc->n_segments = n; + + set_offset: + /* And the offset. */ + if (dash_offset != gc->dash_offset) + (*android_java_env)->SetIntField (android_java_env, + gcontext, + emacs_gc_dash_offset, + dash_offset); + gc->dash_offset = dash_offset; +} + void android_reparent_window (android_window w, android_window parent_handle, int x, int y) @@ -3690,7 +3836,8 @@ android_get_gc_values (struct android_gc *gc, values->ts_y_origin = gc->ts_y_origin; /* Fields involving handles are not used by Emacs, and thus not - implemented */ + implemented. In addition, the size of GCClipMask and GCDashList is + not static, precluding their retrieval. */ } void diff --git a/src/androidgui.h b/src/androidgui.h index f941c7cc577..5e4f6ec3989 100644 --- a/src/androidgui.h +++ b/src/androidgui.h @@ -71,6 +71,10 @@ enum android_gc_value_mask ANDROID_GC_FILL_STYLE = (1 << 7), ANDROID_GC_TILE_STIP_X_ORIGIN = (1 << 8), ANDROID_GC_TILE_STIP_Y_ORIGIN = (1 << 9), + ANDROID_GC_LINE_STYLE = (1 << 10), + ANDROID_GC_LINE_WIDTH = (1 << 11), + ANDROID_GC_DASH_LIST = (1 << 12), + ANDROID_GC_DASH_OFFSET = (1 << 13), }; enum android_fill_style @@ -79,6 +83,12 @@ enum android_fill_style ANDROID_FILL_OPAQUE_STIPPLED = 1, }; +enum android_line_style + { + ANDROID_LINE_SOLID = 0, + ANDROID_LINE_ON_OFF_DASH = 1, + }; + enum android_window_value_mask { ANDROID_CW_BACK_PIXEL = (1 << 1), @@ -114,6 +124,18 @@ struct android_gc_values /* The tile-stipple X and Y origins. */ int ts_x_origin, ts_y_origin; + + /* The line style. */ + enum android_line_style line_style; + + /* The line width. */ + int line_width; + + /* Offset in pixels into the dash pattern specified below. */ + int dash_offset; + + /* One integer providing both segments of a even-odd dash pattern. */ + int dash; }; /* X-like graphics context structure. This is implemented in @@ -152,6 +174,18 @@ struct android_gc /* The tile-stipple X and Y origins. */ int ts_x_origin, ts_y_origin; + + /* The line style. */ + enum android_line_style line_style; + + /* The line width. */ + int line_width; + + /* Offset in pixels into the dash pattern specified below. */ + int dash_offset; + + /* The segments of an even/odd dash pattern. */ + int *dashes, n_segments; }; enum android_swap_action @@ -675,6 +709,7 @@ extern void android_set_clip_rectangles (struct android_gc *, int, int, struct android_rectangle *, int); +extern void android_set_dashes (struct android_gc *, int, int *, int); extern void android_change_gc (struct android_gc *, enum android_gc_value_mask, struct android_gc_values *); diff --git a/src/androidterm.c b/src/androidterm.c index 25b7fa97ebc..4549941ee2e 100644 --- a/src/androidterm.c +++ b/src/androidterm.c @@ -4031,6 +4031,80 @@ android_draw_glyphless_glyph_string_foreground (struct glyph_string *s) s->char2b = NULL; } +/* 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. */ + +static void +android_draw_dash (struct frame *f, struct glyph_string *s, int width, + int segment, int offset, int thickness) +{ + struct android_gc *gc; + struct android_gc_values gcv; + int y_center; + + /* Configure the GC, the dash pattern and a suitable offset. */ + gc = s->gc; + + gcv.line_style = ANDROID_LINE_ON_OFF_DASH; + gcv.line_width = thickness; + android_change_gc (s->gc, (ANDROID_GC_LINE_STYLE + | ANDROID_GC_LINE_WIDTH), &gcv); + android_set_dashes (s->gc, s->x, &segment, 1); + + /* Offset the origin of the line by half the line width. */ + y_center = s->ybase + offset + thickness / 2; + android_draw_line (FRAME_ANDROID_WINDOW (f), gc, + s->x, y_center, s->x + width, y_center); + + /* Restore the initial line style. */ + gcv.line_style = ANDROID_LINE_SOLID; + gcv.line_width = 1; + android_change_gc (s->gc, (ANDROID_GC_LINE_STYLE + | ANDROID_GC_LINE_WIDTH), &gcv); +} + +/* Draw an underline of STYLE onto F at an offset of POSITION from the + baseline of the glyph string S, DECORATION_WIDTH in length, and + THICKNESS in height. */ + +static void +android_fill_underline (struct frame *f, struct glyph_string *s, + enum face_underline_type style, int position, + int decoration_width, 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: + android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), + s->gc, s->x, s->ybase + position, + decoration_width, thickness); + break; + + case FACE_UNDERLINE_DOTS: + segment = thickness; + FALLTHROUGH; + + case FACE_UNDERLINE_DASHES: + android_draw_dash (f, s, decoration_width, segment, position, + thickness); + break; + + case FACE_NO_UNDERLINE: + case FACE_UNDERLINE_WAVE: + default: + emacs_abort (); + } +} + static void android_draw_glyph_string (struct glyph_string *s) { @@ -4167,16 +4241,13 @@ android_draw_glyph_string (struct glyph_string *s) android_set_foreground (s->gc, xgcv.foreground); } } - 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; 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 @@ -4257,18 +4328,16 @@ android_draw_glyph_string (struct glyph_string *s) { struct android_gc_values xgcv; - y = s->ybase + position; - if (s->face->underline_defaulted_p) - android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc, - s->x, y, decoration_width, thickness); - else + if (!s->face->underline_defaulted_p) { android_get_gc_values (s->gc, ANDROID_GC_FOREGROUND, &xgcv); android_set_foreground (s->gc, s->face->underline_color); - android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc, - s->x, y, decoration_width, thickness); } + android_fill_underline (s->f, s, s->face->underline, + position, decoration_width, + thickness); + /* Place a second underline above the first if this was requested in the face specification. */ @@ -4276,9 +4345,8 @@ android_draw_glyph_string (struct glyph_string *s) { /* Compute the position of the second underline. */ position = position - thickness - 1; - y = s->ybase + position; - android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), - s->gc, s->x, y, decoration_width, + android_fill_underline (s->f, s, s->face->underline, + position, decoration_width, thickness); } diff --git a/src/xterm.c b/src/xterm.c index 505a3d9360a..93d347a77ef 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10851,7 +10851,6 @@ x_draw_dash (struct frame *f, struct glyph_string *s, int width, gc = s->gc; display = FRAME_X_DISPLAY (f); - XGetGCValues (display, s->gc, GCLineStyle, &gcv); gcv.line_style = LineOnOffDash; gcv.line_width = thickness; XChangeGC (display, s->gc, GCLineStyle | GCLineWidth, &gcv); commit b329358334712671de38f919c99d1434026aa8f2 Author: Eli Zaretskii Date: Sun Apr 28 11:52:09 2024 +0300 Fix the MS-Windows build broken by a recent commit * src/w32term.c (w32_draw_glyph_string): Move 'foreground' declaration to where it belongs. diff --git a/src/w32term.c b/src/w32term.c index a0037e6e090..64dbafab3fd 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -2657,6 +2657,7 @@ w32_draw_glyph_string (struct glyph_string *s) { unsigned long thickness, position; int y; + COLORREF foreground; if (s->prev && ((s->prev->face->underline == FACE_UNDERLINE_SINGLE) @@ -2679,7 +2680,6 @@ w32_draw_glyph_string (struct glyph_string *s) BOOL use_underline_position_properties; Lisp_Object val = (WINDOW_BUFFER_LOCAL_VALUE (Qunderline_minimum_offset, s->w)); - COLORREF foreground; if (FIXNUMP (val)) minimum_offset = max (0, XFIXNUM (val)); commit ae9c76e588e5f64bfe1517a910d2cd6f54e9975a Author: Po Lu Date: Sun Apr 28 12:03:07 2024 +0800 Fix Android build * src/androidterm.c (android_draw_glyph_string): Omit extraneous argument to android_fill_rectangle. diff --git a/src/androidterm.c b/src/androidterm.c index 9f25c507a23..25b7fa97ebc 100644 --- a/src/androidterm.c +++ b/src/androidterm.c @@ -4279,7 +4279,7 @@ android_draw_glyph_string (struct glyph_string *s) y = s->ybase + position; android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc, s->x, y, decoration_width, - thickness, false); + thickness); } if (!s->face->underline_defaulted_p) commit e844b81c56d74aa2b2efa0ce98ed3de71647e656 Author: Po Lu Date: Thu Jan 1 00:00:00 1970 +0000 Implement dots and dashes on X * src/dispextern.h (enum face_underline_type): Indent and expand commentary as to the new dependency on the order of its enumerals. * src/xfaces.c (realize_gui_face): Enable dots and dashes on window systems. * src/xterm.c (x_draw_underwave): Don't define unused variable on Cairo builds. (x_draw_dash): New function; implement for X and Cairo. (x_fill_underline): New function. Delegate to x_fill_rectangle or x_draw_dash as appropriate. (x_draw_glyph_string): Call x_fill_underline rather than x_fill_rectangle. diff --git a/src/dispextern.h b/src/dispextern.h index 1614a044cbf..93cbde6583d 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -1697,7 +1697,9 @@ enum face_box_type enum face_underline_type { - /* Note: Order matches the order of the Smulx terminfo extension. */ + /* Note: order matches the order of the Smulx terminfo extension, and + is also relied on to remain in its present order by + x_draw_glyph_string and company. */ FACE_NO_UNDERLINE = 0, FACE_UNDERLINE_SINGLE, FACE_UNDERLINE_DOUBLE_LINE, diff --git a/src/xfaces.c b/src/xfaces.c index d9ee82c8e7f..56d067ade5b 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -6404,12 +6404,10 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] face->underline = FACE_UNDERLINE_DOUBLE_LINE; else if (EQ (value, Qwave)) face->underline = FACE_UNDERLINE_WAVE; -#if 0 else if (EQ (value, Qdots)) face->underline = FACE_UNDERLINE_DOTS; else if (EQ (value, Qdashes)) face->underline = FACE_UNDERLINE_DASHES; -#endif /* 0 */ else face->underline = FACE_UNDERLINE_SINGLE; } diff --git a/src/xterm.c b/src/xterm.c index 9b014a7d0e4..505a3d9360a 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10764,13 +10764,11 @@ x_get_scale_factor (struct x_display_info *dpyinfo, static void x_draw_underwave (struct glyph_string *s, int decoration_width) { - Display *display; struct x_display_info *dpyinfo; /* Adjust for scale/HiDPI. */ int scale_x, scale_y; dpyinfo = FRAME_DISPLAY_INFO (s->f); - display = dpyinfo->display; x_get_scale_factor (dpyinfo, &scale_x, &scale_y); int wave_height = 3 * scale_y, wave_length = 2 * scale_x; @@ -10779,6 +10777,7 @@ x_draw_underwave (struct glyph_string *s, int decoration_width) x_draw_horizontal_wave (s->f, s->gc, s->x, s->ybase - wave_height + 3, decoration_width, wave_height, wave_length); #else /* not USE_CAIRO */ + Display *display; int dx, dy, x0, y0, width, x1, y1, x2, y2, xmax, thickness = scale_y;; bool odd; XRectangle wave_clip, string_clip, final_clip; @@ -10801,6 +10800,7 @@ x_draw_underwave (struct glyph_string *s, int decoration_width) if (!gui_intersect_rectangles (&wave_clip, &string_clip, &final_clip)) return; + display = dpyinfo->display; XSetClipRectangles (display, s->gc, 0, 0, &final_clip, 1, Unsorted); /* Draw the waves */ @@ -10833,6 +10833,98 @@ x_draw_underwave (struct glyph_string *s, int decoration_width) #endif /* not USE_CAIRO */ } +/* 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. */ + +static void +x_draw_dash (struct frame *f, struct glyph_string *s, int width, + char segment, int offset, int thickness) +{ +#ifndef USE_CAIRO + GC gc; + Display *display; + XGCValues gcv; + int y_center; + + /* Configure the GC, the dash pattern and a suitable offset. */ + gc = s->gc; + display = FRAME_X_DISPLAY (f); + + XGetGCValues (display, s->gc, GCLineStyle, &gcv); + gcv.line_style = LineOnOffDash; + gcv.line_width = thickness; + XChangeGC (display, s->gc, GCLineStyle | GCLineWidth, &gcv); + XSetDashes (display, s->gc, s->x, &segment, 1); + + /* Offset the origin of the line by half the line width. */ + y_center = s->ybase + offset + thickness / 2; + XDrawLine (display, FRAME_X_DRAWABLE (f), gc, + s->x, y_center, s->x + width, y_center); + + /* Restore the initial line style. */ + gcv.line_style = LineSolid; + gcv.line_width = 1; + XChangeGC (display, s->gc, GCLineStyle | GCLineWidth, &gcv); +#else /* USE_CAIRO */ + cairo_t *cr; + double cr_segment, y_center; + + cr = x_begin_cr_clip (f, s->gc); + cr_segment = (double) segment; + y_center = s->ybase + offset + (thickness / 2.0); + + x_set_cr_source_with_gc_foreground (f, s->gc, false); + cairo_set_dash (cr, &cr_segment, 1, s->x); + cairo_set_line_width (cr, thickness); + cairo_move_to (cr, s->x, y_center); + cairo_line_to (cr, s->x + width, y_center); + cairo_stroke (cr); + x_end_cr_clip (f); +#endif /* USE_CAIRO */ +} + +/* Draw an underline of STYLE onto F at an offset of POSITION from the + baseline of the glyph string S, DECORATION_WIDTH in length, and + THICKNESS in height. */ + +static void +x_fill_underline (struct frame *f, struct glyph_string *s, + enum face_underline_type style, int position, + int decoration_width, int thickness) +{ + int segment; + char x_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: + x_fill_rectangle (f, s->gc, s->x, s->ybase + position, + decoration_width, thickness, false); + break; + + case FACE_UNDERLINE_DOTS: + segment = thickness; + FALLTHROUGH; + + case FACE_UNDERLINE_DASHES: + x_segment = min (segment, CHAR_MAX); + x_draw_dash (f, s, decoration_width, x_segment, position, + thickness); + break; + + case FACE_NO_UNDERLINE: + case FACE_UNDERLINE_WAVE: + default: + emacs_abort (); + } +} /* Draw glyph string S. */ @@ -10973,16 +11065,13 @@ x_draw_glyph_string (struct glyph_string *s) XSetForeground (display, s->gc, xgcv.foreground); } } - 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; 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 @@ -11064,20 +11153,16 @@ x_draw_glyph_string (struct glyph_string *s) Display *display = FRAME_X_DISPLAY (s->f); XGCValues xgcv; - y = s->ybase + position; - if (s->face->underline_defaulted_p) - x_fill_rectangle (s->f, s->gc, - s->x, y, decoration_width, thickness, - false); - else + if (!s->face->underline_defaulted_p) { XGetGCValues (display, s->gc, GCForeground, &xgcv); XSetForeground (display, s->gc, s->face->underline_color); - x_fill_rectangle (s->f, s->gc, - s->x, y, decoration_width, thickness, - false); } + x_fill_underline (s->f, s, s->face->underline, + position, decoration_width, + thickness); + /* Place a second underline above the first if this was requested in the face specification. */ @@ -11085,9 +11170,9 @@ x_draw_glyph_string (struct glyph_string *s) { /* Compute the position of the second underline. */ position = position - thickness - 1; - y = s->ybase + position; - x_fill_rectangle (s->f, s->gc, s->x, y, decoration_width, - thickness, false); + x_fill_underline (s->f, s, s->face->underline, + position, decoration_width, + thickness); } if (!s->face->underline_defaulted_p) commit 77a170a175dfeb17dab23e41668b8497b8b3b9d7 Author: Po Lu Date: Thu Jan 1 00:00:00 1970 +0000 Port double-line underlines to GUI systems * src/xterm.c (x_get_scale_factor): Replace display in first argument with a pointer to dpyinfo. (x_draw_underwave): Adjust to match. (x_draw_glyph_string): Implement double-line underlines. * src/androidterm.c (android_get_scale_factor) (android_draw_glyph_string): * src/haikuterm.c (haiku_draw_text_decoration): * src/nsterm.m (ns_draw_text_decoration): * src/pgtkterm.c (pgtk_draw_glyph_string): * src/w32term.c (w32_draw_glyph_string): Synchronize with X. * src/xfaces.c (realize_gui_face): Enable `double-line' on window systems. diff --git a/src/androidterm.c b/src/androidterm.c index f5173168785..9f25c507a23 100644 --- a/src/androidterm.c +++ b/src/androidterm.c @@ -3740,19 +3740,15 @@ static void android_get_scale_factor (int *scale_x, int *scale_y) { /* This is 96 everywhere else, but 160 on Android. */ - const int base_res = 160; - struct android_display_info *dpyinfo; + int base_res = 160; - dpyinfo = x_display_list; *scale_x = *scale_y = 1; + eassert (x_display_list); - if (dpyinfo) - { - if (dpyinfo->resx > base_res) - *scale_x = floor (dpyinfo->resx / base_res); - if (dpyinfo->resy > base_res) - *scale_y = floor (dpyinfo->resy / base_res); - } + if (x_display_list->resx > base_res) + *scale_x = floor (x_display_list->resx / base_res); + if (x_display_list->resy > base_res) + *scale_y = floor (x_display_list->resy / base_res); } static void @@ -4171,13 +4167,16 @@ android_draw_glyph_string (struct glyph_string *s) android_set_foreground (s->gc, xgcv.foreground); } } - else if (s->face->underline == FACE_UNDERLINE_SINGLE) + else if (s->face->underline == FACE_UNDERLINE_SINGLE + || s->face->underline == FACE_UNDERLINE_DOUBLE_LINE) { unsigned long thickness, position; int y; if (s->prev - && s->prev->face->underline == FACE_UNDERLINE_SINGLE + && ((s->prev->face->underline == FACE_UNDERLINE_SINGLE) + || (s->prev->face->underline + == FACE_UNDERLINE_DOUBLE_LINE)) && (s->prev->face->underline_at_descent_line_p == s->face->underline_at_descent_line_p) && (s->prev->face->underline_pixels_above_descent_line @@ -4254,19 +4253,38 @@ android_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) - android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc, - s->x, y, decoration_width, thickness); - else - { - struct android_gc_values xgcv; - android_get_gc_values (s->gc, ANDROID_GC_FOREGROUND, &xgcv); - android_set_foreground (s->gc, s->face->underline_color); - android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc, + + { + struct android_gc_values xgcv; + + y = s->ybase + position; + if (s->face->underline_defaulted_p) + android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc, s->x, y, decoration_width, thickness); - android_set_foreground (s->gc, xgcv.foreground); - } + else + { + android_get_gc_values (s->gc, ANDROID_GC_FOREGROUND, &xgcv); + android_set_foreground (s->gc, s->face->underline_color); + android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc, + s->x, y, decoration_width, thickness); + } + + /* Place a second underline above the first if this was + requested in the face specification. */ + + if (s->face->underline == FACE_UNDERLINE_DOUBLE_LINE) + { + /* Compute the position of the second underline. */ + position = position - thickness - 1; + y = s->ybase + position; + android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), + s->gc, s->x, y, decoration_width, + thickness, false); + } + + if (!s->face->underline_defaulted_p) + android_set_foreground (s->gc, xgcv.foreground); + } } } /* Draw overline. */ diff --git a/src/haikuterm.c b/src/haikuterm.c index c3971bf6fe4..4a03c4cb2d5 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -829,13 +829,15 @@ haiku_draw_text_decoration (struct glyph_string *s, struct face *face, if (face->underline == FACE_UNDERLINE_WAVE) haiku_draw_underwave (s, width, x); - else if (face->underline == FACE_UNDERLINE_SINGLE) + else if (face->underline == FACE_UNDERLINE_SINGLE + || face->underline == FACE_UNDERLINE_DOUBLE_LINE)) { unsigned long thickness, position; int y; if (s->prev - && s->prev->face->underline == FACE_UNDERLINE_SINGLE + && (s->prev->face->underline == FACE_UNDERLINE_SINGLE + || s->prev->face->underline == FACE_UNDERLINE_DOUBLE_LINE) && (s->prev->face->underline_at_descent_line_p == s->face->underline_at_descent_line_p) && (s->prev->face->underline_pixels_above_descent_line @@ -911,6 +913,17 @@ haiku_draw_text_decoration (struct glyph_string *s, struct face *face, y = s->ybase + position; BView_FillRectangle (view, s->x, y, s->width, thickness); + + /* Place a second underline above the first if this was + requested in the face specification. */ + + if (s->face->underline == FACE_UNDERLINE_DOUBLE_LINE) + { + /* Compute the position of the second underline. */ + position = position - thickness - 1; + y = s->ybase + position; + BView_FillRectangle (view, s->x, y, s->width, thickness); + } } } diff --git a/src/nsterm.m b/src/nsterm.m index 84d94b5be74..bd4010f2844 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -3337,7 +3337,8 @@ Note that CURSOR_WIDTH is meaningful only for (h)bar cursors. ns_draw_underwave (s, width, x); } - else if (s->face->underline == FACE_UNDERLINE_SINGLE) + else if (s->face->underline == FACE_UNDERLINE_SINGLE + || s->face->underline == FACE_UNDERLINE_DOUBLE_LINE) { NSRect r; @@ -3345,7 +3346,9 @@ Note that CURSOR_WIDTH is meaningful only for (h)bar cursors. /* If the prev was underlined, match its appearance. */ if (s->prev - && s->prev->face->underline == FACE_UNDERLINE_SINGLE + && ((s->prev->face->underline == FACE_UNDERLINE_SINGLE) + || (s->prev->face->underline + == FACE_UNDERLINE_DOUBLE_LINE)) && s->prev->underline_thickness > 0 && (s->prev->face->underline_at_descent_line_p == s->face->underline_at_descent_line_p) @@ -3417,6 +3420,17 @@ Note that CURSOR_WIDTH is meaningful only for (h)bar cursors. [[NSColor colorWithUnsignedLong:face->underline_color] set]; NSRectFill (r); + + /* Place a second underline above the first if this was + requested in the face specification. */ + + if (s->face->underline == FACE_UNDERLINE_DOUBLE_LINE) + { + /* Compute the position of the second underline. */ + position = position - thickness - 1; + r = NSMakeRect (x, s->ybase + position, width, thickness); + NSRectFill (r); + } } } /* Do overline. We follow other terms in using a thickness of 1 diff --git a/src/pgtkterm.c b/src/pgtkterm.c index e08e4b2b230..8441189ab8d 100644 --- a/src/pgtkterm.c +++ b/src/pgtkterm.c @@ -2553,13 +2553,17 @@ pgtk_draw_glyph_string (struct glyph_string *s) else pgtk_draw_underwave (s, s->face->underline_color); } - else if (s->face->underline == FACE_UNDERLINE_SINGLE) + else if (s->face->underline == FACE_UNDERLINE_SINGLE + || s->face->underline == FACE_UNDERLINE_DOUBLE_LINE) { unsigned long thickness, position; int y; + unsigned long foreground; if (s->prev - && s->prev->face->underline == FACE_UNDERLINE_SINGLE + && ((s->prev->face->underline == FACE_UNDERLINE_SINGLE) + || (s->prev->face->underline + == FACE_UNDERLINE_DOUBLE_LINE)) && (s->prev->face->underline_at_descent_line_p == s->face->underline_at_descent_line_p) && (s->prev->face->underline_pixels_above_descent_line @@ -2616,15 +2620,25 @@ pgtk_draw_glyph_string (struct glyph_string *s) s->underline_thickness = thickness; s->underline_position = position; y = s->ybase + position; + if (s->face->underline_defaulted_p) - pgtk_fill_rectangle (s->f, s->xgcv.foreground, - s->x, y, s->width, thickness, - false); + foreground = s->xgcv.foreground; else + foreground = s->face->underline_color; + + pgtk_fill_rectangle (s->f, foreground, s->x, y, s->width, + thickness, false); + + /* Place a second underline above the first if this was + requested in the face specification. */ + + if (s->face->underline == FACE_UNDERLINE_DOUBLE_LINE) { - pgtk_fill_rectangle (s->f, s->face->underline_color, - s->x, y, s->width, thickness, - false); + /* Compute the position of the second underline. */ + position = position - thickness - 1; + y = s->ybase + position; + pgtk_fill_rectangle (s->f, foreground, s->x, y, s->width, + thickness, false); } } } diff --git a/src/w32term.c b/src/w32term.c index 20ea346c8aa..a0037e6e090 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -2652,13 +2652,16 @@ w32_draw_glyph_string (struct glyph_string *s) w32_draw_underwave (s, color); } - else if (s->face->underline == FACE_UNDERLINE_SINGLE) + else if (s->face->underline == FACE_UNDERLINE_SINGLE + || s->face->underline == FACE_UNDERLINE_DOUBLE_LINE) { unsigned long thickness, position; int y; if (s->prev - && s->prev->face->underline == FACE_UNDERLINE_SINGLE + && ((s->prev->face->underline == FACE_UNDERLINE_SINGLE) + || (s->prev->face->underline + == FACE_UNDERLINE_DOUBLE_LINE)) && (s->prev->face->underline_at_descent_line_p == s->face->underline_at_descent_line_p) && (s->prev->face->underline_pixels_above_descent_line @@ -2676,6 +2679,7 @@ w32_draw_glyph_string (struct glyph_string *s) BOOL use_underline_position_properties; Lisp_Object val = (WINDOW_BUFFER_LOCAL_VALUE (Qunderline_minimum_offset, s->w)); + COLORREF foreground; if (FIXNUMP (val)) minimum_offset = max (0, XFIXNUM (val)); @@ -2734,18 +2738,28 @@ w32_draw_glyph_string (struct glyph_string *s) if (s->y + s->height < s->ybase + position + thickness) thickness = (s->y + s->height) - (s->ybase + position); s->underline_thickness = thickness; - s->underline_position = position; + s->underline_position = position; y = s->ybase + position; + if (s->face->underline_defaulted_p) - { - w32_fill_area (s->f, s->hdc, s->gc->foreground, s->x, - y, s->width, 1); - } - else - { - w32_fill_area (s->f, s->hdc, s->face->underline_color, s->x, - y, s->width, 1); - } + foreground = s->gc->foreground; + else + foreground = s->face->underline_color; + + w32_fill_area (s->f, s->hdc, foreground, s->x, y, + s->width, thickness); + + /* Place a second underline above the first if this was + requested in the face specification. */ + + if (s->face->underline == FACE_UNDERLINE_DOUBLE_LINE) + { + /* 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); + } } } /* Draw overline. */ diff --git a/src/xfaces.c b/src/xfaces.c index 07e198974fa..d9ee82c8e7f 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -6398,13 +6398,21 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] } else if (EQ (keyword, QCstyle)) { - if (EQ (value, Qline)) - face->underline = FACE_UNDERLINE_SINGLE; - else if (EQ (value, Qwave)) - face->underline = FACE_UNDERLINE_WAVE; - else - face->underline = FACE_UNDERLINE_SINGLE; - } + if (EQ (value, Qline)) + face->underline = FACE_UNDERLINE_SINGLE; + else if (EQ (value, Qdouble_line)) + face->underline = FACE_UNDERLINE_DOUBLE_LINE; + else if (EQ (value, Qwave)) + face->underline = FACE_UNDERLINE_WAVE; +#if 0 + else if (EQ (value, Qdots)) + face->underline = FACE_UNDERLINE_DOTS; + else if (EQ (value, Qdashes)) + face->underline = FACE_UNDERLINE_DASHES; +#endif /* 0 */ + else + face->underline = FACE_UNDERLINE_SINGLE; + } else if (EQ (keyword, QCposition)) { face->underline_at_descent_line_p = !NILP (value); diff --git a/src/xterm.c b/src/xterm.c index 360541ac0b9..9b014a7d0e4 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10735,10 +10735,10 @@ x_draw_stretch_glyph_string (struct glyph_string *s) } static void -x_get_scale_factor (Display *disp, int *scale_x, int *scale_y) +x_get_scale_factor (struct x_display_info *dpyinfo, + int *scale_x, int *scale_y) { - const int base_res = 96; - struct x_display_info * dpyinfo = x_display_info_for_display (disp); + int base_res = 96; *scale_x = *scale_y = 1; @@ -10764,12 +10764,14 @@ x_get_scale_factor (Display *disp, int *scale_x, int *scale_y) static void x_draw_underwave (struct glyph_string *s, int decoration_width) { - Display *display = FRAME_X_DISPLAY (s->f); - + Display *display; + struct x_display_info *dpyinfo; /* Adjust for scale/HiDPI. */ int scale_x, scale_y; - x_get_scale_factor (display, &scale_x, &scale_y); + dpyinfo = FRAME_DISPLAY_INFO (s->f); + display = dpyinfo->display; + x_get_scale_factor (dpyinfo, &scale_x, &scale_y); int wave_height = 3 * scale_y, wave_length = 2 * scale_x; @@ -10971,13 +10973,16 @@ x_draw_glyph_string (struct glyph_string *s) XSetForeground (display, s->gc, xgcv.foreground); } } - else if (s->face->underline == FACE_UNDERLINE_SINGLE) + else if (s->face->underline == FACE_UNDERLINE_SINGLE + || s->face->underline == FACE_UNDERLINE_DOUBLE_LINE) { unsigned long thickness, position; int y; if (s->prev - && s->prev->face->underline == FACE_UNDERLINE_SINGLE + && ((s->prev->face->underline == FACE_UNDERLINE_SINGLE) + || (s->prev->face->underline + == FACE_UNDERLINE_DOUBLE_LINE)) && (s->prev->face->underline_at_descent_line_p == s->face->underline_at_descent_line_p) && (s->prev->face->underline_pixels_above_descent_line @@ -11054,22 +11059,40 @@ x_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) - x_fill_rectangle (s->f, s->gc, - s->x, y, decoration_width, thickness, - false); - else - { - Display *display = FRAME_X_DISPLAY (s->f); - XGCValues xgcv; - XGetGCValues (display, s->gc, GCForeground, &xgcv); - XSetForeground (display, s->gc, s->face->underline_color); - x_fill_rectangle (s->f, s->gc, + + { + Display *display = FRAME_X_DISPLAY (s->f); + XGCValues xgcv; + + y = s->ybase + position; + if (s->face->underline_defaulted_p) + x_fill_rectangle (s->f, s->gc, s->x, y, decoration_width, thickness, false); - XSetForeground (display, s->gc, xgcv.foreground); - } + else + { + XGetGCValues (display, s->gc, GCForeground, &xgcv); + XSetForeground (display, s->gc, s->face->underline_color); + x_fill_rectangle (s->f, s->gc, + s->x, y, decoration_width, thickness, + false); + } + + /* Place a second underline above the first if this was + requested in the face specification. */ + + if (s->face->underline == FACE_UNDERLINE_DOUBLE_LINE) + { + /* Compute the position of the second underline. */ + position = position - thickness - 1; + y = s->ybase + position; + x_fill_rectangle (s->f, s->gc, s->x, y, decoration_width, + thickness, false); + } + + if (!s->face->underline_defaulted_p) + XSetForeground (display, s->gc, xgcv.foreground); + } } } /* Draw overline. */ commit 4992df159157806bcbad87569f34dc5136c96601 Author: Po Lu Date: Sun Apr 28 09:27:59 2024 +0800 ; * src/term.c (turn_on_face): Fix coding style. diff --git a/src/term.c b/src/term.c index a0baf544897..6cb57592643 100644 --- a/src/term.c +++ b/src/term.c @@ -2056,9 +2056,9 @@ turn_on_face (struct frame *f, int face_id) ts = tty->TF_set_underline_color; if (ts && face->underline_color) { - p = tparam (ts, NULL, 0, face->underline_color, 0, 0, 0); - OUTPUT (tty, p); - xfree (p); + p = tparam (ts, NULL, 0, face->underline_color, 0, 0, 0); + OUTPUT (tty, p); + xfree (p); } } } commit 6dcd7de02aa1671f6aa56f7a754b63e809ca8c99 Merge: f5439a92910 cf839129ce0 Author: Eli Zaretskii Date: Sat Apr 27 15:21:13 2024 -0400 Merge from origin/emacs-29 cf839129ce0 Fix last change 3e68d413c1c ; Skip 'csharp-ts-mode' test if grammar is missing commit cf839129ce097c2116292cb69217be265f6b35e8 Author: Eli Zaretskii Date: Sat Apr 27 22:12:14 2024 +0300 Fix last change * test/lisp/progmodes/csharp-mode-tests.el (csharp-ts-mode-test-indentation): If need to skip the tree-sitter test, do so silently. (Bug#70345) diff --git a/test/lisp/progmodes/csharp-mode-tests.el b/test/lisp/progmodes/csharp-mode-tests.el index b3c57a7026b..af06a918f6e 100644 --- a/test/lisp/progmodes/csharp-mode-tests.el +++ b/test/lisp/progmodes/csharp-mode-tests.el @@ -27,7 +27,7 @@ (ert-test-erts-file (ert-resource-file "indent.erts"))) (ert-deftest csharp-ts-mode-test-indentation () - (skip-unless (treesit-ready-p 'c-sharp)) + (skip-unless (treesit-ready-p 'c-sharp t)) (ert-test-erts-file (ert-resource-file "indent-ts.erts"))) (provide 'csharp-mode-tests) commit 3e68d413c1c177e03ff60ba0faf09fc4b8af8e2e Author: john muhl Date: Sat Apr 27 09:55:42 2024 -0500 ; Skip 'csharp-ts-mode' test if grammar is missing * test/lisp/progmodes/csharp-mode-tests.el (csharp-ts-mode-test-indentation): Skip test instead of failing. (Bug#70345) diff --git a/test/lisp/progmodes/csharp-mode-tests.el b/test/lisp/progmodes/csharp-mode-tests.el index 2878fa601f2..b3c57a7026b 100644 --- a/test/lisp/progmodes/csharp-mode-tests.el +++ b/test/lisp/progmodes/csharp-mode-tests.el @@ -27,6 +27,7 @@ (ert-test-erts-file (ert-resource-file "indent.erts"))) (ert-deftest csharp-ts-mode-test-indentation () + (skip-unless (treesit-ready-p 'c-sharp)) (ert-test-erts-file (ert-resource-file "indent-ts.erts"))) (provide 'csharp-mode-tests) commit f5439a929106d1482b185dce5369d4748658946f Author: Eshel Yaron Date: Fri Apr 26 11:43:29 2024 +0200 Refine the Custom type of generated '*-modes' options * lisp/emacs-lisp/easy-mmode.el (define-globalized-minor-mode): Refine the Custom type of the '*-modes' option, generated when this macro is given a ':predicate' argument. (Bug#70589) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index eaad9646985..ba0f8bad393 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -580,7 +580,20 @@ modes derived from `text-mode'\". An element with value t means \"use\" and nil means \"don't use\". There's an implicit nil at the end of the list." mode) - :type '(repeat sexp) + :type '(choice + (const :tag "Enable in all major modes" t) + (const :tag "Don't enable in any major mode" nil) + (repeat + :tag "Rules (earlier takes precedence)..." + (choice + (const :tag "Enable in all (other) modes" t) + (const :tag "Don't enable in any (other) mode" nil) + (symbol :value fundamental-mode + :tag "Enable in major mode") + (cons :tag "Don't enable in major modes" + (const :tag "Don't enable in..." not) + (repeat (symbol :value fundamental-mode + :tag "Major mode")))))) ,@group)) ;; Autoloading define-globalized-minor-mode autoloads everything commit 01e0b783bcd1b48ec856c8960e9da571a289a1b2 Author: Po Lu Date: Sat Apr 27 19:48:45 2024 +0800 Fix ommissions in window scrolling commands that ought to clear vscroll * src/window.c (Fdelete_other_windows_internal) (window_scroll_for_long_lines, Frecenter, Fmove_to_window_line): Reset window vscroll, or, if force_start be set, just preserve_vscroll_p, after moving window start to a position computed from iterators for the window in question, so that vscroll may be reliably reset again after the conditions for redisplay's doing the same were corrected. (bug#70386) diff --git a/src/window.c b/src/window.c index 6c0fce4119f..cf12841bd51 100644 --- a/src/window.c +++ b/src/window.c @@ -3514,6 +3514,10 @@ window-start value is reasonable when this function is called. */) get called. */ w->optional_new_start = true; + /* Reset the vscroll, as redisplay will not. */ + w->vscroll = 0; + w->preserve_vscroll_p = false; + set_buffer_internal (obuf); } } @@ -5751,6 +5755,11 @@ window_scroll_for_long_lines (struct window *w, int n, bool noerror) else if (n < 0) pos = *vmotion (PT, PT_BYTE, - (ht / 2), w); SET_PT_BOTH (pos.bufpos, pos.bytepos); + + /* Since `vmotion' computes coordinates after vscroll is applied, + it is taken into account in POS, and vscroll must be reset by + `force_start' in `redisplay_internal'. */ + w->preserve_vscroll_p = false; } else { @@ -6894,8 +6903,14 @@ and redisplay normally--don't erase and redraw the frame. */) /* Set the new window start. */ set_marker_both (w->start, w->contents, charpos, bytepos); - w->window_end_valid = false; + /* The window start was calculated with an iterator already adjusted + by the existing vscroll, so w->start must not be combined with + retaining the existing vscroll, which redisplay will not reset if + w->preserve_vscroll_p is enabled. (bug#70386) */ + w->vscroll = 0; + w->preserve_vscroll_p = false; + w->window_end_valid = false; w->optional_new_start = true; w->start_at_line_beg = (bytepos == BEGV_BYTE @@ -6983,6 +6998,11 @@ from the top of the window. */) set_marker_both (w->start, w->contents, PT, PT_BYTE); w->start_at_line_beg = !NILP (Fbolp ()); w->force_start = true; + + /* Since `Fvertical_motion' computes coordinates after vscroll is + applied, it is taken into account in POS, and vscroll must be + reset by `force_start' in `redisplay_internal'. */ + w->preserve_vscroll_p = false; } else Fgoto_char (w->start); commit 687c4137fa473031bc62aa0d41aec74df4f1e5af Merge: b761a381066 f37f01b5046 Author: Eli Zaretskii Date: Sat Apr 27 06:23:46 2024 -0400 Merge from origin/emacs-29 f37f01b5046 Fix a typo in Introduction to Emacs Lisp (bug#70571). d8687fd6cd8 Fix last change 494dfd9cf2b Fix indentation of if/else in 'csharp-ts-mode' (bug#70345) 1cc6322e612 ; * etc/PROBLEMS: Document crashes due to tree-sitter ABI... 42766f95e5c * build-aux/make-info-dir: Avoid bashism (bug#70484). 81476fa19e8 Improve documentation of selection and navigation in *xre... 2a533514929 Fix Widget manual typos, markup and omissions (bug#70502) 90be3015b4d ; Document bookmark fringe mark in the user manual afd0b548fcc Fix python-ts-mode built-in functions and attributes (bug... dc720decc3a Fix markup and indexing in the Calendar chapter of user m... f593bf79a91 Fix the user manual for `calendar-time-zone-style' aed2b7a3d82 Avoid assertion violations in 'push_prefix_prop' c929532b469 Remove ert-equal-including-properties from manual e3aae5fd385 ; Document 'filtered-frame-list' commit f37f01b5046b510656d0f2ace22168a222f6481a Author: Brad Howes Date: Thu Apr 25 18:39:02 2024 +0200 Fix a typo in Introduction to Emacs Lisp (bug#70571). Copyright-paperwork-exempt: yes diff --git a/doc/lispintro/emacs-lisp-intro.texi b/doc/lispintro/emacs-lisp-intro.texi index a06822ce539..19777bf8ab7 100644 --- a/doc/lispintro/emacs-lisp-intro.texi +++ b/doc/lispintro/emacs-lisp-intro.texi @@ -19428,7 +19428,7 @@ There is more, but that is the hardest part. @appendixsec The @file{ring.el} File @cindex @file{ring.el} file -Interestingly, GNU Emacs posses a file called @file{ring.el} that +Interestingly, GNU Emacs possesses a file called @file{ring.el} that provides many of the features we just discussed. But functions such as @code{kill-ring-yank-pointer} do not use this library, possibly because they were written earlier. commit b761a381066ca2fdeb510c0d5a88be58b524685d Author: Manuel Giraud Date: Wed Apr 24 16:10:43 2024 +0200 Fix `find-grep-dired' with default OpenBSD's Grep * lisp/find-dired.el (find-grep-options): Use '-q' on OpenBSD as well. (Bug#70550) diff --git a/lisp/find-dired.el b/lisp/find-dired.el index 41581cc7900..fa0c034c816 100644 --- a/lisp/find-dired.el +++ b/lisp/find-dired.el @@ -120,7 +120,8 @@ them for `find-ls-option'." :group 'find-dired) (defcustom find-grep-options - (if (or (eq system-type 'berkeley-unix) + (if (or (and (eq system-type 'berkeley-unix) + (not (string-match "openbsd" system-configuration))) (string-match "solaris2" system-configuration)) "-s" "-q") "Option to grep to be as silent as possible. commit 4e8e877c377e41d72705235922f97b69d81d0267 Author: Eli Zaretskii Date: Sat Apr 27 12:28:42 2024 +0300 ; * test/lisp/jsonrpc-tests.el: Skip all tests on MS-Windows. diff --git a/test/lisp/jsonrpc-tests.el b/test/lisp/jsonrpc-tests.el index cfbea7378e2..c2afe6e3738 100644 --- a/test/lisp/jsonrpc-tests.el +++ b/test/lisp/jsonrpc-tests.el @@ -108,11 +108,13 @@ (ert-deftest returns-3 () "A basic test for adding two numbers in our test RPC." + (skip-when (eq system-type 'windows-nt)) (jsonrpc--with-emacsrpc-fixture (conn) (should (= 3 (jsonrpc-request conn '+ [1 2]))))) (ert-deftest errors-with--32601 () "Errors with -32601" + (skip-when (eq system-type 'windows-nt)) (jsonrpc--with-emacsrpc-fixture (conn) (condition-case err (progn @@ -123,6 +125,7 @@ (ert-deftest signals-an--32603-JSONRPC-error () "Signals an -32603 JSONRPC error." + (skip-when (eq system-type 'windows-nt)) (jsonrpc--with-emacsrpc-fixture (conn) (condition-case err (let ((jsonrpc-inhibit-debug-on-error t)) @@ -133,6 +136,7 @@ (ert-deftest times-out () "Request for 3-sec sit-for with 1-sec timeout times out." + (skip-when (eq system-type 'windows-nt)) (jsonrpc--with-emacsrpc-fixture (conn) (should-error (jsonrpc-request conn 'sit-for [3] :timeout 1)))) @@ -140,11 +144,13 @@ (ert-deftest doesnt-time-out () :tags '(:expensive-test) "Request for 1-sec sit-for with 2-sec timeout succeeds." + (skip-when (eq system-type 'windows-nt)) (jsonrpc--with-emacsrpc-fixture (conn) (jsonrpc-request conn 'sit-for [1] :timeout 2))) (ert-deftest stretching-it-but-works () "Vector of numbers or vector of vector of numbers are serialized." + (skip-when (eq system-type 'windows-nt)) (jsonrpc--with-emacsrpc-fixture (conn) ;; (vconcat [1 2 3] [3 4 5]) => [1 2 3 3 4 5] which can be ;; serialized. @@ -161,6 +167,7 @@ (ert-deftest deferred-action-toolate () :tags '(:expensive-test) "Deferred request fails because no one clears the flag." + (skip-when (eq system-type 'windows-nt)) (jsonrpc--with-emacsrpc-fixture (conn) (should-error (jsonrpc-request conn '+ [1 2] @@ -173,6 +180,7 @@ (ert-deftest deferred-action-intime () :tags '(:expensive-test) "Deferred request barely makes it after event clears a flag." + (skip-when (eq system-type 'windows-nt)) ;; Send an async request, which returns immediately. However the ;; success fun which sets the flag only runs after some time. (jsonrpc--with-emacsrpc-fixture (conn) @@ -191,6 +199,7 @@ (ert-deftest deferred-action-complex-tests () :tags '(:expensive-test) "Test a more complex situation with deferred requests." + (skip-when (eq system-type 'windows-nt)) (jsonrpc--with-emacsrpc-fixture (conn) (let (n-deferred-1 n-deferred-2 commit 990d615cabbeae62366e35bc74fdb27767bb8848 Author: Eli Zaretskii Date: Sat Apr 27 12:19:28 2024 +0300 ; * lisp/jsonrpc.el (jsonrpc-shutdown): Doc fix. diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 111e58cefe2..9e9a5f97fd4 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -592,8 +592,8 @@ connection object, called when the process dies.") &optional cleanup) "Wait for JSONRPC connection CONN to shutdown. With optional CLEANUP, kill any associated buffers. -If CONN is not shutdown within an reasonable amount of time, warn -and delete process." +If CONN is not shutdown within a reasonable amount of time, warn +and delete the network process." (unwind-protect (cl-loop with proc = (jsonrpc--process conn) for i from 0 commit 3aed4400257a6762de96be37fa95357b5836363c Author: Daniel Pettersson Date: Tue Apr 23 18:58:06 2024 +0200 Shut down jsonrpc server more gracefully * lisp/jsonrpc.el (jsonrpc-running-p): Avoid unnecessarily killing the server process. Suggested by Aaron Zeng . (Bug#70522) diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 5037d8c5b2b..111e58cefe2 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -591,15 +591,18 @@ connection object, called when the process dies.") (cl-defmethod jsonrpc-shutdown ((conn jsonrpc-process-connection) &optional cleanup) "Wait for JSONRPC connection CONN to shutdown. -With optional CLEANUP, kill any associated buffers." +With optional CLEANUP, kill any associated buffers. +If CONN is not shutdown within an reasonable amount of time, warn +and delete process." (unwind-protect (cl-loop with proc = (jsonrpc--process conn) for i from 0 while (not (process-get proc 'jsonrpc-sentinel-cleanup-started)) unless (zerop i) do (jsonrpc--warn "Sentinel for %s still hasn't run, deleting it!" proc) - do (delete-process proc) + do + ;; Let sentinel have a chance to run (accept-process-output nil 0.1)) (when cleanup (kill-buffer (process-buffer (jsonrpc--process conn))) commit 4e17e0b84ae1a52a6032c83592bf958a1e26dea5 Author: Eli Zaretskii Date: Sat Apr 27 12:07:53 2024 +0300 Followup changes for styled underline support * src/nsterm.m (ns_draw_text_decoration): * src/pgtkterm.c (pgtk_draw_glyph_string): * src/haikuterm.c (haiku_draw_text_decoration): * src/androidterm.c (android_draw_glyph_string): * src/w32term.c (w32_draw_glyph_string): Use new FACE_UNDER* constants. (Bug#62994) diff --git a/src/androidterm.c b/src/androidterm.c index 5de7b6f4e14..f5173168785 100644 --- a/src/androidterm.c +++ b/src/androidterm.c @@ -4158,7 +4158,7 @@ android_draw_glyph_string (struct glyph_string *s) /* Draw underline. */ if (s->face->underline) { - if (s->face->underline == FACE_UNDER_WAVE) + if (s->face->underline == FACE_UNDERLINE_WAVE) { if (s->face->underline_defaulted_p) android_draw_underwave (s, decoration_width); @@ -4171,13 +4171,13 @@ android_draw_glyph_string (struct glyph_string *s) android_set_foreground (s->gc, xgcv.foreground); } } - else if (s->face->underline == FACE_UNDER_LINE) + else if (s->face->underline == FACE_UNDERLINE_SINGLE) { unsigned long thickness, position; int y; if (s->prev - && s->prev->face->underline == FACE_UNDER_LINE + && 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 diff --git a/src/haikuterm.c b/src/haikuterm.c index 135f99dbdcb..c3971bf6fe4 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -827,15 +827,15 @@ haiku_draw_text_decoration (struct glyph_string *s, struct face *face, else BView_SetHighColor (view, face->foreground); - if (face->underline == FACE_UNDER_WAVE) + if (face->underline == FACE_UNDERLINE_WAVE) haiku_draw_underwave (s, width, x); - else if (face->underline == FACE_UNDER_LINE) + else if (face->underline == FACE_UNDERLINE_SINGLE) { unsigned long thickness, position; int y; if (s->prev - && s->prev->face->underline == FACE_UNDER_LINE + && 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 diff --git a/src/nsterm.m b/src/nsterm.m index faf9324402b..84d94b5be74 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -3330,14 +3330,14 @@ Note that CURSOR_WIDTH is meaningful only for (h)bar cursors. /* Do underline. */ if (face->underline) { - if (s->face->underline == FACE_UNDER_WAVE) + if (s->face->underline == FACE_UNDERLINE_WAVE) { if (!face->underline_defaulted_p) [[NSColor colorWithUnsignedLong:face->underline_color] set]; ns_draw_underwave (s, width, x); } - else if (s->face->underline == FACE_UNDER_LINE) + else if (s->face->underline == FACE_UNDERLINE_SINGLE) { NSRect r; @@ -3345,7 +3345,7 @@ Note that CURSOR_WIDTH is meaningful only for (h)bar cursors. /* If the prev was underlined, match its appearance. */ if (s->prev - && s->prev->face->underline == FACE_UNDER_LINE + && s->prev->face->underline == FACE_UNDERLINE_SINGLE && s->prev->underline_thickness > 0 && (s->prev->face->underline_at_descent_line_p == s->face->underline_at_descent_line_p) diff --git a/src/pgtkterm.c b/src/pgtkterm.c index 1ec6bfcda4e..e08e4b2b230 100644 --- a/src/pgtkterm.c +++ b/src/pgtkterm.c @@ -2546,20 +2546,20 @@ pgtk_draw_glyph_string (struct glyph_string *s) /* Draw underline. */ if (s->face->underline) { - if (s->face->underline == FACE_UNDER_WAVE) + if (s->face->underline == FACE_UNDERLINE_WAVE) { if (s->face->underline_defaulted_p) pgtk_draw_underwave (s, s->xgcv.foreground); else pgtk_draw_underwave (s, s->face->underline_color); } - else if (s->face->underline == FACE_UNDER_LINE) + else if (s->face->underline == FACE_UNDERLINE_SINGLE) { unsigned long thickness, position; int y; if (s->prev - && s->prev->face->underline == FACE_UNDER_LINE + && 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 diff --git a/src/w32term.c b/src/w32term.c index 7afd1303b4d..20ea346c8aa 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -2641,7 +2641,7 @@ w32_draw_glyph_string (struct glyph_string *s) /* Draw underline. */ if (s->face->underline) { - if (s->face->underline == FACE_UNDER_WAVE) + if (s->face->underline == FACE_UNDERLINE_WAVE) { COLORREF color; @@ -2652,13 +2652,13 @@ w32_draw_glyph_string (struct glyph_string *s) w32_draw_underwave (s, color); } - else if (s->face->underline == FACE_UNDER_LINE) + else if (s->face->underline == FACE_UNDERLINE_SINGLE) { unsigned long thickness, position; int y; if (s->prev - && s->prev->face->underline == FACE_UNDER_LINE + && 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 commit 9f589eb924085a4612f46728e8850073128a2e43 Author: Mohsin Kaleem Date: Thu Apr 20 22:30:12 2023 +0100 Add support for colored and styled underlines on tty frames * src/dispextern.h (face, face_underline_type, syms_of_xfacse) (internal-set-lisp-face-attribute) (gui_supports_face_attributes_p): Add definitions for new underline styles of Double-line, Dots and Dashes. Rename FACE_UNDER_LINE and FACE_UNDER_WAVE to make definitions consistent. Delete tty_underline_p from the face struct and use just underline going forward. Add a flag to check whether styled underlines are available. * lisp/cus-face.el (custom-face-attributes): Add entries for Double-line, Dots and Dashes so they can be set through `customize'. * src/termchar.c (tty_display_info): Add an entry for the escape sequence to set the underline style and color on terminal frames. * src/term.c (init_tty, tty_capable_p, turn_on_face): Read and save the underline style escape sequence from the Smulx termcap (alternatively if the Su flag is set use a default sequence). Allow checking for support of styled underlines in the current terminal frame. Output the necessary escape sequences to activate a styled underline on turn_on_face; this is currently only used for the new special underline styles, a default straight underline will still use the "us" termcap. Output escape sequence to set underline color when set in the face and supported by the tty. Save a default value for this sequence on init_tty when styled underlines are supported. * src/xfaces.c (tty_supports_face_attributes_p, realize_tty_face) (map_tty_color): Assert whether styled underlines are supported by the current terminal on display-supports-face-attributes-p checks. Populate the correct underline style and color in the face spec when realizing a face. Allow map_tty_color to map underline colors alongside foreground and background. The interface of map_tty_color was amended to allow the caller to supply the underline color instead of accessing it through the face attributes. (bug#62994) * src/xterm.c (x_draw_glyph_string): Updated to use renamed FACE_UNDERLINE_SINGLE and FACE_UNDERLINE_WAVE face_underline_type enumerations. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index fba15578f4f..8425aa23422 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -2685,12 +2685,15 @@ Underline in color @var{color}, a string specifying a color. @var{color} is either a string, or the symbol @code{foreground-color}, meaning the foreground color of the face. Omitting the attribute @code{:color} means to use the foreground color of the face. -@var{style} should be a symbol @code{line} or @code{wave}, meaning to -use a straight or wavy line. Omitting the attribute @code{:style} -means to use a straight line. @var{position}, if non-@code{nil}, means to -display the underline at the descent of the text, instead of at the -baseline level. If it is a number, then it specifies the amount of -pixels above the descent to display the underline. +@var{style} is a symbol which sets the line-style to of the underline. +It should be one of @code{line}, @code{double-line}, @code{wave}, +@code{dots}, or @code{dashes}. GUI frames only support @code{line} and +@code{wave}. Terminal frames can support all aforementioned underline +styles. Omitting the attribute @code{:style} means to use a straight +line. @var{position}, if non-@code{nil}, means to display the underline +at the descent of the text, instead of at the baseline level. If it is +a number, then it specifies the amount of pixels above the descent to +display the underline. @end table @cindex overlined text diff --git a/etc/NEWS b/etc/NEWS index fea27bb8a31..9c356e64bde 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -446,6 +446,22 @@ Use 'TAB' in the minibuffer to show or hide the password. Likewise, there is an icon on the mode-line, which toggles the visibility of the password when clicking with 'mouse-1'. +** Terminal Emacs + +--- +*** Support for 'styled' and 'colored' underline face attributes on TTY frames. +If your terminals termcap or terminfo database entry has the 'Su' or +'Smulx' capability defined, Emacs will now emit the prescribed escape +sequence necessary to render faces with styled underlines on TTY +frames. + +Styled underlines are any underlines containing a non-default +underline style or a color other than the foreground-color. +The available underline styles for TTY frames are 'single', +'double-line', 'wave', 'dots, and 'dashes'. These are currently +supported by Kitty, libvte, and st (through the undercurl patch) among +other terminals. + * Editing Changes in Emacs 30.1 diff --git a/lisp/cus-face.el b/lisp/cus-face.el index 47afa841f5e..d0a1a66e29f 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -141,7 +141,10 @@ (const :format "" :value :style) (choice :tag "Style" (const :tag "Line" line) - (const :tag "Wave" wave)) + (const :tag "Double line" double-line) + (const :tag "Wave" wave) + (const :tag "Dots" dots) + (const :tag "Dashes" dashes)) (const :format "" :value :position) (choice :tag "Position" (const :tag "At Default Position" nil) diff --git a/src/dispextern.h b/src/dispextern.h index c3c2d61082b..7a942ec79dc 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -1697,9 +1697,13 @@ enum face_box_type enum face_underline_type { + /* Note: Order matches the order of the Smulx terminfo extension. */ FACE_NO_UNDERLINE = 0, - FACE_UNDER_LINE, - FACE_UNDER_WAVE + FACE_UNDERLINE_SINGLE, + FACE_UNDERLINE_DOUBLE_LINE, + FACE_UNDERLINE_WAVE, + FACE_UNDERLINE_DOTS, + FACE_UNDERLINE_DASHES, }; /* Structure describing a realized face. @@ -1783,7 +1787,7 @@ struct face ENUM_BF (face_box_type) box : 2; /* Style of underlining. */ - ENUM_BF (face_underline_type) underline : 2; + ENUM_BF (face_underline_type) underline : 3; /* If `box' above specifies a 3D type, true means use box_color for drawing shadows. */ @@ -1815,7 +1819,6 @@ struct face string meaning the default color of the TTY. */ bool_bf tty_bold_p : 1; bool_bf tty_italic_p : 1; - bool_bf tty_underline_p : 1; bool_bf tty_reverse_p : 1; bool_bf tty_strike_through_p : 1; @@ -3433,6 +3436,7 @@ enum tool_bar_item_image #define TTY_CAP_DIM 0x08 #define TTY_CAP_ITALIC 0x10 #define TTY_CAP_STRIKE_THROUGH 0x20 +#define TTY_CAP_UNDERLINE_STYLED (0x32 & TTY_CAP_UNDERLINE) /*********************************************************************** diff --git a/src/term.c b/src/term.c index 3fa244be824..a0baf544897 100644 --- a/src/term.c +++ b/src/term.c @@ -2014,8 +2014,19 @@ turn_on_face (struct frame *f, int face_id) OUTPUT1 (tty, tty->TS_enter_dim_mode); } - if (face->tty_underline_p && MAY_USE_WITH_COLORS_P (tty, NC_UNDERLINE)) - OUTPUT1_IF (tty, tty->TS_enter_underline_mode); + if (face->underline && MAY_USE_WITH_COLORS_P (tty, NC_UNDERLINE)) + { + if (face->underline == FACE_UNDERLINE_SINGLE + || !tty->TF_set_underline_style) + OUTPUT1_IF (tty, tty->TS_enter_underline_mode); + else if (tty->TF_set_underline_style) + { + char *p; + p = tparam (tty->TF_set_underline_style, NULL, 0, face->underline, 0, 0, 0); + OUTPUT (tty, p); + xfree (p); + } + } if (face->tty_strike_through_p && MAY_USE_WITH_COLORS_P (tty, NC_STRIKE_THROUGH)) @@ -2041,6 +2052,14 @@ turn_on_face (struct frame *f, int face_id) OUTPUT (tty, p); xfree (p); } + + ts = tty->TF_set_underline_color; + if (ts && face->underline_color) + { + p = tparam (ts, NULL, 0, face->underline_color, 0, 0, 0); + OUTPUT (tty, p); + xfree (p); + } } } @@ -2061,7 +2080,7 @@ turn_off_face (struct frame *f, int face_id) if (face->tty_bold_p || face->tty_italic_p || face->tty_reverse_p - || face->tty_underline_p + || face->underline || face->tty_strike_through_p) { OUTPUT1_IF (tty, tty->TS_exit_attribute_mode); @@ -2073,7 +2092,7 @@ turn_off_face (struct frame *f, int face_id) { /* If we don't have "me" we can only have those appearances that have exit sequences defined. */ - if (face->tty_underline_p) + if (face->underline) OUTPUT_IF (tty, tty->TS_exit_underline_mode); } @@ -2104,6 +2123,9 @@ tty_capable_p (struct tty_display_info *tty, unsigned int caps) TTY_CAPABLE_P_TRY (tty, TTY_CAP_UNDERLINE, tty->TS_enter_underline_mode, NC_UNDERLINE); + TTY_CAPABLE_P_TRY (tty, + TTY_CAP_UNDERLINE_STYLED, tty->TF_set_underline_style, + NC_UNDERLINE); TTY_CAPABLE_P_TRY (tty, TTY_CAP_BOLD, tty->TS_enter_bold_mode, NC_BOLD); TTY_CAPABLE_P_TRY (tty, @@ -4360,6 +4382,26 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\ tty->TF_underscore = tgetflag ("ul"); tty->TF_teleray = tgetflag ("xt"); + /* Styled underlines. Support for this is provided either by the + escape sequence in Smulx or the Su flag. The latter results in a + common default escape sequence and is not recommended. */ +#ifdef TERMINFO + tty->TF_set_underline_style = tigetstr ("Smulx"); + if (tty->TF_set_underline_style == (char *) (intptr_t) -1) + tty->TF_set_underline_style = NULL; +#else + tty->TF_set_underline_style = tgetstr ("Smulx", address); +#endif + if (!tty->TF_set_underline_style && tgetflag ("Su")) + /* Default to the kitty escape sequence. See + https://sw.kovidgoyal.net/kitty/underlines/. */ + tty->TF_set_underline_style = "\x1b[4:%p1%dm"; + + if (tty->TF_set_underline_style) + /* Standard escape sequence to set the underline color. + Requires a single parameter, the color index. */ + tty->TF_set_underline_color = "\x1b[58:2::%p1%{65536}%/%d:%p1%{256}%/%{255}%&%d:%p1%{255}%&%dm"; + #else /* DOS_NT */ #ifdef WINDOWSNT { diff --git a/src/termchar.h b/src/termchar.h index 2d845107e11..a1df5a19518 100644 --- a/src/termchar.h +++ b/src/termchar.h @@ -171,6 +171,13 @@ struct tty_display_info non-blank position. Must clear before writing _. */ int TF_teleray; /* termcap xt flag: many weird consequences. For t1061. */ + const char *TF_set_underline_style; /* termcap Smulx entry: Switches the underline + style based on the parameter. Param should + be one of: 0 (none), 1 (straight), 2 (double-line), + 3 (wave), 4 (dots), or 5 (dashes). */ + const char *TF_set_underline_color; /* Enabled when TF_set_underline_style is set: + Sets the color of the underline. Accepts a + single parameter, the color index. */ int RPov; /* # chars to start a TS_repeat */ diff --git a/src/xfaces.c b/src/xfaces.c index d307dbaa246..07e198974fa 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -3297,7 +3297,11 @@ FRAME 0 means change the face on all frames, and change the default } else if (EQ (key, QCstyle) - && !(EQ (val, Qline) || EQ (val, Qwave))) + && !(EQ (val, Qline) + || EQ (val, Qdouble_line) + || EQ (val, Qwave) + || EQ (val, Qdots) + || EQ (val, Qdashes))) { valid_p = false; break; @@ -5265,6 +5269,7 @@ gui_supports_face_attributes_p (struct frame *f, Lisp_Object attrs[LFACE_VECTOR_SIZE], struct face *def_face) { + Lisp_Object val; Lisp_Object *def_attrs = def_face->lface; Lisp_Object lattrs[LFACE_VECTOR_SIZE]; @@ -5359,6 +5364,14 @@ gui_supports_face_attributes_p (struct frame *f, return false; } + /* Check supported underline styles. */ + val = attrs[LFACE_UNDERLINE_INDEX]; + if (!UNSPECIFIEDP (val) + && EQ (CAR_SAFE (val), QCstyle) + && !(EQ (CAR_SAFE (CDR_SAFE (val)), Qline) + || EQ (CAR_SAFE (CDR_SAFE (val)), Qwave))) + return false; /* Unsupported underline style. */ + /* Everything checks out, this face is supported. */ return true; } @@ -5452,9 +5465,18 @@ tty_supports_face_attributes_p (struct frame *f, if (!UNSPECIFIEDP (val)) { if (STRINGP (val)) - return false; /* ttys can't use colored underlines */ - else if (EQ (CAR_SAFE (val), QCstyle) && EQ (CAR_SAFE (CDR_SAFE (val)), Qwave)) - return false; /* ttys can't use wave underlines */ + test_caps |= TTY_CAP_UNDERLINE_STYLED; + else if (EQ (CAR_SAFE (val), QCstyle)) + { + if (!(EQ (CAR_SAFE (CDR_SAFE (val)), Qline) + || EQ (CAR_SAFE (CDR_SAFE (val)), Qdouble_line) + || EQ (CAR_SAFE (CDR_SAFE (val)), Qwave) + || EQ (CAR_SAFE (CDR_SAFE (val)), Qdots) + || EQ (CAR_SAFE (CDR_SAFE (val)), Qdashes))) + return false; /* Face uses an unsupported underline style. */ + + test_caps |= TTY_CAP_UNDERLINE_STYLED; + } else if (face_attr_equal_p (val, def_attrs[LFACE_UNDERLINE_INDEX])) return false; /* same as default */ else @@ -6311,7 +6333,7 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] if (EQ (underline, Qt)) { /* Use default color (same as foreground color). */ - face->underline = FACE_UNDER_LINE; + face->underline = FACE_UNDERLINE_SINGLE; face->underline_defaulted_p = true; face->underline_color = 0; face->underline_at_descent_line_p = false; @@ -6320,7 +6342,7 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] else if (STRINGP (underline)) { /* Use specified color. */ - face->underline = FACE_UNDER_LINE; + face->underline = FACE_UNDERLINE_SINGLE; face->underline_defaulted_p = false; face->underline_color = load_color (f, face, underline, @@ -6340,7 +6362,7 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] { /* `(:color COLOR :style STYLE)'. STYLE being one of `line' or `wave'. */ - face->underline = FACE_UNDER_LINE; + face->underline = FACE_UNDERLINE_SINGLE; face->underline_color = 0; face->underline_defaulted_p = true; face->underline_at_descent_line_p = false; @@ -6377,9 +6399,11 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] else if (EQ (keyword, QCstyle)) { if (EQ (value, Qline)) - face->underline = FACE_UNDER_LINE; + face->underline = FACE_UNDERLINE_SINGLE; else if (EQ (value, Qwave)) - face->underline = FACE_UNDER_WAVE; + face->underline = FACE_UNDERLINE_WAVE; + else + face->underline = FACE_UNDERLINE_SINGLE; } else if (EQ (keyword, QCposition)) { @@ -6430,17 +6454,18 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] } -/* Map a specified color of face FACE on frame F to a tty color index. - IDX is either LFACE_FOREGROUND_INDEX or LFACE_BACKGROUND_INDEX, and - specifies which color to map. Set *DEFAULTED to true if mapping to the +/* Map the specified color COLOR of face FACE on frame F to a tty + color index. IDX is one of LFACE_FOREGROUND_INDEX, + LFACE_BACKGROUND_INDEX or LFACE_UNDERLINE_INDEX, and specifies + which color to map. Set *DEFAULTED to true if mapping to the default foreground/background colors. */ static void -map_tty_color (struct frame *f, struct face *face, - enum lface_attribute_index idx, bool *defaulted) +map_tty_color (struct frame *f, struct face *face, Lisp_Object color, + enum lface_attribute_index idx, bool *defaulted) { - Lisp_Object frame, color, def; - bool foreground_p = idx == LFACE_FOREGROUND_INDEX; + Lisp_Object frame, def; + bool foreground_p = idx != LFACE_BACKGROUND_INDEX; unsigned long default_pixel = foreground_p ? FACE_TTY_DEFAULT_FG_COLOR : FACE_TTY_DEFAULT_BG_COLOR; unsigned long pixel = default_pixel; @@ -6449,10 +6474,11 @@ map_tty_color (struct frame *f, struct face *face, foreground_p ? FACE_TTY_DEFAULT_BG_COLOR : FACE_TTY_DEFAULT_FG_COLOR; #endif - eassert (idx == LFACE_FOREGROUND_INDEX || idx == LFACE_BACKGROUND_INDEX); + eassert (idx == LFACE_FOREGROUND_INDEX + || idx == LFACE_BACKGROUND_INDEX + || idx == LFACE_UNDERLINE_INDEX); XSETFRAME (frame, f); - color = face->lface[idx]; if (STRINGP (color) && SCHARS (color) @@ -6497,13 +6523,21 @@ map_tty_color (struct frame *f, struct face *face, #endif /* MSDOS */ } - if (foreground_p) - face->foreground = pixel; - else - face->background = pixel; + switch (idx) + { + case LFACE_FOREGROUND_INDEX: + face->foreground = pixel; + break; + case LFACE_UNDERLINE_INDEX: + face->underline_color = pixel; + break; + case LFACE_BACKGROUND_INDEX: + default: + face->background = pixel; + break; + } } - /* Realize the fully-specified face with attributes ATTRS in face cache CACHE for ASCII characters. Do it for TTY frame CACHE->f. Value is a pointer to the newly created realized face. */ @@ -6514,6 +6548,7 @@ realize_tty_face (struct face_cache *cache, { struct face *face; int weight, slant; + Lisp_Object underline; bool face_colors_defaulted = false; struct frame *f = cache->f; @@ -6533,16 +6568,83 @@ realize_tty_face (struct face_cache *cache, face->tty_bold_p = true; if (slant != 100) face->tty_italic_p = true; - if (!NILP (attrs[LFACE_UNDERLINE_INDEX])) - face->tty_underline_p = true; if (!NILP (attrs[LFACE_INVERSE_INDEX])) face->tty_reverse_p = true; if (!NILP (attrs[LFACE_STRIKE_THROUGH_INDEX])) face->tty_strike_through_p = true; + /* Text underline. */ + underline = attrs[LFACE_UNDERLINE_INDEX]; + if (NILP (underline)) + { + face->underline = FACE_NO_UNDERLINE; + face->underline_color = 0; + } + else if (EQ (underline, Qt)) + { + face->underline = FACE_UNDERLINE_SINGLE; + face->underline_color = 0; + } + else if (STRINGP (underline)) + { + face->underline = FACE_UNDERLINE_SINGLE; + bool underline_color_defaulted; + map_tty_color (f, face, underline, LFACE_UNDERLINE_INDEX, + &underline_color_defaulted); + } + else if (CONSP (underline)) + { + /* `(:color COLOR :style STYLE)'. + STYLE being one of `line', `double-line', `wave', `dots' or `dashes'. */ + face->underline = FACE_UNDERLINE_SINGLE; + face->underline_color = 0; + + while (CONSP (underline)) + { + Lisp_Object keyword, value; + + keyword = XCAR (underline); + underline = XCDR (underline); + + if (!CONSP (underline)) + break; + value = XCAR (underline); + underline = XCDR (underline); + + if (EQ (keyword, QCcolor)) + { + if (EQ (value, Qforeground_color)) + face->underline_color = 0; + else if (STRINGP (value)) + { + bool underline_color_defaulted; + map_tty_color (f, face, value, LFACE_UNDERLINE_INDEX, + &underline_color_defaulted); + } + } + else if (EQ (keyword, QCstyle)) + { + if (EQ (value, Qline)) + face->underline = FACE_UNDERLINE_SINGLE; + else if (EQ (value, Qdouble_line)) + face->underline = FACE_UNDERLINE_DOUBLE_LINE; + else if (EQ (value, Qwave)) + face->underline = FACE_UNDERLINE_WAVE; + else if (EQ (value, Qdots)) + face->underline = FACE_UNDERLINE_DOTS; + else if (EQ (value, Qdashes)) + face->underline = FACE_UNDERLINE_DASHES; + else + face->underline = FACE_UNDERLINE_SINGLE; + } + } + } + /* Map color names to color indices. */ - map_tty_color (f, face, LFACE_FOREGROUND_INDEX, &face_colors_defaulted); - map_tty_color (f, face, LFACE_BACKGROUND_INDEX, &face_colors_defaulted); + map_tty_color (f, face, face->lface[LFACE_FOREGROUND_INDEX], + LFACE_FOREGROUND_INDEX, &face_colors_defaulted); + map_tty_color (f, face, face->lface[LFACE_BACKGROUND_INDEX], + LFACE_BACKGROUND_INDEX, &face_colors_defaulted); /* Swap colors if face is inverse-video. If the colors are taken from the frame colors, they are already inverted, since the @@ -7228,6 +7330,9 @@ syms_of_xfaces (void) DEFSYM (QCposition, ":position"); DEFSYM (Qline, "line"); DEFSYM (Qwave, "wave"); + DEFSYM (Qdouble_line, "double-line"); + DEFSYM (Qdots, "dots"); + DEFSYM (Qdashes, "dashes"); DEFSYM (Qreleased_button, "released-button"); DEFSYM (Qpressed_button, "pressed-button"); DEFSYM (Qflat_button, "flat-button"); diff --git a/src/xterm.c b/src/xterm.c index e08ffd15b18..360541ac0b9 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10957,7 +10957,7 @@ x_draw_glyph_string (struct glyph_string *s) /* Draw underline. */ if (s->face->underline) { - if (s->face->underline == FACE_UNDER_WAVE) + if (s->face->underline == FACE_UNDERLINE_WAVE) { if (s->face->underline_defaulted_p) x_draw_underwave (s, decoration_width); @@ -10971,13 +10971,13 @@ x_draw_glyph_string (struct glyph_string *s) XSetForeground (display, s->gc, xgcv.foreground); } } - else if (s->face->underline == FACE_UNDER_LINE) + else if (s->face->underline == FACE_UNDERLINE_SINGLE) { unsigned long thickness, position; int y; if (s->prev - && s->prev->face->underline == FACE_UNDER_LINE + && 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 commit a7d51085cf0a6e6d01fa265001d7d6a4bd728ed2 Author: Eli Zaretskii Date: Sat Apr 27 11:52:30 2024 +0300 Improve documentation of 'package-enable-at-startup' * doc/emacs/package.texi (Package Installation): Clarify how to customize 'package-enable-at-startup'. * lisp/emacs-lisp/package.el (package-enable-at-startup): Add note about customization. (Bug#70402) diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi index c8f790bab47..fd445805068 100644 --- a/doc/emacs/package.texi +++ b/doc/emacs/package.texi @@ -490,8 +490,12 @@ startup if invoked with the @samp{-q} or @samp{--no-init-file} options To keep Emacs from automatically making packages available at startup, change the variable @code{package-enable-at-startup} to @code{nil}. You must do this in the early init file, as the variable -is read before loading the regular init file. Currently this variable -cannot be set via Customize. +is read before loading the regular init file. Therefore, if you +customize this variable via Customize, you should save your customized +setting into your early init file. To do this, set or change the value +of the variable @code{custom-file} (@pxref{Saving Customizations}) to +point to your early init file before saving the customized value of +@code{package-enable-at-startup}. @findex package-quickstart-refresh @vindex package-quickstart diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index ab1731aeb54..8c915766e1c 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -174,7 +174,13 @@ with \"-q\"). Even if the value is nil, you can type \\[package-initialize] to make installed packages available at any time, or you can -call (package-activate-all) in your init-file." +call (package-activate-all) in your init-file. + +Note that this variable must be set to a non-default value in +your early-init file, as the variable's value is used before +loading the regular init file. Therefore, if you customize it +via Customize, you should save your customized setting into +your `early-init-file'." :type 'boolean :version "24.1") commit 53333132e47589c59331a7b8b3afb5ce964aed99 Author: Yuan Fu Date: Fri Apr 26 19:55:37 2024 -0700 Fix c-ts-common--fill-paragraph for C This should fix the failing filling test for c-ts-mode. * lisp/progmodes/c-ts-common.el (c-ts-common--fill-paragraph): Don't go back to indentation. diff --git a/lisp/progmodes/c-ts-common.el b/lisp/progmodes/c-ts-common.el index cc8254c5701..b1520db22e9 100644 --- a/lisp/progmodes/c-ts-common.el +++ b/lisp/progmodes/c-ts-common.el @@ -123,12 +123,16 @@ ARG is passed to `fill-paragraph'." (let ((node (treesit-node-at (point)))) (when (string-match-p c-ts-common--comment-regexp (treesit-node-type node)) - (if (save-excursion - (goto-char (treesit-node-start node)) - ;; In rust, NODE will be the body of a comment excluding - ;; the //, so we need to go to BOL to check for //. - (back-to-indentation) - (looking-at "//")) + (if (or (save-excursion + (goto-char (treesit-node-start node)) + (looking-at "//")) + ;; In rust, NODE will be the body of a comment, and the + ;; parent will be the whole comment. + (if-let ((start (treesit-node-start + (treesit-node-parent node)))) + (save-excursion + (goto-char start) + (looking-at "//")))) (fill-comment-paragraph arg) (c-ts-common--fill-block-comment arg))) ;; Return t so `fill-paragraph' doesn't attempt to fill by commit db8f7ed7f652c114e606de423e5094b4cefe49e2 Author: Po Lu Date: Sat Apr 27 10:47:12 2024 +0800 Enable customization of the quit key on Android * doc/emacs/android.texi (Android Windowing): * doc/emacs/input.texi (On-Screen Keyboards): Document various tidbits related to the quit key. * java/org/gnu/emacs/EmacsNative.java (getQuitKeycode): New function. * java/org/gnu/emacs/EmacsWindow.java (EmacsWindow): Rename `lastVolumeButtonRelease' to `lastQuitKeyRelease'. (onKeyUp): Treat value returned by getQuitKeycode as the quit key rather than mandate KEYCODE_VOLUME_DOWN. * src/android.c (getQuitKeycode): Implement new function. * src/androidterm.c (syms_of_androidterm) : New variable. diff --git a/doc/emacs/android.texi b/doc/emacs/android.texi index 9e3716894ee..71bc6540760 100644 --- a/doc/emacs/android.texi +++ b/doc/emacs/android.texi @@ -948,13 +948,16 @@ application via cut-and-paste. @vindex android-pass-multimedia-buttons-to-system @cindex volume/multimedia buttons, Android - The volume keys are normally reserved by Emacs and used to provide -the ability to quit Emacs without a physical keyboard -(@pxref{On-Screen Keyboards}.) However, if you want them to adjust -the volume instead, you can set the variable + The volume keys are normally reserved by Emacs and used to provide the +ability to quit Emacs without a physical keyboard (@pxref{On-Screen +Keyboards}). However, if you want them to adjust the volume instead, +you can set the variable @code{android-pass-multimedia-buttons-to-system} to a non-@code{nil} value; note that you will no longer be able to quit Emacs using the -volume buttons in that case. +volume buttons in that case, and that it is generally easier to activate +the notification shade or another interface that momentarily deprives +Emacs of the keyboard focus while the volume buttons are being +depressed. @cindex dialog boxes, android Emacs is unable to display dialog boxes (@pxref{Dialog Boxes}) while diff --git a/doc/emacs/input.texi b/doc/emacs/input.texi index 67679b00e89..96a20a9bc1b 100644 --- a/doc/emacs/input.texi +++ b/doc/emacs/input.texi @@ -156,9 +156,11 @@ which two rapid clicks of a hardware button that is always present on the device induces a quit. @xref{Quitting}. @vindex x-quit-keysym - No such button is enabled on X, but one can be configured through -the variable @code{x-quit-keysym}. On Android this button is always -the volume down button. +@vindex android-quit-keycode + No such button is enabled on X, but one can be configured through the +variable @code{x-quit-keysym}, whereas the default key is the volume +down button on Android, which is also configurable through a variable, +@code{android-quit-keycode}. @cindex text conversion, keyboards Most input methods designed to work with virtual keyboards edit text diff --git a/java/org/gnu/emacs/EmacsNative.java b/java/org/gnu/emacs/EmacsNative.java index 9b3e60e1a84..acf9e4b204b 100644 --- a/java/org/gnu/emacs/EmacsNative.java +++ b/java/org/gnu/emacs/EmacsNative.java @@ -228,6 +228,10 @@ public static native long sendDndText (short window, int x, int y, be prevented from reaching the system input method. */ public static native boolean shouldForwardCtrlSpace (); + /* Return the keycode repeated activation of which should signal + quit. */ + public static native int getQuitKeycode (); + /* Initialize the current thread, by blocking signals that do not interest it. */ public static native void setupSystemThread (); diff --git a/java/org/gnu/emacs/EmacsWindow.java b/java/org/gnu/emacs/EmacsWindow.java index 911e082144e..961292af527 100644 --- a/java/org/gnu/emacs/EmacsWindow.java +++ b/java/org/gnu/emacs/EmacsWindow.java @@ -136,10 +136,10 @@ private static class Coordinate there is no such window manager. */ private WindowManager windowManager; - /* The time of the last KEYCODE_VOLUME_DOWN release. This is used - to quit Emacs upon two rapid clicks of the volume down - button. */ - private long lastVolumeButtonRelease; + /* The time of the last release of the quit keycode, generally + KEYCODE_VOLUME_DOWN. This is used to signal quit upon two rapid + presses of such key. */ + private long lastQuitKeyRelease; /* Linked list of character strings which were recently sent as events. */ @@ -790,15 +790,12 @@ private static class Coordinate if ((event.getFlags () & KeyEvent.FLAG_CANCELED) != 0) return; - - EmacsNative.sendKeyPress (this.handle, event.getEventTime (), - state, keyCode, unicode_char); } EmacsNative.sendKeyRelease (this.handle, event.getEventTime (), state, keyCode, unicode_char); - if (keyCode == KeyEvent.KEYCODE_VOLUME_DOWN) + if (keyCode == EmacsNative.getQuitKeycode ()) { /* Check if this volume down press should quit Emacs. Most Android devices have no physical keyboard, so it @@ -806,10 +803,10 @@ private static class Coordinate time = event.getEventTime (); - if (time - lastVolumeButtonRelease < 350) + if (time - lastQuitKeyRelease < 350) EmacsNative.quit (); - lastVolumeButtonRelease = time; + lastQuitKeyRelease = time; } } diff --git a/src/android.c b/src/android.c index e44b58c5973..00a77fc398d 100644 --- a/src/android.c +++ b/src/android.c @@ -2645,6 +2645,13 @@ NATIVE_NAME (shouldForwardMultimediaButtons) (JNIEnv *env, return !android_pass_multimedia_buttons_to_system; } +JNIEXPORT jint JNICALL +NATIVE_NAME (getQuitKeycode) (JNIEnv *env, jobject object) +{ + /* Likewise. */ + return (jint) android_quit_keycode; +} + JNIEXPORT jboolean JNICALL NATIVE_NAME (shouldForwardCtrlSpace) (JNIEnv *env, jobject object) { diff --git a/src/androidterm.c b/src/androidterm.c index e4f3abdb2d3..5de7b6f4e14 100644 --- a/src/androidterm.c +++ b/src/androidterm.c @@ -6703,6 +6703,22 @@ so it is important to limit the wait. If set to a non-float value, there will be no wait at all. */); Vandroid_wait_for_event_timeout = make_float (0.1); + DEFVAR_INT ("android-quit-keycode", android_quit_keycode, + doc: /* Keycode that signals quit when typed twice in rapid succession. + +This is the key code of a key whose repeated activation should prompt +Emacs to quit, enabling quitting on systems where a keyboard capable of +typing C-g is unavailable, when set to a key that does exist on the +device. Its value must be a keycode defined by the operating system, +and defaults to 25 (KEYCODE_VOLUME_DOWN), though one of the following +values might be desired on those devices where this default is also +unavailable, or if another key must otherwise serve this function +instead: + + - 4 (KEYCODE_BACK) + - 24 (KEYCODE_VOLUME_UP) */); + android_quit_keycode = 25; + DEFVAR_BOOL ("x-use-underline-position-properties", x_use_underline_position_properties, doc: /* SKIP: real doc in xterm.c. */); commit 763eaa5a324ff51dddad32d725ec8d416597d6d5 Author: Gerd Möllmann Date: Fri Apr 26 12:25:28 2024 +0200 Fix gud-lldb-command-name * lisp/progmodes/gud.el (gud-gud-lldb-command-name): Change to gud-lldb-command-name. (lldb): Don't do stuff that is not needed for lldb. diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index 90fdc99c7e2..c16d78c5097 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -3854,12 +3854,12 @@ so they have been disabled.")) expr)))))))) -;; 'gud-lldb-history' and 'gud-gud-lldb-command-name' are required +;; 'gud-lldb-history' and 'gud-lldb-command-name' are required ;; because 'gud-symbol' uses their values if they are present. Their ;; names are deduced from the minor-mode name. (defvar gud-lldb-history nil) -(defcustom gud-gud-lldb-command-name "lldb" +(defcustom gud-lldb-command-name "lldb" "Default command to invoke LLDB in order to debug a program with it." :type 'string :version "30.1") @@ -4057,15 +4057,6 @@ consider to turn them off in this mode. This command runs functions from `lldb-mode-hook'." (interactive (list (gud-query-cmdline 'lldb))) - - (when (and gud-comint-buffer - (buffer-name gud-comint-buffer) - (get-buffer-process gud-comint-buffer) - (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gud-lldb))) - (gdb-restore-windows) - ;; FIXME: Copied from gud-gdb, but what does that even say? - (error "Multiple debugging requires restarting in text command mode")) - (gud-common-init command-line nil 'gud-lldb-marker-filter) (setq-local gud-minor-mode 'lldb) commit 758fe9b670e9d889f5dee541c492417af6af9f10 Author: Philip Kaludercic Date: Fri Apr 26 08:21:37 2024 +0200 Always update VC packages from a vc-dir buffer * lisp/emacs-lisp/package-vc.el (vc-dir-prepare-status-buffer): Add a declaration. (package-vc-upgrade): Prepare a dummy vc-dir buffer to ensure that 'vc-pull' (or rather 'vc-deduce-fileset') can correctly infer the VC backend to use. (bug#70526) diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index ef056c7909b..c86577b6b26 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -774,6 +774,9 @@ conflicts with its remote repository state." (package-vc-upgrade pkg-desc)))) (message "Done upgrading packages.")) +(declare-function vc-dir-prepare-status-buffer "vc-dir" + (bname dir backend &optional create-new)) + ;;;###autoload (defun package-vc-upgrade (pkg-desc) "Upgrade the package described by PKG-DESC from package's VC repository. @@ -810,7 +813,10 @@ with the remote repository state." (remove-hook 'vc-post-command-functions post-upgrade)))))) (add-hook 'vc-post-command-functions post-upgrade) (with-demoted-errors "Failed to fetch: %S" - (let ((default-directory pkg-dir)) + (require 'vc-dir) + (with-current-buffer (vc-dir-prepare-status-buffer + (format " *package-vc-dir: %s*" pkg-dir) + pkg-dir (vc-responsible-backend pkg-dir)) (vc-pull))))) (defun package-vc--archives-initialize () commit 32ed3d26793753124d344901a6401eecd9225cd1 Author: Juri Linkov Date: Thu Apr 25 20:39:56 2024 +0300 * lisp/tab-line.el: Fix tab-line-buffers in window-persistent-parameters. Replace '(tab-line-buffers . writable)' with '(tab-line-buffers . t)' in 'window-persistent-parameters' (bug#69993). diff --git a/lisp/tab-line.el b/lisp/tab-line.el index 84dd20a6307..896e1c802f7 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -540,7 +540,7 @@ And newly displayed buffers are added to the end of the tab line." (set-window-parameter nil 'tab-line-buffers new-buffers) new-buffers)) -(add-to-list 'window-persistent-parameters '(tab-line-buffers . writable)) +(add-to-list 'window-persistent-parameters '(tab-line-buffers . t)) (defcustom tab-line-tab-name-format-function #'tab-line-tab-name-format-default commit 598505c4faa7c37133223417172223356ea02e65 Author: Juri Linkov Date: Thu Apr 25 20:34:28 2024 +0300 Suppress warnings for obsolete display-comint-buffer-action (bug#69983) * lisp/cmuscheme.el (run-scheme, switch-to-scheme): * lisp/shell.el (shell): * lisp/eshell/eshell.el (eshell): * lisp/progmodes/inf-lisp.el (inferior-lisp): * lisp/progmodes/sh-script.el (sh-show-shell): * lisp/textmodes/tex-mode.el (tex-display-shell) (tex-recenter-output-buffer): Add 'with-suppressed-warnings' to suppress warnings for obsolete options 'display-comint-buffer-action' and 'display-tex-shell-buffer-action'. diff --git a/lisp/cmuscheme.el b/lisp/cmuscheme.el index c84a1809322..d4316fb1175 100644 --- a/lisp/cmuscheme.el +++ b/lisp/cmuscheme.el @@ -238,7 +238,8 @@ is run). (inferior-scheme-mode))) (setq scheme-program-name cmd) (setq scheme-buffer "*scheme*") - (pop-to-buffer "*scheme*" display-comint-buffer-action)) + (with-suppressed-warnings ((obsolete display-comint-buffer-action)) + (pop-to-buffer "*scheme*" display-comint-buffer-action))) (defun scheme-start-file (prog) "Return the name of the start file corresponding to PROG. @@ -358,7 +359,8 @@ With argument, position cursor at end of buffer." (interactive "P") (if (or (and scheme-buffer (get-buffer scheme-buffer)) (scheme-interactively-start-process)) - (pop-to-buffer scheme-buffer display-comint-buffer-action) + (with-suppressed-warnings ((obsolete display-comint-buffer-action)) + (pop-to-buffer scheme-buffer display-comint-buffer-action)) (error "No current process buffer. See variable `scheme-buffer'")) (when eob-p (push-mark) diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el index 7d374587dc4..503f64add41 100644 --- a/lisp/eshell/eshell.el +++ b/lisp/eshell/eshell.el @@ -250,7 +250,8 @@ information on Eshell, see Info node `(eshell)Top'." (t (get-buffer-create eshell-buffer-name))))) (cl-assert (and buf (buffer-live-p buf))) - (pop-to-buffer buf display-comint-buffer-action) + (with-suppressed-warnings ((obsolete display-comint-buffer-action)) + (pop-to-buffer buf display-comint-buffer-action)) (unless (derived-mode-p 'eshell-mode) (eshell-mode)) buf)) diff --git a/lisp/progmodes/inf-lisp.el b/lisp/progmodes/inf-lisp.el index 141bd18cf1e..687b176009e 100644 --- a/lisp/progmodes/inf-lisp.el +++ b/lisp/progmodes/inf-lisp.el @@ -308,7 +308,8 @@ quoted using shell quote syntax. "inferior-lisp" (car cmdlist) nil (cdr cmdlist))) (inferior-lisp-mode))) (setq inferior-lisp-buffer "*inferior-lisp*") - (pop-to-buffer "*inferior-lisp*" display-comint-buffer-action)) + (with-suppressed-warnings ((obsolete display-comint-buffer-action)) + (pop-to-buffer "*inferior-lisp*" display-comint-buffer-action))) ;;;###autoload (defalias 'run-lisp 'inferior-lisp) diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index 20c9e00edbf..a348e9ba6fd 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -1435,7 +1435,8 @@ If FORCE is non-nil and no process found, create one." (defun sh-show-shell () "Pop the shell interaction buffer." (interactive) - (pop-to-buffer (process-buffer (sh-shell-process t)) display-comint-buffer-action)) + (with-suppressed-warnings ((obsolete display-comint-buffer-action)) + (pop-to-buffer (process-buffer (sh-shell-process t)) display-comint-buffer-action))) (defun sh-send-text (text) "Send TEXT to `sh-shell-process'." diff --git a/lisp/shell.el b/lisp/shell.el index cd49d289403..e6b315ee5c0 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -923,7 +923,8 @@ Make the shell buffer the current buffer, and return it. (current-buffer))) ;; The buffer's window must be correctly set when we call comint ;; (so that comint sets the COLUMNS env var properly). - (pop-to-buffer buffer display-comint-buffer-action) + (with-suppressed-warnings ((obsolete display-comint-buffer-action)) + (pop-to-buffer buffer display-comint-buffer-action)) (with-connection-local-variables (when file-name diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index 02ee1242c72..97c950267c6 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -2035,7 +2035,8 @@ In the tex shell buffer this command behaves like `comint-send-input'." (defun tex-display-shell () "Make the TeX shell buffer visible in a window." - (display-buffer (tex-shell-buf) display-tex-shell-buffer-action) + (with-suppressed-warnings ((obsolete display-tex-shell-buffer-action)) + (display-buffer (tex-shell-buf) display-tex-shell-buffer-action)) (tex-recenter-output-buffer nil)) (defun tex-shell-sentinel (proc _msg) @@ -2692,7 +2693,8 @@ line LINE of the window, or centered if LINE is nil." (if (null tex-shell) (message "No TeX output buffer") (when-let ((window - (display-buffer tex-shell display-tex-shell-buffer-action))) + (with-suppressed-warnings ((obsolete display-tex-shell-buffer-action)) + (display-buffer tex-shell display-tex-shell-buffer-action)))) (with-selected-window window (bury-buffer tex-shell) (goto-char (point-max)) commit 98649236f5eb1d89a60ebb9cc06c71f410f6b347 Author: Eli Zaretskii Date: Thu Apr 25 19:34:42 2024 +0300 Fix 'mode-line-right-align-edge' with asymmetrical margins * lisp/bindings.el (mode--line-format-right-align): Fix alignment when window-margins are different on each side of the window. Suggested by Charles Gonnaud . (Bug#70485) diff --git a/lisp/bindings.el b/lisp/bindings.el index 50af32076a3..5a8c7cfafd7 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -381,7 +381,7 @@ the symbol `mode-line-format-right-align' is processed by `(space :align-to (,(- (window-pixel-width) (window-scroll-bar-width) (window-right-divider-width) - (* (or (cdr (window-margins)) 1) + (* (or (car (window-margins)) 0) (frame-char-width)) ;; Manually account for value of ;; `mode-line-right-align-edge' even commit d8687fd6cd807db1c76084a5e2bb214f9b6c9a49 Author: Eli Zaretskii Date: Thu Apr 25 18:59:25 2024 +0300 Fix last change * test/lisp/progmodes/csharp-mode-tests.el (csharp-ts-mode-test-indentation): Move the test to here. * test/lisp/progmodes/csharp-ts-mode-tests.el: Remove file. * test/lisp/progmodes/csharp-ts-mode-resources/indent.erts: Move to test/lisp/progmodes/csharp-mode-resources/indent-ts.erts. diff --git a/test/lisp/progmodes/csharp-ts-mode-resources/indent.erts b/test/lisp/progmodes/csharp-mode-resources/indent-ts.erts similarity index 100% rename from test/lisp/progmodes/csharp-ts-mode-resources/indent.erts rename to test/lisp/progmodes/csharp-mode-resources/indent-ts.erts diff --git a/test/lisp/progmodes/csharp-mode-tests.el b/test/lisp/progmodes/csharp-mode-tests.el index f50fabf5836..2878fa601f2 100644 --- a/test/lisp/progmodes/csharp-mode-tests.el +++ b/test/lisp/progmodes/csharp-mode-tests.el @@ -26,5 +26,8 @@ (ert-deftest csharp-mode-test-indentation () (ert-test-erts-file (ert-resource-file "indent.erts"))) +(ert-deftest csharp-ts-mode-test-indentation () + (ert-test-erts-file (ert-resource-file "indent-ts.erts"))) + (provide 'csharp-mode-tests) ;;; csharp-mode-tests.el ends here diff --git a/test/lisp/progmodes/csharp-ts-mode-tests.el b/test/lisp/progmodes/csharp-ts-mode-tests.el deleted file mode 100644 index 0df0211d86b..00000000000 --- a/test/lisp/progmodes/csharp-ts-mode-tests.el +++ /dev/null @@ -1,30 +0,0 @@ -;;; csharp-ts-mode-tests.el --- Tests for Tree-sitter-based C# mode -*- lexical-binding: t; -*- - -;; Copyright (C) 2024 Free Software Foundation, Inc. - -;; 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 . - -;;; Code: - -(require 'ert) -(require 'ert-x) -(require 'csharp-mode) - -(ert-deftest csharp-ts-mode-test-indentation () - (ert-test-erts-file (ert-resource-file "indent.erts"))) - -(provide 'csharp-ts-mode-tests) -;;; csharp-ts-mode-tests.el ends here commit 494dfd9cf2becdb33eefb1c0e6d8bc383cb8a2f0 Author: Jacob Leeming Date: Mon Apr 22 09:49:15 2024 +0100 Fix indentation of if/else in 'csharp-ts-mode' (bug#70345) * lisp/progmodes/csharp-mode.el (csharp-ts-mode--indent-rules): Fix indentation rules for 'if' and 'else'. * test/lisp/progmodes/csharp-ts-mode-tests.el: * test/lisp/progmodes/csharp-ts-mode-resources/indent.erts: New test files. Copyright-paperwork-exempt: yes diff --git a/lisp/progmodes/csharp-mode.el b/lisp/progmodes/csharp-mode.el index 607360f737a..62bbbfe02ff 100644 --- a/lisp/progmodes/csharp-mode.el +++ b/lisp/progmodes/csharp-mode.el @@ -689,7 +689,9 @@ compilation and evaluation time conflicts." ((parent-is "binary_expression") parent 0) ((parent-is "block") parent-bol csharp-ts-mode-indent-offset) ((parent-is "local_function_statement") parent-bol 0) - ((parent-is "if_statement") parent-bol 0) + ((match "block" "if_statement") parent-bol 0) + ((match "else" "if_statement") parent-bol 0) + ((parent-is "if_statement") parent-bol csharp-ts-mode-indent-offset) ((parent-is "for_statement") parent-bol 0) ((parent-is "for_each_statement") parent-bol 0) ((parent-is "while_statement") parent-bol 0) diff --git a/test/lisp/progmodes/csharp-ts-mode-resources/indent.erts b/test/lisp/progmodes/csharp-ts-mode-resources/indent.erts new file mode 100644 index 00000000000..3cb23608270 --- /dev/null +++ b/test/lisp/progmodes/csharp-ts-mode-resources/indent.erts @@ -0,0 +1,51 @@ +Code: + (lambda () + (csharp-ts-mode) + (indent-region (point-min) (point-max))) + +Point-Char: | + +Name: Indent single statement body for if/else. (bug#70345) + +=-= + +int x; +int y; + +if (true) + x = 2; + +if (true) +{ + x = 2; +} + +if (true) + x = 2; +else + y = 2; + +if (true) +{ + x = 2; +} +else +{ + y = 2; +} + +if (true) + x = 2; +else +{ + y = 2; +} + +if (true) +{ + x = 2; +} +else + y = 2; + +=-=-= diff --git a/test/lisp/progmodes/csharp-ts-mode-tests.el b/test/lisp/progmodes/csharp-ts-mode-tests.el new file mode 100644 index 00000000000..0df0211d86b --- /dev/null +++ b/test/lisp/progmodes/csharp-ts-mode-tests.el @@ -0,0 +1,30 @@ +;;; csharp-ts-mode-tests.el --- Tests for Tree-sitter-based C# mode -*- lexical-binding: t; -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; 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 . + +;;; Code: + +(require 'ert) +(require 'ert-x) +(require 'csharp-mode) + +(ert-deftest csharp-ts-mode-test-indentation () + (ert-test-erts-file (ert-resource-file "indent.erts"))) + +(provide 'csharp-ts-mode-tests) +;;; csharp-ts-mode-tests.el ends here commit c493f28cc948ac4aef9c262345a608b3c7d413a4 Author: john muhl Date: Sat Apr 20 21:19:27 2024 -0500 Fix which-function error in 'lua-ts-mode' (bug#70515) * lisp/progmodes/lua-ts-mode.el (lua-ts-mode): Remove incorrect usage of 'which-func-functions'. * test/lisp/progmodes/lua-ts-mode-tests.el (lua-ts-test-which-function): Add test. * test/lisp/progmodes/lua-ts-mode-resources/which-function.lua: New file. diff --git a/lisp/progmodes/lua-ts-mode.el b/lisp/progmodes/lua-ts-mode.el index 45ea8ec9a81..06663e5bd0e 100644 --- a/lisp/progmodes/lua-ts-mode.el +++ b/lisp/progmodes/lua-ts-mode.el @@ -764,7 +764,7 @@ Calls REPORT-FN directly." "vararg_expression")))) (text "comment")))) - ;; Imenu/Outline. + ;; Imenu/Outline/Which-function. (setq-local treesit-simple-imenu-settings `(("Requires" "\\`function_call\\'" @@ -776,9 +776,6 @@ Calls REPORT-FN directly." lua-ts--named-function-p nil))) - ;; Which-function. - (setq-local which-func-functions (treesit-defun-at-point)) - ;; Align. (setq-local align-indent-before-aligning t) diff --git a/test/lisp/progmodes/lua-ts-mode-resources/which-function.lua b/test/lisp/progmodes/lua-ts-mode-resources/which-function.lua new file mode 100644 index 00000000000..621d818461c --- /dev/null +++ b/test/lisp/progmodes/lua-ts-mode-resources/which-function.lua @@ -0,0 +1,3 @@ +local function f(x) + print(x) +end diff --git a/test/lisp/progmodes/lua-ts-mode-tests.el b/test/lisp/progmodes/lua-ts-mode-tests.el index 565e6f91dbd..a7b637d18d1 100644 --- a/test/lisp/progmodes/lua-ts-mode-tests.el +++ b/test/lisp/progmodes/lua-ts-mode-tests.el @@ -23,6 +23,7 @@ (require 'ert-font-lock) (require 'ert-x) (require 'treesit) +(require 'which-func) (ert-deftest lua-ts-test-indentation () (skip-unless (treesit-ready-p 'lua)) @@ -37,6 +38,16 @@ (let ((treesit-font-lock-level 4)) (ert-font-lock-test-file (ert-resource-file "font-lock.lua") 'lua-ts-mode))) +(ert-deftest lua-ts-test-which-function () + (skip-unless (treesit-ready-p 'lua)) + (with-temp-buffer + (insert-file-contents (ert-resource-file "which-function.lua")) + (lua-ts-mode) + (which-function-mode) + (goto-char (point-min)) + (should (equal "f" (which-function))) + (which-function-mode -1))) + (provide 'lua-ts-mode-tests) ;;; lua-ts-mode-tests.el ends here commit a45ae6bce982ee7eff33242e0742a6cfda01d4cb Author: Eshel Yaron Date: Wed Apr 24 19:27:15 2024 +0200 ; Exclude more modes in 'global-completion-preview-mode' Avoid activating Completion Preview mode in a few more major modes when 'global-completion-preview-mode' is enabled. * lisp/completion-preview.el (global-completion-preview-mode): By default, exclude a few more major modes for which Completion Preview mode isn't suitable. diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el index 25c1cd4a22f..e2012b0f80a 100644 --- a/lisp/completion-preview.el +++ b/lisp/completion-preview.el @@ -570,7 +570,14 @@ backward." ;;;###autoload (define-globalized-minor-mode global-completion-preview-mode completion-preview-mode completion-preview-mode - :predicate '((not minibuffer-mode special-mode) t)) + :predicate '((not compilation-mode + diff-mode + dired-mode + minibuffer-mode + minibuffer-inactive-mode + special-mode + wdired-mode) + t)) (provide 'completion-preview) ;;; completion-preview.el ends here commit 1cc6322e61275ad8b5056eb7dd43af6fe459aa0b Author: Eli Zaretskii Date: Thu Apr 25 12:39:36 2024 +0300 ; * etc/PROBLEMS: Document crashes due to tree-sitter ABI (bug#70438). diff --git a/etc/PROBLEMS b/etc/PROBLEMS index 54dc23c0951..2b3b7ba96f6 100644 --- a/etc/PROBLEMS +++ b/etc/PROBLEMS @@ -216,6 +216,28 @@ arguments you intend to pass to Emacs): $ SNAP=1 SNAP_NAME=1 SNAP_REVISION=1 emacs ... +** Emacs built with tree-sitter crashes when some *-ts-mode is turned on. + +The crash is in many cases an abort due to run-time detection of stack +smashing, and it happens when one of the *-ts-mode modes is turned on +in a buffer. + +The reason is that the tree-sitter library changed its Application +Binary Interface (ABI) between version 0.22.2 and 0.22.4, but did not +increment the ABI version number. Therefore, Emacs compiled with +tree-sitter versions before the change will try to use the shared +library after the change, and crash due to incompatibilities in the +ABI. + +Until and unless the tree-sitter developers release a library with an +updated ABI version, the solution is to rebuild Emacs with the actual +library with which it will be used. If you cannot rebuild Emacs, +downgrade your tree-sitter library to version 0.22.2 or older. + +The relevant tree-sitter issue is here: + + https://github.com/tree-sitter/tree-sitter/issues/3296 + ** Emacs crashes when you try to view a file with complex characters. One possible reason for this could be a bug in the libotf or the commit 88ebabe23a253ce040de94e6396bc4f587ba6e69 Author: Mattias Engdegård Date: Thu Apr 25 11:33:25 2024 +0200 Better eval-when-compile example in manual * doc/lispref/compile.texi (Eval During Compile): `regexp-opt` makes for a poor example because as a pure function it doesn't need `eval-when-compile` for constant inputs. diff --git a/doc/lispref/compile.texi b/doc/lispref/compile.texi index 00602198da5..08e824d2781 100644 --- a/doc/lispref/compile.texi +++ b/doc/lispref/compile.texi @@ -334,8 +334,8 @@ If you have a constant that needs some calculation to produce, @code{eval-when-compile} can do that at compile-time. For example, @lisp -(defvar my-regexp - (eval-when-compile (regexp-opt '("aaa" "aba" "abb")))) +(defvar gauss-schoolboy-problem + (eval-when-compile (apply #'+ (number-sequence 1 100)))) @end lisp @cindex macros, at compile time commit 2c8e7ebe6947b1268986dc51b0c093a68a18ce55 Author: Po Lu Date: Thu Apr 25 10:54:17 2024 +0800 Improve custom button faces on monochrome displays * lisp/cus-edit.el (custom-button, custom-button-mouse) (custom-button-pressed): Define raised boxes on monochrome displays. diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index f004002333b..8915500a501 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -2251,24 +2251,33 @@ and `face'." ;;; The `custom' Widget. (defface custom-button - '((((type x w32 ns haiku pgtk android) (class color)) ; Like default mode line + '((((type x w32 ns haiku pgtk android) (class color) + (min-colors 88)) ; Like default mode line :box (:line-width 2 :style released-button) - :background "lightgrey" :foreground "black")) + :background "lightgrey" :foreground "black") + (((type x w32 ns haiku pgtk android)) + :box (:line-width 2 :style released-button) + :background "white" :foreground "black")) "Face for custom buffer buttons if `custom-raised-buttons' is non-nil." - :version "21.1" + :version "30.1" :group 'custom-faces) (defface custom-button-mouse - '((((type x w32 ns haiku pgtk android) (class color)) + '((((type x w32 ns haiku pgtk android) (class color) + (min-colors 88)) :box (:line-width 2 :style released-button) :background "grey90" :foreground "black") + (((type x w32 ns haiku pgtk android)) + :box (:line-width 2 :style released-button) + ;; Either light gray or a stipple pattern. + :background "gray20" :foreground "black") (t ;; This is for text terminals that support mouse, like GPM mouse ;; or the MS-DOS terminal: inverse-video makes the button stand ;; out on mouse-over. :inverse-video t)) "Mouse face for custom buffer buttons if `custom-raised-buttons' is non-nil." - :version "22.1" + :version "30.1" :group 'custom-faces) (defface custom-button-unraised @@ -2284,12 +2293,16 @@ and `face'." (if custom-raised-buttons 'custom-button-mouse 'highlight)) (defface custom-button-pressed - '((((type x w32 ns haiku pgtk android) (class color)) + '((((type x w32 ns haiku pgtk android) (class color grayscale)) :box (:line-width 2 :style pressed-button) :background "lightgrey" :foreground "black") + (((type x w32 ns haiku pgtk android)) + :box (:line-width 2 :style pressed-button) + ;; Either light gray or a stipple pattern. + :background "gray20" :foreground "black") (t :inverse-video t)) "Face for pressed custom buttons if `custom-raised-buttons' is non-nil." - :version "21.1" + :version "30.1" :group 'custom-faces) (defface custom-button-pressed-unraised commit 3776539152711ca364d94f0d4f8166d6f67eb413 Author: Po Lu Date: Wed Apr 24 16:33:33 2024 +0800 Disable unsuitable XPM color selection mechanism on Android * src/image.c (xpm_load_image) [HAVE_ANDROID]: Always select XPM_COLOR_KEY_C. diff --git a/src/image.c b/src/image.c index 74249b8d465..ab61e49f695 100644 --- a/src/image.c +++ b/src/image.c @@ -6237,6 +6237,8 @@ xpm_load_image (struct frame *f, expect (','); XSETFRAME (frame, f); + +#ifndef HAVE_ANDROID if (!NILP (Fxw_display_color_p (frame))) best_key = XPM_COLOR_KEY_C; else if (!NILP (Fx_display_grayscale_p (frame))) @@ -6244,6 +6246,14 @@ xpm_load_image (struct frame *f, ? XPM_COLOR_KEY_G : XPM_COLOR_KEY_G4); else best_key = XPM_COLOR_KEY_M; +#else /* HAVE_ANDROID */ + /* The color-loading loop has not been taught to progressively settle + for less optimal color keys if no colors are defined for best_key, + and since libXpm is not available on Android, there is no better + option than delegating the task of mapping whatever color values + are provided to B/W or grayscale to the display driver. */ + best_key = XPM_COLOR_KEY_C; +#endif /* !HAVE_ANDROID */ color_symbols = image_spec_value (img->spec, QCcolor_symbols, NULL); if (chars_per_pixel == 1) commit 0e9cd1d7c6f64680c9e98a7c5c373a470088d4f9 Author: Gerd Möllmann Date: Wed Apr 24 09:33:50 2024 +0200 Fix tbreak for LLDB * lisp/progmodes/gud.el (lldb): Use _regexp-tbreak command. diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index f10b047cc74..90fdc99c7e2 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -4074,7 +4074,7 @@ This command runs functions from `lldb-mode-hook'." "\C-b" "Set breakpoint at current line.") (gud-def gud-tbreak - "_regexp-break %f:%l" + "_regexp-tbreak %f:%l" "\C-t" "Set temporary breakpoint at current line.") (gud-def gud-remove commit 3bf9a047427aab554ce228250a796fa327d9b353 Author: Eli Zaretskii Date: Wed Apr 24 10:02:22 2024 +0300 Fix handling of glyph codes in whitespace.el * lisp/whitespace.el (whitespace-display-vector-p): Support glyph codes, not just plain characters. See https://lists.gnu.org/archive/html/help-gnu-emacs/2024-04/msg00248.html for the details. diff --git a/lisp/whitespace.el b/lisp/whitespace.el index 15c1b83fcc1..bc23a8794eb 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -2474,7 +2474,7 @@ purposes)." (let ((i (length vec))) (when (> i 0) (while (and (>= (setq i (1- i)) 0) - (whitespace-char-valid-p (aref vec i)))) + (whitespace-char-valid-p (glyph-char (aref vec i))))) (< i 0)))) commit 2df8bc468549523806270808ca6652de8ebc8824 Author: Michael Albinus Date: Wed Apr 24 08:28:20 2024 +0200 ; Remove comment in eglot-tests.el diff --git a/test/lisp/progmodes/eglot-tests.el b/test/lisp/progmodes/eglot-tests.el index 96519175fa1..af1ee998919 100644 --- a/test/lisp/progmodes/eglot-tests.el +++ b/test/lisp/progmodes/eglot-tests.el @@ -439,9 +439,6 @@ directory hierarchy." (ert-deftest eglot-test-basic-symlink () "Test basic symlink support." (skip-unless (executable-find "clangd")) - ;; This test is said to fail due to bug#70408. So we skip it at least - ;; on EMBA, because it poisons the test jobs. - ;(skip-when (getenv "EMACS_EMBA_CI")) ;; MS-Windows either fails symlink creation or pops up UAC prompts. (skip-when (eq system-type 'windows-nt)) (eglot--with-fixture commit c8c319e0b024eb2441cda786c282a094a9cd30fb Author: Yuan Fu Date: Tue Apr 23 22:28:25 2024 -0700 Make c-ts-common-comment-indent-new-line work for rust doc comment * lisp/progmodes/c-ts-common.el (c-ts-common-comment-indent-new-line): Support //! comment directives. diff --git a/lisp/progmodes/c-ts-common.el b/lisp/progmodes/c-ts-common.el index c06295b8a87..cc8254c5701 100644 --- a/lisp/progmodes/c-ts-common.el +++ b/lisp/progmodes/c-ts-common.el @@ -296,9 +296,10 @@ and /* */ comments. SOFT works the same as in ;; auto-fill or other smart features. (cond ;; Line starts with //, or ///, or ////... + ;; Or //! (used in rust). ((save-excursion (beginning-of-line) - (looking-at (rx "//" (group (* "/") (* " "))))) + (looking-at (rx "//" (group (* (any "/!")) (* " "))))) (let ((whitespaces (match-string 1))) (if soft (insert-and-inherit ?\n) (newline 1)) (delete-region (line-beginning-position) (point)) @@ -316,7 +317,7 @@ and /* */ comments. SOFT works the same as in ;; Line starts with *. ((save-excursion (beginning-of-line) - (looking-at (rx (group (* " ") (or "*" "|") (* " "))))) + (looking-at (rx (group (* " ") (any "*|") (* " "))))) (let ((prefix (match-string 1))) (if soft (insert-and-inherit ?\n) (newline 1)) (delete-region (line-beginning-position) (point)) commit 67ef1d54e7e3983bb03840cf8f2990d579942710 Author: Yuan Fu Date: Tue Apr 23 16:28:20 2024 -0700 Make c-ts-common--fill-paragraph work for rust line comment * lisp/progmodes/c-ts-common.el (c-ts-common--fill-paragraph): Back to BOL before checking for //. diff --git a/lisp/progmodes/c-ts-common.el b/lisp/progmodes/c-ts-common.el index 457aa55c195..c06295b8a87 100644 --- a/lisp/progmodes/c-ts-common.el +++ b/lisp/progmodes/c-ts-common.el @@ -125,6 +125,9 @@ ARG is passed to `fill-paragraph'." (treesit-node-type node)) (if (save-excursion (goto-char (treesit-node-start node)) + ;; In rust, NODE will be the body of a comment excluding + ;; the //, so we need to go to BOL to check for //. + (back-to-indentation) (looking-at "//")) (fill-comment-paragraph arg) (c-ts-common--fill-block-comment arg))) commit 145a77808ebd36fffb2e9c0376f821f09733d045 Author: Po Lu Date: Wed Apr 24 11:45:31 2024 +0800 More effectually prevent defun list wrapping in C-x C-w * lisp/vc/log-edit.el (log-edit-fill-entry): Match and replace with NBSPs the opening defun list also. * test/lisp/vc/log-edit-tests.el (log-edit-fill-entry-no-defun-list-wrapping): New test. diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el index 1f766eea455..d61a108b195 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -698,7 +698,15 @@ according to `fill-column'." (save-excursion (goto-char beg) (when (re-search-forward - "^[[:blank:]]*(.*\\([[:space:]]\\).*):" + ;; Also replace spaces within defun lists + ;; prefixed by a file name so that + ;; fill-region never attempts to break + ;; them, even if multiple items combine + ;; with symbols to exceed the fill column + ;; by the expressly permitted margin of 1 + ;; character. + (concat "^\\([[:blank:]]*\\|\\* .*[[:blank:]]" + "\\)(.*\\([[:space:]]\\).*):") end t) (replace-regexp-in-region "[[:space:]]" " " (setq space-beg diff --git a/test/lisp/vc/log-edit-tests.el b/test/lisp/vc/log-edit-tests.el index 8373156587d..db60d21f137 100644 --- a/test/lisp/vc/log-edit-tests.el +++ b/test/lisp/vc/log-edit-tests.el @@ -344,4 +344,22 @@ next line instead.") (let ((fill-column 20)) (log-edit-fill-entry)) (should (equal (buffer-string) wanted))))) +(ert-deftest log-edit-fill-entry-no-defun-list-wrapping () + ;; This test verifies that the opening defun list of an entry is never + ;; broken, even in the event its length in total exceeds the fill + ;; column. + (let (string wanted) + (setq string " +* src/androidfns.c (Fxw_display_color_p): +(Fx_display_grayscale_p): Report color and/or grayscale properly. +" + wanted " +* src/androidfns.c (Fxw_display_color_p, Fx_display_grayscale_p): +Report color and/or grayscale properly. +") + (with-temp-buffer + (insert string) + (let ((fill-column 64)) (log-edit-fill-entry)) + (should (equal (buffer-string) wanted))))) + ;;; log-edit-tests.el ends here commit d3d1be8ae56efe29e4a721c5dd4e1fa973cf9d5a Author: Po Lu Date: Wed Apr 24 11:42:48 2024 +0800 Miscellaneous fixes for Android port * lisp/touch-screen.el (touch-screen-hold, touch-screen-drag): Clear deactivate-mark if the mark is activated to prevent undue deactivation after completion. * lisp/wid-edit.el (widget-field, widget-single-line-field): Insert specifications suitable for monochrome displays. * src/androidfns.c (Fxw_display_color_p, Fx_display_grayscale_p): Report color and/or grayscale properly. * src/image.c (image_create_bitmap_from_file) [HAVE_ANDROID]: If a file with no extension cannot be located, append .xbm and retry. diff --git a/lisp/touch-screen.el b/lisp/touch-screen.el index 037386112d3..52a36712c44 100644 --- a/lisp/touch-screen.el +++ b/lisp/touch-screen.el @@ -351,7 +351,8 @@ word around EVENT; otherwise, set point to the location of EVENT." touch-screen-word-select-bounds nil) (push-mark point) (goto-char point) - (activate-mark)) + (activate-mark) + (setq deactivate-mark nil)) ;; Start word selection by trying to obtain the position ;; around point. (let ((word-start nil) @@ -381,7 +382,8 @@ word around EVENT; otherwise, set point to the location of EVENT." touch-screen-word-select-initial-word nil) (push-mark point) (goto-char point) - (activate-mark)) + (activate-mark) + (setq deactivate-mark nil)) ;; Otherwise, select the word. Move point to either the ;; end or the start of the word, depending on which is ;; closer to EVENT. @@ -420,10 +422,12 @@ word around EVENT; otherwise, set point to the location of EVENT." (progn (push-mark word-start) (activate-mark) + (setq deactivate-mark nil) (goto-char word-end)) (progn (push-mark word-end) (activate-mark) + (setq deactivate-mark nil) (goto-char word-start))) ;; Record the bounds of the selected word. (setq touch-screen-word-select-bounds @@ -837,7 +841,8 @@ area." ;; Display a preview of the line now around ;; point if requested by the user. (when touch-screen-preview-select - (touch-screen-preview-select)))))))))))))) + (touch-screen-preview-select))))))))))) + (setq deactivate-mark nil)))) (defun touch-screen-restart-drag (event) "Restart dragging to select text. diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index dc481d4d0a5..2d82fbe7c89 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -141,12 +141,21 @@ This exists as a variable so it can be set locally in certain buffers.") :background "dim gray" :box (:line-width (1 . -1) :color "gray46") :extend t) + ;; Monochrome displays. + (((background light)) + :background "white" + :box (:line-width (1 . -1) :color "black") + :extend t) + (((background dark)) + :background "black" + :box (:line-width (1 . -1) :color "white") + :extend t) (t :slant italic :extend t)) "Face used for editable fields." :group 'widget-faces - :version "28.1") + :version "30.1") (defface widget-single-line-field '((((type tty)) :background "green3" @@ -157,6 +166,10 @@ This exists as a variable so it can be set locally in certain buffers.") (((class grayscale color) (background dark)) :background "dim gray") + ;; Monochrome displays. + (((background light)) + :stipple "gray3" + :extend t) (t :slant italic)) "Face used for editable fields spanning only a single line." diff --git a/src/androidfns.c b/src/androidfns.c index b6df7ae0677..df425e5779e 100644 --- a/src/androidfns.c +++ b/src/androidfns.c @@ -1202,7 +1202,10 @@ DEFUN ("xw-display-color-p", Fxw_display_color_p, doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { - return Qt; + struct android_display_info *dpyinfo; + + dpyinfo = check_android_display_info (terminal); + return dpyinfo->n_planes > 8 ? Qt : Qnil; } DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, @@ -1210,7 +1213,11 @@ DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { - return Qnil; + struct android_display_info *dpyinfo; + + dpyinfo = check_android_display_info (terminal); + return (dpyinfo->n_planes > 1 && dpyinfo->n_planes <= 8 + ? Qt : Qnil); } DEFUN ("x-display-pixel-width", Fx_display_pixel_width, diff --git a/src/image.c b/src/image.c index d1faadee968..74249b8d465 100644 --- a/src/image.c +++ b/src/image.c @@ -957,10 +957,17 @@ image_create_bitmap_from_file (struct frame *f, Lisp_Object file) } } - /* Search bitmap-file-path for the file, if appropriate. */ - if (openp (Vx_bitmap_file_path, file, Qnil, &found, - make_fixnum (R_OK), false, false, NULL) - < 0) + /* Search bitmap-file-path for the file, if appropriate. If no file + extension or directory is specified and no file by this name + exists, append the extension ".xbm" and retry. */ + if ((openp (Vx_bitmap_file_path, file, Qnil, &found, + make_fixnum (R_OK), false, false, NULL) < 0) + && (NILP (Fequal (Ffile_name_nondirectory (file), file)) + || strrchr (SSDATA (file), '.') + || (openp (Vx_bitmap_file_path, + CALLN (Fconcat, file, build_string (".xbm")), + Qnil, &found, make_fixnum (R_OK), false, false, + NULL) < 0))) return -1; if (!STRINGP (image_find_image_fd (file, &fd)) commit 42766f95e5c0e7eb9e21db964ed93c7e093cc0b9 Author: Ulrich Müller Date: Tue Apr 23 07:37:17 2024 +0200 * build-aux/make-info-dir: Avoid bashism (bug#70484). diff --git a/build-aux/make-info-dir b/build-aux/make-info-dir index e5f4972902f..631fe533e69 100755 --- a/build-aux/make-info-dir +++ b/build-aux/make-info-dir @@ -33,7 +33,8 @@ ## Header contains non-printing characters, so this is more ## reliable than using awk. -cat <"${1?}" || exit +test $# -ge 2 || exit 1 +cat <"$1" shift exec "${AWK-awk}" ' @@ -101,4 +102,4 @@ exec "${AWK-awk}" ' if (data[dircat]) printf "\n%s\n%s", topic[dircat], data[dircat] } -' "${@?}" +' "$@" commit d8d4fd8c6dbe11542432fccdc31701da9f686460 Author: Eli Zaretskii Date: Tue Apr 23 21:28:09 2024 +0300 ; * lisp/progmodes/eglot.el (eglot-path-to-uri): Improve commentary. diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index b066e2e33eb..6896baf30ce 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -1091,8 +1091,11 @@ ACTION is an LSP object of either `CodeAction' or `Command' type." (cl-defun eglot-path-to-uri (path &key truenamep) "Convert PATH, a file name, to LSP URI string and return it. TRUENAMEP indicated PATH is already a truename." - ;; LSP assumes little of filesystems, servers being potentially - ;; physically detached from it. Make sure we hand them true names. + ;; LSP servers should not be expected to access the filesystem, and + ;; therefore are generally oblivious that some filenames are + ;; different, but point to the same file, like a symlink and its + ;; target. Make sure we hand the server the true name of a file by + ;; calling file-truename. (let ((truepath (if truenamep path (file-truename path)))) (if (and (url-type (url-generic-parse-url path)) ;; PATH might be MS Windows file name which includes a commit 1601c5a518dfa208af4827c56cf9570f3b90e15d Author: Daniel Semyonov Date: Wed Jun 21 10:05:04 2023 +0300 Gnus: Add back end for Atom feeds (nnatom) * lisp/gnus/gnus.el (gnus-valid-select-methods): Add entry for nnatom. * lisp/gnus/nnfeed.el: New file implementing an abstract web feed back end. * lisp/gnus/nnatom.el: New file implementing a back end for Atom feeds. * doc/misc/gnus.texi (Browsing the Web, Back End Interface): * etc/NEWS (Gnus): Document nnatom and nnfeed. diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index 419a5390374..8aa7f855aea 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -715,6 +715,7 @@ Browsing the Web * Web Searches:: Creating groups from articles that match a string. * RSS:: Reading RDF site summary. +* Atom:: Reading Atom Syndication Format feeds. Other Sources @@ -975,6 +976,7 @@ Back End Interface * Writing New Back Ends:: Extending old back ends. * Hooking New Back Ends Into Gnus:: What has to be done on the Gnus end. * Mail-like Back Ends:: Some tips on mail back ends. +* Web Feed Back Ends:: Easily defining back ends for web feeds. Various File Formats @@ -17252,6 +17254,7 @@ interfaces to these sources. @menu * Web Searches:: Creating groups from articles that match a string. * RSS:: Reading RDF site summary. +* Atom:: Reading Atom Syndication Format feeds. @end menu The main caveat with all these web sources is that they probably won't @@ -17496,6 +17499,42 @@ Parameters}) in order to display @samp{text/html} parts only in @end lisp +@node Atom +@subsection Atom +@cindex nnatom +@cindex Atom + +Some web sites provide an Atom Syndication Format feed. Atom is a web +feed format similar in function to RDF Site Summary (@pxref{RSS}). + +The @code{nnatom} back end allows you to add HTTP or local Atom feeds as +Gnus servers, by adding them to @code{gnus-secondary-select-methods} or +as foreign servers by pressing "B" in the @file{*Group*} buffer, for +example (@pxref{Finding the News}). The address of each server is its +feed's location (though the address shouldn't be prefixed with or +) and each server contains a single group which holds the +feed's entries. + +Features of @code{nnatom} include: + +@itemize @bullet + +@item +Server data is saved per-server in the @file{atom} sub-directory of +@file{gnus-directory}. + +@item +An article part is generated for both the summary and the content for +each entry in the feed. Content of all MIME types should be displayed +correctly through Gnus (as long as they are supported and the feed +specifies a MIME type). + +@item +Article modification and publish dates are tracked, and articles are +updated if changed. + +@end itemize + @node Other Sources @section Other Sources @@ -29997,6 +30036,7 @@ In the examples and definitions I will refer to the imaginary back end * Writing New Back Ends:: Extending old back ends. * Hooking New Back Ends Into Gnus:: What has to be done on the Gnus end. * Mail-like Back Ends:: Some tips on mail back ends. +* Web Feed Back Ends:: Easily defining back ends for web feeds. @end menu @@ -30770,6 +30810,43 @@ this: @end example +@node Web Feed Back Ends +@subsubsection Web Feed Back Ends + +If you want to write a back end for a new type of web feed (RSS, +Atom), or some other type of feed, an ``abstract'' back end +(@code{nnfeed}) exists to enable the creation of such back ends with +minimal knowledge of Gnus. + +@code{nnfeed} defines a generic parser, which uses functions stored in +server variables to parse information from a feed (@code{nnfeed} +itself doesn't actually define any such functions though). + +The data parsed from the feed is stored in server variables (and +stored per-feed in a sub-directory of @option{gnus-directory} whose name +corresponds to the name of the back end). + +A Gnus back end interface is also defined, which uses the data parsed +from the feed. + +Therefore, a new back end only needs to inherit from @code{nnfeed}, +define (fairly) generic parsing functions for the feed type and setup +the required server variables. + +@code{nnfeed} was originally created to support Atom Syndication +Format feeds (@pxref{Atom}), but is very generic (as of writing this, +no standard web feed exists which can meaningfully use all the +features supported): it supports multiple groups contained in a single +feed, it allows for situations when the entire feed can't (or +shouldn't) be read ahead of time and it allows for very advanced +customization of the actual printing of articles from parsed data +(while providing a reasonably powerful default method). + +Further implementation details are available in the documentation +strings of the various @code{nnfeed-*} server variables and +the commentary and other comments of @file{nnfeed.el}. + + @node Score File Syntax @subsection Score File Syntax diff --git a/etc/NEWS b/etc/NEWS index 82c73f7416b..fea27bb8a31 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1337,6 +1337,16 @@ when using the ':vc' keyword. ** Gnus ++++ +*** New back end 'nnfeed'. +This allows back end developers to easily create new back ends for web +feeds, as inheriting back ends of 'nnfeed'. + ++++ +*** New back end 'nnatom'. +This allow users to add Atom Syndication Format feeds to Gnus as +servers. + *** The 'nnweb-type' option 'gmane' has been removed. The gmane.org website is, sadly, down since a number of years with no prospect of it coming back. Therefore, it is no longer valid to set diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index dab66b60205..bc8819dc967 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -1360,6 +1360,7 @@ slower." ("nnimap" post-mail address prompt-address physical-address respool server-marks cloud) ("nnmaildir" mail respool address server-marks) + ("nnatom" address) ("nnnil" none)) "An alist of valid select methods. The first element of each list lists should be a string with the name diff --git a/lisp/gnus/nnatom.el b/lisp/gnus/nnatom.el new file mode 100644 index 00000000000..e8dfa12aff5 --- /dev/null +++ b/lisp/gnus/nnatom.el @@ -0,0 +1,276 @@ +;;; nnatom.el --- Atom backend for Gnus -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. +;; Author: Daniel Semyonov + +;; This file is part of GNU Emacs. + +;; nnatom 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. + +;; nnatom 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 nnatom. If not, see . + +;;; Commentary: + +;; Gnus backend for HTTP or local feeds following the +;; Atom Syndication Format . + +;;; Code: + +(eval-when-compile + (require 'cl-lib) + (require 'subr-x)) + +(require 'nnfeed) +(require 'mm-url) +(require 'dom) + +(defgroup nnatom nil + "Atom backend for Gnus." + :group 'nnfeed) + +(nnoo-declare nnatom nnfeed) + +(nnfeed-define-basic-backend-interface nnatom) + +;;;; Atom feed parser: + +(defun nnatom--read-feed (feed _) + "Return a list structure representing FEED, or nil." + (if (string-match-p "\\`https?://" feed) + (nnheader-report + nnatom-backend + "Address shouldn't start with \"http://\" or \"https://\"") + (with-temp-buffer + (condition-case e + (if (file-name-absolute-p feed) + (insert-file-contents feed) + (mm-url-insert-file-contents (concat "https://" feed))) + (file-error (nnheader-report nnatom-backend (cdr e))) + (:success (when-let ((data (if (libxml-available-p) + (libxml-parse-xml-region + (point-min) (point-max)) + (car (xml-parse-region + (point-min) (point-max))))) + (authors (list 'authors))) + (when (eq (car data) 'top) + (setq data (assq 'feed data))) + (dom-add-child-before data authors) + (let ((all (dom-children data))) + (while-let ((rest (cdr all)) + (child (car-safe rest)) + (type (car-safe child)) + ((not (eq type 'entry)))) + (and (or (eq type 'author) + (eq type 'contributor)) + (dom-add-child-before authors child)) + (setq all rest)) + ;; Order of entries is reversed as most Atom feeds + ;; list only the "most recent" entries, in reverse + ;; chronological order. + (setcdr all (nreverse (cdr all)))) + data)))))) +(defvoo nnatom-read-feed-function #'nnatom--read-feed + nil nnfeed-read-feed-function) + +(defun nnatom--read-group (data) + "Return the next group and the remaining DATA in a cons cell, or nil." + `(,data)) +(defvoo nnatom-read-group-function #'nnatom--read-group + nil nnfeed-read-group-function) + +(defun nnatom--read-article (data _) + "Return the next article and the remaining DATA in a cons cell, or nil." + (when (eq (car data) 'feed) (setq data (dom-children data))) + ;; Discard any children between/after entries. + (while (and data (not (eq (car-safe (car data)) 'entry))) (pop data)) + (when-let ((article (car data)) + (auths (list 'authors)) (links (list 'links))) + (dom-add-child-before article links) + (dom-add-child-before article auths) + (dolist (child (cddddr article) `(,article . ,(cdr data))) + (pcase (car-safe child) ; Authors and links can appear + ((or 'author 'contributor) ; anywhere in the entry so we + (dom-add-child-before auths child) ; collect them all here to + (dom-add-child-before links child)) ; avoid looping over the + ((or 'link ; entry multiple times later. + (and 'content (guard (assq 'src (dom-attributes child))))) + (dom-add-child-before links child)))))) +(defvoo nnatom-read-article-function #'nnatom--read-article + nil nnfeed-read-article-function) + +(defun nnatom--read-title (group) + "Return the title of GROUP, or nil." + (dom-text (dom-child-by-tag group 'title))) +(defvoo nnatom-read-title-function #'nnatom--read-title + nil nnfeed-read-title-function) + +(defun nnatom--read-description (group) + "Return the description of GROUP, or nil." + (dom-text (dom-child-by-tag group 'subtitle))) +(defvoo nnatom-read-description-function #'nnatom--read-description + nil nnfeed-read-description-function) + +(defun nnatom--read-article-or-group-authors (article-or-group) + "Return the authors of ARTICLE-OR-GROUP, or nil." + (when-let + ((a (mapconcat + (lambda (author) + (let* ((name (dom-text (dom-child-by-tag author 'name))) + (name (unless (string-blank-p name) name)) + (email (dom-text (dom-child-by-tag author 'email))) + (email (unless (string-blank-p email) email))) + (or (and name email (format "%s <%s>" name email)) name email))) + (dom-children (dom-child-by-tag article-or-group 'authors)) + ", ")) + ((not (string-blank-p a)))) + a)) +(defvoo nnatom-read-author-function #'nnatom--read-article-or-group-authors + nil nnfeed-read-author-function) +(defvoo nnatom-read-group-author-function + #'nnatom--read-article-or-group-authors + nil nnfeed-read-group-author-function) + +(defun nnatom--read-subject (article) + "Return the subject of ARTICLE, or nil." + (dom-text (dom-child-by-tag article 'title))) +(defvoo nnatom-read-subject-function #'nnatom--read-subject + nil nnfeed-read-subject-function) + +(defun nnatom--read-id (article) + "Return the ID of ARTICLE. +If the ARTICLE doesn't contain an ID but it does contain a subject, +return the subject. Otherwise, return nil." + (or (dom-text (dom-child-by-tag article 'id)) + (nnatom--read-subject article))) +(defvoo nnatom-read-id-function #'nnatom--read-id + nil nnfeed-read-id-function) + +(defun nnatom--read-publish (article) + "Return the date and time ARTICLE was published, or nil." + (when-let (d (dom-child-by-tag article 'published)) + (date-to-time (dom-text d)))) +(defvoo nnatom-read-publish-date-function #'nnatom--read-publish + nil nnfeed-read-publish-date-function) + +(defun nnatom--read-update (article) + "Return the date and time of the last update to ARTICLE, or nil." + (when-let (d (dom-child-by-tag article 'updated)) + (date-to-time (dom-text d)))) +(defvoo nnatom-read-update-date-function #'nnatom--read-update + nil nnfeed-read-update-date-function) + +(defun nnatom--read-links (article) + "Return all links contained in ARTICLE, or nil." + (let ((alt 0) (rel 0) (sel 0) (enc 0) (via 0) (aut 0)) + (mapcan + (lambda (link) + (when-let ((l (car-safe link))) + (or + (when-let (((eq l 'content)) + (src (dom-attr link 'src)) + (label (concat "Link" + (and (< 1 (cl-incf alt)) + (format " %s" alt))))) + `(((("text/plain") . ,(format "%s: %s\n" label src)) + (("text/html") . ,(format "[%s] " + src label))))) + (when-let (((or (eq l 'author) (eq l 'contributor))) + (name (dom-text (dom-child-by-tag link 'name))) + (name (if (string-blank-p name) + (concat "Author" + (and (< 1 (cl-incf aut)) + (format " %s" aut))) + name)) + (uri (dom-text (dom-child-by-tag link 'uri))) + ((not (string-blank-p uri)))) + `(((("text/plain") . ,(format "%s: %s\n" name uri)) + (("text/html") . ,(format "[%s] " + uri name))))) + (when-let (((eq l 'link)) + (attrs (dom-attributes link)) + (label (or (cdr (assq 'title attrs)) + (pcase (cdr (assq 'rel attrs)) + ("related" + (concat "Related" + (and (< 1 (cl-incf rel)) + (format " %s" rel)))) + ("self" + (concat "More" + (and (< 1 (cl-incf sel)) + (format " %s" sel)))) + ("enclosure" + (concat "Enclosure" + (and (< 1 (cl-incf enc)) + (format " %s" enc)))) + ("via" + (concat "Source" + (and (< 1 (cl-incf via)) + (format " %s" via)))) + (_ (if-let + ((lang (cdr (assq 'hreflang link)))) + (format "Link (%s)" lang) + (concat + "Link" + (and (< 1 (cl-incf alt)) + (format " %s" alt)))))))) + (link (cdr (assq 'href attrs)))) + `(((("text/plain") . ,(format "%s: %s\n" label link)) + (("text/html") . ,(format "[%s] " + link label)))))))) + (dom-children (dom-child-by-tag article 'links))))) +(defvoo nnatom-read-links-function #'nnatom--read-links + nil nnfeed-read-links-function) + +(defun nnatom--read-part (part type) + (let* ((atypes '("html" "plain")) + (mtypes '(("xhtml" . "text/html") ("text" . "text/plain"))) + (xsuff (concat "[+/]xml\\(-\\(dtd\\|external-parsed-entity\\)\\)?\\'" + "\\|^text")) + (part (if (string= type "xhtml") + (with-temp-buffer + (dom-print (dom-child-by-tag part 'div) nil t) + (buffer-substring-no-properties + (point-min) (point-max))) + (dom-text part))) + (type (if (member type atypes) (concat "text/" type) type)) + (type (or (cdr (assoc type mtypes)) type))) + (unless (string-blank-p part) + `(,part (Content-Type . ,(or type (setq type "text/plain"))) + ,(and (not (string-match-p xsuff type)) + '(Content-Transfer-Encoding . "base64")))))) + +(defun nnatom--read-parts (article) + "Return all parts contained in ARTICLE, or an empty HTML part with links." + (let* ((summary (dom-child-by-tag article 'summary)) + (stype (cdr (assq 'type (dom-attributes summary)))) + (summary (nnatom--read-part summary stype)) + (content (dom-child-by-tag article 'content)) + (ctype (cdr (assq 'type (dom-attributes content)))) + (content (nnatom--read-part content ctype)) + (st (string= stype ctype)) + parts) + (cond ((and summary content) + (and st (push summary parts)) + (push (append content '(links)) parts) + (or st (push summary parts))) + ((setq content (or summary content)) + (push (append content '(links)) parts)) + (t (push '((nil (Content-Type . "text/html") links)) parts))) + parts)) +(defvoo nnatom-read-parts-function #'nnatom--read-parts + nil nnfeed-read-parts-function) + +(gnus-declare-backend (symbol-name nnatom-backend) 'address) + +(provide 'nnatom) + +;;; nnatom.el ends here diff --git a/lisp/gnus/nnfeed.el b/lisp/gnus/nnfeed.el new file mode 100644 index 00000000000..0bf599553e4 --- /dev/null +++ b/lisp/gnus/nnfeed.el @@ -0,0 +1,683 @@ +;;; nnfeed.el --- Generic feed backend for Gnus -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. +;; Author: Daniel Semyonov + +;; This file is part of GNU Emacs. + +;; nnfeed 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. + +;; nnfeed 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 nnfeed. If not, see . + +;;; Commentary: + +;; Generic Gnus backend (intended) for implementing backends for web +;; feeds (Atom, RSS). +;; +;; This backend is abstract - it doesn't implement a parser for any +;; specific web feed type, and so can't be used independently. +;; +;; Instead, it implements a generic parser, feed data storage and most +;; of the Gnus backend interface; the intended use for this backend is +;; to be a source of inheritance for backends supporting new web feed +;; types. +;; +;; To implement new backends, use `nnfeed-define-basic-backend-interface': +;; +;; ... +;; (require 'nnfeed) +;; +;; (nnoo-declare nnfoo nnfeed) +;; +;; (nnfeed-define-basic-backend-interface nnfoo) +;; ... +;; [ definitions of parsing functions, see the "Feed parser interface" +;; section for more information. ] +;; +;; (defvoo nnfoo-read-feed-function #'nnfoo--read-feed +;; nil nnfeed-read-feed-function) +;; ... +;; (gnus-declare-backend (symbol-name nnfeed-backend) 'address) +;; +;; (provide 'nnfoo) +;; +;;; Code: + +(eval-when-compile + (require 'subr-x)) + +(require 'gnus) +(require 'nnoo) + +(defgroup nnfeed nil + "Generic feed backend for Gnus." + :group 'gnus) + +(defcustom nnfeed-date-format "%F %X%p" + "Format of displayed dates (see function `format-time-string')." + :type 'string) + +(nnoo-declare nnfeed) + +(defvoo nnfeed-backend nil + "Symbol which identifies this backend.") + +(defvoo nnfeed-status-string nil + "Last status message reported by this backend.") + +;; This macro should be used to define inheriting backends. + +(defmacro nnfeed-define-basic-backend-interface (backend) + "Define a basic set of functions and variables for BACKEND." + `(progn + (defvoo ,(nnoo-symbol backend 'backend) ',backend nil nnfeed-backend) + (defvoo ,(nnoo-symbol backend 'status-string) + nil nil nnfeed-status-string) + (defvoo ,(nnoo-symbol backend 'group) nil nil nnfeed-group) + (defvoo ,(nnoo-symbol backend 'servers) + (make-hash-table :test 'equal) nil nnfeed-servers) + (defvoo ,(nnoo-symbol backend 'group-article-ids) + (make-hash-table :test 'equal) nil nnfeed-group-article-ids) + (defvoo ,(nnoo-symbol backend 'group-articles) + (make-hash-table :test 'eql) nil nnfeed-group-articles) + (defvoo ,(nnoo-symbol backend 'group-article-max-num) 0 nil + nnfeed-group-article-max-num) + (defvoo ,(nnoo-symbol backend 'group-article-mix-num) 1 nil + nnfeed-group-article-min-num) + ,@(mapcar (lambda (fun) + `(deffoo ,(nnoo-symbol backend fun) (&optional server) + (,(nnoo-symbol 'nnoo fun) ',backend server))) + '(server-opened status-message)) + (deffoo ,(nnoo-symbol backend 'open-server) (server &optional defs) + (nnfeed-open-server server defs ',backend)) + (nnoo-import ,backend (nnfeed)))) + +;;;; Feed parser interface: + +;; The following set of server variables define a parser for a +;; specific web feed type. +;; An inheriting backend doesn't necessarily have to define all of +;; these functions (see the comments below for more information). +;; Apart from this set of variables there is also +;; `nnfeed-print-content-function' which can optionally be defined +;; by an inheriting backend to allow more advanced control over the +;; printing of articles. + +(defvoo nnfeed-read-feed-function #'ignore + "Function returning a Lisp object representing a feed (or part of it). + +It should accept two arguments, the address of a feed and the name of +a group (or nil). +If a group name is supplied, it should return a representation of only +the group (as if it was extracted from the feed with +`nnfeed-read-group-function').") + +(defvoo nnfeed-read-group-function #'ignore + "Function returning a cons cell of a group and remaining data from a feed. + +The returned group can be represented by any Lisp object. +It should accept a single argument, a Lisp object representing a feed +\(as can be returned by this function or `nnfeed-read-feed-function').") + +(defvoo nnfeed-read-article-function #'ignore + "Function returning a cons cell of an article and remaining data from a group. + +The returned article can be represented by any Lisp object. +It should accept two arguments, a Lisp object representing a group +\(as can be returned by this function or `nnfeed-read-group-function'), +and a flag indicating whether the last article was not new or updated.") + +(defvoo nnfeed-read-title-function #'ignore + "Function returning the title of a group (a string). + +It should accept a single argument, a Lisp object representing a group +\(as returned by `nnfeed-read-group-function').") + +;; Optional. +(defvoo nnfeed-read-description-function #'ignore + "Function returning the description of a group (a string), or nil. + +It should accept a single argument, a Lisp object representing a group +\(as returned by `nnfeed-read-group-function').") + +;; Either this function or `nnfeed-read-author-function' is required. +(defvoo nnfeed-read-group-author-function #'ignore + "Function returning the author of a group (a string), or nil. + +It should accept a single argument, a Lisp object representing a group +\(as returned by `nnfeed-read-group-function')..") + +(defvoo nnfeed-read-id-function #'ignore + "Function returning the ID of an article. + +It should accept a single argument, a Lisp object representing an article +\(as returned by `nnfeed-read-article-function').") + +(defvoo nnfeed-read-subject-function #'ignore + "Function returning the subject of an article (a string), or nil. + +It should accept a single argument, a Lisp object representing an article +\(as returned by `nnfeed-read-article-function').") + +;; Either this function or `nnfeed-read-update-date-function' is required. +(defvoo nnfeed-read-publish-date-function #'ignore + "Function returning the publish date of an article (a time value), or nil. + +It should accept a single argument, a Lisp object representing an article +\(as returned by `nnfeed-read-article-function').") + +;; Either this function or `nnfeed-read-publish-date-function' is required. +(defvoo nnfeed-read-update-date-function #'ignore + "Function returning the update date of an article (a time value), or nil. + +It should accept a single argument, a Lisp object representing an article +\(as returned by `nnfeed-read-article-function').") + +;; Either this function or `nnfeed-read-group-author-function' is required. +(defvoo nnfeed-read-author-function #'ignore + "Function returning the author of an article (a string), or nil. + +It should accept a single argument, a Lisp object representing an article +\(as returned by `nnfeed-read-article-function').") + +(defvoo nnfeed-read-headers-function #'ignore + "Function returning an alist of article-wide MIME headers. + +Each element of this alist maps a MIME header (a symbol, +i.e. `Content-Type') to its value. As a special case, `:boundary' +maps to a string which will serve as the boundary between article +parts. This must be supplied if a custom boundary is used in a +multipart content type header. The default boundary is \"-_nnfeed_-\", +and is automatically modified to match the name of the back end. +It should accept a single argument, a Lisp object representing an article +\(as returned by `nnfeed-read-article-function').") + +;; As mentioned in their docstrings, the last two parsing functions +;; can optionally return any Lisp representation they want, provided +;; an appropriate `nnfeed-print-content-function' is defined. This +;; means they are also not _strictly_ required. + +(defvoo nnfeed-read-links-function #'ignore + "Function returning all links contained in an article. + +With the default `nnfeed-print-content-function', it should return a +list of links, where each link is an alist mapping MIME content types +to links formatted for display in a part of that type. Each content +type may also be a list of content types. +Otherwise, it could return any Lisp object. +It should accept a single argument, a Lisp object representing an article +\(as returned by `nnfeed-read-article-function').") + +(defvoo nnfeed-read-parts-function #'ignore + "Function returning an alist associating parts of an article to their headers. + +With the default `nnfeed-print-content-function', each part should be a +string. Otherwise, it can be any Lisp object. The \"headers\" of +each part should be a list where each element is either a cons of a +MIME header (a symbol, i.e. `Content-Type') and its value (a string), +or any other Lisp object. MIME headers will be printed, the rest will +be passed on to `nnfeed-print-content-function', which recognizes the +following extra data by default: +- `links', if present, will cause links to be printed in the part. +It should accept a single argument, a Lisp object representing an article +\(as returned by `nnfeed-read-article-function').") + +;;;; Feed data storage: + +;; This section defines the data types used to store feed data, and +;; functions to read and write it. +;; All variables in this section are automatically defined by +;; `nnfeed-define-basic-backend-interface'. + +(defvoo nnfeed-servers (make-hash-table :test 'equal) + "Hash table mapping known servers to their groups. + +Each value in this table should itself be a hash table mapping known +group names to their data, which should be a vector of the form +[GROUP IDS ARTICLES MAX MIN DESCRIPTION], where: +- GROUP is the \"real\" group name (the name known to the server). +- IDS is a hash table mapping article IDs to their numbers. +- ARTICLES is a hash table mapping article numbers to articles and + their attributes (see `nnfeed-group-articles'). +- MAX is the maximum article number. +- MIN is the minimum article number. +- DESCRIPTION is the group description.") + +(defvoo nnfeed-group-names (make-hash-table :test 'equal) + "Hash table mapping real group names to their custom name.") + +(defun nnfeed--server-address (server) + "Return SERVER's real address." + (if (string-suffix-p "-ephemeral" server) + (setq server (or (cadr (assq (nnoo-symbol nnfeed-backend 'address) + (cddr (gnus-server-to-method + (concat + (symbol-name nnfeed-backend) ":" + server))))) + server)) + server)) + +(defun nnfeed--server-file (server) + "Return the file containing data for SERVER." + (expand-file-name (format "%s/%s.eld" + (string-trim (symbol-name nnfeed-backend) + "nn") + (gnus-newsgroup-savable-name + (nnfeed--server-address server))) + gnus-directory)) + +(defun nnfeed--read-server (server) + "Read SERVER's information from storage." + (if-let ((f (nnfeed--server-file server)) + ((file-readable-p f))) + (with-temp-buffer + (insert-file-contents f) + (goto-char (point-min)) + (puthash server (read (current-buffer)) nnfeed-servers)) + (nnheader-report nnfeed-backend "Can't read %s" server))) + +(defun nnfeed--write-server (server) + "Write SERVER's information to storage." + (if-let ((f (nnfeed--server-file server)) + ((file-writable-p f))) + (if-let ((s (gethash server nnfeed-servers)) + ((hash-table-p s))) + (with-temp-file f + (insert ";;;; -*- mode: lisp-data -*- DO NOT EDIT\n") + (prin1 s (current-buffer)) + (insert "\n") + t) + t) + (nnheader-report nnfeed-backend "Can't write %s" f))) + +;; The following function uses the parsing functions defined in the last +;; section to parse a feed (or just one group from it). +;; This is the only place where these parsing functions are used; the Gnus +;; backend interface extracts all required information from the parsed feed. + +(defun nnfeed--parse-feed (feed &optional group) + "Parse GROUP from FEED into a new or existing server. +If GROUP is omitted or nil, parse the entire FEED." + (let* ((feed (nnfeed--server-address feed)) + (s (or (gethash feed nnfeed-servers) (nnfeed--read-server feed) + (make-hash-table :test 'equal))) + (name group) ; (Maybe) fake name (or nil) + (group (aref (gethash group s `[,group]) 0)) ; Real name (or nil) + data) + (when (setq data (funcall nnfeed-read-feed-function feed group)) + (while-let ((cg (or (and name (cons data)) ; `data' is a single group + (funcall nnfeed-read-group-function data))) + (cg (prog1 (car cg) (setq data (cdr cg))))) + (let* ((name (funcall nnfeed-read-title-function cg)) ; Real name + (group (gethash name nnfeed-group-names name)) ; (Maybe) fake name + (info (gnus-get-info + (concat (symbol-name nnfeed-backend) "+" feed ":" group))) + (g (or (gethash group s) + `[ ,name ,(make-hash-table :test 'equal) + ,(make-hash-table :test 'eql) nil 1 ""])) + (desc (funcall nnfeed-read-description-function cg)) + (ids (aref g 1)) + (articles (aref g 2)) + (max (aref g 3)) + (max (if max max + (setq max 0) ; Find max article number + (dolist ; remembered by Gnus. + ( r (cons (gnus-info-read info) + (gnus-info-marks info)) + max) + (mapc (lambda (x) + (let ((x (if (consp x) + (if (< (car x) (cdr x)) + (cdr x) (car x)) + x))) + (when (< max x) (setq max x)))) + (if (symbolp (car r)) (cdr r) r))))) + (group-author (funcall nnfeed-read-group-author-function cg)) + stale) + (and desc (aset g 5 desc)) + (while-let ((article (funcall nnfeed-read-article-function cg stale)) + (article (prog1 (car article) (setq cg (cdr article))))) + (when-let ((id (funcall nnfeed-read-id-function article)) + (id (format "<%s@%s.%s>" id name nnfeed-backend))) + (let* ((num (gethash id ids)) + (update (funcall nnfeed-read-update-date-function article)) + (prev-update (aref (gethash num articles + '[nil nil nil nil nil]) + 4))) + (if (or (null num) ; New article ID. + (and (null prev-update) update) + (and prev-update update + (time-less-p prev-update update))) + (let* ((num (or num (aset g 3 (setq max (1+ max))))) + (publish (funcall nnfeed-read-publish-date-function + article))) + (setf + (gethash id (aref g 1)) num + (gethash num (aref g 2)) + `[ ,id + ,(or (funcall nnfeed-read-author-function article) + group-author group) + ,(or (funcall nnfeed-read-subject-function article) + "no subject") + ,(or publish update '(0 0)) ; published + ,(or update publish '(0 0)) ; updated + ,(funcall nnfeed-read-links-function article) + ,(funcall nnfeed-read-parts-function article) + ,(funcall nnfeed-read-headers-function article)] + stale nil)) + (setq stale t))))) + (puthash group g s))) + (puthash feed s nnfeed-servers)))) + +;;;; Gnus backend functions: + +;; The following two sections define a Gnus backend interface based on +;; the parsed data from the last section. +;; All server variables in this section are automatically defined by +;; `nnfeed-define-basic-backend-interface'. +;; For more information about these functions see the "Back End +;; Interface" section of the Gnus manual. + +(defvoo nnfeed-group nil + "Name of the current group.") + +(defvoo nnfeed-group-article-ids (make-hash-table :test 'equal) + "Hash table mapping article IDs to their article number.") + +(defvoo nnfeed-group-articles (make-hash-table :test 'eql) + "Hash table mapping article numbers to articles and their attributes. + +Each value in this table should be a vector of the form +[ID FROM SUBJECT DATE UPDATED LINKS PARTS HEADERS], where: +- ID is the ID of the article. +- FROM is the author of the article or group. +- SUBJECT is the subject of the article. +- DATE is the date the article was published, or last updated (time value). +- UPDATE is the date the article was last updated, or published (time value). +- LINKS is a collection of links (any Lisp object). +- PARTS is an alist associating the content of each part of the + article to its headers. +- HEADERS is an alist associating article-wide MIME headers to their value.") + +(defvoo nnfeed-group-article-max-num 0 + "Maximum article number for the current group.") + +(defvoo nnfeed-group-article-min-num 1 + "Minimum article number for the current group.") + +(nnoo-define-basics nnfeed) + +(defun nnfeed--current-server-no-prefix () + "Remove the \"+\" prefix from the current server." + (string-remove-prefix (concat (symbol-name nnfeed-backend) "+") + (nnoo-current-server nnfeed-backend))) + +(defun nnfeed--group-data (group server) + "Get parsed data for GROUP from SERVER." + (when-let ((server (nnfeed--server-address server)) + (s (gethash server nnfeed-servers)) + ((hash-table-p s))) + (gethash group s))) + +(defun nnfeed-retrieve-article (article group) + "Retrieve headers for ARTICLE from GROUP." + (if-let ((a (gethash article (aref group 2)))) + (insert (format "221 %s Article retrieved. +From: %s\nSubject: %s\nDate: %s\nMessage-ID: %s\n.\n" + article + (aref a 1) + (aref a 2) + (format-time-string "%F %H:%M" (aref a 3)) + (aref a 0))) + (insert "404 Article not found.\n.\n"))) + +(deffoo nnfeed-retrieve-headers (articles &optional group server _fetch-old) + (if-let ((server (or server (nnfeed--current-server-no-prefix))) + (g (or (nnfeed--group-data group server) + `[ nil ,nnfeed-group-article-ids ,nnfeed-group-articles + nil nil nil]))) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (or (and (stringp (car articles)) + (mapc (lambda (a) + (nnfeed-retrieve-article + (gethash a (aref g 2)) g)) + articles)) + (and (numberp (car articles)) + (range-map (lambda (a) (nnfeed-retrieve-article a g)) + articles))) + 'headers) + (nnheader-report nnfeed-backend "Group %s not found" (or group "")))) + +(deffoo nnfeed-open-server (server &optional defs backend) + (let ((backend (or backend 'nnfeed)) + (a (nnfeed--server-address server)) + s) + (nnoo-change-server backend server defs) + (when (setq s (or (gethash a nnfeed-servers) (nnfeed--read-server server))) + (maphash (lambda (group g) + (setq g (aref g 0)) + (unless (string= group g) + (puthash g group nnfeed-group-names))) + s)) + (setq a (nnfeed--server-file server)) + (or s (condition-case _ (make-directory (file-name-parent-directory a) t) + (:success (file-writable-p a)) + (t nil)) + (and (nnoo-close-server nnfeed-backend server) + (nnheader-report + nnfeed-backend "Server file %s not readable or writable" + server))))) + +(deffoo nnfeed-request-close () + (when (hash-table-p nnfeed-servers) + (maphash (lambda (server _) (nnfeed--write-server server)) nnfeed-servers) + (setq nnfeed-servers (make-hash-table :test 'equal))) + (setq nnfeed-status-string nil) + t) + +;; The default content printing function, which should be suitable for +;; most inheriting backends. + +(defun nnfeed--print-content (content attributes links) + "Return CONTENT formatted according to ATTRIBUTES, with LINKS possibly added." + (let ((links (and (memq 'links attributes) links))) + (when (or content links) + (concat + (and content (format "%s\n\n" content)) + (mapconcat (lambda (link) + (cdr (assoc (cdr (assq 'Content-Type attributes)) link + (lambda (types type) + (if (stringp types) (string= types type) + (member type types)))))) + links))))) + +(defvoo nnfeed-print-content-function #'nnfeed--print-content + "Function returning a single piece of content for an article (a string). + +It should accept three arguments, a part and its attributes (as returned +by `nnfeed-read-parts-function'), and links (as returned by +`nnfeed-read-links-function').") + +(defun nnfeed--print-part (content headers mime links) + "Print part of an article using its CONTENT, HEADERS, and LINKS. +Only HEADERS of a type included in MIME are considered." + (concat + (mapconcat (lambda (header) + (when-let ((m (car-safe header)) + ((member m mime))) + (format "%s: %s\n" m (cdr header)))) + headers) + "\n" + (funcall nnfeed-print-content-function content headers links))) + +(deffoo nnfeed-request-article (article &optional group server to-buffer) + (if-let ((server (or server (nnfeed--current-server-no-prefix))) + (g (or (nnfeed--group-data group server) + (and (setq group nnfeed-group) + `[ nil ,nnfeed-group-article-ids + ,nnfeed-group-articles + ,nnfeed-group-article-max-num + ,nnfeed-group-article-min-num nil]))) + (num (or (and (stringp article) + (gethash article (aref g 1))) + (and (numberp article) article))) + ((and (<= num (aref g 3)) + (>= num (aref g 4)))) + (a (gethash num (aref g 2)))) + (with-current-buffer (or to-buffer nntp-server-buffer) + (erase-buffer) + (let* ((links (aref a 5)) + (parts (aref a 6)) + (headers (aref a 7)) + (boundary (or (cdr (assq :boundary headers)) + (format "-_%s_-" nnfeed-backend))) + (multi (length> parts 1)) + (mime '( Content-Type Content-Disposition + Content-Transfer-Encoding))) + (insert (format + "Subject: %s\nFrom: %s\nDate: %s\nMessage-ID: %s\n" + (aref a 2) (aref a 1) + (format-time-string + nnfeed-date-format (or (aref a 3) '(0 0))) + (aref a 0)) + (if (assq 'MIME-Version headers) "" "MIME-Version: 1.0\n") + (mapconcat (lambda (header) + (unless (keywordp (car header)) + (format "%s: %s\n" (car header) (cdr header)))) + headers) + (if multi + (if (assq 'Content-Type headers) "" + (format + "Content-Type: multipart/alternative; boundary=%s\n" + boundary)) + (prog1 (nnfeed--print-part + (caar parts) (cdar parts) mime links) + (setq parts nil))) + (mapconcat (lambda (part) + (format "--%s\n%s\n" boundary + (nnfeed--print-part + (car part) (cdr part) mime links))) + parts) + (if multi (format "--%s--" boundary) "\n"))) + `(,group . ,num)) + (nnheader-report nnfeed-backend "No such article"))) + +(deffoo nnfeed-request-group (group &optional server fast _info) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (if-let ((server (or server (nnfeed--current-server-no-prefix))) + (g (or (if fast (nnfeed--group-data group server) + (setq server (nnfeed--parse-feed server group)) + (and (hash-table-p server) (gethash group server))) + `[ ,group ,(make-hash-table :test 'equal) + ,(make-hash-table :test 'eql) 0 1 ""]))) + (progn + (setq nnfeed-group group + nnfeed-group-article-ids (aref g 1) + nnfeed-group-articles (aref g 2) + nnfeed-group-article-max-num (aref g 3) + nnfeed-group-article-min-num (aref g 4)) + (insert (format "211 %s %s %s \"%s\"" + (hash-table-count nnfeed-group-article-ids) + nnfeed-group-article-min-num + nnfeed-group-article-max-num group)) + t) + (insert "404 group not found") + (nnheader-report nnfeed-backend "Group %s not found" group)))) + +(deffoo nnfeed-close-group (group &optional server) + (and (string= group nnfeed-group) + (setq nnfeed-group nil + nnfeed-group-article-ids (make-hash-table :test 'equal) + nnfeed-group-articles (make-hash-table :test 'eql) + nnfeed-group-article-max-num 0 + nnfeed-group-article-min-num 1)) + (setq server (or server (nnfeed--current-server-no-prefix))) + (nnfeed--write-server server)) + +(deffoo nnfeed-request-list (&optional server) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (when-let ((p (point)) + (s (nnfeed--parse-feed + (or server (nnfeed--current-server-no-prefix)))) + ((hash-table-p s))) + (maphash (lambda (group g) + (insert (format "\"%s\" %s %s y\n" + group (aref g 3) (aref g 4)))) + s) + (not (= (point) p))))) + +(deffoo nnfeed-request-post (&optional _server) + (nnheader-report nnfeed-backend "%s is a read only backend" nnfeed-backend)) + +;;;; Optional back end functions: + +(deffoo nnfeed-retrieve-groups (_groups &optional server) + (nnfeed-request-list server) + 'active) + +(deffoo nnfeed-request-type (_group &optional _article) + 'unknown) + +(deffoo nnfeed-request-group-description (group &optional server) + (when-let ((server (or server (nnfeed--current-server-no-prefix))) + (g (nnfeed--group-data group server))) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (insert group " " (aref g 5) "\n")))) + +(deffoo nnfeed-request-list-newsgroups (&optional server) + (when-let ((server (or server (nnfeed--current-server-no-prefix))) + (s (gethash (nnfeed--server-address server) nnfeed-servers)) + ((hash-table-p s))) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (maphash (lambda (group g) + (insert group " " (aref g 5) "\n")) + s)))) + +(deffoo nnfeed-request-rename-group (group new-name &optional server) + (when-let ((server (or server (nnfeed--current-server-no-prefix))) + (a (nnfeed--server-address server)) + (s (or (gethash a nnfeed-servers) + (and ; Open the server to add it to `nnfeed-servers' + (save-match-data + (nnfeed-open-server + server + (cdr ; Get defs and backend. + (assoc a (cdr (assq nnfeed-backend nnoo-state-alist)) + (lambda (car key) + (and (stringp car) + (string-match + (concat + "\\`\\(\\(nn[[:alpha:]]+\\)\\+\\)?" + (regexp-quote key) "\\'") + car) + (setq server car))))) + (if (match-string 1 server) + (intern (match-string 2 server)) 'nnfeed))) + (gethash a nnfeed-servers)))) + (g (or (nnfeed--group-data group a) + `[ ,group ,(make-hash-table :test 'equal) + ,(make-hash-table :test 'eql) nil 1 ""]))) + (puthash new-name g s) + (puthash group new-name nnfeed-group-names) + (remhash group s) + (and (string= group nnfeed-group) + (setq nnfeed-group new-name)) + t)) + +(provide 'nnfeed) + +;;; nnfeed.el ends here commit 94ed2df02fa1841095041c8c26ad243052638e22 Author: Michael Albinus Date: Tue Apr 23 17:08:06 2024 +0200 Revert skip on eglot-tests.el * test/lisp/progmodes/eglot-tests.el (eglot-test-basic-symlink): Comment out skip on EMBA. diff --git a/test/lisp/progmodes/eglot-tests.el b/test/lisp/progmodes/eglot-tests.el index 4a75a1c5147..96519175fa1 100644 --- a/test/lisp/progmodes/eglot-tests.el +++ b/test/lisp/progmodes/eglot-tests.el @@ -441,7 +441,7 @@ directory hierarchy." (skip-unless (executable-find "clangd")) ;; This test is said to fail due to bug#70408. So we skip it at least ;; on EMBA, because it poisons the test jobs. - (skip-when (getenv "EMACS_EMBA_CI")) + ;(skip-when (getenv "EMACS_EMBA_CI")) ;; MS-Windows either fails symlink creation or pops up UAC prompts. (skip-when (eq system-type 'windows-nt)) (eglot--with-fixture commit 418cade2390e4d6cd7ead1122e62742282e7b2cd Author: João Távora Date: Tue Apr 23 08:43:06 2024 -0500 Eglot: robustify eglot-test-basic-symlink test (bug#70036) The previous version of this test was brittle, unstable and didn't really fail when supposed to (because we need main.cpp to not be visited when visiting mainlink.cpp). This new version is faster and more secure. * test/lisp/progmodes/eglot-tests.el (eglot--sniffing): Add to the jsonrpc-event-hook at the end. (eglot-test-basic-symlink): Robustify test. diff --git a/test/lisp/progmodes/eglot-tests.el b/test/lisp/progmodes/eglot-tests.el index 914f23bc9e3..4a75a1c5147 100644 --- a/test/lisp/progmodes/eglot-tests.el +++ b/test/lisp/progmodes/eglot-tests.el @@ -230,7 +230,7 @@ directory hierarchy." `(push message ,client-replies))))))))) (unwind-protect (progn - (add-hook 'jsonrpc-event-hook #',log-event-hook-sym) + (add-hook 'jsonrpc-event-hook #',log-event-hook-sym t) ,@body) (remove-hook 'jsonrpc-event-hook #',log-event-hook-sym)))))) @@ -452,17 +452,42 @@ directory hierarchy." (find-file-noselect "symlink-project/main.cpp") (make-symbolic-link "main.cpp" "mainlink.cpp") (eglot--tests-connect) - (find-file-noselect "mainlink.cpp") + (eglot--sniffing (:client-notifications c-notifs) + (let ((eglot-autoshutdown nil)) (kill-buffer (current-buffer))) + (eglot--wait-for (c-notifs 10) + (&key method &allow-other-keys) + (and (string= method "textDocument/didClose"))))) + (eglot--sniffing (:client-notifications c-notifs) (with-current-buffer - (find-file-noselect "foo.h") - (goto-char 5) - (xref-find-references "foo") - (with-current-buffer (get-buffer "*xref*") - (goto-char (point-max)) - ;; Expect xref buffer to not contain duplicate references to - ;; main.c and mainlink.c. If it did, total lines would be 7. - ;; FIXME: make less brittle by counting actual references. - (should (= (line-number-at-pos (point)) 5))))))) + (find-file-noselect "symlink-project/main.cpp") + (should (eglot-current-server))) + (eglot--wait-for (c-notifs 10) + (&rest whole &key params method &allow-other-keys) + (and (string= method "textDocument/didOpen") + (string-match "main.cpp$" + (plist-get (plist-get params :textDocument) + :uri))))) + ;; This last segment is deactivated, because it's likely not needed. + ;; The only way the server would answer with '3' references is if we + ;; had erroneously sent a 'didOpen' for anything other than + ;; `main.cpp', but if we got this far is because we've just asserted + ;; that we didn't. + (when nil + (with-current-buffer + (find-file-noselect "symlink-project/foo.h") + ;; Give clangd some time to settle its analysis so it can + ;; accurately respond to `textDocument/references' + (sleep-for 3) + (search-forward "foo") + (eglot--sniffing (:server-replies s-replies) + (call-interactively 'xref-find-references) + (eglot--wait-for (s-replies 10) + (&key method result &allow-other-keys) + ;; Expect xref buffer to not contain duplicate references to + ;; main.cpp and mainlink.cpp. If it did, 'result's length + ;; would be 3. + (and (string= method "textDocument/references") + (= (length result) 2)))))))) (ert-deftest eglot-test-diagnostic-tags-unnecessary-code () "Test rendering of diagnostics tagged \"unnecessary\"." commit 3a4583baf679289857150ee8ecf20b61e59b9d37 Author: João Távora Date: Mon Apr 22 16:37:38 2024 +0100 Eglot: fix bug#70408 yet another way The previous fix based on comparing the Eglot-provided didOpen URI to the server-provided textDocument/publishDiagnostics URI didn't quite work because the URI differs slightly in escaping conventions on certain platforms. This elephant-size bug is easily reproducible on Windows with clangd, where every file is basically diagnostic-free. * lisp/progmodes/eglot.el (eglot-path-to-uri): Rework. (eglot--TextDocumentIdentifier-cache): Rename from eglot--TextDocumentIdentifier-uri. (eglot-handle-notification textDocument/publishDiagnostics): Tweak. (eglot--TextDocumentIdentifier): Rework. (eglot--signal-textDocument/didOpen): Tweak. diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index efdbfba1075..b066e2e33eb 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -1088,11 +1088,12 @@ ACTION is an LSP object of either `CodeAction' or `Command' type." (concat remote-prefix normalized)) uri))) -(defun eglot-path-to-uri (path) - "Convert PATH, a file name, to LSP URI string and return it." - ;; Some LSP servers don't resolve symlinks, so we must do that - ;; for them by calling 'file-truename below'. - (let ((truepath (file-truename path))) +(cl-defun eglot-path-to-uri (path &key truenamep) + "Convert PATH, a file name, to LSP URI string and return it. +TRUENAMEP indicated PATH is already a truename." + ;; LSP assumes little of filesystems, servers being potentially + ;; physically detached from it. Make sure we hand them true names. + (let ((truepath (if truenamep path (file-truename path)))) (if (and (url-type (url-generic-parse-url path)) ;; PATH might be MS Windows file name which includes a ;; drive letter that looks like a URL scheme (bug#59338). @@ -2383,8 +2384,11 @@ still unanswered LSP requests to the server\n"))) (lambda () (remhash token (eglot--progress-reporters server)))))))))) -(defvar-local eglot--TextDocumentIdentifier-uri nil - "A cached LSP TextDocumentIdentifier URI string.") +(defvar-local eglot--TextDocumentIdentifier-cache nil + "LSP TextDocumentIdentifier-related cached info for current buffer. +Value is (TRUENAME . (:uri STR)), where STR is what is sent to the +server on textDocument/didOpen and similar calls. TRUENAME is the +expensive cached value of `file-truename'.") (cl-defmethod eglot-handle-notification (server (_method (eql textDocument/publishDiagnostics)) &key uri diagnostics @@ -2397,17 +2401,16 @@ still unanswered LSP requests to the server\n"))) (t 'eglot-note))) (mess (source code message) (concat source (and code (format " [%s]" code)) ": " message)) - (find-it (uri) - ;; Search managed buffers with server-provided URIs since - ;; that's what we give them in the "didOpen" notification - ;; `find-buffer-visiting' would be nicer, but it calls the - ;; the potentially slow `file-truename' (bug#70036). + (find-it (abspath) + ;; `find-buffer-visiting' would be natural, but calls the + ;; potentially slow `file-truename' (bug#70036). (cl-loop for b in (eglot--managed-buffers server) when (with-current-buffer b - (equal eglot--TextDocumentIdentifier-uri uri)) + (equal (car eglot--TextDocumentIdentifier-cache) + abspath)) return b))) (if-let* ((path (expand-file-name (eglot-uri-to-path uri))) - (buffer (find-it uri))) + (buffer (find-it path))) (with-current-buffer buffer (cl-loop initially @@ -2535,12 +2538,14 @@ THINGS are either registrations or unregisterations (sic)." (defun eglot--TextDocumentIdentifier () "Compute TextDocumentIdentifier object for current buffer. Sets `eglot--TextDocumentIdentifier-uri' (which see) as a side effect." - `(:uri ,(or eglot--TextDocumentIdentifier-uri - (setq eglot--TextDocumentIdentifier-uri - (eglot-path-to-uri (or buffer-file-name - (ignore-errors - (buffer-file-name - (buffer-base-buffer))))))))) + (unless eglot--TextDocumentIdentifier-cache + (let ((truename (file-truename (or buffer-file-name + (ignore-errors + (buffer-file-name + (buffer-base-buffer))))))) + (setq eglot--TextDocumentIdentifier-cache + `(,truename . (:uri ,(eglot-path-to-uri truename :truenamep t)))))) + (cdr eglot--TextDocumentIdentifier-cache)) (defvar-local eglot--versioned-identifier 0) @@ -2836,7 +2841,7 @@ When called interactively, use the currently active server" "Send textDocument/didOpen to server." (setq eglot--recent-changes nil eglot--versioned-identifier 0 - eglot--TextDocumentIdentifier-uri nil) + eglot--TextDocumentIdentifier-cache nil) (jsonrpc-notify (eglot--current-server-or-lose) :textDocument/didOpen `(:textDocument ,(eglot--TextDocumentItem)))) commit 3a8d94dec136a067119ed0af2acc18664969dfbd Author: Andrea Corallo Date: Tue Apr 23 15:39:28 2024 +0200 Run admin/syncdoc-type-hierarchy.el * doc/lispref/elisp_type_hierarchy.jpg: Update. * doc/lispref/elisp_type_hierarchy.txt: Likewise. diff --git a/doc/lispref/elisp_type_hierarchy.jpg b/doc/lispref/elisp_type_hierarchy.jpg index 386954e1007..6559ef8bf9b 100644 Binary files a/doc/lispref/elisp_type_hierarchy.jpg and b/doc/lispref/elisp_type_hierarchy.jpg differ diff --git a/doc/lispref/elisp_type_hierarchy.txt b/doc/lispref/elisp_type_hierarchy.txt index bb93cd831b9..08ce0603243 100644 --- a/doc/lispref/elisp_type_hierarchy.txt +++ b/doc/lispref/elisp_type_hierarchy.txt @@ -1,33 +1,33 @@ | Type | Derived Types | |---------------------+-----------------------------------------------------------| -| t | sequence atom | -| atom | number-or-marker array record symbol function | -| | window-configuration font-object font-entity mutex | -| | tree-sitter-node buffer overlay tree-sitter-parser thread | -| | font-spec native-comp-unit tree-sitter-compiled-query | -| | terminal window frame hash-table user-ptr obarray condvar | -| | process | -| sequence | array list | -| list | null cons | -| function | oclosure compiled-function module-function | -| | interpreted-function | -| symbol | boolean symbol-with-pos keyword | -| compiled-function | subr byte-code-function | -| oclosure | accessor advice--forward cconv--interactive-helper | -| | cl--generic-nnm advice save-some-buffers-function | -| record | cl-structure-object | -| cl-structure-object | cl--class lisp-indent-state cl--random-state registerv | -| | xref-elisp-location isearch--state cl-slot-descriptor | -| | cl--generic-generalizer uniquify-item cl--generic-method | -| | register-preview-info cl--generic | -| cons | ppss decoded-time | -| array | vector string char-table bool-vector | -| number-or-marker | number integer-or-marker | -| integer-or-marker | integer marker | -| number | integer float | -| cl--class | built-in-class cl-structure-class oclosure--class | -| subr | subr-native-elisp subr-primitive | -| accessor | oclosure-accessor | -| vector | timer | | boolean | null | | integer | fixnum bignum | +| accessor | oclosure-accessor | +| cl--class | cl-structure-class oclosure--class built-in-class | +| vector | timer | +| cons | ppss decoded-time | +| number | integer float | +| integer-or-marker | integer marker | +| number-or-marker | number integer-or-marker | +| array | vector string bool-vector char-table | +| oclosure | accessor advice cconv--interactive-helper advice--forward | +| | save-some-buffers-function cl--generic-nnm | +| cl-structure-object | cl--class xref-elisp-location org-cite-processor | +| | cl--generic-method cl--random-state register-preview-info | +| | cl--generic cl-slot-descriptor uniquify-item registerv | +| | isearch--state cl--generic-generalizer lisp-indent-state | +| record | cl-structure-object | +| symbol | boolean symbol-with-pos | +| subr | primitive-function subr-native-elisp special-form | +| compiled-function | primitive-function subr-native-elisp byte-code-function | +| function | oclosure compiled-function interpreted-function | +| | module-function | +| list | null cons | +| sequence | array list | +| atom | number-or-marker array record symbol subr function mutex | +| | font-spec frame tree-sitter-compiled-query | +| | tree-sitter-node font-entity finalizer tree-sitter-parser | +| | hash-table window-configuration user-ptr overlay process | +| | font-object obarray condvar buffer terminal thread window | +| | native-comp-unit | +| t | sequence atom | commit cb04549204d738603400d1fe14de7f5b59cc516f Author: Andrea Corallo Date: Tue Apr 23 15:37:04 2024 +0200 * Generate elisp_type_hierarchy.txt with top level types on top of it * admin/syncdoc-type-hierarchy.el (syncdoc-make-type-table): Prioratize to level types. diff --git a/admin/syncdoc-type-hierarchy.el b/admin/syncdoc-type-hierarchy.el index 56f2c30527e..ed827844d0b 100644 --- a/admin/syncdoc-type-hierarchy.el +++ b/admin/syncdoc-type-hierarchy.el @@ -97,7 +97,7 @@ (lambda (x1 x2) (< (length (memq (car x2) syncdoc-all-types)) (length (memq (car x1) syncdoc-all-types))))) - (cl-loop for (type . children) in subtypes + (cl-loop for (type . children) in (reverse subtypes) do (insert "|" (symbol-name type) " |") do (cl-loop with x = 0 for child in children commit 05008290fbbcdcf1cb8b75a447b855f94d6e4a7e Author: Andrea Corallo Date: Tue Apr 23 15:35:44 2024 +0200 * admin/syncdoc-type-hierarchy.el (org): Add missing require. diff --git a/admin/syncdoc-type-hierarchy.el b/admin/syncdoc-type-hierarchy.el index bfbbbc45aa4..56f2c30527e 100644 --- a/admin/syncdoc-type-hierarchy.el +++ b/admin/syncdoc-type-hierarchy.el @@ -35,6 +35,7 @@ ;;; Code: (require 'cl-lib) +(require 'org) (defconst syncdoc-file (or (macroexp-file-name) buffer-file-name)) commit 2234fe929a4d397941b257941bfe2634b0cd7a10 Author: Eshel Yaron Date: Fri Apr 12 23:19:13 2024 +0200 (completion-preview-prev-candidate): add numeric prefix argument * lisp/completion-preview.el (completion-preview-prev-candidate): Add numeric prefix argument N. (completion-preview-next-candidate): Update documentation. diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el index a3443eae801..25c1cd4a22f 100644 --- a/lisp/completion-preview.el +++ b/lisp/completion-preview.el @@ -489,16 +489,18 @@ completions list." 'keymap completion-preview--mouse-map)) 'completion-preview-end pos)))))) -(defun completion-preview-prev-candidate () - "Cycle the candidate that the preview is showing to the previous suggestion." - (interactive) - (completion-preview-next-candidate -1)) +(defun completion-preview-prev-candidate (n) + "Cycle the candidate the preview is showing N candidates backward. + +If N is negative, cycle -N candidates forward. Interactively, N is the +prefix argument and defaults to 1." + (interactive "p") + (completion-preview-next-candidate (- n))) -(defun completion-preview-next-candidate (direction) - "Cycle the candidate that the preview is showing in direction DIRECTION. +(defun completion-preview-next-candidate (n) + "Cycle the candidate the preview is showing N candidates forward. -DIRECTION should be either 1 which means cycle forward, or -1 -which means cycle backward. Interactively, DIRECTION is the +If N is negative, cycle -N candidates backward. Interactively, N is the prefix argument and defaults to 1." (interactive "p") (when completion-preview-active-mode @@ -508,7 +510,7 @@ prefix argument and defaults to 1." (com (completion-preview--get 'completion-preview-common)) (cur (completion-preview--get 'completion-preview-index)) (len (length all)) - (new (mod (+ cur direction) len)) + (new (mod (+ cur n) len)) (suf (nth new all)) (lencom (length com))) ;; Skip suffixes that are no longer applicable. This may happen @@ -519,7 +521,7 @@ prefix argument and defaults to 1." (while (or (<= (+ beg lencom (length suf)) end) (not (string-prefix-p (buffer-substring beg end) (concat com suf)))) - (setq new (mod (+ new direction) len) + (setq new (mod (+ new n) len) suf (nth new all))) (set-text-properties 0 (length suf) (list 'face (if (cdr all) commit 6b26644300a6bc7a24af883552b67112a5d41a03 Author: Eshel Yaron Date: Sun Apr 14 09:21:03 2024 +0200 ; Fix Completion Preview mode mouse-click bindings * lisp/completion-preview.el (completion-preview--ignore): New internal command. (completion-preview--internal-commands): Add it. (completion-preview--mouse-map): Use it to fix bindings. diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el index 8bc8cadc46b..a3443eae801 100644 --- a/lisp/completion-preview.el +++ b/lisp/completion-preview.el @@ -147,19 +147,34 @@ If this option is nil, these commands do not display any message." ;; "M-p" #'completion-preview-prev-candidate ) +(defun completion-preview--ignore () + "Do nothing, including updating the completion preview. + +This is the same as `ignore', except that Completion Preview mode skips +hiding or updating the completion preview after this command runs." + (interactive) + nil) + +(put 'completion-preview--ignore 'completion-predicate #'ignore) + (defvar-keymap completion-preview--mouse-map :doc "Keymap for mouse clicks on the completion preview." - "" #'completion-preview-insert - "C-" #'completion-preview-complete - "" #'completion-preview-complete - "" #'completion-preview-prev-candidate - "" #'completion-preview-next-candidate) + "" #'completion-preview-insert + ;; Ignore the corresponding button-down event. + "" #'completion-preview--ignore + "C-" #'completion-preview-complete + "C-" #'completion-preview--ignore + "" #'completion-preview-complete + "" #'completion-preview--ignore + "" #'completion-preview-prev-candidate + "" #'completion-preview-next-candidate) (defvar-local completion-preview--overlay nil) (defvar completion-preview--internal-commands '(completion-preview-next-candidate completion-preview-prev-candidate + completion-preview--ignore ;; Don't dismiss or update the preview when the user scrolls. mwheel-scroll) "List of commands that manipulate the completion preview. commit 956821672eb5306d4eeeae0dc07df4664cef230a Author: Michael Albinus Date: Tue Apr 23 13:54:09 2024 +0200 Support remote trash-directory * doc/misc/tramp.texi (Frequently Asked Questions): Describe how to manipulate trash-directory. Explain tramp-inhibit-errors-if-setting-file-attributes-fail. * lisp/files.el (move-file-to-trash): Use connection-local value of `trash-directory'. (Bug#70421) diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index b503ce13373..c87d0e70bb4 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -5444,7 +5444,7 @@ HISTFILE=/dev/null Where are remote files trashed to? @vindex remote-file-name-inhibit-delete-by-moving-to-trash -Emacs can trash file instead of deleting +Emacs can trash files instead of deleting @ifinfo them, @ref{Misc File Ops, Trashing , , emacs}. @end ifinfo @@ -5456,6 +5456,29 @@ option @code{remote-file-name-inhibit-delete-by-moving-to-trash} is non-@code{nil}, or it is a remote encrypted file (@pxref{Keeping files encrypted}), which are deleted anyway. +@c Since Emacs 30. +@vindex trash-directory +If you want to trash a remote file into a remote trash directory, you +could configure the user option @code{trash-directory} to a +connection-local value. +@ifinfo +@xref{Connection Variables, , , emacs}. +@end ifinfo + +@lisp +@group +(connection-local-set-profile-variables + 'remote-trash-directory + '((trash-directory . "/sudo::~/.local/share/Trash"))) +@end group + +@group +(connection-local-set-profiles + `(:application tramp :protocol "sudo" :machine ,system-name) + 'remote-trash-directory) +@end group +@end lisp + If Emacs is configured to use the XDG conventions for the trash directory, remote files cannot be restored with the respective tools, because those conventions don't specify remote paths. Such files must @@ -5898,6 +5921,17 @@ If these errors can be ignored, set user option non-@code{nil} value. This transforms the error into a warning. +@item +How to ignore errors when changing file attributes? + +@vindex tramp-inhibit-errors-if-setting-file-attributes-fail +Sometimes, for example while saving remote files, errors appear when +changing file attributes like permissions, time stamps, or ownership. +If these errors can be ignored, set user option +@code{tramp-inhibit-errors-if-setting-file-attributes-fail} to a +non-@code{nil} value. This transforms the error into a warning. + + @item How to disable other packages from calling @value{tramp}? diff --git a/lisp/files.el b/lisp/files.el index 9f5ed85ce60..7dec67c5cf0 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -8812,9 +8812,10 @@ Otherwise, trash FILENAME using the freedesktop.org conventions, ;; If `system-move-file-to-trash' is defined, use it. (cond ((fboundp 'system-move-file-to-trash) (system-move-file-to-trash filename)) - (trash-directory + ((connection-local-value trash-directory) ;; If `trash-directory' is non-nil, move the file there. - (let* ((trash-dir (expand-file-name trash-directory)) + (let* ((trash-dir (expand-file-name + (connection-local-value trash-directory))) (fn (directory-file-name (expand-file-name filename))) (new-fn (concat (file-name-as-directory trash-dir) (file-name-nondirectory fn)))) commit 0e139ca741a5a98abc199c9bce277d5d1f262bf3 Author: Michael Albinus Date: Tue Apr 23 13:24:35 2024 +0200 * test/lisp/progmodes/eglot-tests.el (eglot-test-basic-symlink): Skip on EMBA. diff --git a/test/lisp/progmodes/eglot-tests.el b/test/lisp/progmodes/eglot-tests.el index c4ca870fbe6..914f23bc9e3 100644 --- a/test/lisp/progmodes/eglot-tests.el +++ b/test/lisp/progmodes/eglot-tests.el @@ -439,6 +439,9 @@ directory hierarchy." (ert-deftest eglot-test-basic-symlink () "Test basic symlink support." (skip-unless (executable-find "clangd")) + ;; This test is said to fail due to bug#70408. So we skip it at least + ;; on EMBA, because it poisons the test jobs. + (skip-when (getenv "EMACS_EMBA_CI")) ;; MS-Windows either fails symlink creation or pops up UAC prompts. (skip-when (eq system-type 'windows-nt)) (eglot--with-fixture commit 4a27b31c462d1cb015e28ddec8e0c43a3af0dc34 Author: Michael Albinus Date: Tue Apr 23 13:24:09 2024 +0200 Some EMBA integration fixes * test/infra/Dockerfile.emba (emacs-native-comp-speed2): Fix typo. * test/infra/gitlab-ci.yml (.job-template): Add configure.log to artifacts. diff --git a/test/infra/Dockerfile.emba b/test/infra/Dockerfile.emba index 9091d60e8c8..088df86ad70 100644 --- a/test/infra/Dockerfile.emba +++ b/test/infra/Dockerfile.emba @@ -208,4 +208,4 @@ COPY . /checkout WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure --with-native-compilation -RUN make -j `nproc` bootstrap` +RUN make -j `nproc` bootstrap diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index e6840d064b5..49e2118761d 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -93,6 +93,7 @@ default: # - test -n "$(docker ps -aq -f name=${test_name})" && ( docker export ${test_name} | tar -tvf - ) # Prepare test artifacts. - test -n "$(docker ps -aq -f name=${test_name})" && docker cp ${test_name}:checkout/test ${test_name} + - test -n "$(docker ps -aq -f name=${test_name})" && docker cp ${test_name}:checkout/configure.log ${test_name} - test -n "$(docker ps -aq -f name=${test_name})" && docker rm ${test_name} - find ${test_name} ! \( -name "*.log" -o -name ${EMACS_TEST_JUNIT_REPORT} \) -type f -delete # BusyBox find does not know -empty. commit cd56e85c08307915941d5ae03a02569a52a2889c Author: Po Lu Date: Tue Apr 23 17:09:50 2024 +0800 ; Fix default Android tile mode * java/org/gnu/emacs/EmacsGC.java (markDirty): Use rather REPEAT than MIRROR. diff --git a/java/org/gnu/emacs/EmacsGC.java b/java/org/gnu/emacs/EmacsGC.java index 96df0c61ca6..b2474c5bd76 100644 --- a/java/org/gnu/emacs/EmacsGC.java +++ b/java/org/gnu/emacs/EmacsGC.java @@ -139,7 +139,7 @@ public final class EmacsGC extends EmacsHandleObject { tileObject = new BitmapDrawable (EmacsService.resources, stippleBitmap); - tileObject.setTileModeXY (TileMode.MIRROR, TileMode.MIRROR); + tileObject.setTileModeXY (TileMode.REPEAT, TileMode.REPEAT); } else /* Otherwise, update the existing tile object with the new commit 326437e6c8a6497b1a38d002b1d28e74678a07aa Merge: cd7456e00d7 d22c260cb7d Author: Po Lu Date: Tue Apr 23 15:59:06 2024 +0800 Merge remote-tracking branch 'savannah/master' into master-android-1 commit cd7456e00d719d32c203c71b4e23c98b0c4e1967 Author: Po Lu Date: Tue Apr 23 15:57:45 2024 +0800 Enable configuring Emacs for "pseudo-grayscale" systems on Android * doc/emacs/android.texi (Android Windowing): Document how to configure Emacs for monochrome displays. * src/androidfns.c (Fx_display_visual_class): Return Qstatic_gray when n_planes is smaller than 24. (Fandroid_get_connection): Set n_planes by the value of android_display_planes. (syms_of_androidfns): : New function. * src/androidterm.c (android_alloc_nearest_color): Allocate monochrome colors similarly to the X server. (android_query_colors): Fix typos. (android_draw_fringe_bitmap): Create bitmaps of n_image_planes depth. (android_term_init): Initialize n_image_planes to 24. (syms_of_androidterm) : New variable. * src/androidterm.h (struct android_display_info): New field `n_image_planes'. * src/image.c (n_planes) [HAVE_ANDROID]: Define to n_image_planes. diff --git a/doc/emacs/android.texi b/doc/emacs/android.texi index 15c5fbcce3a..9e3716894ee 100644 --- a/doc/emacs/android.texi +++ b/doc/emacs/android.texi @@ -827,7 +827,7 @@ example, the permission to access contacts may be useful for EUDC. applications as maximized or full-screen, and, in the general case, only one window can be displayed at a time. On larger devices, the system permits simultaneously tiling up to four windows on the screen, though -in emulators or installations configured for ``desktop'' system stacks +in emulators or installations configured for ``desktop'' systems stacks freely resizable windows as other desktop window managers do. Windows, or, in system nomenclature, activities, do not exist @@ -1002,12 +1002,31 @@ customized through altering the variable @code{android-keyboard-bell-duration} to any value between @code{10} and @code{1000}. +@vindex android-display-planes +@cindex visual class, Android +@cindex display color space, Android + Color-related characteristics of the display are not automatically +detectable on Android, so the variable @code{android-display-planes} +should be configured to a suitable value if Emacs is to realize faces +and images in a manner consistent with the true visual attributes of a +grayscale or monochrome display: to @code{8} for the former class of +display, and @code{1} for the latter, which will, respectively, force +all colors to be rendered in 256 grays, or in monochrome. As this +variable is processed at the time the display connection is established, +customizations will not take effect unless they be performed from +@code{early-init.el} (@pxref{Early Init File}). + + The value of this variable does not affect anti-aliasing in the font +driver, as monochrome displays nevertheless expect Emacs to provide +antialiased text, which they receive after it is processed into bitmap +data by the display driver. + @node Android Fonts @section Font Backends and Selection under Android @cindex fonts, android - Emacs supports two font backends under Android: they are -respectively named @code{sfnt-android} and @code{android}. + Emacs supports two font backends under Android: they are respectively +named @code{sfnt-android} and @code{android}. Upon startup, Emacs enumerates all the TrueType format fonts in the directories @file{/system/fonts} and @file{/product/fonts}, and the diff --git a/src/androidfns.c b/src/androidfns.c index 9f7ac8b69b2..b6df7ae0677 100644 --- a/src/androidfns.c +++ b/src/androidfns.c @@ -1345,7 +1345,12 @@ DEFUN ("x-display-visual-class", Fx_display_visual_class, doc: /* SKIP: real doc in xfns.c. */) (Lisp_Object terminal) { - check_android_display_info (terminal); + struct android_display_info *dpyinfo; + + dpyinfo = check_android_display_info (terminal); + + if (dpyinfo->n_planes < 24) + return Qstatic_gray; return Qtrue_color; } @@ -1805,7 +1810,16 @@ Android, so there is no equivalent of `x-open-connection'. */) terminal = Qnil; if (x_display_list) - XSETTERMINAL (terminal, x_display_list->terminal); + { + XSETTERMINAL (terminal, x_display_list->terminal); + + /* Update the display's bit depth from + `android_display_planes'. */ + x_display_list->n_planes + = (android_display_planes > 8 + ? 24 : (android_display_planes > 1 + ? android_display_planes : 1)); + } return terminal; #endif @@ -3479,6 +3493,7 @@ syms_of_androidfns (void) { /* Miscellaneous symbols used by some functions here. */ DEFSYM (Qtrue_color, "true-color"); + DEFSYM (Qstatic_gray, "static-color"); DEFSYM (Qwhen_mapped, "when-mapped"); DEFVAR_LISP ("x-pointer-shape", Vx_pointer_shape, diff --git a/src/androidterm.c b/src/androidterm.c index c920375fdbe..e4f3abdb2d3 100644 --- a/src/androidterm.c +++ b/src/androidterm.c @@ -1964,10 +1964,33 @@ android_parse_color (struct frame *f, const char *color_name, bool android_alloc_nearest_color (struct frame *f, Emacs_Color *color) { + unsigned int ntsc; + gamma_correct (f, color); - color->pixel = RGB_TO_ULONG (color->red / 256, - color->green / 256, - color->blue / 256); + + if (FRAME_DISPLAY_INFO (f)->n_planes == 1) + { + /* Black and white. I think this is the luminance formula applied + by the X server on generic monochrome framebuffers. */ + color->pixel = ((((30l * color->red + + 59l * color->green + + 11l * color->blue) >> 8) + >= (((1 << 8) -1) * 50)) + ? 0xffffff : 0); + } + else if (FRAME_DISPLAY_INFO (f)->n_planes <= 8) + { + /* 256 grays. */ + ntsc = min (255, ((color->red * 0.299 + + color->green * 0.587 + + color->blue * 0.114) + / 256)); + color->pixel = RGB_TO_ULONG (ntsc, ntsc, ntsc); + } + else + color->pixel = RGB_TO_ULONG (color->red / 256, + color->green / 256, + color->blue / 256); return true; } @@ -1980,8 +2003,8 @@ android_query_colors (struct frame *f, Emacs_Color *colors, int ncolors) for (i = 0; i < ncolors; ++i) { colors[i].red = RED_FROM_ULONG (colors[i].pixel) * 257; - colors[i].green = RED_FROM_ULONG (colors[i].pixel) * 257; - colors[i].blue = RED_FROM_ULONG (colors[i].pixel) * 257; + colors[i].green = GREEN_FROM_ULONG (colors[i].pixel) * 257; + colors[i].blue = BLUE_FROM_ULONG (colors[i].pixel) * 257; } } @@ -2630,7 +2653,7 @@ android_draw_fringe_bitmap (struct window *w, struct glyph_row *row, clipmask = ANDROID_NONE; background = face->background; cursor_pixel = f->output_data.android->cursor_pixel; - depth = FRAME_DISPLAY_INFO (f)->n_planes; + depth = FRAME_DISPLAY_INFO (f)->n_image_planes; /* Intersect the destination rectangle with that of the row. Setting a clip mask overrides the clip rectangles provided by @@ -6504,8 +6527,8 @@ android_term_init (void) terminal = android_create_terminal (dpyinfo); terminal->kboard = allocate_kboard (Qandroid); terminal->kboard->reference_count++; - dpyinfo->n_planes = 24; + dpyinfo->n_image_planes = 24; /* This function should only be called once at startup. */ eassert (!x_display_list); @@ -6702,6 +6725,17 @@ Emacs is running on. */); doc: /* Name of the developer of the running version of Android. */); Vandroid_build_manufacturer = Qnil; + DEFVAR_INT ("android-display-planes", android_display_planes, + doc: /* Depth and visual class of the display. +This variable controls the visual class and depth of the display, which +cannot be detected on Android. The default value of 24, and values from +there to 8 represent a TrueColor display providing 24 planes, values +between 8 and 1 StaticGray displays providing that many planes, and 1 or +lower monochrome displays with a single plane. Modifications to this +variable must be completed before the window system is initialized, in, +for instance, `early-init.el', or they will be of no effect. */); + android_display_planes = 24; + DEFVAR_LISP ("x-ctrl-keysym", Vx_ctrl_keysym, doc: /* SKIP: real doc in xterm.c. */); Vx_ctrl_keysym = Qnil; diff --git a/src/androidterm.h b/src/androidterm.h index fd4cc99f641..24eb2c30f12 100644 --- a/src/androidterm.h +++ b/src/androidterm.h @@ -77,8 +77,9 @@ struct android_display_info /* Mouse highlight information. */ Mouse_HLInfo mouse_highlight; - /* Number of planes on this screen. Always 24. */ - int n_planes; + /* Number of planes on this screen, and the same for the purposes of + image processing. */ + int n_planes, n_image_planes; /* Mask of things causing the mouse to be grabbed. */ int grabbed; diff --git a/src/image.c b/src/image.c index 3028c2e707a..d1faadee968 100644 --- a/src/image.c +++ b/src/image.c @@ -198,6 +198,9 @@ typedef android_pixmap Pixmap; #define GREEN16_FROM_ULONG(color) (GREEN_FROM_ULONG (color) * 0x101) #define BLUE16_FROM_ULONG(color) (BLUE_FROM_ULONG (color) * 0x101) +/* DPYINFO->n_planes is unsuitable for this file, because it accepts + values that may not be supported for pixmap creation. */ +#define n_planes n_image_planes #endif static void image_disable_image (struct frame *, struct image *); commit 81476fa19e86f4d3a697909a87bec58a48e98d58 Author: Eli Zaretskii Date: Tue Apr 23 10:40:50 2024 +0300 Improve documentation of selection and navigation in *xref* buffers * doc/emacs/maintaining.texi (Looking Up Identifiers): More detailed description of 'xref-auto-jump-to-first-definition'. Improve indexing. Describe the use of 'next-error' and 'previous-error' in conjunction with the *xref* buffer. (Identifier Search): More detailed description of 'xref-auto-jump-to-first-xref'. Describe the use of 'next-error' and 'previous-error'. diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi index b22aa018292..205d4315094 100644 --- a/doc/emacs/maintaining.texi +++ b/doc/emacs/maintaining.texi @@ -2334,19 +2334,33 @@ documentation for details. @vindex xref-auto-jump-to-first-definition If any of the above commands finds more than one matching definition, it by default pops up the @file{*xref*} buffer showing the -matching candidates. (@kbd{C-M-.}@: @emph{always} pops up the -@file{*xref*} buffer if it finds at least one match.) The candidates -are normally shown in that buffer as the name of a file and the -matching identifier(s) in that file. In that buffer, you can select -any of the candidates for display, and you have several additional -commands, described in @ref{Xref Commands}. However, if the value of -the variable @code{xref-auto-jump-to-first-definition} is @code{move}, -the first of these candidates is automatically selected in the -@file{*xref*} buffer, and if it's @code{t} or @code{show}, the first -candidate is automatically shown in its own window; @code{t} also -selects the window showing the first candidate. The default value is -@code{nil}, which just shows the candidates in the @file{*xref*} -buffer, but doesn't select any of them. +matching candidates and selects that buffer's window. (@kbd{C-M-.}@: +@emph{always} pops up the @file{*xref*} buffer if it finds at least +one match.) Each candidate is normally shown in that buffer as the +name of a file and the matching identifier(s) in that file. In that +buffer, you can select any of the candidates for display, and you have +several additional commands, described in @ref{Xref Commands}. +However, if the value of the variable +@code{xref-auto-jump-to-first-definition} is @code{move}, Emacs +automatically moves point to the first of these candidates in the +@file{*xref*} buffer, so just typing @key{RET} will display the +definition of that candidate. If the value of the variable is +@code{t} or @code{show}, the first candidate is automatically shown in +its own window; @code{t} also selects the window showing the first +candidate's definition, while @code{show} leaves the window of the +@file{*xfer*} buffer selected. The default value is @code{nil}, which +just shows the candidates in the @file{*xref*} buffer, but neither +selects any of them nor shows their definition, until you select a +candidate in the @file{*xref*} buffer. + +@findex next-error, in @file{*xref*} buffer +@findex previous-error, in @file{*xref*} buffer +@kindex M-g M-n, for navigation in @file{*xref*} buffer +@kindex M-g M-p, for navigation in @file{*xref*} buffer + If you switch away of the window showing the @file{*xref*} buffer +which displays several candidates, you can move from one candidate to +another using the commands @w{@kbd{M-g M-n}} (@code{next-error}) and +@w{@kbd{M-g M-p}} (@code{previous-error}). @xref{Compilation Mode}. @kindex M-, @findex xref-go-back @@ -2509,12 +2523,17 @@ referenced. The XREF mode commands are available in this buffer, see @vindex xref-auto-jump-to-first-xref If the value of the variable @code{xref-auto-jump-to-first-xref} is @code{t}, @code{xref-find-references} automatically jumps to the first -result and selects the window where it is displayed. If the value is -@code{show}, the first result is shown, but the window showing the +result in the @file{*xref*} buffer and selects the window where that +reference is displayed; you can select the other results with +@w{@kbd{M-g M-n}} (@code{next-error}) and @w{@kbd{M-g M-p}} +(@code{previous-error}) (@pxref{Compilation Mode}). If the value is +@code{show}, the first result is displayed, but the window showing the @file{*xref*} buffer is left selected. If the value is @code{move}, the first result is selected in the @file{*xref*} buffer, but is not -shown. The default value is @code{nil}, which just shows the results -in the @file{*xref*} buffer, but doesn't select any of them. +displayed; you can then use @key{RET} to actually display the +reference. The default value is @code{nil}, which just shows the +results in the @file{*xref*} buffer, but doesn't select any of them, +and doesn't display the reference itself. @findex xref-query-replace-in-results @kbd{r} (@code{xref-query-replace-in-results}) reads a @var{replacement} commit d22c260cb7d43a27632750920f5238ed7947ae8d Author: Eli Zaretskii Date: Tue Apr 23 10:02:39 2024 +0300 Fix dumping signal-handler data * src/sysdep.c (init_signals): Don't install signal handlers while dumping only with unexec, as pdumper doesn't dump static data of signal handlers. See https://lists.gnu.org/archive/html/emacs-devel/2024-04/msg00539.html for the details. diff --git a/src/sysdep.c b/src/sysdep.c index cf2985b4b89..07237885cb9 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -2037,10 +2037,10 @@ init_signals (void) main_thread_id = pthread_self (); #endif - /* Don't alter signal handlers if dumping. On some machines, - changing signal handlers sets static data that would make signals - fail to work right when the dumped Emacs is run. */ - if (will_dump_p ()) + /* Don't alter signal handlers if dumping with unexec. On some + machines, changing signal handlers sets static data that would make + signals fail to work right when the dumped Emacs is run. */ + if (will_dump_with_unexec_p ()) return; sigfillset (&process_fatal_action.sa_mask); commit b9c191d690fd5d1480858469df23cc4509996fae Author: Po Lu Date: Tue Apr 23 14:30:38 2024 +0800 Implement face stipples on Android * .gitignore: * java/Makefile.in: Fix typos. * java/org/gnu/emacs/EmacsFillRectangle.java (perform): Call blitOpaqueStipple if filling an unobscured rectangle with an opaque stipple. * java/org/gnu/emacs/EmacsGC.java (EmacsGC) : New field. (markDirty): Synchronize the current stipple with tileObject. (prepareStipple, blitOpaqueStipple): New functions. * java/org/gnu/emacs/EmacsService.java (EmacsService) : New static field. (onCreate): Set it. * src/android.c (android_create_bitmap_from_data): Correct order of arguments to android_create_pixmap_from_bitmap_data. (HAS_BUILTIN_TRAP): Delete macro. (emacs_abort): Always induce backtraces by means of a NULL pointer deference. * src/dispextern.h (Emacs_GC, Emacs_Rectangle, GCForeground) (GCBackground, GCFillStyle, GCStipple, FillOpaqueStipple) [HAVE_ANDROID]: Define to their Android counterparts rather than simulating their existence. * src/epaths.in: Set bitmap path to /assets/bitmaps on Android. * src/image.c (image_bitmap_pixmap): Also enable when HAVE_ANDROID. * src/sfntfont-android.c (sfntfont_android_put_glyphs): Assert that this is never called to draw a stippled background. * src/xfaces.c (x_create_gc) [HAVE_ANDROID]: Redefine as wrapper around android_create_gc. (prepare_face_for_display) [HAVE_ANDROID]: Enable stipples. diff --git a/.gitignore b/.gitignore index 4098e2210b5..1557c085fad 100644 --- a/.gitignore +++ b/.gitignore @@ -68,7 +68,7 @@ java/org/gnu/emacs/R.java # Built by `make'. java/org/gnu/emacs/EmacsConfig.java -java/org/gnu/emacs/cf-stamp +java/cf-stamp # Built by `config.status'. java/AndroidManifest.xml diff --git a/java/Makefile.in b/java/Makefile.in index abddae6b5cf..35d2637837c 100644 --- a/java/Makefile.in +++ b/java/Makefile.in @@ -197,10 +197,13 @@ install_temp: $(CROSS_BINS) $(CROSS_LIBS) $(RESOURCE_FILES) $(AM_V_SILENT) mkdir -p install_temp/assets/etc $(AM_V_SILENT) mkdir -p install_temp/assets/lisp $(AM_V_SILENT) mkdir -p install_temp/assets/info -# Install architecture independents to assets/etc and assets/lisp + $(AM_V_SILENT) mkdir -p install_temp/assets/bitmaps +# Install architecture independents to assets/etc, assets/lisp and +# assets/bitmaps $(AM_V_SILENT) cp -r $(top_srcdir)/lisp install_temp/assets $(AM_V_SILENT) cp -r $(top_srcdir)/etc install_temp/assets $(AM_V_SILENT) cp -r $(top_srcdir)/info install_temp/assets + $(AM_V_SILENT) cp -r $(top_srcdir)/src/bitmaps install_temp/assets # Replace etc/DOC generated by compiling Emacs for the build machine # with etc/DOC from the cross-compiled Emacs. $(AM_V_SILENT) test -f $(top_builddir)/cross/etc/DOC \ @@ -354,8 +357,8 @@ public static final String[] EMACS_SHARED_LIBRARIES\ # cf-stamp-1 is a phony target invoked in a second `make' instance after # all shared libraries are compiled, because the computation of -# ALL_DEPENDENCIES cannot be postponed until that stage in this instance -# of Make. +# ALL_DEPENDENCIES in this instance of Make cannot be postponed until +# that stage. cf-stamp: $(NDK_BUILD_SHARED) $(CROSS_LIBS) $(AM_V_EMACSCONFIG) $(MAKE) cf-stamp-1 $(AM_V_at) touch $@ diff --git a/java/org/gnu/emacs/EmacsFillRectangle.java b/java/org/gnu/emacs/EmacsFillRectangle.java index ca87c06c014..f338a54f97b 100644 --- a/java/org/gnu/emacs/EmacsFillRectangle.java +++ b/java/org/gnu/emacs/EmacsFillRectangle.java @@ -40,22 +40,23 @@ public final class EmacsFillRectangle Canvas canvas; Bitmap clipBitmap; - /* TODO implement stippling. */ - if (gc.fill_style == EmacsGC.GC_FILL_OPAQUE_STIPPLED) - return; - canvas = drawable.lockCanvas (gc); if (canvas == null) return; - paint = gc.gcPaint; rect = new Rect (x, y, x + width, y + height); + paint = gc.gcPaint; paint.setStyle (Paint.Style.FILL); if (gc.clip_mask == null) - canvas.drawRect (rect, paint); + { + if (gc.fill_style != EmacsGC.GC_FILL_OPAQUE_STIPPLED) + canvas.drawRect (rect, paint); + else + gc.blitOpaqueStipple (canvas, rect); + } else { /* Drawing with a clip mask involves calculating the @@ -113,4 +114,4 @@ maskRect, new Rect (0, 0, drawable.damageRect (rect); } -} +}; diff --git a/java/org/gnu/emacs/EmacsGC.java b/java/org/gnu/emacs/EmacsGC.java index e45f0666fe2..96df0c61ca6 100644 --- a/java/org/gnu/emacs/EmacsGC.java +++ b/java/org/gnu/emacs/EmacsGC.java @@ -22,10 +22,19 @@ import android.graphics.Rect; import android.graphics.Paint; +import android.graphics.Bitmap; +import android.graphics.Canvas; +import android.graphics.ColorFilter; import android.graphics.PorterDuff.Mode; +import android.graphics.PorterDuffColorFilter; import android.graphics.PorterDuffXfermode; +import android.graphics.Shader.TileMode; import android.graphics.Xfermode; +import android.graphics.drawable.BitmapDrawable; + +import android.os.Build; + /* X like graphics context structures. Keep the enums in synch with androidgui.h! */ @@ -47,6 +56,9 @@ public final class EmacsGC extends EmacsHandleObject public EmacsPixmap clip_mask, stipple; public Paint gcPaint; + /* Drawable object for rendering the stiple bitmap. */ + public BitmapDrawable tileObject; + /* ID incremented every time the clipping rectangles of any GC changes. */ private static long clip_serial; @@ -86,6 +98,7 @@ public final class EmacsGC extends EmacsHandleObject markDirty (boolean clipRectsChanged) { int i; + Bitmap stippleBitmap; if (clipRectsChanged) { @@ -110,12 +123,85 @@ public final class EmacsGC extends EmacsHandleObject gcPaint.setColor (foreground | 0xff000000); gcPaint.setXfermode (function == GC_XOR ? xorAlu : srcInAlu); + + /* Update the stipple object with the new stipple bitmap, or delete + it if the stipple has been cleared on systems too old to support + modifying such objects. */ + + if (stipple != null) + { + stippleBitmap = stipple.getBitmap (); + + /* Allocate a new tile object if none is already present or it + cannot be reconfigured. */ + if ((tileObject == null) + || (Build.VERSION.SDK_INT < Build.VERSION_CODES.S)) + { + tileObject = new BitmapDrawable (EmacsService.resources, + stippleBitmap); + tileObject.setTileModeXY (TileMode.MIRROR, TileMode.MIRROR); + } + else + /* Otherwise, update the existing tile object with the new + bitmap. */ + tileObject.setBitmap (stippleBitmap); + } + else if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.S + && tileObject != null) + tileObject.setBitmap (null); + else if (tileObject != null) + tileObject = null; } - public void - resetXfermode () + /* Prepare the tile object to draw a stippled image onto a section of + a drawable defined by RECT. It is an error to call this function + unless the `stipple' field of the GContext is set. */ + + private void + prepareStipple (Rect rect) { - gcPaint.setXfermode (function == GC_XOR - ? xorAlu : srcInAlu); + int sx, sy; /* Stipple origin. */ + int bw, bh; /* Stipple size. */ + Bitmap bitmap; + Rect boundsRect; + + /* Retrieve the dimensions of the stipple bitmap, which doubles as + the unit of advance for this stipple. */ + bitmap = tileObject.getBitmap (); + bw = bitmap.getWidth (); + bh = bitmap.getHeight (); + + /* Align the lower left corner of the bounds rectangle to the + initial position of the stipple. */ + sx = (rect.left % bw) * -1 + (-ts_origin_x % bw) * -1; + sy = (rect.top % bh) * -1 + (-ts_origin_y % bh) * -1; + boundsRect = new Rect (rect.left + sx, rect.top + sy, + rect.right, rect.bottom); + tileObject.setBounds (boundsRect); + } + + /* Fill the rectangle BOUNDS in the provided CANVAS with the stipple + pattern defined for this GContext, in the foreground color where + the pattern is on, and in the background color where off. */ + + protected void + blitOpaqueStipple (Canvas canvas, Rect rect) + { + ColorFilter filter; + + prepareStipple (rect); + filter = new PorterDuffColorFilter (foreground | 0xff000000, + Mode.SRC_IN); + tileObject.setColorFilter (filter); + + canvas.save (); + canvas.clipRect (rect); + + tileObject.draw (canvas); + filter = new PorterDuffColorFilter (background | 0xff000000, + Mode.SRC_OUT); + tileObject.setColorFilter (filter); + tileObject.draw (canvas); + canvas.restore (); } }; diff --git a/java/org/gnu/emacs/EmacsService.java b/java/org/gnu/emacs/EmacsService.java index 2d4079c11b0..8e459ce4cdc 100644 --- a/java/org/gnu/emacs/EmacsService.java +++ b/java/org/gnu/emacs/EmacsService.java @@ -64,6 +64,7 @@ import android.content.res.AssetManager; import android.content.res.Configuration; +import android.content.res.Resources; import android.hardware.input.InputManager; @@ -146,6 +147,9 @@ public final class EmacsService extends Service thread. */ private Thread mainThread; + /* "Resources" object required by GContext bookkeeping. */ + public static Resources resources; + static { servicingQuery = new AtomicInteger (); @@ -238,10 +242,11 @@ public final class EmacsService extends Service super.onCreate (); SERVICE = this; + resources = getResources (); handler = new Handler (Looper.getMainLooper ()); manager = getAssets (); app_context = getApplicationContext (); - metrics = getResources ().getDisplayMetrics (); + metrics = resources.getDisplayMetrics (); pixelDensityX = metrics.xdpi; pixelDensityY = metrics.ydpi; tempScaledDensity = ((getScaledDensity (metrics) diff --git a/src/android.c b/src/android.c index 7a7eadc946a..e44b58c5973 100644 --- a/src/android.c +++ b/src/android.c @@ -4882,8 +4882,8 @@ android_pixmap android_create_bitmap_from_data (char *bits, unsigned int width, unsigned int height) { - return android_create_pixmap_from_bitmap_data (bits, 1, 0, - width, height, 1); + return android_create_pixmap_from_bitmap_data (bits, width, height, + 1, 0, 1); } struct android_image * @@ -5994,40 +5994,22 @@ android_toggle_on_screen_keyboard (android_window window, bool show) -#if defined __clang_major__ && __clang_major__ < 5 -# define HAS_BUILTIN_TRAP 0 -#elif 3 < __GNUC__ + (3 < __GNUC_MINOR__ + (4 <= __GNUC_PATCHLEVEL__)) -# define HAS_BUILTIN_TRAP 1 -#elif defined __has_builtin -# define HAS_BUILTIN_TRAP __has_builtin (__builtin_trap) -#else /* !__has_builtin */ -# define HAS_BUILTIN_TRAP 0 -#endif /* defined __clang_major__ && __clang_major__ < 5 */ - /* emacs_abort implementation for Android. This logs a stack trace. */ void emacs_abort (void) { -#ifndef HAS_BUILTIN_TRAP volatile char *foo; -#endif /* !HAS_BUILTIN_TRAP */ __android_log_print (ANDROID_LOG_FATAL, __func__, "emacs_abort called, please review the following" " stack trace"); -#ifndef HAS_BUILTIN_TRAP /* Induce a NULL pointer dereference to make debuggerd generate a tombstone. */ foo = NULL; *foo = '\0'; -#else /* HAS_BUILTIN_TRAP */ - /* Crash through __builtin_trap instead. This appears to more - uniformly elicit crash reports from debuggerd. */ - __builtin_trap (); -#endif /* !HAS_BUILTIN_TRAP */ abort (); } diff --git a/src/dispextern.h b/src/dispextern.h index f29377f3596..c3c2d61082b 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -69,12 +69,6 @@ typedef struct unsigned width, height; } Emacs_Rectangle; -#else - -typedef struct android_rectangle Emacs_Rectangle; - -#endif - /* XGCValues-like struct used by non-X GUI code. */ typedef struct { @@ -88,6 +82,19 @@ typedef struct #define GCForeground 0x01 #define GCBackground 0x02 +#else + +typedef struct android_rectangle Emacs_Rectangle; +typedef struct android_gc_values Emacs_GC; + +#define GCForeground ANDROID_GC_FOREGROUND +#define GCBackground ANDROID_GC_BACKGROUND +#define GCFillStyle ANDROID_GC_FILL_STYLE +#define GCStipple ANDROID_GC_STIPPLE +#define FillOpaqueStippled ANDROID_FILL_OPAQUE_STIPPLED + +#endif + #endif /* HAVE_X_WINDOWS */ #ifdef MSDOS diff --git a/src/epaths.in b/src/epaths.in index 275d13985aa..8415ce51586 100644 --- a/src/epaths.in +++ b/src/epaths.in @@ -95,7 +95,7 @@ along with GNU Emacs. If not, see . */ # define PATH_DOC "/assets/etc/" # define PATH_INFO "/assets/info/" # define PATH_GAME "" - # define PATH_BITMAPS "" + # define PATH_BITMAPS "/assets/bitmaps/" extern char *android_site_load_path; extern char *android_lib_dir; diff --git a/src/image.c b/src/image.c index 3968145728f..3028c2e707a 100644 --- a/src/image.c +++ b/src/image.c @@ -419,7 +419,7 @@ x_bitmap_stipple (struct frame *f, Pixmap pixmap) #endif /* USE_CAIRO */ #endif -#if defined (HAVE_X_WINDOWS) || defined (HAVE_NTGUI) +#if defined (HAVE_X_WINDOWS) || defined (HAVE_NTGUI) || defined (HAVE_ANDROID) ptrdiff_t image_bitmap_pixmap (struct frame *f, ptrdiff_t id) { diff --git a/src/sfntfont-android.c b/src/sfntfont-android.c index 1ed394b9458..b90ca857dd4 100644 --- a/src/sfntfont-android.c +++ b/src/sfntfont-android.c @@ -503,6 +503,10 @@ sfntfont_android_put_glyphs (struct glyph_string *s, int from, if (with_background) { + /* The background should have been filled in advance if a stipple + is enabled. */ + eassert (s->gc->fill_style != ANDROID_FILL_OPAQUE_STIPPLED); + /* Fill the background. First, offset the background rectangle to become relative from text_rectangle.x, text_rectangle.y. */ diff --git a/src/xfaces.c b/src/xfaces.c index d4583e1a78f..d307dbaa246 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -619,21 +619,7 @@ static struct android_gc * x_create_gc (struct frame *f, unsigned long value_mask, Emacs_GC *xgcv) { - struct android_gc_values gcv; - unsigned long mask; - - gcv.foreground = xgcv->foreground; - gcv.background = xgcv->background; - - mask = 0; - - if (value_mask & GCForeground) - mask |= ANDROID_GC_FOREGROUND; - - if (value_mask & GCBackground) - mask |= ANDROID_GC_BACKGROUND; - - return android_create_gc (mask, &gcv); + return android_create_gc (value_mask, xgcv); } static void @@ -4630,14 +4616,18 @@ prepare_face_for_display (struct frame *f, struct face *face) #endif block_input (); -#ifdef HAVE_X_WINDOWS +#if defined HAVE_X_WINDOWS || defined HAVE_ANDROID if (face->stipple) { egc.fill_style = FillOpaqueStippled; +#ifndef ANDROID_STUBIFY egc.stipple = image_bitmap_pixmap (f, face->stipple); +#else /* !ANDROID_STUBIFY */ + emacs_abort (); +#endif /* !ANDROID_STUBIFY */ mask |= GCFillStyle | GCStipple; } -#endif +#endif /* HAVE_X_WINDOWS || HAVE_ANDROID */ face->gc = x_create_gc (f, mask, &egc); if (face->font) font_prepare_for_face (f, face); commit 6ae835c924124a743d4f9dc6255ff1a3bd09ba6f Author: Yuan Fu Date: Mon Apr 22 21:55:45 2024 -0700 ; Add some comments to c-ts-common-comment-indent-new-line * lisp/progmodes/c-ts-common.el: (c-ts-common-comment-indent-new-line): Add comments. diff --git a/lisp/progmodes/c-ts-common.el b/lisp/progmodes/c-ts-common.el index 025703d7fce..457aa55c195 100644 --- a/lisp/progmodes/c-ts-common.el +++ b/lisp/progmodes/c-ts-common.el @@ -301,7 +301,7 @@ and /* */ comments. SOFT works the same as in (delete-region (line-beginning-position) (point)) (insert "//" whitespaces))) - ;; Line starts with /* or /** + ;; Line starts with /* or /**. ((save-excursion (beginning-of-line) (looking-at (rx "/*" (group (? "*") (* " "))))) @@ -310,7 +310,7 @@ and /* */ comments. SOFT works the same as in (delete-region (line-beginning-position) (point)) (insert " *" (make-string whitespace-and-star-len ?\s)))) - ;; Line starts with * + ;; Line starts with *. ((save-excursion (beginning-of-line) (looking-at (rx (group (* " ") (or "*" "|") (* " "))))) @@ -319,7 +319,8 @@ and /* */ comments. SOFT works the same as in (delete-region (line-beginning-position) (point)) (insert prefix))) - ;; Line starts with whitespaces + ;; Line starts with whitespaces or no space. This is basically the + ;; default case since (rx (* " ")) matches anything. ((save-excursion (beginning-of-line) (looking-at (rx (* " ")))) commit 1f443c277a1215ab6353c47161819af155638110 Author: Vincenzo Pupillo Date: Mon Apr 22 21:05:49 2024 +0200 Cover more c-ts-common-comment-indent-new-line (bug#70520) * lisp/progmodes/c-ts-common.el: (c-ts-common-comment-indent-new-line): Handles the case of comments in a comment block that begin with whitespaces. diff --git a/lisp/progmodes/c-ts-common.el b/lisp/progmodes/c-ts-common.el index 735126e1eac..025703d7fce 100644 --- a/lisp/progmodes/c-ts-common.el +++ b/lisp/progmodes/c-ts-common.el @@ -317,7 +317,16 @@ and /* */ comments. SOFT works the same as in (let ((prefix (match-string 1))) (if soft (insert-and-inherit ?\n) (newline 1)) (delete-region (line-beginning-position) (point)) - (insert prefix))))) + (insert prefix))) + + ;; Line starts with whitespaces + ((save-excursion + (beginning-of-line) + (looking-at (rx (* " ")))) + (let ((whitespaces (match-string 0))) + (if soft (insert-and-inherit ?\n) (newline 1)) + (delete-region (line-beginning-position) (point)) + (insert whitespaces))))) ;;; Statement indent commit 63765a74f15ef22109750414ec3025c8a40039f0 Author: Karl Fogel Date: Mon Apr 22 14:45:39 2024 -0500 Fix two bugs in removing bookmark fringe marks This fixes bug#70019 and a separate fringe-mark removal bug that also affected bookmarks in certain Info nodes. * lisp/bookmark.el (bookmark--remove-fringe-mark): Fix bug#70019 by temporarily widening in order to ensure we fetch the right overlays. Also, normalize both filenames before comparing, to avoid spurious failure to match. Thanks to Dani Moncayo for the bug report and for testing. diff --git a/lisp/bookmark.el b/lisp/bookmark.el index bf2357207d8..06f8e24b518 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -515,18 +515,45 @@ See user option `bookmark-fringe-mark'." (non-essential t) overlays found temp) (when (and pos filename) - (setq filename (abbreviate-file-name (expand-file-name filename))) (dolist (buf (buffer-list)) (with-current-buffer buf - (when (equal filename - (ignore-errors (bookmark-buffer-file-name))) - (setq overlays - (save-excursion - (goto-char pos) - (overlays-in (pos-bol) (1+ (pos-bol))))) - (while (and (not found) (setq temp (pop overlays))) - (when (eq 'bookmark (overlay-get temp 'category)) - (delete-overlay (setq found temp)))))))))) + (let ((bkmk-fname (ignore-errors (bookmark-buffer-file-name)))) + (when bkmk-fname + ;; Normalize both filenames before comparing, because the + ;; filename we receive from the bookmark wasn't + ;; necessarily generated by `bookmark-buffer-file-name'. + ;; For example, bookmarks set in Info nodes get a filename + ;; based on `Info-current-file', and under certain + ;; circumstances that can be an unexpanded path (e.g., + ;; when the Info page was under your home directory). + (let ((this-fname-normalized (expand-file-name filename)) + (bkmk-fname-normalized (expand-file-name bkmk-fname))) + (when (equal this-fname-normalized bkmk-fname-normalized) + (setq overlays + (save-excursion + (save-restriction + ;; Suppose bookmark "foo" was earlier set at + ;; location X in a file, but now the file is + ;; narrowed such that X is outside the + ;; restriction. Then the `goto-char' below + ;; would go to the wrong place and thus the + ;; wrong overlays would be fetched. This is + ;; why we temporarily `widen' before + ;; fetching. + ;; + ;; (This circumstance can easily arise when + ;; a bookmark was set on Info node X but now + ;; the "*info*" buffer is showing some other + ;; node Y, with X and Y physically located + ;; in the same file, as is often the case + ;; with Info nodes. See bug #70019, for + ;; example.) + (widen) + (goto-char pos) + (overlays-in (pos-bol) (1+ (pos-bol)))))) + (while (and (not found) (setq temp (pop overlays))) + (when (eq 'bookmark (overlay-get temp 'category)) + (delete-overlay (setq found temp))))))))))))) (defun bookmark-maybe-sort-alist () "Return `bookmark-alist' for display. commit e442161f11d11e5d4cac6bb1d5920a9ec36ad29f Author: Mattias Engdegård Date: Mon Apr 22 16:29:13 2024 +0200 Better format string compilation warning * lisp/emacs-lisp/bytecomp.el (byte-compile-format-warn): Speed up by eliminating the temporary buffer. Detect invalid format sequences. Use plurals properly. * test/lisp/emacs-lisp/bytecomp-tests.el: Update test. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index fb3278c08ab..2704378fc84 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1596,24 +1596,39 @@ extra args." (when (and (symbolp (car form)) (stringp (nth 1 form)) (get (car form) 'byte-compile-format-like)) - (let ((nfields (with-temp-buffer - (insert (nth 1 form)) - (goto-char (point-min)) - (let ((i 0) (n 0)) - (while (re-search-forward "%." nil t) - (backward-char) - (unless (eq ?% (char-after)) - (setq i (if (looking-at "\\([0-9]+\\)\\$") - (string-to-number (match-string 1) 10) - (1+ i)) - n (max n i))) - (forward-char)) - n))) - (nargs (- (length form) 2))) + (let* ((nargs (length (cddr form))) + (nfields 0) + (format-str (nth 1 form)) + (len (length format-str)) + (start 0)) + (while (and (< start len) + (string-match + (rx "%" + (? (group (+ digit)) "$") ; field + (* (in "+ #0-")) ; flags + (* digit) ; width + (? "." (* digit)) ; precision + (? (group (in "sdioxXefgcS%")))) ; spec + format-str start)) + (let ((field (if (match-beginning 1) + (string-to-number (match-string 1 format-str)) + (1+ nfields))) + (spec (and (match-beginning 2) + (aref format-str (match-beginning 2))))) + (setq start (match-end 0)) + (cond + ((not spec) + (byte-compile-warn-x + form "Bad format sequence in call to `%s' at string offset %d" + (car form) (match-beginning 0))) + ((not (eq spec ?%)) + (setq nfields (max field nfields)))))) (unless (= nargs nfields) - (byte-compile-warn-x (car form) - "`%s' called with %d args to fill %d format field(s)" (car form) - nargs nfields))))) + (byte-compile-warn-x + (car form) "`%s' called with %d argument%s to fill %d format field%s" + (car form) + nargs (if (= nargs 1) "" "s") + nfields (if (= nfields 1) "" "s")))))) (dolist (elt '(format message format-message error)) (put elt 'byte-compile-format-like t)) diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index a943012e5fc..e3ce87cc9af 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -1135,7 +1135,7 @@ byte-compiled. Run with dynamic binding." "var.*foo.*lacks a prefix") (bytecomp--define-warning-file-test "warn-format.el" - "called with 2 args to fill 1 format field") + "called with 2 arguments to fill 1 format field") (bytecomp--define-warning-file-test "warn-free-setq.el" "free.*foo") commit a2e327cbca1e756373109d4788ea635250d23224 Author: F. Moukayed Date: Mon Apr 22 07:54:47 2024 -0700 Ensure that Gnus inline preview undisplayer removes added newline * lisp/gnus/mm-view.el (mm-inline-image): Remove two characters ("x\n") instead of leaving behind a superfluous newline (bug#69920). diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index 109b6c17c2c..223da19a164 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -105,7 +105,7 @@ This is only used if `mm-inline-large-images' is set to (lambda () (let ((inhibit-read-only t)) (remove-images b b) - (delete-region b (1+ b))))))) + (delete-region b (+ b 2))))))) (defvar mm-w3m-setup nil "Whether gnus-article-mode has been setup to use emacs-w3m.") commit 6f810459d892bbcb66ad715a5232656cbb99d364 Author: Michael Albinus Date: Mon Apr 22 16:54:07 2024 +0200 ; Fix last commit * test/infra/Makefile.in: * test/infra/gitlab-ci.yml: * test/infra/test-jobs.yml: Do not quote make_params. diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in index 1d92a67f3aa..77ab1921212 100644 --- a/test/infra/Makefile.in +++ b/test/infra/Makefile.in @@ -103,7 +103,7 @@ define subdir_template @echo ' - test/$(1)/*.el' >>$(FILE) @echo ' variables:' >>$(FILE) @echo ' target: emacs-inotify' >>$(FILE) - @echo ' make_params: "-C test $(target)"' >>$(FILE) + @echo ' make_params: -C test $(target)' >>$(FILE) endef $(foreach subdir, $(SUBDIRS), $(eval $(call subdir_template,$(subdir)))) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 1b383e3b52c..e6840d064b5 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -255,9 +255,9 @@ test-filenotify-gio: target: emacs-filenotify-gio # This is needed in order to get a JUnit test report. make_params: >- - 'check-expensive + check-expensive TEST_HOME=/root - LOGFILES="lisp/autorevert-tests.log lisp/filenotify-tests.log"' + LOGFILES="lisp/autorevert-tests.log lisp/filenotify-tests.log" build-image-eglot: stage: platform-images @@ -275,12 +275,12 @@ test-eglot: target: emacs-eglot # This is needed in order to get a JUnit test report. make_params: >- - 'check-expensive - TEST_HOME=/root LOGFILES="lisp/progmodes/eglot-tests.log"' + check-expensive + TEST_HOME=/root LOGFILES="lisp/progmodes/eglot-tests.log" # EMACS_EXTRAOPT="--eval \(package-reinstall\ \(quote\ company\)\) # --eval \(package-reinstall\ \(quote\ yasnippet\)\) # --eval \(use-package\ company\) - # --eval \(use-package\ yasnippet\)"' + # --eval \(use-package\ yasnippet\)" build-image-tree-sitter: stage: platform-images @@ -300,7 +300,7 @@ test-tree-sitter: \(and\ \$\{SELECTOR_EXPENSIVE\}\ \(or\ \\\"^treesit\\\"\ \\\"-ts-\\\"\)\) # This is needed in order to get a JUnit test report. make_params: >- - 'check SELECTOR=$selector TEST_HOME=/root LOGFILES="$tree_sitter_files"' + check SELECTOR=$selector TEST_HOME=/root LOGFILES="$tree_sitter_files" build-image-gnustep: stage: platform-images @@ -348,7 +348,7 @@ test-native-comp-speed2: optional: true variables: target: emacs-native-comp-speed2 - make_params: "check SELECTOR='(not (tag :unstable))'" + make_params: check SELECTOR='(not (tag :unstable))' # Local Variables: # add-log-current-defun-header-regexp: "^\\([-_.[:alnum:]]+\\)[ \t]*:" diff --git a/test/infra/test-jobs.yml b/test/infra/test-jobs.yml index d1d4f10e1cf..d9ba2363c9e 100644 --- a/test/infra/test-jobs.yml +++ b/test/infra/test-jobs.yml @@ -15,7 +15,7 @@ test-lib-src-inotify: - test/lib-src/*.el variables: target: emacs-inotify - make_params: "-C test check-lib-src" + make_params: -C test check-lib-src test-lisp-inotify: stage: normal @@ -32,7 +32,7 @@ test-lisp-inotify: - test/lisp/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp" + make_params: -C test check-lisp test-lisp-calc-inotify: stage: normal @@ -49,7 +49,7 @@ test-lisp-calc-inotify: - test/lisp/calc/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-calc" + make_params: -C test check-lisp-calc test-lisp-calendar-inotify: stage: normal @@ -66,7 +66,7 @@ test-lisp-calendar-inotify: - test/lisp/calendar/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-calendar" + make_params: -C test check-lisp-calendar test-lisp-cedet-inotify: stage: normal @@ -83,7 +83,7 @@ test-lisp-cedet-inotify: - test/lisp/cedet/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-cedet" + make_params: -C test check-lisp-cedet test-lisp-cedet-semantic-inotify: stage: normal @@ -100,7 +100,7 @@ test-lisp-cedet-semantic-inotify: - test/lisp/cedet/semantic/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-cedet-semantic" + make_params: -C test check-lisp-cedet-semantic test-lisp-cedet-semantic-bovine-inotify: stage: normal @@ -117,7 +117,7 @@ test-lisp-cedet-semantic-bovine-inotify: - test/lisp/cedet/semantic/bovine/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-cedet-semantic-bovine" + make_params: -C test check-lisp-cedet-semantic-bovine test-lisp-cedet-srecode-inotify: stage: normal @@ -134,7 +134,7 @@ test-lisp-cedet-srecode-inotify: - test/lisp/cedet/srecode/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-cedet-srecode" + make_params: -C test check-lisp-cedet-srecode test-lisp-emacs-lisp-inotify: stage: normal @@ -151,7 +151,7 @@ test-lisp-emacs-lisp-inotify: - test/lisp/emacs-lisp/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-emacs-lisp" + make_params: -C test check-lisp-emacs-lisp test-lisp-emacs-lisp-eieio-tests-inotify: stage: normal @@ -168,7 +168,7 @@ test-lisp-emacs-lisp-eieio-tests-inotify: - test/lisp/emacs-lisp/eieio-tests/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-emacs-lisp-eieio-tests" + make_params: -C test check-lisp-emacs-lisp-eieio-tests test-lisp-emacs-lisp-faceup-tests-inotify: stage: normal @@ -185,7 +185,7 @@ test-lisp-emacs-lisp-faceup-tests-inotify: - test/lisp/emacs-lisp/faceup-tests/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-emacs-lisp-faceup-tests" + make_params: -C test check-lisp-emacs-lisp-faceup-tests test-lisp-emulation-inotify: stage: normal @@ -202,7 +202,7 @@ test-lisp-emulation-inotify: - test/lisp/emulation/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-emulation" + make_params: -C test check-lisp-emulation test-lisp-erc-inotify: stage: normal @@ -219,7 +219,7 @@ test-lisp-erc-inotify: - test/lisp/erc/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-erc" + make_params: -C test check-lisp-erc test-lisp-eshell-inotify: stage: normal @@ -236,7 +236,7 @@ test-lisp-eshell-inotify: - test/lisp/eshell/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-eshell" + make_params: -C test check-lisp-eshell test-lisp-gnus-inotify: stage: normal @@ -253,7 +253,7 @@ test-lisp-gnus-inotify: - test/lisp/gnus/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-gnus" + make_params: -C test check-lisp-gnus test-lisp-image-inotify: stage: normal @@ -270,7 +270,7 @@ test-lisp-image-inotify: - test/lisp/image/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-image" + make_params: -C test check-lisp-image test-lisp-international-inotify: stage: normal @@ -287,7 +287,7 @@ test-lisp-international-inotify: - test/lisp/international/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-international" + make_params: -C test check-lisp-international test-lisp-mail-inotify: stage: normal @@ -304,7 +304,7 @@ test-lisp-mail-inotify: - test/lisp/mail/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-mail" + make_params: -C test check-lisp-mail test-lisp-mh-e-inotify: stage: normal @@ -321,7 +321,7 @@ test-lisp-mh-e-inotify: - test/lisp/mh-e/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-mh-e" + make_params: -C test check-lisp-mh-e test-lisp-net-inotify: stage: normal @@ -338,7 +338,7 @@ test-lisp-net-inotify: - test/lisp/net/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-net" + make_params: -C test check-lisp-net test-lisp-nxml-inotify: stage: normal @@ -355,7 +355,7 @@ test-lisp-nxml-inotify: - test/lisp/nxml/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-nxml" + make_params: -C test check-lisp-nxml test-lisp-obsolete-inotify: stage: normal @@ -372,7 +372,7 @@ test-lisp-obsolete-inotify: - test/lisp/obsolete/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-obsolete" + make_params: -C test check-lisp-obsolete test-lisp-org-inotify: stage: normal @@ -389,7 +389,7 @@ test-lisp-org-inotify: - test/lisp/org/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-org" + make_params: -C test check-lisp-org test-lisp-play-inotify: stage: normal @@ -406,7 +406,7 @@ test-lisp-play-inotify: - test/lisp/play/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-play" + make_params: -C test check-lisp-play test-lisp-progmodes-inotify: stage: normal @@ -430,7 +430,7 @@ test-lisp-progmodes-inotify: - test/lisp/progmodes/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-progmodes" + make_params: -C test check-lisp-progmodes test-lisp-so-long-tests-inotify: stage: normal @@ -447,7 +447,7 @@ test-lisp-so-long-tests-inotify: - test/lisp/so-long-tests/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-so-long-tests" + make_params: -C test check-lisp-so-long-tests test-lisp-term-inotify: stage: normal @@ -464,7 +464,7 @@ test-lisp-term-inotify: - test/lisp/term/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-term" + make_params: -C test check-lisp-term test-lisp-textmodes-inotify: stage: normal @@ -481,7 +481,7 @@ test-lisp-textmodes-inotify: - test/lisp/textmodes/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-textmodes" + make_params: -C test check-lisp-textmodes test-lisp-url-inotify: stage: normal @@ -498,7 +498,7 @@ test-lisp-url-inotify: - test/lisp/url/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-url" + make_params: -C test check-lisp-url test-lisp-use-package-inotify: stage: normal @@ -515,7 +515,7 @@ test-lisp-use-package-inotify: - test/lisp/use-package/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-use-package" + make_params: -C test check-lisp-use-package test-lisp-vc-inotify: stage: normal @@ -532,7 +532,7 @@ test-lisp-vc-inotify: - test/lisp/vc/*.el variables: target: emacs-inotify - make_params: "-C test check-lisp-vc" + make_params: -C test check-lisp-vc test-misc-inotify: stage: normal @@ -549,7 +549,7 @@ test-misc-inotify: - test/misc/*.el variables: target: emacs-inotify - make_params: "-C test check-misc" + make_params: -C test check-misc test-src-inotify: stage: normal @@ -570,7 +570,7 @@ test-src-inotify: - test/src/*.el variables: target: emacs-inotify - make_params: "-C test check-src" + make_params: -C test check-src # js-tests.el and python-tests.el don't follow test file name convention. .tree-sitter-files-template: commit 42c8e2dfceb504533c6db3f336e28dd6c94aaa70 Author: Michael Albinus Date: Mon Apr 22 13:38:10 2024 +0200 Rework EMBA integration * test/infra/Dockerfile.emba (emacs-inotify, emacs-filenotify-gio) (emacs-eglot, emacs-tree-sitter, emacs-gnustep) (emacs-native-comp-speed0, emacs-native-comp-speed1) (emacs-native-comp-speed2): Use "-j `nproc`". (emacs-eglot): Add libxml2-dev and node-typescript. (emacs-tree-sitter) Add libxml2-dev and tree-sitter-rust. * test/infra/Makefile.in (subdir_template): Simplify make_params. * test/infra/gitlab-ci.yml (.job-template): Set environment variable NPROC. Use "-k -j \$NPROC". (test-filenotify-gio, test-eglot, test-tree-sitter) (test-native-comp-speed2): Simplify make_params. * test/infra/test-jobs.yml: Regenerate. diff --git a/test/infra/Dockerfile.emba b/test/infra/Dockerfile.emba index 233e210fc74..9091d60e8c8 100644 --- a/test/infra/Dockerfile.emba +++ b/test/infra/Dockerfile.emba @@ -45,7 +45,7 @@ WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure # 'make -j4 bootstrap' does not work reliably. -RUN make bootstrap +RUN make -j `nproc` bootstrap FROM emacs-base as emacs-filenotify-gio @@ -58,7 +58,7 @@ COPY . /checkout WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure --with-file-notification=gfile -RUN make bootstrap +RUN make -j `nproc` bootstrap # Debian bullseye doesn't provide proper packages. So we use Debian # sid for this. @@ -68,20 +68,49 @@ FROM debian:sid as emacs-eglot RUN apt-get update && \ apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \ libc-dev gcc g++ make autoconf automake libncurses-dev gnutls-dev \ - libdbus-1-dev libacl1-dev acl git texinfo gdb \ + libxml2-dev libdbus-1-dev libacl1-dev acl git texinfo gdb \ && rm -rf /var/lib/apt/lists/* -# Install clangd. +# Install clangd, tsserver. RUN apt-get update && \ apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \ - clangd \ + clangd node-typescript \ && rm -rf /var/lib/apt/lists/* +# eclipse-jdt-ls is planned as Java language server. +# See . + +# The following LSP servers exist as snap packages. However, snap +# cannot be used inside containers. We keep this here for reference. + +# # Install snapd. +# RUN apt-get update && \ +# apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \ +# snapd \ +# && rm -rf /var/lib/apt/lists/* +# RUN snap install core + +# # Install rust-analyzer. +# RUN snap install rust-analyzer --beta + +# # Install typescript-language-server. +# RUN snap install typescript-language-server + +# # Install vscode-json-languageserver. +# RUN snap install vscode-json-languageserver + COPY . /checkout WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure -RUN make bootstrap +RUN make -j `nproc` bootstrap + +# # Install company and yasnippet. +# RUN mkdir /root/.emacs.d +# RUN src/emacs --batch \ +# --eval '(setq url-debug 0 debug-on-error t)' \ +# --eval '(package-install (quote company))' \ +# --eval '(package-install (quote yasnippet))' # Debian bullseye doesn't provide proper packages. So we use Debian # sid for this. @@ -91,7 +120,7 @@ FROM debian:sid as emacs-tree-sitter RUN apt-get update && \ apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \ libc-dev gcc g++ make autoconf automake libncurses-dev gnutls-dev \ - libdbus-1-dev libacl1-dev acl git texinfo gdb \ + libxml2-dev libdbus-1-dev libacl1-dev acl git texinfo gdb \ && rm -rf /var/lib/apt/lists/* # Install tree-sitter library. @@ -104,7 +133,7 @@ COPY . /checkout WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure --with-tree-sitter -RUN make bootstrap +RUN make -j `nproc` bootstrap # Install language grammars. RUN mkdir -p /root/.emacs.d/tree-sitter @@ -129,6 +158,7 @@ RUN src/emacs -Q --batch \ (lua "https://github.com/tree-sitter-grammars/tree-sitter-lua") \ (python "https://github.com/tree-sitter/tree-sitter-python") \ (ruby "https://github.com/tree-sitter/tree-sitter-ruby") \ + (rust "https://github.com/tree-sitter/tree-sitter-rust") \ (tsx "https://github.com/tree-sitter/tree-sitter-typescript" "master" "tsx/src") \ (typescript "https://github.com/tree-sitter/tree-sitter-typescript" "master" "typescript/src"))))' \ --eval '(dolist (lang (mapcar (quote car) treesit-language-source-alist)) \ @@ -145,7 +175,7 @@ COPY . /checkout WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure --with-ns -RUN make bootstrap +RUN make -j `nproc` bootstrap FROM emacs-base as emacs-native-comp @@ -161,7 +191,7 @@ COPY . /checkout WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure --with-native-compilation -RUN make bootstrap -j2 \ +RUN make -j `nproc` bootstrap \ NATIVE_FULL_AOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' FROM emacs-native-comp as emacs-native-comp-speed1 @@ -170,7 +200,7 @@ COPY . /checkout WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure --with-native-compilation -RUN make bootstrap -j2 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' +RUN make -j `nproc` bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' FROM emacs-native-comp as emacs-native-comp-speed2 @@ -178,4 +208,4 @@ COPY . /checkout WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure --with-native-compilation -RUN make bootstrap -j2 +RUN make -j `nproc` bootstrap` diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in index 20fa9021abc..1d92a67f3aa 100644 --- a/test/infra/Makefile.in +++ b/test/infra/Makefile.in @@ -103,7 +103,7 @@ define subdir_template @echo ' - test/$(1)/*.el' >>$(FILE) @echo ' variables:' >>$(FILE) @echo ' target: emacs-inotify' >>$(FILE) - @echo ' make_params: "-k -C test $(target)"' >>$(FILE) + @echo ' make_params: "-C test $(target)"' >>$(FILE) endef $(foreach subdir, $(SUBDIRS), $(eval $(call subdir_template,$(subdir)))) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index d262218e276..1b383e3b52c 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -86,7 +86,7 @@ default: # TODO: with make -j4 several of the tests were failing, for # example shadowfile-tests, but passed without it. - 'export PWD=$(pwd)' - - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} -e EMACS_TEST_JUNIT_REPORT=${EMACS_TEST_JUNIT_REPORT} -e EMACS_TEST_TIMEOUT=${EMACS_TEST_TIMEOUT} -e EMACS_TEST_VERBOSE=${EMACS_TEST_VERBOSE} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro --name ${test_name} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -xvc "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"' + - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} -e EMACS_TEST_JUNIT_REPORT=${EMACS_TEST_JUNIT_REPORT} -e EMACS_TEST_TIMEOUT=${EMACS_TEST_TIMEOUT} -e EMACS_TEST_VERBOSE=${EMACS_TEST_VERBOSE} -e NPROC=`nproc` --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro --name ${test_name} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -xvc "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j \$NPROC && make -k -j \$NPROC ${make_params}"' after_script: # - docker ps -a # - printenv @@ -255,7 +255,7 @@ test-filenotify-gio: target: emacs-filenotify-gio # This is needed in order to get a JUnit test report. make_params: >- - '-k -C test check-expensive + 'check-expensive TEST_HOME=/root LOGFILES="lisp/autorevert-tests.log lisp/filenotify-tests.log"' @@ -275,8 +275,12 @@ test-eglot: target: emacs-eglot # This is needed in order to get a JUnit test report. make_params: >- - '-k -C test check-expensive + 'check-expensive TEST_HOME=/root LOGFILES="lisp/progmodes/eglot-tests.log"' + # EMACS_EXTRAOPT="--eval \(package-reinstall\ \(quote\ company\)\) + # --eval \(package-reinstall\ \(quote\ yasnippet\)\) + # --eval \(use-package\ company\) + # --eval \(use-package\ yasnippet\)"' build-image-tree-sitter: stage: platform-images @@ -296,8 +300,7 @@ test-tree-sitter: \(and\ \$\{SELECTOR_EXPENSIVE\}\ \(or\ \\\"^treesit\\\"\ \\\"-ts-\\\"\)\) # This is needed in order to get a JUnit test report. make_params: >- - '-k -C test check SELECTOR=$selector - TEST_HOME=/root LOGFILES="$tree_sitter_files"' + 'check SELECTOR=$selector TEST_HOME=/root LOGFILES="$tree_sitter_files"' build-image-gnustep: stage: platform-images @@ -345,7 +348,7 @@ test-native-comp-speed2: optional: true variables: target: emacs-native-comp-speed2 - make_params: "-k -C test check SELECTOR='(not (tag :unstable))'" + make_params: "check SELECTOR='(not (tag :unstable))'" # Local Variables: # add-log-current-defun-header-regexp: "^\\([-_.[:alnum:]]+\\)[ \t]*:" diff --git a/test/infra/test-jobs.yml b/test/infra/test-jobs.yml index 095964ee4ed..d1d4f10e1cf 100644 --- a/test/infra/test-jobs.yml +++ b/test/infra/test-jobs.yml @@ -15,7 +15,7 @@ test-lib-src-inotify: - test/lib-src/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lib-src" + make_params: "-C test check-lib-src" test-lisp-inotify: stage: normal @@ -32,7 +32,7 @@ test-lisp-inotify: - test/lisp/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp" + make_params: "-C test check-lisp" test-lisp-calc-inotify: stage: normal @@ -49,7 +49,7 @@ test-lisp-calc-inotify: - test/lisp/calc/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-calc" + make_params: "-C test check-lisp-calc" test-lisp-calendar-inotify: stage: normal @@ -66,7 +66,7 @@ test-lisp-calendar-inotify: - test/lisp/calendar/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-calendar" + make_params: "-C test check-lisp-calendar" test-lisp-cedet-inotify: stage: normal @@ -83,7 +83,7 @@ test-lisp-cedet-inotify: - test/lisp/cedet/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-cedet" + make_params: "-C test check-lisp-cedet" test-lisp-cedet-semantic-inotify: stage: normal @@ -100,7 +100,7 @@ test-lisp-cedet-semantic-inotify: - test/lisp/cedet/semantic/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-cedet-semantic" + make_params: "-C test check-lisp-cedet-semantic" test-lisp-cedet-semantic-bovine-inotify: stage: normal @@ -117,7 +117,7 @@ test-lisp-cedet-semantic-bovine-inotify: - test/lisp/cedet/semantic/bovine/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-cedet-semantic-bovine" + make_params: "-C test check-lisp-cedet-semantic-bovine" test-lisp-cedet-srecode-inotify: stage: normal @@ -134,7 +134,7 @@ test-lisp-cedet-srecode-inotify: - test/lisp/cedet/srecode/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-cedet-srecode" + make_params: "-C test check-lisp-cedet-srecode" test-lisp-emacs-lisp-inotify: stage: normal @@ -151,7 +151,7 @@ test-lisp-emacs-lisp-inotify: - test/lisp/emacs-lisp/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-emacs-lisp" + make_params: "-C test check-lisp-emacs-lisp" test-lisp-emacs-lisp-eieio-tests-inotify: stage: normal @@ -168,7 +168,7 @@ test-lisp-emacs-lisp-eieio-tests-inotify: - test/lisp/emacs-lisp/eieio-tests/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-emacs-lisp-eieio-tests" + make_params: "-C test check-lisp-emacs-lisp-eieio-tests" test-lisp-emacs-lisp-faceup-tests-inotify: stage: normal @@ -185,7 +185,7 @@ test-lisp-emacs-lisp-faceup-tests-inotify: - test/lisp/emacs-lisp/faceup-tests/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-emacs-lisp-faceup-tests" + make_params: "-C test check-lisp-emacs-lisp-faceup-tests" test-lisp-emulation-inotify: stage: normal @@ -202,7 +202,7 @@ test-lisp-emulation-inotify: - test/lisp/emulation/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-emulation" + make_params: "-C test check-lisp-emulation" test-lisp-erc-inotify: stage: normal @@ -219,7 +219,7 @@ test-lisp-erc-inotify: - test/lisp/erc/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-erc" + make_params: "-C test check-lisp-erc" test-lisp-eshell-inotify: stage: normal @@ -236,7 +236,7 @@ test-lisp-eshell-inotify: - test/lisp/eshell/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-eshell" + make_params: "-C test check-lisp-eshell" test-lisp-gnus-inotify: stage: normal @@ -253,7 +253,7 @@ test-lisp-gnus-inotify: - test/lisp/gnus/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-gnus" + make_params: "-C test check-lisp-gnus" test-lisp-image-inotify: stage: normal @@ -270,7 +270,7 @@ test-lisp-image-inotify: - test/lisp/image/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-image" + make_params: "-C test check-lisp-image" test-lisp-international-inotify: stage: normal @@ -287,7 +287,7 @@ test-lisp-international-inotify: - test/lisp/international/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-international" + make_params: "-C test check-lisp-international" test-lisp-mail-inotify: stage: normal @@ -304,7 +304,7 @@ test-lisp-mail-inotify: - test/lisp/mail/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-mail" + make_params: "-C test check-lisp-mail" test-lisp-mh-e-inotify: stage: normal @@ -321,7 +321,7 @@ test-lisp-mh-e-inotify: - test/lisp/mh-e/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-mh-e" + make_params: "-C test check-lisp-mh-e" test-lisp-net-inotify: stage: normal @@ -338,7 +338,7 @@ test-lisp-net-inotify: - test/lisp/net/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-net" + make_params: "-C test check-lisp-net" test-lisp-nxml-inotify: stage: normal @@ -355,7 +355,7 @@ test-lisp-nxml-inotify: - test/lisp/nxml/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-nxml" + make_params: "-C test check-lisp-nxml" test-lisp-obsolete-inotify: stage: normal @@ -372,7 +372,7 @@ test-lisp-obsolete-inotify: - test/lisp/obsolete/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-obsolete" + make_params: "-C test check-lisp-obsolete" test-lisp-org-inotify: stage: normal @@ -389,7 +389,7 @@ test-lisp-org-inotify: - test/lisp/org/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-org" + make_params: "-C test check-lisp-org" test-lisp-play-inotify: stage: normal @@ -406,7 +406,7 @@ test-lisp-play-inotify: - test/lisp/play/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-play" + make_params: "-C test check-lisp-play" test-lisp-progmodes-inotify: stage: normal @@ -430,7 +430,7 @@ test-lisp-progmodes-inotify: - test/lisp/progmodes/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-progmodes" + make_params: "-C test check-lisp-progmodes" test-lisp-so-long-tests-inotify: stage: normal @@ -447,7 +447,7 @@ test-lisp-so-long-tests-inotify: - test/lisp/so-long-tests/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-so-long-tests" + make_params: "-C test check-lisp-so-long-tests" test-lisp-term-inotify: stage: normal @@ -464,7 +464,7 @@ test-lisp-term-inotify: - test/lisp/term/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-term" + make_params: "-C test check-lisp-term" test-lisp-textmodes-inotify: stage: normal @@ -481,7 +481,7 @@ test-lisp-textmodes-inotify: - test/lisp/textmodes/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-textmodes" + make_params: "-C test check-lisp-textmodes" test-lisp-url-inotify: stage: normal @@ -498,7 +498,7 @@ test-lisp-url-inotify: - test/lisp/url/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-url" + make_params: "-C test check-lisp-url" test-lisp-use-package-inotify: stage: normal @@ -515,7 +515,7 @@ test-lisp-use-package-inotify: - test/lisp/use-package/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-use-package" + make_params: "-C test check-lisp-use-package" test-lisp-vc-inotify: stage: normal @@ -532,7 +532,7 @@ test-lisp-vc-inotify: - test/lisp/vc/*.el variables: target: emacs-inotify - make_params: "-k -C test check-lisp-vc" + make_params: "-C test check-lisp-vc" test-misc-inotify: stage: normal @@ -549,7 +549,7 @@ test-misc-inotify: - test/misc/*.el variables: target: emacs-inotify - make_params: "-k -C test check-misc" + make_params: "-C test check-misc" test-src-inotify: stage: normal @@ -570,7 +570,7 @@ test-src-inotify: - test/src/*.el variables: target: emacs-inotify - make_params: "-k -C test check-src" + make_params: "-C test check-src" # js-tests.el and python-tests.el don't follow test file name convention. .tree-sitter-files-template: @@ -585,5 +585,6 @@ test-src-inotify: lisp/progmodes/lua-ts-mode-tests.log lisp/progmodes/python-tests.log lisp/progmodes/ruby-ts-mode-tests.log + lisp/progmodes/rust-ts-mode-tests.log lisp/progmodes/typescript-ts-mode-tests.log src/treesit-tests.log commit 2a533514929f2ad241bf1c6a65bdbf796bae092c Author: Stephen Berman Date: Mon Apr 22 11:32:10 2024 +0200 Fix Widget manual typos, markup and omissions (bug#70502) * doc/misc/widget.texi (Widgets and the Buffer): Correct typos and texinfo markup, add equivalent key bindings and make minor changes in wording. (Customization): Correct names of two faces and add documentation of remaining widget faces. diff --git a/doc/misc/widget.texi b/doc/misc/widget.texi index cfb9d2211cf..c1c36e0c353 100644 --- a/doc/misc/widget.texi +++ b/doc/misc/widget.texi @@ -760,14 +760,14 @@ This chapter describes commands that are specific to buffers that contain widgets. @cindex widget keybindings -@defvr Const widget-keymap +@defvar widget-keymap Keymap containing useful bindings for buffers containing widgets. -Binds @key{TAB} and @kbd{C-@key{TAB}} to @code{widget-forward} and -@code{widget-backward}, respectively. It also binds @key{RET} to -@code{widget-button-press} and @kbd{down-mouse-1} and +Binds @key{TAB} to @code{widget-forward} and both @kbd{S-@key{TAB}} and +@kbd{M-@key{TAB}} to @code{widget-backward}. It also binds @key{RET} to +@code{widget-button-press} and both @kbd{down-mouse-1} and @kbd{down-mouse-2} to @code{widget-button-click}. -@end defvr +@end defvar There's also a keymap for events that the Widget library doesn't need to handle. @@ -788,8 +788,8 @@ The following navigation commands are available: @deffn Command widget-forward &optional count Move point @var{count} buttons or editing fields forward. @end deffn -@item @kbd{M-@key{TAB}} -@itemx @kbd{S-@key{TAB}} +@item M-@key{TAB} +@itemx S-@key{TAB} @deffn Command widget-backward &optional count Move point @var{count} buttons or editing fields backward. @end deffn @@ -800,30 +800,35 @@ When editing an @code{editable-field} widget, the following commands are available: @table @kbd -@item @key{C-e} +@item C-e @deffn Command widget-end-of-line Move point to the end of field or end of line, whichever is first. @end deffn -@item @kbd{C-k} +@item C-k @deffn Command widget-kill-line Kill to end of field or end of line, whichever is first. @end deffn -@item @kbd{M-TAB} +@item M-@key{TAB} +@itemx C-M-i @deffn Command widget-complete Complete the content of the editable field at point. @end deffn -@item @kbd{C-m} +@item C-m +@itemx @key{RET} @deffn Command widget-field-activate Invoke the editable field at point. @end deffn @end table -The following two are commands that can execute widget actions. +The following two commands can execute the action associated with a +button widget (e.g., a radio button or checkbox): + @table @kbd @item @key{RET} +@itemx C-m @findex widget-button-press @deffn Command widget-button-press @var{pos} &optional @var{event} Invoke the button at @var{pos}, defaulting to point. @@ -3257,14 +3262,26 @@ to get a string. Otherwise, it @code{eval}s it. This chapter is about the customization options for the Widget library, for the end user. -@deffn Face widget-field-face -Face used for other editing fields. +@deffn Face widget-documentation +Face used for documentation text. +@end deffn + +@deffn Face widget-field +Face used for editable fields. @end deffn -@deffn Face widget-button-face +@deffn Face widget-button Face used for buttons. @end deffn +@deffn Face widget-button-pressed +Face used for pressed buttons. +@end deffn + +@deffn Face widget-inactive +Face used for inactive widgets. +@end deffn + @defopt widget-mouse-face Face used for highlighting a button when the mouse pointer moves across it. commit 931cd9331363051a8cb5ef45dc37937e63b243d9 Author: Po Lu Date: Mon Apr 22 16:37:01 2024 +0800 ; * java/Makefile.in: Fix typos. diff --git a/java/Makefile.in b/java/Makefile.in index bd1938689d5..abddae6b5cf 100644 --- a/java/Makefile.in +++ b/java/Makefile.in @@ -367,7 +367,7 @@ $(CLASS_FILES): $(RESOURCE_FILE) $(CONFIG_FILE) .SUFFIXES: .java .class $(CLASS_FILES) &: $(JAVA_FILES) - $(AM_V_JAVAC) $(JAVAC) $(JAVAFLAGS) $(JAVA_FILES) + $(AM_V_JAVAC) $(JAVAC) $(JAVAFLAGS) $(JAVA_FILES) $(CONFIG_FILE) $(AM_V_SILENT) touch $(CLASS_FILES) # N.B. that find must be called all over again in case javac generated @@ -375,17 +375,18 @@ $(CLASS_FILES) &: $(JAVA_FILES) ALL_CLASS_FILES = \ $(subst $$,\$$,$(shell find $(srcdir) -type f -name *.class)) +ALL_CLASS_FILES_1 = ifneq ($(builddir),$(srcdir)) # If the build directory is distinct from the source directory, also # include generated class files located there. -ALL_CLASS_FILES = $(ALL_CLASS_FILES) \ +ALL_CLASS_FILES_1 = \ $(subst $$,\$$,$(shell find $(builddir) -type f -name *.class)) endif classes.dex: $(CLASS_FILES) $(if $(IS_D8_R8), $(srcdir)/proguard.conf) $(AM_V_D8) $(D8) --classpath $(ANDROID_JAR) \ - $(ALL_CLASS_FILES) \ + $(ALL_CLASS_FILES) $(ALL_CLASS_FILES_1) \ --output $(builddir) \ --min-api $(ANDROID_MIN_SDK) \ $(if $(filter false,$(ANDROID_DEBUGGABLE)),--release, \ commit 3bcdf010a9f2576bac0d7f23af70fa9dff81ef95 Author: Po Lu Date: Mon Apr 22 16:27:30 2024 +0800 Generate Android shared library list automatically * .gitignore: Ignore new generated files. * cross/Makefile.in (src/Makefile): Remove leftover specification of the source Gnulib directory. * cross/ndk-build/ndk-build.mk.in (NDK_BUILD_READELF): New variable. * java/Makefile.in (CONFIG_FILE, ALL_DEPENDENCIES, READELF) (cf-stamp-1, cf-stamp): New variables and rules; compute the set of library files in the order of loading and generate a file with this information. (ALL_CLASS_FILES): New variable; if builddir is not srcdir, $($(CONFIG_FILE), $(CLASS_FILES)): Depend on EmacsConfig.java. add generated files in the build directory. (classes.dex): Adjust to match. * java/org/gnu/emacs/EmacsNative.java (EmacsNative) : Load shared libraries from EMACS_SHARED_LIBRARIES rather than a hard-coded list. * m4/ndk-build.m4 (ndk_INIT): Search for readelf... (ndk_CHECK_MODULES): ...and substitute its path as NDK_BUILD_READELF. diff --git a/.gitignore b/.gitignore index 29c571a3dcb..4098e2210b5 100644 --- a/.gitignore +++ b/.gitignore @@ -66,6 +66,10 @@ java/org/gnu/emacs/*.class # Built by `aapt'. java/org/gnu/emacs/R.java +# Built by `make'. +java/org/gnu/emacs/EmacsConfig.java +java/org/gnu/emacs/cf-stamp + # Built by `config.status'. java/AndroidManifest.xml diff --git a/cross/Makefile.in b/cross/Makefile.in index 1e8daea6f91..575c6c4cb29 100644 --- a/cross/Makefile.in +++ b/cross/Makefile.in @@ -140,7 +140,7 @@ src/Makefile: $(top_builddir)/src/Makefile.android -e 's/\.\.\/admin\/charsets/..\/..\/admin\/charsets/g' \ -e 's/^libsrc =.*$$/libsrc = \.\.\/\.\.\/lib-src/g' \ -e 's/libsrc =.*$$/libsrc = \.\.\/\.\.\/lib-src/g' \ - -e 's/-I\$$(top_srcdir)\/lib/-I..\/$(subst /,\/,$(srcdir))\/lib/g' \ + -e 's/-I\$$(top_srcdir)\/lib//g' \ < $(top_builddir)/src/Makefile.android > $@ src/epaths.h: $(top_builddir)/src/epaths.h diff --git a/cross/ndk-build/ndk-build.mk.in b/cross/ndk-build/ndk-build.mk.in index ea1be5af6f1..9948e019e3b 100644 --- a/cross/ndk-build/ndk-build.mk.in +++ b/cross/ndk-build/ndk-build.mk.in @@ -27,6 +27,7 @@ NDK_BUILD_CXX_LDFLAGS = @NDK_BUILD_CXX_LDFLAGS@ NDK_BUILD_ANY_CXX_MODULE = @NDK_BUILD_ANY_CXX_MODULE@ NDK_BUILD_SHARED = NDK_BUILD_STATIC = +NDK_BUILD_READELF = @NDK_BUILD_READELF@ define uniqify $(if $1,$(firstword $1) $(call uniqify,$(filter-out $(firstword $1),$1))) diff --git a/java/Makefile.in b/java/Makefile.in index 7d732be8f91..bd1938689d5 100644 --- a/java/Makefile.in +++ b/java/Makefile.in @@ -83,6 +83,10 @@ RESOURCE_FILES := $(foreach file,$(wildcard $(srcdir)/res/*), \ # code. Instead, it is automatically included by the Java compiler. RESOURCE_FILE := $(srcdir)/org/gnu/emacs/R.java +# EmacsConfig.java is a file that holds information regarding the set of +# shared libraries this binary links to, and similar build variables. +CONFIG_FILE := $(builddir)/org/gnu/emacs/EmacsConfig.java + # CLASS_FILES is what should actually be built and included in the # resulting Emacs executable. The Java compiler might generate more # than one class file for each source file, so this only serves as a @@ -294,8 +298,72 @@ $(RESOURCE_FILE): $(RESOURCE_FILES) -J $(dir $@) -M AndroidManifest.xml \ -S $(top_srcdir)/java/res -# Make all class files depend on R.java being built. -$(CLASS_FILES): $(RESOURCE_FILE) +# Generate a list of libemacs's dependencies with each item ordered +# before its dependents for the startup process to load in advance, as +# older versions of the dynamic linker do not consider these libraries +# when resolving its imports. The several following statements are +# executed from a recursive `make' run after shared libraries are +# generated. + +ALL_DEPENDENCIES := + +ifneq (,$(filter cf-stamp-1,$(MAKECMDGOALS))) +# Don't be sidetracked by dependencies of shared libraries outside the +# ndk-build directory. +define get-dependencies +$(foreach x, \ +$(and $(wildcard $(top_builddir)/cross/ndk-build/$1.so), \ + $(shell $(NDK_BUILD_READELF) -d \ + $(wildcard $(top_builddir)/cross/ndk-build/$1.so) \ + | sed -n 's/.*(NEEDED).*\[\(.*\.so\)\].*/\1/p')), \ +$(basename $(notdir $(x)))) +endef #get-dependencies +define resolve-one-dependency +$(foreach dependency,$(call get-dependencies,$1),\ + $(if $(findstring "$(dependency)",$(ALL_DEPENDENCIES)),,\ + $(call resolve-one-dependency,$(basename $(notdir $(dependency)))) \ + $(eval ALL_DEPENDENCIES := $(ALL_DEPENDENCIES) "$(dependency)",))) +endef #resolve-one-dependency +DEPENDENCIES := $(foreach file,$(NDK_BUILD_SHARED),\ + $(basename $(notdir $(file)))) +$(foreach file,$(DEPENDENCIES),\ + $(if $(findstring "$(file)",$(ALL_DEPENDENCIES)),,\ + $(call resolve-one-dependency,$(file)) \ + $(eval ALL_DEPENDENCIES := $(ALL_DEPENDENCIES) "$(file)",))) +endif + +# EmacsConfig.java: +ifeq (${V},1) +AM_V_EMACSCONFIG = +else +AM_V_EMACSCONFIG = @$(info $. GEN org/gnu/emacs/EmacsConfig.java) +endif + +.PHONY: cf-stamp-1 +cf-stamp-1: + $(AM_V_at) echo 'package org.gnu.emacs;\ +public class EmacsConfig\ +{\ +/* This is a generated file. Do not edit! */\ +public static final String[] EMACS_SHARED_LIBRARIES\ += {$(ALL_DEPENDENCIES)};\ +}' | sed 's/\\//g' > globals.tmp + $(AM_V_at) mkdir -p org/gnu/emacs + $(AM_V_at) $(top_srcdir)/build-aux/move-if-change \ + globals.tmp org/gnu/emacs/EmacsConfig.java + +# cf-stamp-1 is a phony target invoked in a second `make' instance after +# all shared libraries are compiled, because the computation of +# ALL_DEPENDENCIES cannot be postponed until that stage in this instance +# of Make. +cf-stamp: $(NDK_BUILD_SHARED) $(CROSS_LIBS) + $(AM_V_EMACSCONFIG) $(MAKE) cf-stamp-1 + $(AM_V_at) touch $@ +$(CONFIG_FILE): cf-stamp; @true + +# Make all class files depend on R.java and EmacsConfig.java being +# built. +$(CLASS_FILES): $(RESOURCE_FILE) $(CONFIG_FILE) .SUFFIXES: .java .class $(CLASS_FILES) &: $(JAVA_FILES) @@ -305,13 +373,23 @@ $(CLASS_FILES) &: $(JAVA_FILES) # N.B. that find must be called all over again in case javac generated # nested classes. +ALL_CLASS_FILES = \ + $(subst $$,\$$,$(shell find $(srcdir) -type f -name *.class)) + +ifneq ($(builddir),$(srcdir)) +# If the build directory is distinct from the source directory, also +# include generated class files located there. +ALL_CLASS_FILES = $(ALL_CLASS_FILES) \ + $(subst $$,\$$,$(shell find $(builddir) -type f -name *.class)) +endif + classes.dex: $(CLASS_FILES) $(if $(IS_D8_R8), $(srcdir)/proguard.conf) $(AM_V_D8) $(D8) --classpath $(ANDROID_JAR) \ - $(subst $$,\$$,$(shell find $(srcdir) -type f \ - -name *.class)) --output $(builddir) \ + $(ALL_CLASS_FILES) \ + --output $(builddir) \ --min-api $(ANDROID_MIN_SDK) \ $(if $(filter false,$(ANDROID_DEBUGGABLE)),--release, \ - --debug) \ + --debug) \ $(if $(IS_D8_R8),--pg-conf $(srcdir)/proguard.conf) # When emacs.keystore expires, regenerate it with: @@ -345,7 +423,8 @@ TAGS: $(ETAGS) $(tagsfiles) $(AM_V_GEN) $(ETAGS) $(tagsfiles) clean: - rm -f *.apk emacs.apk-in *.dex *.unaligned *.class *.idsig + rm -f *.apk emacs.apk-in *.dex *.unaligned *.class *.idsig \ + cf-stamp $(CONFIG_FILE) rm -rf install-temp $(RESOURCE_FILE) TAGS find . -name '*.class' $(FIND_DELETE) diff --git a/java/org/gnu/emacs/EmacsNative.java b/java/org/gnu/emacs/EmacsNative.java index 567242f2ec3..9b3e60e1a84 100644 --- a/java/org/gnu/emacs/EmacsNative.java +++ b/java/org/gnu/emacs/EmacsNative.java @@ -321,39 +321,35 @@ public static native void blitRect (Bitmap src, Bitmap dest, int x1, static { - /* Older versions of Android cannot link correctly with shared - libraries that link with other shared libraries built along - Emacs unless all requisite shared libraries are explicitly - loaded from Java. - - Every time you add a new shared library dependency to Emacs, - please insert it here as well, before other shared libraries of - which it might be a dependency. */ - - libraryDeps = new String[] { "c++_shared", "gnustl_shared", - "stlport_shared", "gabi++_shared", - "png_emacs", "pcre_emacs", - "selinux_emacs", "crypto_emacs", - "packagelistparser_emacs", - "gmp_emacs", "nettle_emacs", - "p11-kit_emacs", "tasn1_emacs", - "hogweed_emacs", "gnutls_emacs", - "jpeg_emacs", "tiff_emacs", - "icuuc_emacs", "xml2_emacs", - "harfbuzz_emacs", "tree-sitter_emacs", }; + /* A library search path misconfiguration prevents older versions of + Android from successfully loading application shared libraries + unless all requisite shared libraries provided by the application + are explicitly loaded from Java. The build process arranges that + EmacsConfig.EMACS_SHARED_LIBRARIES hold the names of each of + these libraries in the correct order, so load them now. */ + + libraryDeps = EmacsConfig.EMACS_SHARED_LIBRARIES; for (String dependency : libraryDeps) { - try - { - System.loadLibrary (dependency); - } - catch (UnsatisfiedLinkError exception) - { - /* Ignore this exception. */ - } + /* Remove the "lib" prefix, if any. */ + if (dependency.startsWith ("lib")) + dependency = dependency.substring (3); + + /* If this library is provided by the operating system, don't + link to it. */ + if (dependency.equals ("z") + || dependency.equals ("c") + || dependency.equals ("m") + || dependency.equals ("dl") + || dependency.equals ("log") + || dependency.equals ("android")) + continue; + + System.loadLibrary (dependency); } + /* At this point, it should be alright to load Emacs. */ System.loadLibrary ("emacs"); }; }; diff --git a/m4/ndk-build.m4 b/m4/ndk-build.m4 index abe06063ab0..2689ee34287 100644 --- a/m4/ndk-build.m4 +++ b/m4/ndk-build.m4 @@ -339,6 +339,16 @@ NDK_BUILD_NASM= AS_IF([test "$ndk_ARCH" = "x86" || test "$ndk_ARCH" = "x86_64"], [AC_CHECK_PROGS([NDK_BUILD_NASM], [nasm])]) +# Search for a suitable readelf binary, which is required to generate +# the shared library list loaded on old Android systems. +AC_PATH_PROGS([READELF], [readelf llvm-readelf $host_alias-readelf], + [], [$ndk_ranlib_search_path:$PATH]) +AS_IF([test -z "$READELF"], + [AC_MSG_ERROR([A suitable `readelf' utility cannot be located. +Please verify that the Android NDK has been installed correctly, +or install a functioning `readelf' yourself.])]) +NDK_BUILD_READELF="$READELF" + # Search for a C++ compiler. Upon failure, pretend the C compiler is a # C++ compiler and use that instead. @@ -644,6 +654,7 @@ AC_DEFUN_ONCE([ndk_CONFIG_FILES], AC_SUBST([NDK_BUILD_CXX_LDFLAGS]) AC_SUBST([NDK_BUILD_ANY_CXX_MODULE]) AC_SUBST([NDK_BUILD_CFLAGS]) + AC_SUBST([NDK_BUILD_READELF]) AC_CONFIG_FILES([$ndk_DIR/Makefile]) AC_CONFIG_FILES([$ndk_DIR/ndk-build.mk]) commit 90be3015b4dfe8068407dec996a48926b82d0ecb Author: Eli Zaretskii Date: Mon Apr 22 10:37:18 2024 +0300 ; Document bookmark fringe mark in the user manual * doc/emacs/regs.texi (Bookmarks): Document 'bookmark-fringe-mark'. diff --git a/doc/emacs/regs.texi b/doc/emacs/regs.texi index 4302a4caa49..440fc64a6ef 100644 --- a/doc/emacs/regs.texi +++ b/doc/emacs/regs.texi @@ -337,8 +337,19 @@ Save all the current bookmark values in the default bookmark file. @kbd{C-x r m}, which sets a bookmark using the visited file name as the default for the bookmark name. If you name each bookmark after the file it points to, then you can conveniently revisit any of those -files with @kbd{C-x r b}, and move to the position of the bookmark at -the same time. +files with @kbd{C-x r b} (@code{bookmark-jump}), and move to the +position of the bookmark at the same time. + +@vindex bookmark-fringe-mark + In addition to recording the current position, on graphical displays +@kbd{C-x r m} places a special image on the left fringe +(@pxref{Fringes}) of the screen line corresponding to the recorded +position, to indicate that there's a bookmark there. This can be +controlled by the user option @code{bookmark-fringe-mark}: customize +it to @code{nil} to disable the fringe mark. The default value is +@code{bookmark-mark}, which is the bitmap used for this purpose. When +you later use @kbd{C-x r b} to jump back to the bookmark, the fringe +mark will be again shown on the fringe. @kindex C-x r M @findex bookmark-set-no-overwrite commit afd0b548fcc5e141528a442ff9100fe8e2b98f21 Author: Prateek Sharma Date: Sat Apr 20 02:06:17 2024 +0530 Fix python-ts-mode built-in functions and attributes (bug#70478) * lisp/progmodes/python.el (python--treesit-settings): Change the treesitter query to fetch the correct type of node for built-in functions and attributes and highlight them with corresponding font-lock face. diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 9849fde8588..02588d756e9 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -1187,13 +1187,15 @@ fontified." :feature 'builtin :language 'python - `(((identifier) @font-lock-builtin-face - (:match ,(rx-to-string - `(seq bol - (or ,@python--treesit-builtins - ,@python--treesit-special-attributes) - eol)) - @font-lock-builtin-face))) + `((call function: (identifier) @font-lock-builtin-face + (:match ,(rx-to-string + `(seq bol (or ,@python--treesit-builtins) eol)) + @font-lock-builtin-face)) + (attribute attribute: (identifier) @font-lock-builtin-face + (:match ,(rx-to-string + `(seq bol + (or ,@python--treesit-special-attributes) eol)) + @font-lock-builtin-face))) :feature 'decorator :language 'python commit dc720decc3a7f0cfaaaf4467c0c5d2954dec527c Author: Eli Zaretskii Date: Sun Apr 21 19:49:14 2024 +0300 Fix markup and indexing in the Calendar chapter of user manual * doc/emacs/calendar.texi (Calendar Unit Motion) (Scroll Calendar, Writing Calendar Files, Holidays) (Sunrise/Sunset, Lunar Phases, Calendar Systems) (To Other Calendar, Displaying the Diary, Date Formats) (Adding to Diary, Special Diary Entries): Fix markup, style, and indexing. diff --git a/doc/emacs/calendar.texi b/doc/emacs/calendar.texi index 856e0be4f1c..10fe404099d 100644 --- a/doc/emacs/calendar.texi +++ b/doc/emacs/calendar.texi @@ -104,8 +104,11 @@ Move point one year backward (@code{calendar-backward-year}). The day and week commands are natural analogues of the usual Emacs commands for moving by characters and by lines. Just as @kbd{C-n} usually moves to the same column in the following line, in Calendar -mode it moves to the same day in the following week. And @kbd{C-p} -moves to the same day in the previous week. +mode it is bound to @code{calendar-forward-week}, which moves to the +same day in the following week. And @kbd{C-p} +(@code{calendar-backward-week} moves to the same day in the previous +week. @kbd{C-f} (@code{calendar-forward-day}) and @kbd{C-b} +(@code{calendar-backward-day}) move forward and back by days. The arrow keys are equivalent to @kbd{C-f}, @kbd{C-b}, @kbd{C-n} and @kbd{C-p}, just as they normally are in other modes. @@ -119,10 +122,12 @@ moves to the same day in the previous week. @kindex C-x [ @r{(Calendar mode)} @findex calendar-backward-year The commands for motion by months and years work like those for -weeks, but move a larger distance. The month commands @kbd{M-@}} and -@kbd{M-@{} move forward or backward by an entire month. The year -commands @kbd{C-x ]} and @w{@kbd{C-x [}} move forward or backward a -whole year. +weeks, but move a larger distance. The month commands @kbd{M-@}} +(@code{calendar-forward-month}) and @kbd{M-@{} +(@code{calendar-backward-month}) move forward or backward by an entire +month. The year commands @w{@kbd{C-x ]}} +(@code{calendar-forward-year}) and @w{@kbd{C-x [}} +(@code{calendar-backward-year}) move forward or backward a whole year. The easiest way to remember these commands is to consider months and years analogous to paragraphs and pages of text, respectively. But @@ -261,8 +266,9 @@ Scroll backward by three months (@code{calendar-scroll-right-three-months}). @findex calendar-scroll-right The most basic calendar scroll commands scroll by one month at a time. This means that there are two months of overlap between the -display before the command and the display after. @kbd{>} scrolls the -calendar contents one month forward in time. @kbd{<} scrolls the +display before the command and the display after. @kbd{>} +(@code{calendar-scroll-left}) scrolls the calendar contents one month +forward in time. @kbd{<} (@code{calendar-scroll-right}) scrolls the contents one month backwards in time. @kindex C-v @r{(Calendar mode)} @@ -273,13 +279,15 @@ contents one month backwards in time. @kindex PageUp @r{(Calendar mode)} @kindex prior @r{(Calendar mode)} @findex calendar-scroll-right-three-months - The commands @kbd{C-v} and @kbd{M-v} scroll the calendar by an entire -screenful---three months---in analogy with the usual meaning of -these commands. @kbd{C-v} makes later dates visible and @kbd{M-v} makes -earlier dates visible. These commands take a numeric argument as a -repeat count; in particular, since @kbd{C-u} multiplies the next command -by four, typing @kbd{C-u C-v} scrolls the calendar forward by a year and -typing @kbd{C-u M-v} scrolls the calendar backward by a year. + The commands @kbd{C-v} (@code{calendar-scroll-left-three-months}) +and @kbd{M-v} (@code{calendar-scroll-right-three-months}) scroll the +calendar by an entire screenful---three months---in analogy with the +usual meaning of these commands. @kbd{C-v} makes later dates visible +and @kbd{M-v} makes earlier dates visible. These commands take a +numeric argument as a repeat count; in particular, since @kbd{C-u} +multiplies the next command by four, typing @kbd{C-u C-v} scrolls the +calendar forward by a year and typing @kbd{C-u M-v} scrolls the +calendar backward by a year. The function keys @key{PageDown} (or @key{next}) and @key{PageUp} (or @key{prior}) are equivalent to @kbd{C-v} and @kbd{M-v}, just as @@ -358,6 +366,8 @@ calendar deletes or iconifies that frame depending on the value of You can write calendars and diary entries to HTML and @LaTeX{} files. @cindex calendar and HTML +@vindex cal-html-directory +@vindex cal-html-holidays The Calendar HTML commands produce files of HTML code that contain calendar, holiday, and diary entries. Each file applies to one month, and has a name of the format @file{@var{yyyy}-@var{mm}.html}, where @@ -382,10 +392,13 @@ Generate a one-month calendar (@code{cal-html-cursor-month}). @item H y Generate a calendar file for each month of a year, as well as an index page (@code{cal-html-cursor-year}). By default, this command writes -files to a @var{yyyy} subdirectory---if this is altered some hyperlinks -between years will not work. +files to a @var{year} subdirectory, where @var{year} is the year at +cursor---if this is altered, some hyperlinks between years will not +work. @end table +@vindex cal-html-print-day-number-flag +@vindex cal-html-year-index-cols If the variable @code{cal-html-print-day-number-flag} is non-@code{nil}, then the monthly calendars show the day-of-the-year number. The variable @code{cal-html-year-index-cols} specifies the @@ -444,6 +457,9 @@ paper size (3.75in x 6.75in). All of these commands accept a prefix argument, which specifies how many days, weeks, months or years to print (starting always with the selected one). +@vindex cal-tex-holidays +@vindex cal-tex-diary +@vindex cal-tex-rules If the variable @code{cal-tex-holidays} is non-@code{nil} (the default), then the printed calendars show the holidays in @code{calendar-holidays}. If the variable @code{cal-tex-diary} is non-@code{nil} (the default is @@ -454,6 +470,7 @@ pages in styles that have sufficient room. Consult the documentation of the individual cal-tex functions to see which calendars support which features. +@vindex cal-tex-preamble-extra You can use the variable @code{cal-tex-preamble-extra} to insert extra @LaTeX{} commands in the preamble of the generated document if you need to. @@ -486,12 +503,12 @@ List holidays in another window for a specified range of years. @kindex h @r{(Calendar mode)} @findex calendar-cursor-holidays -@vindex calendar-view-holidays-initially-flag To see if any holidays fall on a given date, position point on that -date in the calendar window and use the @kbd{h} command. Alternatively, -click on that date with @kbd{mouse-3} and then choose @kbd{Holidays} -from the menu that appears. Either way, this displays the holidays for -that date, in the echo area if they fit there, otherwise in a separate +date in the calendar window and use the @kbd{h} +(@code{calendar-cursor-holidays}) command. Alternatively, click on +that date with @kbd{mouse-3} and then choose @kbd{Holidays} from the +menu that appears. Either way, this displays the holidays for that +date, in the echo area if they fit there, otherwise in a separate window. @kindex x @r{(Calendar mode)} @@ -500,8 +517,8 @@ window. @findex calendar-unmark @vindex calendar-mark-holidays-flag To view the distribution of holidays for all the dates shown in the -calendar, use the @kbd{x} command. This displays the dates that are -holidays in a different face. +calendar, use the @kbd{x} (@code{calendar-mark-holidays}) command. +This displays the dates that are holidays in a different face. @iftex @xref{Calendar Customizing,,, emacs-xtra, Specialized Emacs Features}. @end iftex @@ -510,19 +527,22 @@ holidays in a different face. @end ifnottex The command applies both to the currently visible months and to other months that subsequently become visible by scrolling. To turn -marking off and erase the current marks, type @kbd{u}, which also -erases any diary marks (@pxref{Diary}). If the variable -@code{calendar-mark-holidays-flag} is non-@code{nil}, creating or -updating the calendar marks holidays automatically. +marking off and erase the current marks, type @kbd{u} +(@code{calendar-unmark}), which also erases any diary marks +(@pxref{Diary}). If the variable @code{calendar-mark-holidays-flag} +is non-@code{nil}, creating or updating the calendar marks holidays +automatically. @kindex a @r{(Calendar mode)} @findex calendar-list-holidays - To get even more detailed information, use the @kbd{a} command, which -displays a separate buffer containing a list of all holidays in the -current three-month range. You can use @key{SPC} and @key{DEL} in the -calendar window to scroll that list up and down, respectively. + To get even more detailed information, use the @kbd{a} +(@code{calendar-list-holidays}) command, which displays a separate +buffer containing a list of all holidays in the current three-month +range. You can use @key{SPC} and @key{DEL} in the calendar window to +scroll that list up and down, respectively. @findex holidays +@vindex calendar-view-holidays-initially-flag The command @kbd{M-x holidays} displays the list of holidays for the current month and the preceding and succeeding months; this works even if you don't have a calendar window. If the variable @@ -536,6 +556,7 @@ major Bahá'í, Chinese, Christian, Islamic, and Jewish holidays; also the solstices and equinoxes. @findex list-holidays +@findex holiday-list The command @kbd{M-x holiday-list} displays the list of holidays for a range of years. This function asks you for the starting and stopping years, and allows you to choose all the holidays or one of several @@ -569,14 +590,14 @@ Display times of sunrise and sunset for the selected month. @kindex S @r{(Calendar mode)} @findex calendar-sunrise-sunset @findex sunrise-sunset - Within the calendar, to display the @emph{local times} of sunrise and -sunset in the echo area, move point to the date you want, and type -@kbd{S}. Alternatively, click @kbd{mouse-3} on the date, then choose -@samp{Sunrise/sunset} from the menu that appears. The command @kbd{M-x -sunrise-sunset} is available outside the calendar to display this -information for today's date or a specified date. To specify a date -other than today, use @kbd{C-u M-x sunrise-sunset}, which prompts for -the year, month, and day. + Within the calendar, to display the @emph{local times} of sunrise +and sunset in the echo area, move point to the date you want, and type +@kbd{S} (@code{calendar-sunrise-sunset}). Alternatively, click +@kbd{mouse-3} on the date, then choose @samp{Sunrise/sunset} from the +menu that appears. The command @kbd{M-x sunrise-sunset} is available +outside the calendar to display this information for today's date or a +specified date. To specify a date other than today, use @kbd{C-u M-x +sunrise-sunset}, which prompts for the year, month, and day. You can display the times of sunrise and sunset for any location and any date with @kbd{C-u C-u M-x sunrise-sunset}. This asks you for a @@ -584,13 +605,13 @@ longitude, latitude, number of minutes difference from Coordinated Universal Time, and date, and then tells you the times of sunrise and sunset for that location on that date. +@vindex calendar-location-name +@vindex calendar-longitude +@vindex calendar-latitude Because the times of sunrise and sunset depend on the location on earth, you need to tell Emacs your latitude, longitude, and location name before using these commands. Here is an example of what to set: -@vindex calendar-location-name -@vindex calendar-longitude -@vindex calendar-latitude @example (setq calendar-latitude 40.1) (setq calendar-longitude -88.2) @@ -601,14 +622,14 @@ name before using these commands. Here is an example of what to set: Use one decimal place in the values of @code{calendar-latitude} and @code{calendar-longitude}. +@vindex calendar-time-zone +@vindex calendar-standard-time-zone-name +@vindex calendar-daylight-time-zone-name Your time zone also affects the local time of sunrise and sunset. Emacs usually gets time zone information from the operating system, but if these values are not what you want (or if the operating system does not supply them), you must set them yourself. Here is an example: -@vindex calendar-time-zone -@vindex calendar-standard-time-zone-name -@vindex calendar-daylight-time-zone-name @example (setq calendar-time-zone -360) (setq calendar-standard-time-zone-name "CST") @@ -616,9 +637,9 @@ not supply them), you must set them yourself. Here is an example: @end example @noindent -The value of @code{calendar-time-zone} is the number of minutes +The value of @code{calendar-time-zone} is the number of minutes of difference between your local standard time and Coordinated Universal -Time (Greenwich time). The values of +Time (a.k.a.@: ``Greenwich time''). The values of @code{calendar-standard-time-zone-name} and @code{calendar-daylight-time-zone-name} are the abbreviations used in your time zone. Emacs displays the times of sunrise and sunset @@ -627,7 +648,7 @@ for how daylight saving time is determined. @vindex calendar-time-zone-style If you want to display numerical time zones (like @samp{"+0100"}) -instead of symbolic ones (like @samp{"CET"}), set +instead of symbolic ones (like @samp{"CET"}), set the variable @code{calendar-time-zone-style} to @code{numeric}. As a user, you might find it convenient to set the calendar location @@ -640,10 +661,10 @@ for all users in a @file{default.el} file. @xref{Init File}. @cindex phases of the moon @cindex moon, phases of - These calendar commands display the dates and times of the phases of -the moon (new moon, first quarter, full moon, last quarter). This -feature is useful for debugging problems that depend on the phase of -the moon. + The calendar commands described in this section display the dates +and times of the phases of the moon (new moon, first quarter, full +moon, last quarter). This feature is useful for debugging problems +that depend on the phase of the moon. @table @kbd @item M @@ -656,9 +677,10 @@ today's date. @kindex M @r{(Calendar mode)} @findex calendar-lunar-phases - Within the calendar, use the @kbd{M} command to display a separate -buffer of the phases of the moon for the current three-month range. The -dates and times listed are accurate to within a few minutes. + Within the calendar, use the @kbd{M} (@code{calendar-lunar-phases}) +command to display a separate buffer of the phases of the moon for the +current three-month range. The dates and times listed are accurate to +within a few minutes. @findex lunar-phases Outside the calendar, use the command @kbd{M-x lunar-phases} to @@ -669,21 +691,22 @@ year. The dates and times given for the phases of the moon are given in local time (corrected for daylight saving, when appropriate). -See the discussion in the previous section. @xref{Sunrise/Sunset}. +See the discussion in the previous section (@pxref{Sunrise/Sunset}). @node Other Calendars @section Conversion To and From Other Calendars @cindex Gregorian calendar - The Emacs calendar displayed is @emph{always} the Gregorian calendar, -sometimes called the New Style calendar, which is used in most of -the world today. However, this calendar did not exist before the -sixteenth century and was not widely used before the eighteenth century; -it did not fully displace the Julian calendar and gain universal -acceptance until the early twentieth century. The Emacs calendar can -display any month since January, year 1 of the current era, but the -calendar displayed is always the Gregorian, even for a date at which -the Gregorian calendar did not exist. +@cindex New Style calendar + The Emacs calendar displayed is @emph{always} the @dfn{Gregorian +calendar}, sometimes called the @dfn{New Style calendar}, which is +used in most of the world today. However, this calendar did not exist +before the sixteenth century and was not widely used before the +eighteenth century; it did not fully displace the Julian calendar and +gain universal acceptance until the early twentieth century. The +Emacs calendar can display any month since January, year 1 of the +current era, but the calendar displayed is always the Gregorian, even +for a date at which the Gregorian calendar did not exist. While Emacs cannot display other calendars, it can convert dates to and from several other calendars. @@ -712,7 +735,8 @@ century. @cindex astronomical day numbers Astronomers use a simple counting of days elapsed since noon, Monday, January 1, 4713 BC on the Julian calendar. The number of days elapsed -is called the @dfn{Julian day number} or the @dfn{Astronomical day number}. +since then is called the @dfn{Julian day number} or the +@dfn{Astronomical day number}. @cindex Hebrew calendar The Hebrew calendar is used by tradition in the Jewish religion. The @@ -737,6 +761,10 @@ the metric system. The French government officially abandoned this calendar at the end of 1805. @cindex Mayan calendars +@cindex long count calendar system +@cindex tzolkin calendar system +@cindex haab calendar system +@cindex Goodman-Martinez-Thompson correlation The Maya of Central America used three separate, overlapping calendar systems, the @emph{long count}, the @emph{tzolkin}, and the @emph{haab}. Emacs knows about all three of these calendars. Experts dispute the @@ -752,6 +780,7 @@ extra period to make it six days. The Ethiopic calendar is identical in structure, but has different year numbers and month names. @cindex Persian calendar +@cindex Birashk The Persians use a solar calendar based on a design of Omar Khayyam. Their calendar consists of twelve months of which the first six have 31 days, the next five have 30 days, and the last has 29 in ordinary years @@ -841,13 +870,13 @@ Display Mayan date for selected day (@code{calendar-mayan-print-date}). Otherwise, move point to the date you want to convert, then type the appropriate command starting with @kbd{p} from the table above. The prefix @kbd{p} is a mnemonic for ``print'', since Emacs ``prints'' the -equivalent date in the echo area. @kbd{p o} displays the -date in all forms known to Emacs. You can also use @kbd{mouse-3} and -then choose @kbd{Other calendars} from the menu that appears. This -displays the equivalent forms of the date in all the calendars Emacs -understands, in the form of a menu. (Choosing an alternative from -this menu doesn't actually do anything---the menu is used only for -display.) +equivalent date in the echo area. @kbd{p o} +(@code{calendar-print-other-dates}) displays the date in all forms +known to Emacs. You can also use @kbd{mouse-3} and then choose +@kbd{Other calendars} from the menu that appears. This displays the +equivalent forms of the date in all the calendars Emacs understands, +in the form of a menu. (Choosing an alternative from this menu +doesn't actually do anything---the menu is used only for display.) @node From Other Calendar @subsection Converting From Other Calendars @@ -1054,10 +1083,11 @@ Mail yourself email reminders about upcoming diary entries. @kindex d @r{(Calendar mode)} @findex diary-view-entries @vindex calendar-view-diary-initially-flag - Displaying the diary entries with @kbd{d} shows in a separate buffer -the diary entries for the selected date in the calendar. The mode line -of the new buffer shows the date of the diary entries. Holidays are -shown either in the buffer or in the mode line, depending on the display + Displaying the diary entries with @kbd{d} +(@code{diary-view-entries}) shows in a separate buffer the diary +entries for the selected date in the calendar. The mode line of the +new buffer shows the date of the diary entries. Holidays are shown +either in the buffer or in the mode line, depending on the display method you choose @iftex (@pxref{Diary Display,,, emacs-xtra, Specialized Emacs Features}). @@ -1080,8 +1110,8 @@ current date is visible). @findex diary-mark-entries @vindex calendar-mark-diary-entries-flag To get a broader view of which days are mentioned in the diary, use -the @kbd{m} command. This marks the dates that have diary entries in -a different face. +the @kbd{m} (@code{diary-mark-entries}) command. This marks the dates +that have diary entries in a different face. @iftex @xref{Calendar Customizing,,, emacs-xtra, Specialized Emacs Features}. @end iftex @@ -1090,9 +1120,10 @@ a different face. @end ifnottex This command applies both to the months that are currently visible -and to those that subsequently become visible after scrolling. To turn -marking off and erase the current marks, type @kbd{u}, which also -turns off holiday marks (@pxref{Holidays}). If the variable +and to those that subsequently become visible after scrolling. To +turn marking off and erase the current marks, type @kbd{u} +(@code{calendar-unmark}), which also turns off holiday marks +(@pxref{Holidays}). If the variable @code{calendar-mark-diary-entries-flag} is non-@code{nil}, creating or updating the calendar marks diary dates automatically. @@ -1108,9 +1139,10 @@ otherwise mark many different dates. @kindex s @r{(Calendar mode)} @findex diary-show-all-entries To see the full diary file, rather than just some of the entries, use -the @kbd{s} command. +the @kbd{s} (@code{diary-show-all-entries}) command. @findex diary +@vindex diary-number-of-entries The command @kbd{M-x diary} displays the diary entries for the current date, independently of the calendar display, and optionally for the next few days as well; the variable @code{diary-number-of-entries} specifies @@ -1162,6 +1194,9 @@ and @var{day} are numbers of one or two digits. The optional @var{year} is also a number, and may be abbreviated to the last two digits; that is, you can use @samp{11/12/2012} or @samp{11/12/12}. +@vindex calendar-abbrev-length +@vindex calendar-month-abbrev-array +@vindex calendar-day-abbrev-array Dates can also have the form @samp{@var{monthname} @var{day}} or @samp{@var{monthname} @var{day}, @var{year}}, where the month's name can be spelled in full or abbreviated (with or without a period). The @@ -1195,6 +1230,7 @@ significant. @node Adding to Diary @subsection Commands to Add to the Diary +@cindex create diary entries While in the calendar, there are several commands to create diary entries. The basic commands are listed here; more sophisticated @@ -1220,10 +1256,11 @@ Add a diary entry for the selected day of the year (@code{diary-insert-yearly-en @kindex i d @r{(Calendar mode)} @findex diary-insert-entry - You can make a diary entry for a specific date by selecting that date -in the calendar window and typing the @kbd{i d} command. This command -displays the end of your diary file in another window and inserts the -date; you can then type the rest of the diary entry. + You can make a diary entry for a specific date by selecting that +date in the calendar window and typing the @kbd{i d} +(@code{diary-insert-entry}) command. This command displays the end of +your diary file in another window and inserts the date; you can then +type the rest of the diary entry. @kindex i w @r{(Calendar mode)} @findex diary-insert-weekly-entry @@ -1232,12 +1269,14 @@ date; you can then type the rest of the diary entry. @kindex i y @r{(Calendar mode)} @findex diary-insert-yearly-entry If you want to make a diary entry that applies to a specific day of -the week, select that day of the week (any occurrence will do) and type -@kbd{i w}. This inserts the day-of-week as a generic date; you can then -type the rest of the diary entry. You can make a monthly diary entry in -the same fashion: select the day of the month, use the @kbd{i m} -command, and type the rest of the entry. Similarly, you can insert a -yearly diary entry with the @kbd{i y} command. +the week, select that day of the week (any occurrence will do) and +type @kbd{i w} (@code{diary-insert-weekly-entry}). This inserts the +day-of-week as a generic date; you can then type the rest of the diary +entry. You can make a monthly diary entry in the same fashion: select +the day of the month, use the @kbd{i m} +(@code{diary-insert-monthly-entry}) command, and type the rest of the +entry. Similarly, you can insert a yearly diary entry with the @kbd{i +y} (@code{diary-insert-yearly-entry}) command. All of the above commands make marking diary entries by default. To make a nonmarking diary entry, give a prefix argument to the command. @@ -1252,6 +1291,7 @@ calendar window, if appropriate. You can use the command @node Special Diary Entries @subsection Special Diary Entries +@cindex sexp entries, in diary In addition to entries based on calendar dates, the diary file can contain @dfn{sexp entries} for regular events such as anniversaries. These entries are based on Lisp expressions (sexps) that Emacs evaluates @@ -1277,11 +1317,12 @@ Add a cyclic diary entry starting at the date @kindex i a @r{(Calendar mode)} @findex diary-insert-anniversary-entry - If you want to make a diary entry that applies to the anniversary of a -specific date, move point to that date and use the @kbd{i a} command. -This displays the end of your diary file in another window and inserts -the anniversary description; you can then type the rest of the diary -entry. The entry looks like this: + If you want to make a diary entry that applies to the anniversary of +a specific date, move point to that date and use the @kbd{i a} +(@code{diary-insert-anniversary-entry}) command. This displays the +end of your diary file in another window and inserts the anniversary +description; you can then type the rest of the diary entry. The entry +looks like this: @findex diary-anniversary @example @@ -1295,6 +1336,7 @@ calendar style, the input order of month, day and year is different.) The reason this expression requires a beginning year is that advanced diary functions can use it to calculate the number of elapsed years. +@cindex block diary entry A @dfn{block} diary entry applies to a specified range of consecutive dates. Here is a block diary entry that applies to all dates from June 24, 2012 through July 10, 2012: @@ -1311,17 +1353,19 @@ calendar style, the input order of month, day and year is different.) @kindex i b @r{(Calendar mode)} @findex diary-insert-block-entry - To insert a block entry, place point and the mark on the two -dates that begin and end the range, and type @kbd{i b}. This command -displays the end of your diary file in another window and inserts the -block description; you can then type the diary entry. + To insert a block entry, place point and the mark on the two dates +that begin and end the range, and type @kbd{i b} +(@code{diary-insert-block-entry}). This command displays the end of +your diary file in another window and inserts the block description; +you can then type the diary entry. @kindex i c @r{(Calendar mode)} @findex diary-insert-cyclic-entry - @dfn{Cyclic} diary entries repeat after a fixed interval of days. To -create one, select the starting date and use the @kbd{i c} command. The -command prompts for the length of interval, then inserts the entry, -which looks like this: +@cindex cyclic diary entry + @dfn{Cyclic} diary entries repeat after a fixed interval of days. +To create one, select the starting date and use the @kbd{i c} +(@code{diary-insert-cyclic-entry}) command. The command prompts for +the length of interval, then inserts the entry, which looks like this: @findex diary-cyclic @example @@ -1343,6 +1387,7 @@ since every date visible in the calendar window must be individually checked. So it's a good idea to make sexp diary entries nonmarking (with @samp{&}) when possible. +@cindex floating diary entry Another sophisticated kind of sexp entry, a @dfn{floating} diary entry, specifies a regularly occurring event by offsets specified in days, weeks, and months. It is comparable to a crontab entry interpreted by @@ -1478,6 +1523,7 @@ appointment list with @kbd{M-x appt-delete}. @node Importing Diary @subsection Importing and Exporting Diary Entries +@cindex importing diary entries You can transfer diary entries between Emacs diary files and a variety of other formats. @@ -1535,6 +1581,7 @@ to the main diary file, if these are different files. @findex icalendar-export-file @findex icalendar-export-region +@cindex export diary Use @code{icalendar-export-file} to interactively export an entire Emacs diary file to iCalendar format. To export only a part of a diary file, mark the relevant area, and call @code{icalendar-export-region}. commit f593bf79a91f3744daa83c8974f7fd21f6b07c3c Author: Gautier Ponsinet Date: Sun Apr 21 15:39:49 2024 +0200 Fix the user manual for `calendar-time-zone-style' * doc/emacs/calendar.texi (Sunrise/Sunset): Refer to the variable `calendar-time-zone-style' explicitly. (Bug#70498) diff --git a/doc/emacs/calendar.texi b/doc/emacs/calendar.texi index 7312cfb34c9..856e0be4f1c 100644 --- a/doc/emacs/calendar.texi +++ b/doc/emacs/calendar.texi @@ -627,7 +627,8 @@ for how daylight saving time is determined. @vindex calendar-time-zone-style If you want to display numerical time zones (like @samp{"+0100"}) -instead of symbolic ones (like @samp{"CET"}), set this to @code{numeric}. +instead of symbolic ones (like @samp{"CET"}), set +@code{calendar-time-zone-style} to @code{numeric}. As a user, you might find it convenient to set the calendar location variables for your usual physical location in your @file{.emacs} file. commit aed2b7a3d82fd16789befe3c6e4c05e20ed0ae60 Author: Eli Zaretskii Date: Sun Apr 21 16:06:34 2024 +0300 Avoid assertion violations in 'push_prefix_prop' * src/xdisp.c (push_prefix_prop): Set the 'string_from_prefix_prop_p' flag for any valid value of the 'line-prefix' or 'wrap-prefix' property/variable. (Bug#70495) diff --git a/src/dispextern.h b/src/dispextern.h index de46658dc0a..1590fa64436 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -2373,7 +2373,9 @@ struct it bool_bf string_from_display_prop_p : 1; /* True means `string' comes from a `line-prefix' or `wrap-prefix' - property. */ + property, and that these properties were already handled, even if + their value is not a string. This is used to avoid processing + the same line/wrap prefix more than once for the same glyph row. */ bool_bf string_from_prefix_prop_p : 1; /* True means we are iterating an object that came from a value of a diff --git a/src/xdisp.c b/src/xdisp.c index a9eb47720d0..6e945ed114b 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -24030,6 +24030,7 @@ push_prefix_prop (struct it *it, Lisp_Object prop) { it->method = GET_FROM_STRETCH; it->object = prop; + it->string_from_prefix_prop_p = true; } #ifdef HAVE_WINDOW_SYSTEM else if (IMAGEP (prop)) @@ -24037,6 +24038,7 @@ push_prefix_prop (struct it *it, Lisp_Object prop) it->what = IT_IMAGE; it->image_id = lookup_image (it->f, prop, it->face_id); it->method = GET_FROM_IMAGE; + it->string_from_prefix_prop_p = true; } #endif /* HAVE_WINDOW_SYSTEM */ else commit c929532b4694a1c5d0f61ae77f4e8664706a36a1 Author: Basil L. Contovounesios Date: Sat Apr 20 16:01:49 2024 +0200 Remove ert-equal-including-properties from manual * doc/misc/ert.texi (Useful Techniques): Mention only equal-including-properties in place of the now obsolete ert-equal-including-properties. diff --git a/doc/misc/ert.texi b/doc/misc/ert.texi index e10b8e3a7b4..74d8a29691d 100644 --- a/doc/misc/ert.texi +++ b/doc/misc/ert.texi @@ -766,7 +766,6 @@ Here's a more complicated test: @end lisp @findex make-ert-test -@findex ert-equal-including-properties This test creates a test object using @code{make-ert-test} whose body will immediately signal failure. It then runs that test and asserts that it fails. Then, it creates a temporary buffer and invokes @@ -775,7 +774,7 @@ to the current buffer. Finally, it extracts the first line from the buffer and asserts that it matches what we expect. It uses @code{buffer-substring-no-properties} and @code{equal} to ignore text properties; for a test that takes properties into account, -@code{buffer-substring} and @code{ert-equal-including-properties} +@code{buffer-substring} and @code{equal-including-properties} could be used instead. The reason why this test only checks the first line of the backtrace commit e3aae5fd385bd5512f614d2273a2d6d8e95a7ce6 Author: Eli Zaretskii Date: Sat Apr 20 14:52:02 2024 +0300 ; Document 'filtered-frame-list' * doc/lispref/frames.texi (Finding All Frames): Document 'filtered-frame-list'. diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index dc38f90ed74..edc080153d6 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -2804,6 +2804,18 @@ direction. See also @code{next-window} and @code{previous-window}, in @ref{Cyclic Window Ordering}. + Some Lisp programs need to find one or more frames that satisfy a +given criteria. The function @code{filtered-frame-list} is provided for +this purpose. + +@defun filtered-frame-list predicate +This function returns the list of all the live frames which satisfy the +specified @var{predicate}. The argument @var{predicate} must be a +function of one argument, a frame to be tested against the filtering +criteria, and should return non-@code{nil} if the frame satisfies the +criteria. +@end defun + @node Minibuffers and Frames @section Minibuffers and Frames