commit 0df28dc00edd0db343619d02aa41999a7bfce5fb (HEAD, refs/remotes/origin/master) Author: Andrea Corallo Date: Wed Mar 20 16:59:33 2024 +0100 ; * lisp/emacs-lisp/comp-run.el (comp-run-async-workers): Fix indentation. diff --git a/lisp/emacs-lisp/comp-run.el b/lisp/emacs-lisp/comp-run.el index 480f048777c..5cc61579030 100644 --- a/lisp/emacs-lisp/comp-run.el +++ b/lisp/emacs-lisp/comp-run.el @@ -233,8 +233,8 @@ display a message." "`comp-files-queue' should be \".el\" files: %s" source-file) when (or native-comp-always-compile - load ; Always compile when the compilation is - ; commanded for late load. + load ; Always compile when the compilation is + ; commanded for late load. ;; Skip compilation if `comp-el-to-eln-filename' fails ;; to find a writable directory. (with-demoted-errors "Async compilation :%S" commit ae9d8eedfdd6030a082010ac933b4aa4ddc05749 Author: Eli Zaretskii Date: Wed Mar 20 16:08:15 2024 +0200 ; Minor copyedits of last change. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 7e8d4e15e0a..1df1e3b3ddb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3010,24 +3010,25 @@ These are substituted with a normal `set' op." ;;; Sanitizer pass specific code. -;; This pass aims to verify compile time value type predictions during -;; execution. +;; This pass aims to verify compile-time value-type predictions during +;; execution of the code. ;; The sanitizer pass injects a call to 'helper_sanitizer_assert' before -;; each conditional branch. 'helper_sanitizer_assert' will verify that +;; each conditional branch. 'helper_sanitizer_assert' will verify that ;; the variable tested by the conditional branch is of the predicted -;; value type and signal an error otherwise. +;; value type, or signal an error otherwise. ;;; Example: -;; Assuming we want to compile 'test.el' and test function `foo' defined -;; into it. -;; Native compile 'test.el' instrumenting it for sanitizer usage. -;; (let ((comp-sanitizer-emit t)) -;; (load (native-compile "test.el"))) +;; Assume we want to compile 'test.el' and test the function `foo' +;; defined in it. Then: -;; Run `foo' with the sanitizer active. -;; (let ((comp-sanitizer-active t)) -;; (foo)) +;; - Native-compile 'test.el' instrumenting it for sanitizer usage: +;; (let ((comp-sanitizer-emit t)) +;; (load (native-compile "test.el"))) + +;; - Run `foo' with the sanitizer active: +;; (let ((comp-sanitizer-active t)) +;; (foo)) (defvar comp-sanitizer-emit nil "Gates the sanitizer pass. commit e2fec514fd22e61c2a4e9343056aa744e93203a1 Author: Andrea Corallo Date: Wed Mar 20 14:49:28 2024 +0100 ; * lisp/emacs-lisp/comp.el: Add a simple sanitizer usage example. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index d7830597709..7e8d4e15e0a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3017,6 +3017,18 @@ These are substituted with a normal `set' op." ;; the variable tested by the conditional branch is of the predicted ;; value type and signal an error otherwise. +;;; Example: +;; Assuming we want to compile 'test.el' and test function `foo' defined +;; into it. + +;; Native compile 'test.el' instrumenting it for sanitizer usage. +;; (let ((comp-sanitizer-emit t)) +;; (load (native-compile "test.el"))) + +;; Run `foo' with the sanitizer active. +;; (let ((comp-sanitizer-active t)) +;; (foo)) + (defvar comp-sanitizer-emit nil "Gates the sanitizer pass. This is intended to be used only for development and verification of commit 1475e3c3b562f7604e538fccbb41f1d66b10663d Author: Eli Zaretskii Date: Wed Mar 20 14:27:25 2024 +0200 ; Fix doc strings of recent changes * src/comp.c (syms_of_comp) : * lisp/emacs-lisp/comp.el (comp-sanitizer-emit): Doc fixes. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6afb357bef2..d7830597709 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3019,7 +3019,8 @@ These are substituted with a normal `set' op." (defvar comp-sanitizer-emit nil "Gates the sanitizer pass. -In use for native compiler development and verification only.") +This is intended to be used only for development and verification of +the native compiler.") (defun comp--sanitizer (_) (when comp-sanitizer-emit diff --git a/src/comp.c b/src/comp.c index 5e4ca643072..99f51e07048 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5931,10 +5931,11 @@ For internal use. */); Vcomp_subr_arities_h = CALLN (Fmake_hash_table, QCtest, Qequal); DEFVAR_BOOL ("comp-sanitizer-active", comp_sanitizer_active, - doc: /* When non-nil enable sanitizer runtime execution. -To be effective Lisp Code must have been compiled with -`comp-sanitizer-emit' non-nil. -In use for native compiler development and verification only. */); + doc: /* If non-nil, enable runtime execution of native-compiler sanitizer. +For this to be effective, Lisp code must be compiled +with `comp-sanitizer-emit' non-nil. +This is intended to be used only for development and +verification of the native compiler. */); comp_sanitizer_active = false; Fprovide (intern_c_string ("native-compile"), Qnil); commit e8d2bc75314262d512d367c270c6d43201ef533f Author: Andrea Corallo Date: Wed Mar 20 11:49:32 2024 +0100 ; * lisp/emacs-lisp/comp-cstr.el (comp--normalize-typeset0): Fix comment. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 70456a70de1..cbfb9540f03 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -288,13 +288,10 @@ Return them as multiple value." (apply #'append (mapcar #'comp--direct-supertypes typeset))) for subs = (comp--direct-subtypes sup) - when (and (length> subs 1) ;;FIXME: Why? - ;; Every subtype of `sup` is a subtype of - ;; some element of `typeset`? - ;; It's tempting to just check (member x typeset), - ;; but think of the typeset (marker number), - ;; where `sup' is `integer-or-marker' and `sub' - ;; is `integer'. + when (and (length> subs 1) ;; If there's only one sub do + ;; nothing as we want to + ;; return the most specific + ;; type. (cl-every (lambda (sub) (cl-some (lambda (type) (comp-subtype-p sub type)) commit 0b0c7da8c80a1e4dc328459f3403f358736ae90d Author: Andrea Corallo Date: Wed Feb 21 22:31:45 2024 +0100 Add native compiler sanitizer * src/comp.c (ABI_VERSION): Bump new version. (CALL0I): Uncomment. (helper_link_table, declare_runtime_imported_funcs): Add 'helper_sanitizer_assert'. (Fcomp__init_ctxt): Register emitter for 'helper_sanitizer_assert'. (helper_sanitizer_assert): New function. (syms_of_comp): 'helper_sanitizer_assert' defsym. (syms_of_comp): 'comp-sanitizer-error' define error. (syms_of_comp): 'comp-sanitizer-active' defvar. * lisp/emacs-lisp/comp.el (comp-passes): Add 'comp--sanitizer'. (comp-sanitizer-emit): Define var. (comp--sanitizer): Define function. * lisp/emacs-lisp/comp-run.el (comp-run-async-workers): Forward 'comp-sanitizer-emit'. diff --git a/lisp/emacs-lisp/comp-run.el b/lisp/emacs-lisp/comp-run.el index afb46e3cd19..480f048777c 100644 --- a/lisp/emacs-lisp/comp-run.el +++ b/lisp/emacs-lisp/comp-run.el @@ -256,6 +256,7 @@ display a message." load-path backtrace-line-length byte-compile-warnings + comp-sanitizer-emit ;; package-load-list ;; package-user-dir ;; package-directory-list diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9c2182092cb..6afb357bef2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -165,6 +165,7 @@ Can be one of: `d-default', `d-impure' or `d-ephemeral'. See `comp-ctxt'.") comp--tco comp--fwprop comp--remove-type-hints + comp--sanitizer comp--compute-function-types comp--final) "Passes to be executed in order.") @@ -3006,6 +3007,51 @@ These are substituted with a normal `set' op." (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) + +;;; Sanitizer pass specific code. + +;; This pass aims to verify compile time value type predictions during +;; execution. +;; The sanitizer pass injects a call to 'helper_sanitizer_assert' before +;; each conditional branch. 'helper_sanitizer_assert' will verify that +;; the variable tested by the conditional branch is of the predicted +;; value type and signal an error otherwise. + +(defvar comp-sanitizer-emit nil + "Gates the sanitizer pass. +In use for native compiler development and verification only.") + +(defun comp--sanitizer (_) + (when comp-sanitizer-emit + (cl-loop + for f being each hash-value of (comp-ctxt-funcs-h comp-ctxt) + for comp-func = f + unless (comp-func-has-non-local comp-func) + do + (cl-loop + for b being each hash-value of (comp-func-blocks f) + do + (cl-loop + named in-the-basic-block + for insns-seq on (comp-block-insns b) + do (pcase insns-seq + (`((cond-jump ,(and (pred comp-mvar-p) mvar-tested) + ,(pred comp-mvar-p) ,_bb1 ,_bb2)) + (let ((type (comp-cstr-to-type-spec mvar-tested)) + (insn (car insns-seq))) + ;; No need to check if type is t. + (unless (eq type t) + (comp--add-const-to-relocs type) + (setcar + insns-seq + (comp--call 'helper_sanitizer_assert + mvar-tested + (make--comp-mvar :constant type))) + (setcdr insns-seq (list insn))) + ;; (setf (comp-func-ssa-status comp-func) 'dirty) + (cl-return-from in-the-basic-block)))))) + do (comp--log-func comp-func 3)))) + ;;; Function types pass specific code. diff --git a/src/comp.c b/src/comp.c index 76cf1f3ab6e..5e4ca643072 100644 --- a/src/comp.c +++ b/src/comp.c @@ -469,7 +469,7 @@ load_gccjit_if_necessary (bool mandatory) /* Increase this number to force a new Vcomp_abi_hash to be generated. */ -#define ABI_VERSION "5" +#define ABI_VERSION "6" /* Length of the hashes used for eln file naming. */ #define HASH_LENGTH 8 @@ -502,11 +502,9 @@ load_gccjit_if_necessary (bool mandatory) #define THIRD(x) \ XCAR (XCDR (XCDR (x))) -#if 0 /* unused for now */ /* Like call0 but stringify and intern. */ #define CALL0I(fun) \ CALLN (Ffuncall, intern_c_string (STR (fun))) -#endif /* Like call1 but stringify and intern. */ #define CALL1I(fun, arg) \ @@ -702,6 +700,8 @@ static void helper_save_restriction (void); static bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object, enum pvec_type); static struct Lisp_Symbol_With_Pos * helper_GET_SYMBOL_WITH_POSITION (Lisp_Object); +static Lisp_Object +helper_sanitizer_assert (Lisp_Object, Lisp_Object); /* Note: helper_link_table must match the list created by `declare_runtime_imported_funcs'. */ @@ -714,6 +714,7 @@ static void *helper_link_table[] = helper_unbind_n, helper_save_restriction, helper_GET_SYMBOL_WITH_POSITION, + helper_sanitizer_assert, record_unwind_current_buffer, set_internal, helper_unwind_protect, @@ -2975,6 +2976,10 @@ declare_runtime_imported_funcs (void) ADD_IMPORTED (helper_GET_SYMBOL_WITH_POSITION, comp.lisp_symbol_with_position_ptr_type, 1, args); + args[0] = comp.lisp_obj_type; + args[1] = comp.lisp_obj_type; + ADD_IMPORTED (helper_sanitizer_assert, comp.lisp_obj_type, 2, args); + ADD_IMPORTED (record_unwind_current_buffer, comp.void_type, 0, NULL); args[0] = args[1] = args[2] = comp.lisp_obj_type; @@ -4619,6 +4624,8 @@ Return t on success. */) emit_simple_limple_call_void_ret); register_emitter (Qhelper_save_restriction, emit_simple_limple_call_void_ret); + register_emitter (Qhelper_sanitizer_assert, + emit_simple_limple_call_lisp_ret); /* Inliners. */ register_emitter (Qadd1, emit_add1); register_emitter (Qsub1, emit_sub1); @@ -5082,6 +5089,21 @@ helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a) return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos); } +static Lisp_Object +helper_sanitizer_assert (Lisp_Object val, Lisp_Object type) +{ + if (!comp_sanitizer_active + || !NILP ((CALL2I (cl-typep, val, type)))) + return Qnil; + + AUTO_STRING (format, "Comp sanitizer FAIL for %s with type %s"); + CALLN (Fmessage, format, val, type); + CALL0I (backtrace); + xsignal2 (Qcomp_sanitizer_error, val, type); + + return Qnil; +} + /* `native-comp-eln-load-path' clean-up support code. */ @@ -5709,6 +5731,7 @@ natively-compiled one. */); DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); DEFSYM (Qhelper_save_restriction, "helper_save_restriction"); + DEFSYM (Qhelper_sanitizer_assert, "helper_sanitizer_assert"); /* Inliners. */ DEFSYM (Qadd1, "1+"); DEFSYM (Qsub1, "1-"); @@ -5779,6 +5802,12 @@ natively-compiled one. */); build_pure_c_string ("eln file inconsistent with current runtime " "configuration, please recompile")); + DEFSYM (Qcomp_sanitizer_error, "comp-sanitizer-error"); + Fput (Qcomp_sanitizer_error, Qerror_conditions, + pure_list (Qcomp_sanitizer_error, Qerror)); + Fput (Qcomp_sanitizer_error, Qerror_message, + build_pure_c_string ("Native code sanitizer runtime error")); + DEFSYM (Qnative__compile_async, "native--compile-async"); defsubr (&Scomp__subr_signature); @@ -5901,6 +5930,13 @@ subr-name -> arity For internal use. */); Vcomp_subr_arities_h = CALLN (Fmake_hash_table, QCtest, Qequal); + DEFVAR_BOOL ("comp-sanitizer-active", comp_sanitizer_active, + doc: /* When non-nil enable sanitizer runtime execution. +To be effective Lisp Code must have been compiled with +`comp-sanitizer-emit' non-nil. +In use for native compiler development and verification only. */); + comp_sanitizer_active = false; + Fprovide (intern_c_string ("native-compile"), Qnil); #endif /* #ifdef HAVE_NATIVE_COMP */ commit e72f17e4622fae45c9814f6ed196e5a9ed06cdd2 Author: Po Lu Date: Wed Mar 20 10:23:42 2024 +0800 Respect file display names during Android drag-and-drop * java/org/gnu/emacs/EmacsService.java (buildContentName): Remove redundant projection argument to resolver.query. * java/org/gnu/emacs/EmacsWindow.java (onDragEvent): If a content resolver is available, attempt to convert content URIs into file names in advance. * lisp/term/android-win.el (android-handle-dnd-event): Adjust correspondingly. diff --git a/java/org/gnu/emacs/EmacsService.java b/java/org/gnu/emacs/EmacsService.java index 19aa3dee456..785163c713c 100644 --- a/java/org/gnu/emacs/EmacsService.java +++ b/java/org/gnu/emacs/EmacsService.java @@ -1072,7 +1072,6 @@ If a display name can be requested from URI (using the resolver { StringBuilder builder; String displayName; - String[] projection; Cursor cursor; int column; @@ -1081,8 +1080,7 @@ If a display name can be requested from URI (using the resolver try { - projection = new String[] { OpenableColumns.DISPLAY_NAME, }; - cursor = resolver.query (uri, projection, null, null, null); + cursor = resolver.query (uri, null, null, null, null); if (cursor != null) { diff --git a/java/org/gnu/emacs/EmacsWindow.java b/java/org/gnu/emacs/EmacsWindow.java index 6e8bdaf7401..93a512cc7ef 100644 --- a/java/org/gnu/emacs/EmacsWindow.java +++ b/java/org/gnu/emacs/EmacsWindow.java @@ -31,6 +31,7 @@ import android.content.ClipData; import android.content.ClipDescription; +import android.content.ContentResolver; import android.content.Context; import android.graphics.Rect; @@ -1699,10 +1700,11 @@ else if (EmacsWindow.this.isMapped) ClipData data; ClipDescription description; int i, j, x, y, itemCount; - String type; + String type, uriString; Uri uri; EmacsActivity activity; StringBuilder builder; + ContentResolver resolver; x = (int) event.getX (); y = (int) event.getY (); @@ -1799,6 +1801,20 @@ else if (type.equals (ClipDescription.MIMETYPE_TEXT_URILIST)) { if ((activity.requestDragAndDropPermissions (event) == null)) uri = null; + else + { + resolver = activity.getContentResolver (); + + /* Substitute a content file name for the URI, if + possible. */ + uriString = EmacsService.buildContentName (uri, resolver); + + if (uriString != null) + { + builder.append (uriString).append ("\n"); + continue; + } + } } if (uri != null) diff --git a/lisp/term/android-win.el b/lisp/term/android-win.el index 1d10402b15d..8d262e5da98 100644 --- a/lisp/term/android-win.el +++ b/lisp/term/android-win.el @@ -282,11 +282,12 @@ If it reflects the motion of an item above a frame, call `dnd-handle-movement' to move the cursor or scroll the window under the item pursuant to the pertinent user options. -If it reflects dropped text, insert such text within window at -the location of the drop. +If it holds dropped text, insert such text within window at the +location of the drop. -If it reflects a list of URIs, then open each URI, converting -content:// URIs into the special file names which represent them." +If it holds a list of URIs, or file names, then open each URI or +file name, converting content:// URIs into the special file +names which represent them." (interactive "e") (let ((message (caddr event)) (posn (event-start event))) @@ -304,18 +305,22 @@ content:// URIs into the special file names which represent them." (new-uri-list nil) (dnd-unescape-file-uris t)) (dolist (uri uri-list) - (ignore-errors - (let ((url (url-generic-parse-url uri))) - (when (equal (url-type url) "content") - ;; Replace URI with a matching /content file - ;; name. - (setq uri (format "file:/content/by-authority/%s%s" - (url-host url) - (url-filename url)) - ;; And guarantee that this file URI is not - ;; subject to URI decoding, for it must be - ;; transformed back into a content URI. - dnd-unescape-file-uris nil)))) + ;; If the URI is a preprepared file name, insert it directly. + (if (string-match-p "^/content/by-authority\\(-named\\)?/" uri) + (setq uri (concat "file:" uri) + dnd-unescape-file-uris nil) + (ignore-errors + (let ((url (url-generic-parse-url uri))) + (when (equal (url-type url) "content") + ;; Replace URI with a matching /content file + ;; name. + (setq uri (format "file:/content/by-authority/%s%s" + (url-host url) + (url-filename url)) + ;; And guarantee that this file URI is not + ;; subject to URI decoding, for it must be + ;; transformed back into a content URI. + dnd-unescape-file-uris nil))))) (push uri new-uri-list)) (dnd-handle-multiple-urls (posn-window posn) new-uri-list commit 014cd0040275bb2a4d08d392825b4814452275db Author: Kévin Le Gouguec Date: Mon Mar 18 19:47:59 2024 +0100 Fix vc-git test when no identities are configured Reported by john muhl . * test/lisp/vc/vc-git-tests.el (vc-git-test--with-repo): Set some environment variables (lifted from vc-tests.el) to let 'git commit' compute dummy author and committer identities. diff --git a/test/lisp/vc/vc-git-tests.el b/test/lisp/vc/vc-git-tests.el index fd3e8ccd602..bbf0c4277dd 100644 --- a/test/lisp/vc/vc-git-tests.el +++ b/test/lisp/vc/vc-git-tests.el @@ -88,10 +88,17 @@ The current directory will be set to the top of that repository; NAME will be bound to that directory's file name. Once BODY exits, the -directory will be deleted." +directory will be deleted. + +Some dummy environment variables will be set for the duration of BODY to +allow 'git commit' to determine identities for authors and committers." (declare (indent 1)) `(ert-with-temp-directory ,name - (let ((default-directory ,name)) + (let ((default-directory ,name) + (process-environment (append '("EMAIL=john@doe.ee" + "GIT_AUTHOR_NAME=A" + "GIT_COMMITTER_NAME=C") + process-environment))) (vc-create-repo 'Git) ,@body))) commit 88355de6022458c3e890cc6d5da60d6f35fe8868 Author: Eli Zaretskii Date: Tue Mar 19 14:45:45 2024 +0200 Unbreak the Cygw32 build broken by resent WTS_SESSION changes * src/w32xfns.c (WTS_VIRTUAL_CLASS): * src/w32fns.c (WTS_VIRTUAL_CLASS, WM_WTSSESSION_CHANGE) (WTS_SESSION_LOCK): Define only for WINDOWSNT. * src/w32xfns.c (drain_message_queue): Call 'reset_w32_kbdhook_state' only for WINDOWSNT. (Bug#69888) diff --git a/src/w32fns.c b/src/w32fns.c index 7d288ce7bd5..ace8d1016a5 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -305,10 +305,12 @@ static unsigned int sound_type = 0xFFFFFFFF; /* Special virtual key code for indicating "any" key. */ #define VK_ANY 0xFF -#ifndef WM_WTSSESSION_CHANGE +#ifdef WINDOWSNT +# ifndef WM_WTSSESSION_CHANGE /* 32-bit MinGW does not define these constants. */ -# define WM_WTSSESSION_CHANGE 0x02B1 -# define WTS_SESSION_LOCK 0x7 +# define WM_WTSSESSION_CHANGE 0x02B1 +# define WTS_SESSION_LOCK 0x7 +# endif #endif #ifndef WS_EX_NOACTIVATE diff --git a/src/w32xfns.c b/src/w32xfns.c index 853c8368118..b248697e658 100644 --- a/src/w32xfns.c +++ b/src/w32xfns.c @@ -22,9 +22,11 @@ along with GNU Emacs. If not, see . */ #include #include #include + +#ifdef WINDOWSNT /* Override API version to get the required functionality. */ -#undef _WIN32_WINNT -#define _WIN32_WINNT 0x0501 +# undef _WIN32_WINNT +# define _WIN32_WINNT 0x0501 /* mingw.org's MinGW headers mistakenly omit this enumeration: */ # ifndef MINGW_W64 typedef enum _WTS_VIRTUAL_CLASS { @@ -33,6 +35,7 @@ typedef enum _WTS_VIRTUAL_CLASS { } WTS_VIRTUAL_CLASS; # endif #include /* for WM_WTSSESSION_CHANGE, WTS_SESSION_LOCK */ +#endif /* WINDOWSNT */ #include "lisp.h" #include "frame.h" @@ -426,10 +429,12 @@ drain_message_queue (void) { switch (msg.message) { +#ifdef WINDOWSNT case WM_WTSSESSION_CHANGE: if (msg.wParam == WTS_SESSION_LOCK) reset_w32_kbdhook_state (); break; +#endif case WM_EMACS_FILENOTIFY: retval = 1; break; commit f7f619779c93bb567a1658ef06199fc1816f88fb Author: Andrea Corallo Date: Tue Mar 19 10:48:18 2024 +0100 * test/lisp/emacs-lisp/comp-cstr-tests.el (comp-cstr-test-93): Add test. diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 991ab1f40eb..b823a190d5a 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -232,9 +232,8 @@ The arg is an alist of: type specifier -> expected type specifier." ;; 92 ((or string char-table bool-vector vector cons symbol number) . (or number sequence symbol)) - ;; 93? - ;; FIXME: I get `cons' rather than `list'? - ;;((or null cons) . list) + ;; 93 + ((or list (not null)) . t) )) ;;; comp-cstr-tests.el ends here commit 0f76baeac074a3d8f15b29b34b873b44d551979b Author: Andrea Corallo Date: Tue Mar 19 10:41:52 2024 +0100 * Use 'cl-type-of' in comp-cstr.el * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-homogeneous-no-range) (comp-cstr-union-1-no-mem, comp-cstr-intersection-no-hashcons): Make use of 'cl-type-of' in place of 'type-of'. diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 5922a8caf12..70456a70de1 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -575,7 +575,7 @@ All SRCS constraints must be homogeneously negated or non-negated." ;; We propagate only values those types are not already ;; into typeset. when (cl-notany (lambda (x) - (comp-subtype-p (type-of v) x)) + (comp-subtype-p (cl-type-of v) x)) (comp-cstr-typeset dst)) collect v))) @@ -664,7 +664,7 @@ DST is returned." ;; Verify disjoint condition between positive types and ;; negative types coming from values, in case give-up. - (let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) + (let ((neg-value-types (nconc (mapcar #'cl-type-of (valset neg)) (when (range neg) '(integer))))) (when (cl-some (lambda (x) @@ -685,7 +685,7 @@ DST is returned." ((cl-some (lambda (x) (cl-some (lambda (y) (comp-subtype-p y x)) - (mapcar #'type-of (valset pos)))) + (mapcar #'cl-type-of (valset pos)))) (typeset neg)) (give-up)) (t @@ -1108,7 +1108,7 @@ DST is returned." (cl-loop for v in (valset dst) unless (symbolp v) do (push v strip-values) - (push (type-of v) strip-types)) + (push (cl-type-of v) strip-types)) (when strip-values (setf (typeset dst) (comp-union-typesets (typeset dst) strip-types) (valset dst) (cl-set-difference (valset dst) strip-values))) commit a7cb220523d881449a2dba683e7358b3312fd482 Author: Po Lu Date: Tue Mar 19 12:17:43 2024 +0800 Update android.texi * doc/emacs/android.texi (Android Startup): Describe /content/by-authority-named. diff --git a/doc/emacs/android.texi b/doc/emacs/android.texi index a45ec84f3f0..56bfa2591f6 100644 --- a/doc/emacs/android.texi +++ b/doc/emacs/android.texi @@ -143,11 +143,13 @@ that if that Emacs in turn does not start the Emacs server, subsequent attempts to open the file with the wrapper will fail. @cindex /content/by-authority directory, android +@cindex /content/by-authority-named directory, android Some files are given to Emacs as ``content identifiers'' that the system provides access to outside the normal filesystem APIs. Emacs -uses a pseudo-directory named @file{/content/by-authority} to access -those files. Do not make any assumptions about the contents of this -directory, or try to open files in it yourself. +uses pseudo-directories named @file{/content/by-authority} and +@file{/content/by-authority-named} to access those files. Do not make +any assumptions about the contents of this directory, or try to open +files in it yourself. This feature is not provided on Android 4.3 and earlier, in which case such files are copied to a temporary directory before being commit f2e239c6a7d54ec3849a3bb783685953b6683752 Author: Po Lu Date: Tue Mar 19 12:08:17 2024 +0800 Respect display names of Android content URIs * java/org/gnu/emacs/EmacsNative.java (displayNameHash): New function. * java/org/gnu/emacs/EmacsService.java (buildContentName): New argument RESOLVER. Generate names holding URI's display name if available. All callers changed. * lisp/international/mule-cmds.el (set-default-coding-systems): Fix file name coding system as utf-8-unix on Android as on Mac OS. * src/androidvfs.c (enum android_vnode_type): New enum ANDROID_VNODE_CONTENT_AUTHORITY_NAMED. (android_content_name): Register root directories for this new type. (displayNameHash): New function. (android_get_content_name): New argument WITH_CHECKSUM. If present, treat the final two components as a pair of checksum and display name, and verify and exclude the two. (android_authority_name): Provide new argument as appropriate. (android_authority_initial_name): New function. diff --git a/java/org/gnu/emacs/EmacsNative.java b/java/org/gnu/emacs/EmacsNative.java index 898eaef41a7..654e94b1a7d 100644 --- a/java/org/gnu/emacs/EmacsNative.java +++ b/java/org/gnu/emacs/EmacsNative.java @@ -281,7 +281,7 @@ public static native SurroundingText getSurroundingText (short window, public static native int[] getSelection (short window); - /* Graphics functions used as a replacement for potentially buggy + /* Graphics functions used as replacements for potentially buggy Android APIs. */ public static native void blitRect (Bitmap src, Bitmap dest, int x1, @@ -289,7 +289,6 @@ public static native void blitRect (Bitmap src, Bitmap dest, int x1, /* Increment the generation ID of the specified BITMAP, forcing its texture to be re-uploaded to the GPU. */ - public static native void notifyPixelsChanged (Bitmap bitmap); @@ -313,6 +312,13 @@ public static native void blitRect (Bitmap src, Bitmap dest, int x1, in the process. */ public static native boolean ftruncate (int fd); + + /* Functions that assist in generating content file names. */ + + /* Calculate an 8 digit checksum for the byte array DISPLAYNAME + suitable for inclusion in a content file name. */ + public static native String displayNameHash (byte[] displayName); + static { /* Older versions of Android cannot link correctly with shared diff --git a/java/org/gnu/emacs/EmacsOpenActivity.java b/java/org/gnu/emacs/EmacsOpenActivity.java index 9ae1bf353dd..2cdfa2ec776 100644 --- a/java/org/gnu/emacs/EmacsOpenActivity.java +++ b/java/org/gnu/emacs/EmacsOpenActivity.java @@ -252,7 +252,7 @@ private class EmacsClientThread extends Thread if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.KITKAT) { - content = EmacsService.buildContentName (uri); + content = EmacsService.buildContentName (uri, getContentResolver ()); return content; } @@ -423,6 +423,7 @@ private class EmacsClientThread extends Thread /* Obtain the intent that started Emacs. */ intent = getIntent (); action = intent.getAction (); + resolver = getContentResolver (); if (action == null) { @@ -536,7 +537,7 @@ private class EmacsClientThread extends Thread if ((scheme = uri.getScheme ()) != null && scheme.equals ("content")) { - tem1 = EmacsService.buildContentName (uri); + tem1 = EmacsService.buildContentName (uri, resolver); attachmentString = ("'(\"" + (tem1.replace ("\\", "\\\\") .replace ("\"", "\\\"") .replace ("$", "\\$")) @@ -568,7 +569,8 @@ private class EmacsClientThread extends Thread && (scheme = uri.getScheme ()) != null && scheme.equals ("content")) { - tem1 = EmacsService.buildContentName (uri); + tem1 + = EmacsService.buildContentName (uri, resolver); builder.append ("\""); builder.append (tem1.replace ("\\", "\\\\") .replace ("\"", "\\\"") @@ -609,7 +611,6 @@ private class EmacsClientThread extends Thread underlying file, but it cannot be found without opening the file and doing readlink on its file descriptor in /proc/self/fd. */ - resolver = getContentResolver (); fd = null; try diff --git a/java/org/gnu/emacs/EmacsService.java b/java/org/gnu/emacs/EmacsService.java index 9bc40d63311..19aa3dee456 100644 --- a/java/org/gnu/emacs/EmacsService.java +++ b/java/org/gnu/emacs/EmacsService.java @@ -79,6 +79,7 @@ import android.provider.DocumentsContract; import android.provider.DocumentsContract.Document; +import android.provider.OpenableColumns; import android.provider.Settings; import android.util.Log; @@ -1033,22 +1034,87 @@ invocation of app_process (through android-emacs) can return false; } + /* Return a 8 character checksum for the string STRING, after encoding + as UTF-8 data. */ + + public static String + getDisplayNameHash (String string) + { + byte[] encoded; + + try + { + encoded = string.getBytes ("UTF-8"); + return EmacsNative.displayNameHash (encoded); + } + catch (UnsupportedEncodingException exception) + { + /* This should be impossible. */ + return "error"; + } + } + /* Build a content file name for URI. Return a file name within the /contents/by-authority pseudo-directory that `android_get_content_name' can then transform back into an encoded URI. + If a display name can be requested from URI (using the resolver + RESOLVER), append it to this file name. + A content name consists of any number of unencoded path segments separated by `/' characters, possibly followed by a question mark and an encoded query string. */ public static String - buildContentName (Uri uri) + buildContentName (Uri uri, ContentResolver resolver) { StringBuilder builder; + String displayName; + String[] projection; + Cursor cursor; + int column; + + displayName = null; + cursor = null; - builder = new StringBuilder ("/content/by-authority/"); + try + { + projection = new String[] { OpenableColumns.DISPLAY_NAME, }; + cursor = resolver.query (uri, projection, null, null, null); + + if (cursor != null) + { + cursor.moveToFirst (); + column + = cursor.getColumnIndexOrThrow (OpenableColumns.DISPLAY_NAME); + displayName + = cursor.getString (column); + + /* Verify that the display name is valid, i.e. it + contains no characters unsuitable for a file name and + is nonempty. */ + if (displayName.isEmpty () || displayName.contains ("/")) + displayName = null; + } + } + catch (Exception e) + { + /* Ignored. */ + } + finally + { + if (cursor != null) + cursor.close (); + } + + /* If a display name is available, at this point it should be the + value of displayName. */ + + builder = new StringBuilder (displayName != null + ? "/content/by-authority-named/" + : "/content/by-authority/"); builder.append (uri.getAuthority ()); /* First, append each path segment. */ @@ -1065,6 +1131,16 @@ invocation of app_process (through android-emacs) can if (uri.getEncodedQuery () != null) builder.append ('?').append (uri.getEncodedQuery ()); + /* Append the display name. */ + + if (displayName != null) + { + builder.append ('/'); + builder.append (getDisplayNameHash (displayName)); + builder.append ('/'); + builder.append (displayName); + } + return builder.toString (); } diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 6b4c83112e3..e80c42f523a 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -350,9 +350,10 @@ This also sets the following values: if CODING-SYSTEM is ASCII-compatible" (check-coding-system coding-system) (setq-default buffer-file-coding-system coding-system) - - (if (eq system-type 'darwin) - ;; The file-name coding system on Darwin systems is always utf-8. + (if (or (eq system-type 'darwin) + (eq system-type 'android)) + ;; The file-name coding system on Darwin and Android systems is + ;; always UTF-8. (setq default-file-name-coding-system 'utf-8-unix) (if (and (or (not coding-system) (coding-system-get coding-system 'ascii-compatible-p))) diff --git a/src/androidvfs.c b/src/androidvfs.c index 4bb652f3eb7..9e3d5cab8cf 100644 --- a/src/androidvfs.c +++ b/src/androidvfs.c @@ -33,6 +33,7 @@ along with GNU Emacs. If not, see . */ #include #include +#include #include @@ -255,6 +256,7 @@ enum android_vnode_type ANDROID_VNODE_AFS, ANDROID_VNODE_CONTENT, ANDROID_VNODE_CONTENT_AUTHORITY, + ANDROID_VNODE_CONTENT_AUTHORITY_NAMED, ANDROID_VNODE_SAF_ROOT, ANDROID_VNODE_SAF_TREE, ANDROID_VNODE_SAF_FILE, @@ -2435,6 +2437,7 @@ struct android_content_vdir }; static struct android_vnode *android_authority_initial (char *, size_t); +static struct android_vnode *android_authority_initial_name (char *, size_t); static struct android_vnode *android_saf_root_initial (char *, size_t); /* Content provider meta-interface. This implements a vnode at @@ -2445,9 +2448,9 @@ static struct android_vnode *android_saf_root_initial (char *, size_t); a list of each directory tree Emacs has been granted permanent access to through the Storage Access Framework. - /content/by-authority exists on Android 4.4 and later; it contains - no directories, but provides a `name' function that converts - children into content URIs. */ + /content/by-authority and /content/by-authority-named exists on + Android 4.4 and later; it contains no directories, but provides a + `name' function that converts children into content URIs. */ static struct android_vnode *android_content_name (struct android_vnode *, char *, size_t); @@ -2490,7 +2493,7 @@ static struct android_vops content_vfs_ops = static const char *content_directory_contents[] = { - "storage", "by-authority", + "storage", "by-authority", "by-authority-named", }; /* Chain consisting of all open content directory streams. */ @@ -2508,8 +2511,9 @@ android_content_name (struct android_vnode *vnode, char *name, int api; static struct android_special_vnode content_vnodes[] = { - { "storage", 7, android_saf_root_initial, }, - { "by-authority", 12, android_authority_initial, }, + { "storage", 7, android_saf_root_initial, }, + { "by-authority", 12, android_authority_initial, }, + { "by-authority-named", 18, android_authority_initial_name, }, }; /* Canonicalize NAME. */ @@ -2551,7 +2555,7 @@ android_content_name (struct android_vnode *vnode, char *name, call its root lookup function with the rest of NAME there. */ if (api < 19) - i = 2; + i = 3; else if (api < 21) i = 1; else @@ -2855,18 +2859,59 @@ android_content_initial (char *name, size_t length) +#ifdef __clang__ +#pragma clang diagnostic push +#pragma clang diagnostic ignored "-Wmissing-prototypes" +#else /* GNUC */ +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wmissing-prototypes" +#endif /* __clang__ */ + /* Content URI management functions. */ +JNIEXPORT jstring JNICALL +NATIVE_NAME (displayNameHash) (JNIEnv *env, jobject object, + jbyteArray display_name) +{ + char checksum[9], block[MD5_DIGEST_SIZE]; + jbyte *data; + + data = (*env)->GetByteArrayElements (env, display_name, NULL); + if (!data) + return NULL; + + /* Hash the buffer. */ + md5_buffer ((char *) data, (*env)->GetArrayLength (env, display_name), + block); + (*env)->ReleaseByteArrayElements (env, display_name, data, JNI_ABORT); + + /* Generate the digest string. */ + hexbuf_digest (checksum, (char *) block, 4); + checksum[8] = '\0'; + return (*env)->NewStringUTF (env, checksum); +} + +#ifdef __clang__ +#pragma clang diagnostic pop +#else /* GNUC */ +#pragma GCC diagnostic pop +#endif /* __clang__ */ + /* Return the content URI corresponding to a `/content/by-authority' file name, or NULL if it is invalid for some reason. FILENAME should be relative to /content/by-authority, with no leading - directory separator character. */ + directory separator character. + + WITH_CHECKSUM should be true if FILENAME contains a display name and + a checksum for that display name. */ static char * -android_get_content_name (const char *filename) +android_get_content_name (const char *filename, bool with_checksum) { char *fill, *buffer; size_t length; + char checksum[9], new_checksum[9], block[MD5_DIGEST_SIZE]; + const char *p2, *p1; /* Make sure FILENAME isn't obviously invalid: it must contain an authority name and a file name component. */ @@ -2888,11 +2933,55 @@ android_get_content_name (const char *filename) return NULL; } + if (!with_checksum) + goto no_checksum; + + /* Content file names hold two components providing a display name and + a short checksum that protects against files being opened under + display names besides those provided in the content file name at + the time of generation. */ + + p1 = strrchr (filename, '/'); /* Display name. */ + p2 = memrchr (filename, '/', p1 - filename); /* Start of checksum. */ + + /* If the name be excessively short or the checksum of an invalid + length, return. */ + if (!p2 || (p1 - p2) != 9) + { + errno = ENOENT; + return NULL; + } + + /* Copy the checksum into CHECKSUM. */ + memcpy (checksum, p2 + 1, 8); + new_checksum[8] = checksum[8] = '\0'; + + /* Hash this string and store 8 bytes of the resulting digest into + new_checksum. */ + md5_buffer (p1 + 1, strlen (p1 + 1), block); + hexbuf_digest (new_checksum, (char *) block, 4); + + /* Compare both checksums. */ + if (strcmp (new_checksum, checksum)) + { + errno = ENOENT; + return NULL; + } + + /* Remove the checksum and file display name from the URI. */ + length = p2 - filename; + + no_checksum: + if (length > INT_MAX) + { + errno = ENOMEM; + return NULL; + } + /* Prefix FILENAME with content:// and return the buffer containing that URI. */ - - buffer = xmalloc (sizeof "content://" + length); - sprintf (buffer, "content://%s", filename); + buffer = xmalloc (sizeof "content://" + length + 1); + sprintf (buffer, "content://%.*s", (int) length, filename); return buffer; } @@ -2932,7 +3021,7 @@ android_check_content_access (const char *uri, int mode) /* Content authority-based vnode implementation. - /contents/by-authority is a simple vnode implementation that converts + /content/by-authority is a simple vnode implementation that converts components to content:// URIs. It does not canonicalize file names by removing parent directory @@ -3039,7 +3128,14 @@ android_authority_name (struct android_vnode *vnode, char *name, if (android_verify_jni_string (name)) goto no_entry; - uri_name = android_get_content_name (name); + if (vp->vnode.type == ANDROID_VNODE_CONTENT_AUTHORITY_NAMED) + /* This indicates that the two trailing components of NAME + provide a checksum and a file display name, to be verified, + then excluded from the content URI. */ + uri_name = android_get_content_name (name, true); + else + uri_name = android_get_content_name (name, false); + if (!uri_name) goto error; @@ -3333,6 +3429,32 @@ android_authority_initial (char *name, size_t length) return android_authority_name (&temp.vnode, name, length); } +/* Find the vnode designated by NAME relative to the root of the + by-authority-named directory. + + If NAME is empty or a single leading separator character, return + a vnode representing the by-authority directory itself. + + Otherwise, represent the remainder of NAME as a URI (without + normalizing it) and return a vnode corresponding to that. + + Value may also be NULL with errno set if the designated vnode is + not available, such as when Android windowing has not been + initialized. */ + +static struct android_vnode * +android_authority_initial_name (char *name, size_t length) +{ + struct android_authority_vnode temp; + + temp.vnode.ops = &authority_vfs_ops; + temp.vnode.type = ANDROID_VNODE_CONTENT_AUTHORITY_NAMED; + temp.vnode.flags = 0; + temp.uri = NULL; + + return android_authority_name (&temp.vnode, name, length); +} + /* SAF ``root'' vnode implementation. commit ce29ae32d0b05cedbc9ba65c1a347ab7c34420ad Author: Eli Zaretskii Date: Mon Mar 18 15:59:54 2024 +0200 ; * lisp/vc/vc-git.el (vc-git--out-str): Doc fix. diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index cbb5618ffce..a1e49b50510 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -1781,7 +1781,7 @@ With prefix numeric argument ARG, do it that many times." (interactive) (save-excursion (goto-char (pos-bol)) - (when-let* ((re (rx bol "(" (group (+ (not (in " ")))))) + (when-let* ((re (rx bol "(" (group (+ (not (in " )")))))) (string (and (or (looking-at re) (re-search-backward re nil t)) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 0d54e234659..b23a5ca95a1 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -2240,7 +2240,7 @@ Return whether the process exited with status zero." (zerop (apply #'vc-git--call '(t nil) command args))) (defun vc-git--out-str (command &rest args) - "Run `git COMMAND ARGS...' and return standard output. + "Run `git COMMAND ARGS...' and return standard output as a string. The exit status is ignored." (with-output-to-string (with-current-buffer standard-output commit 70ac815ece299007ff468c09632ef4d488e69be3 Author: Stefan Monnier Date: Mon Mar 18 09:38:23 2024 -0400 * lisp/emacs-lisp/cl-preloaded.el (user-ptr): Add predicate diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index cba56e0bbd4..f7757eae9c0 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -328,7 +328,9 @@ (:predicate (setq predicate val)) (_ (error "Unknown keyword arg: %S" kw))))) `(progn - ,(if predicate `(put ',name 'cl-deftype-satisfies #',predicate)) + ,(if predicate `(put ',name 'cl-deftype-satisfies #',predicate) + ;; (message "Missing predicate for: %S" name) + nil) (put ',name 'cl--class (built-in-class--make ',name ,docstring (mapcar (lambda (type) @@ -352,7 +354,8 @@ (cl--define-built-in-type tree-sitter-compiled-query atom) (cl--define-built-in-type tree-sitter-node atom) (cl--define-built-in-type tree-sitter-parser atom) -(cl--define-built-in-type user-ptr atom) +(cl--define-built-in-type user-ptr atom + nil :predicate user-ptrp) ;; FIXME: Shouldn't it be called `user-ptr-p'? (cl--define-built-in-type font-object atom) (cl--define-built-in-type font-entity atom) (cl--define-built-in-type font-spec atom) commit be08372bf9b7ebe244ba6940f3e78fc754910d86 Merge: 1a8b34a503e 63e67916b01 Author: Stefan Monnier Date: Mon Mar 18 09:35:11 2024 -0400 Merge branch 'cl-type-of' (bug#69739) commit 63e67916b01569da5bb24f6d9a354dc72897c468 Author: Stefan Monnier Date: Thu Mar 14 12:49:08 2024 -0400 Followup changes to `cl-type-of` These changes came up while working on `cl-type-of` but are not directly related to the new `cl-type-of`. The BASE_PURESIZE bump was needed at some point on one of my machine, not sure why. * src/puresize.h (BASE_PURESIZE): Bump up. * src/sqlite.c (bind_value): Don't use `Ftype_of`. * lisp/emacs-lisp/seq.el (seq-remove-at-position): Simplify. * lisp/emacs-lisp/cl-preloaded.el (finalizer): New (previously missing) type. * doc/lispref/objects.texi (Type Predicates): Minor tweaks. diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi index 1e448b64296..aa1e073042f 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -1485,8 +1485,8 @@ types that are not built into Emacs. @subsection Type Descriptors A @dfn{type descriptor} is a @code{record} which holds information -about a type. Slot 1 in the record must be a symbol naming the type, and -@code{type-of} relies on this to return the type of @code{record} +about a type. The first slot in the record must be a symbol naming the type, +and @code{type-of} relies on this to return the type of @code{record} objects. No other type descriptor slot is used by Emacs; they are free for use by Lisp extensions. @@ -2175,7 +2175,7 @@ with references to further information. function @code{type-of}. Recall that each object belongs to one and only one primitive type; @code{type-of} tells you which one (@pxref{Lisp Data Types}). But @code{type-of} knows nothing about non-primitive -types. In most cases, it is more convenient to use type predicates than +types. In most cases, it is preferable to use type predicates than @code{type-of}. @defun type-of object diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index d11c97a3e3a..cba56e0bbd4 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -365,6 +365,7 @@ (cl--define-built-in-type buffer atom) (cl--define-built-in-type window atom) (cl--define-built-in-type process atom) +(cl--define-built-in-type finalizer atom) (cl--define-built-in-type window-configuration atom) (cl--define-built-in-type overlay atom) (cl--define-built-in-type number-or-marker atom diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 20077db9e60..a20cff16982 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -362,8 +362,7 @@ the result. The result is a sequence of the same type as SEQUENCE." (seq-concatenate - (let ((type (type-of sequence))) - (if (eq type 'cons) 'list type)) + (if (listp sequence) 'list (type-of sequence)) (seq-subseq sequence 0 n) (seq-subseq sequence (1+ n)))) diff --git a/src/lisp.h b/src/lisp.h index f353e4956eb..f86758c88fb 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -569,10 +569,8 @@ enum Lisp_Fwd_Type your object -- this way, the same object could be used to represent several disparate C structures. - In addition, you need to add switch branches in data.c for Ftype_of. - - You also need to add the new type to the constant - `cl--typeof-types' in lisp/emacs-lisp/cl-preloaded.el. */ + In addition, you need to add switch branches in data.c for Fcl_type_of + and `cl--define-builtin-type` in lisp/emacs-lisp/cl-preloaded.el. */ /* A Lisp_Object is a tagged pointer or integer. Ordinarily it is a diff --git a/src/puresize.h b/src/puresize.h index ac5d2da30dc..2a716872832 100644 --- a/src/puresize.h +++ b/src/puresize.h @@ -47,7 +47,7 @@ INLINE_HEADER_BEGIN #endif #ifndef BASE_PURESIZE -#define BASE_PURESIZE (2750000 + SYSTEM_PURESIZE_EXTRA + SITELOAD_PURESIZE_EXTRA) +#define BASE_PURESIZE (3000000 + SYSTEM_PURESIZE_EXTRA + SITELOAD_PURESIZE_EXTRA) #endif /* Increase BASE_PURESIZE by a ratio depending on the machine's word size. */ diff --git a/src/sqlite.c b/src/sqlite.c index 7a018b28aa4..261080da673 100644 --- a/src/sqlite.c +++ b/src/sqlite.c @@ -349,9 +349,7 @@ bind_values (sqlite3 *db, sqlite3_stmt *stmt, Lisp_Object values) value = XCAR (values); values = XCDR (values); } - Lisp_Object type = Ftype_of (value); - - if (EQ (type, Qstring)) + if (STRINGP (value)) { Lisp_Object encoded; bool blob = false; @@ -385,14 +383,11 @@ bind_values (sqlite3 *db, sqlite3_stmt *stmt, Lisp_Object values) SSDATA (encoded), SBYTES (encoded), NULL); } - else if (EQ (type, Qinteger)) - { - if (BIGNUMP (value)) - ret = sqlite3_bind_int64 (stmt, i + 1, bignum_to_intmax (value)); - else - ret = sqlite3_bind_int64 (stmt, i + 1, XFIXNUM (value)); - } - else if (EQ (type, Qfloat)) + else if (FIXNUMP (value)) + ret = sqlite3_bind_int64 (stmt, i + 1, XFIXNUM (value)); + else if (BIGNUMP (value)) + ret = sqlite3_bind_int64 (stmt, i + 1, bignum_to_intmax (value)); + else if (FLOATP (value)) ret = sqlite3_bind_double (stmt, i + 1, XFLOAT_DATA (value)); else if (NILP (value)) ret = sqlite3_bind_null (stmt, i + 1); commit e624bc62752ceb2e60940c5fd9cb6e70611df71c Author: Stefan Monnier Date: Sun Mar 17 17:29:02 2024 -0400 (primitive-function): New type The type hierarchy and `cl-type-of` code assumed that `subr-primitive` only applies to functions, but since it also accepts special-forms it makes it an unsuitable choice since it can't be a subtype of `compiled-function`. So, use a new type `primitive-function` instead. * lisp/subr.el (subr-primitive-p): Fix docstring (bug#69832). (primitive-function-p): New function. * lisp/emacs-lisp/cl-preloaded.el (primitive-function): Rename from `subr-primitive` since `subr-primitive-p` means something else. * src/data.c (Fcl_type_of): Return `primitive-function` instead of `subr-primitive` for C functions. (syms_of_data): Adjust accordingly. * test/src/data-tests.el (data-tests--cl-type-of): Remove workaround. diff --git a/etc/NEWS b/etc/NEWS index b522fbd338b..69e61d91b0e 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1652,6 +1652,10 @@ This function is like 'type-of' except that it sometimes returns a more precise type. For example, for nil and t it returns 'null' and 'boolean' respectively, instead of just 'symbol'. +** New function `primitive-function-p`. +This is like `subr-primitive-p` except that it returns t only if the +argument is a function rather than a special-form. + ** Built-in types have now corresponding classes. At the Lisp level, this means that things like (cl-find-class 'integer) will now return a class object, and at the UI level it means that diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 3e89afea452..d11c97a3e3a 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -436,7 +436,7 @@ For this build of Emacs it's %dbit." "Type of the core syntactic elements of the Emacs Lisp language.") (cl--define-built-in-type subr-native-elisp (subr compiled-function) "Type of functions that have been compiled by the native compiler.") -(cl--define-built-in-type subr-primitive (subr compiled-function) +(cl--define-built-in-type primitive-function (subr compiled-function) "Type of functions hand written in C.") (unless (cl--class-parents (cl--find-class 'cl-structure-object)) diff --git a/lisp/subr.el b/lisp/subr.el index 38a3f6edb34..3de4412637f 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -312,11 +312,20 @@ value of last one, or nil if there are none." cond '(empty-body unless) t))) (defsubst subr-primitive-p (object) - "Return t if OBJECT is a built-in primitive function." + "Return t if OBJECT is a built-in primitive written in C. +Such objects can be functions or special forms." (declare (side-effect-free error-free)) (and (subrp object) (not (subr-native-elisp-p object)))) +(defsubst primitive-function-p (object) + "Return t if OBJECT is a built-in primitive function. +This excludes special forms, since they are not functions." + (declare (side-effect-free error-free)) + (and (subrp object) + (not (or (subr-native-elisp-p object) + (eq (cdr (subr-arity object)) 'unevalled))))) + (defsubst xor (cond1 cond2) "Return the boolean exclusive-or of COND1 and COND2. If only one of the arguments is non-nil, return it; otherwise diff --git a/src/data.c b/src/data.c index 5d6b6e0ba9d..69b990bed76 100644 --- a/src/data.c +++ b/src/data.c @@ -248,7 +248,7 @@ a fixed set of types. */) case PVEC_SUBR: return XSUBR (object)->max_args == UNEVALLED ? Qspecial_form : SUBR_NATIVE_COMPILEDP (object) ? Qsubr_native_elisp - : Qsubr_primitive; + : Qprimitive_function; case PVEC_COMPILED: return Qcompiled_function; case PVEC_BUFFER: return Qbuffer; case PVEC_CHAR_TABLE: return Qchar_table; @@ -4245,7 +4245,7 @@ syms_of_data (void) DEFSYM (Qwindow, "window"); DEFSYM (Qsubr, "subr"); DEFSYM (Qspecial_form, "special-form"); - DEFSYM (Qsubr_primitive, "subr-primitive"); + DEFSYM (Qprimitive_function, "primitive-function"); DEFSYM (Qsubr_native_elisp, "subr-native-elisp"); DEFSYM (Qcompiled_function, "compiled-function"); DEFSYM (Qbuffer, "buffer"); diff --git a/test/src/data-tests.el b/test/src/data-tests.el index 9d76c58224d..daa49e671b5 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -869,9 +869,7 @@ comparing the subr with a much slower Lisp implementation." tree-sitter-node tree-sitter-parser ;; `functionp' also matches things of type ;; `symbol' and `cons'. - ;; FIXME: `subr-primitive-p' also matches - ;; special-forms. - function subr-primitive)) + function)) (should-not (cl-typep val subtype))))))))) commit 706403f2aa3a306369a0150022da0cba1802ca2b Author: Stefan Monnier Date: Tue Mar 12 09:26:24 2024 -0400 (cl-type-of): New function to return more precise types (bug#69739) * src/data.c (Fcl_type_of): New function, extracted from `Ftype_of`. Make it return more precise types for symbols, integers, and subrs. (Ftype_of): Use it. (syms_of_data): Define the corresponding new symbols and defsubr the new function. * doc/lispref/objects.texi (Type Predicates): Document it. * src/comp.c (emit_limple_insn): Use `Fcl_type_of`. * lisp/emacs-lisp/cl-preloaded.el (subr): Demote it to `atom`. (subr-native-elisp, subr-primitive): Add `compiled-function` as parent instead. (special-form): New type. * lisp/obsolete/eieio-core.el (cl--generic-struct-tag): * lisp/emacs-lisp/cl-generic.el (cl--generic-typeof-generalizer): Use `cl-type-of`. cl--generic--unreachable-types): Update accordingly. test/src/data-tests.el (data-tests--cl-type-of): New test. diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi index 279f449a994..1e448b64296 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -2207,6 +2207,27 @@ slot is returned; @ref{Records}. @end example @end defun +@defun cl-type-of object +This function returns a symbol naming @emph{the} type of +@var{object}. It usually behaves like @code{type-of}, except +that it guarantees to return the most precise type possible, which also +implies that the specific type it returns may change depending on the +Emacs version. For this reason, as a rule you should never compare its +return value against some fixed set of types. + +@example +(cl-type-of 1) + @result{} fixnum +@group +(cl-type-of 'nil) + @result{} null +(cl-type-of (record 'foo)) + @result{} foo +@end group +@end example +@end defun + + @node Equality Predicates @section Equality Predicates @cindex equality diff --git a/etc/NEWS b/etc/NEWS index b02712dd21c..b522fbd338b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1647,6 +1647,11 @@ values. * Lisp Changes in Emacs 30.1 +** New function 'cl-type-of'. +This function is like 'type-of' except that it sometimes returns +a more precise type. For example, for nil and t it returns 'null' +and 'boolean' respectively, instead of just 'symbol'. + ** Built-in types have now corresponding classes. At the Lisp level, this means that things like (cl-find-class 'integer) will now return a class object, and at the UI level it means that diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 613ecf82a92..62abe8d1589 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1334,8 +1334,7 @@ These match if the argument is `eql' to VAL." (defconst cl--generic--unreachable-types ;; FIXME: Try to make that list empty? - '(fixnum bignum boolean keyword - special-form subr-primitive subr-native-elisp) + '(keyword) "Built-in classes on which we cannot dispatch for technical reasons.") (defun cl--generic-type-specializers (tag &rest _) @@ -1345,8 +1344,7 @@ These match if the argument is `eql' to VAL." (cl--class-allparents class))))) (cl-generic-define-generalizer cl--generic-typeof-generalizer - ;; FIXME: We could also change `type-of' to return `null' for nil. - 10 (lambda (name &rest _) `(if ,name (type-of ,name) 'null)) + 10 (lambda (name &rest _) `(cl-type-of ,name)) #'cl--generic-type-specializers) (cl-defmethod cl-generic-generalizers :extra "typeof" (type) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 515aa99549d..3e89afea452 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -339,8 +339,6 @@ ',parents)))))) ;; FIXME: Our type DAG has various quirks: -;; - `subr' says it's a `compiled-function' but that's not true -;; for those subrs that are special forms! ;; - Some `keyword's are also `symbol-with-pos' but that's not reflected ;; in the DAG. ;; - An OClosure can be an interpreted function or a `byte-code-function', @@ -428,15 +426,17 @@ For this build of Emacs it's %dbit." "Abstract type of functions that have been compiled.") (cl--define-built-in-type byte-code-function (compiled-function) "Type of functions that have been byte-compiled.") -(cl--define-built-in-type subr (compiled-function) +(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) "Type of functions that have not been compiled.") -(cl--define-built-in-type subr-native-elisp (subr) - "Type of function that have been compiled by the native compiler.") -(cl--define-built-in-type subr-primitive (subr) +(cl--define-built-in-type special-form (subr) + "Type of the core syntactic elements of the Emacs Lisp language.") +(cl--define-built-in-type subr-native-elisp (subr compiled-function) + "Type of functions that have been compiled by the native compiler.") +(cl--define-built-in-type subr-primitive (subr compiled-function) "Type of functions hand written in C.") (unless (cl--class-parents (cl--find-class 'cl-structure-object)) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index a2f7c4172a3..cf8bd749f2a 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -1046,7 +1046,7 @@ method invocation orders of the involved classes." (defun cl--generic-struct-tag (name &rest _) ;; Use exactly the same code as for `typeof'. - `(if ,name (type-of ,name) 'null)) + `(cl-type-of ,name)) (cl-generic-define-generalizer eieio--generic-generalizer ;; Use the exact same tagcode as for cl-struct, so that methods diff --git a/src/comp.c b/src/comp.c index 3f989c722d4..76cf1f3ab6e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2442,7 +2442,7 @@ emit_limple_insn (Lisp_Object insn) { Lisp_Object arg1 = arg[1]; - if (EQ (Ftype_of (arg1), Qcomp_mvar)) + if (EQ (Fcl_type_of (arg1), Qcomp_mvar)) res = emit_mvar_rval (arg1); else if (EQ (FIRST (arg1), Qcall)) res = emit_limple_call (XCDR (arg1)); diff --git a/src/data.c b/src/data.c index 35f4c82c68f..5d6b6e0ba9d 100644 --- a/src/data.c +++ b/src/data.c @@ -193,16 +193,37 @@ DEFUN ("null", Fnull, Snull, 1, 1, 0, DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0, doc: /* Return a symbol representing the type of OBJECT. The symbol returned names the object's basic type; -for example, (type-of 1) returns `integer'. */) +for example, (type-of 1) returns `integer'. +Contrary to `cl-type-of', the returned type is not always the most +precise type possible, because instead this function tries to preserve +compatibility with the return value of previous Emacs versions. */) + (Lisp_Object object) +{ + return SYMBOLP (object) ? Qsymbol + : INTEGERP (object) ? Qinteger + : SUBRP (object) ? Qsubr + : Fcl_type_of (object); +} + +DEFUN ("cl-type-of", Fcl_type_of, Scl_type_of, 1, 1, 0, + doc: /* Return a symbol representing the type of OBJECT. +The returned symbol names the most specific possible type of the object. +for example, (cl-type-of nil) returns `null'. +The specific type returned may change depending on Emacs versions, +so we recommend you use `cl-typep', `cl-typecase', or other predicates +rather than compare the return value of this function against +a fixed set of types. */) (Lisp_Object object) { switch (XTYPE (object)) { case_Lisp_Int: - return Qinteger; + return Qfixnum; case Lisp_Symbol: - return Qsymbol; + return NILP (object) ? Qnull + : EQ (object, Qt) ? Qboolean + : Qsymbol; case Lisp_String: return Qstring; @@ -215,7 +236,7 @@ for example, (type-of 1) returns `integer'. */) switch (PSEUDOVECTOR_TYPE (XVECTOR (object))) { case PVEC_NORMAL_VECTOR: return Qvector; - case PVEC_BIGNUM: return Qinteger; + case PVEC_BIGNUM: return Qbignum; case PVEC_MARKER: return Qmarker; case PVEC_SYMBOL_WITH_POS: return Qsymbol_with_pos; case PVEC_OVERLAY: return Qoverlay; @@ -224,7 +245,10 @@ for example, (type-of 1) returns `integer'. */) case PVEC_WINDOW_CONFIGURATION: return Qwindow_configuration; case PVEC_PROCESS: return Qprocess; case PVEC_WINDOW: return Qwindow; - case PVEC_SUBR: return Qsubr; + case PVEC_SUBR: + return XSUBR (object)->max_args == UNEVALLED ? Qspecial_form + : SUBR_NATIVE_COMPILEDP (object) ? Qsubr_native_elisp + : Qsubr_primitive; case PVEC_COMPILED: return Qcompiled_function; case PVEC_BUFFER: return Qbuffer; case PVEC_CHAR_TABLE: return Qchar_table; @@ -4202,7 +4226,9 @@ syms_of_data (void) "Variable binding depth exceeds max-specpdl-size"); /* Types that type-of returns. */ + DEFSYM (Qboolean, "boolean"); DEFSYM (Qinteger, "integer"); + DEFSYM (Qbignum, "bignum"); DEFSYM (Qsymbol, "symbol"); DEFSYM (Qstring, "string"); DEFSYM (Qcons, "cons"); @@ -4218,6 +4244,9 @@ syms_of_data (void) DEFSYM (Qprocess, "process"); DEFSYM (Qwindow, "window"); DEFSYM (Qsubr, "subr"); + DEFSYM (Qspecial_form, "special-form"); + DEFSYM (Qsubr_primitive, "subr-primitive"); + DEFSYM (Qsubr_native_elisp, "subr-native-elisp"); DEFSYM (Qcompiled_function, "compiled-function"); DEFSYM (Qbuffer, "buffer"); DEFSYM (Qframe, "frame"); @@ -4255,6 +4284,7 @@ syms_of_data (void) defsubr (&Seq); defsubr (&Snull); defsubr (&Stype_of); + defsubr (&Scl_type_of); defsubr (&Slistp); defsubr (&Snlistp); defsubr (&Sconsp); diff --git a/test/src/data-tests.el b/test/src/data-tests.el index ad3b2071254..9d76c58224d 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -838,4 +838,41 @@ comparing the subr with a much slower Lisp implementation." (dolist (sym (list nil t 'xyzzy (make-symbol ""))) (should (eq sym (bare-symbol (position-symbol sym 0))))))) +(require 'cl-extra) ;For `cl--class-children'. + +(ert-deftest data-tests--cl-type-of () + ;; Make sure that `cl-type-of' returns the most precise type. + ;; Note: This doesn't work for list/vector structs since those types + ;; are too difficult/unreliable to detect (so `cl-type-of' only says + ;; it's a `cons' or a `vector'). + (dolist (val (list -2 10 (expt 2 128) nil t 'car + (symbol-function 'car) + (symbol-function 'progn) + (position-symbol 'car 7))) + (let* ((type (cl-type-of val)) + (class (cl-find-class type)) + (alltypes (cl--class-allparents class)) + ;; FIXME: Our type DAG is affected by `symbols-with-pos-enabled'. + ;; (e.g. `symbolp' returns nil on a sympos if that var is nil). + (symbols-with-pos-enabled t)) + (dolist (parent alltypes) + (should (cl-typep val parent)) + (dolist (subtype (cl--class-children (cl-find-class parent))) + (unless (memq subtype alltypes) + (unless (memq subtype + ;; FIXME: Some types don't have any associated + ;; predicate, + '( font-spec font-entity font-object + finalizer condvar terminal + native-comp-unit interpreted-function + tree-sitter-compiled-query + tree-sitter-node tree-sitter-parser + ;; `functionp' also matches things of type + ;; `symbol' and `cons'. + ;; FIXME: `subr-primitive-p' also matches + ;; special-forms. + function subr-primitive)) + (should-not (cl-typep val subtype))))))))) + + ;;; data-tests.el ends here