commit 23cc2d192c4657b7963906317b8af0b8bbe1b0b3 (HEAD, refs/remotes/origin/master) Author: Eli Zaretskii Date: Sat Dec 23 09:32:04 2023 +0200 ; * src/sfnt.c (sfnt_interpret_compound_glyph_2): Reword a comment. diff --git a/src/sfnt.c b/src/sfnt.c index 6698c9c27df..553b828a2db 100644 --- a/src/sfnt.c +++ b/src/sfnt.c @@ -12639,7 +12639,7 @@ sfnt_interpret_compound_glyph_2 (struct sfnt_glyph *glyph, sfnt_f26dot6 *x_base, *y_base; /* Figure out how many points and contours there are to instruct. A - minimum of two points must be present, to wit the origin and + minimum of two points must be present, namely: the origin and advance phantom points. */ num_points = context->num_points - base_index; num_contours = context->num_end_points - base_contour; commit 509d530646465b717bbbfb4376f9e209d99a15d9 Author: Stefan Kangas Date: Sat Dec 23 07:24:39 2023 +0100 ; Update function name in package-vc--unpack-1 * lisp/emacs-lisp/package-vc.el (package-vc--unpack-1): Use renamed function 'lm--prepare-package-dependencies'. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index bef498f997c..b3e3f450f1d 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -527,7 +527,7 @@ package-vc--unpack-1 (thread-last (mapconcat #'identity require-lines " ") package-read-from-string - package--prepare-dependencies + lm--prepare-package-dependencies (nconc deps) (setq deps)))))) (dolist (dep deps) commit 1c9f5add6ccf0bb374b70038c8b03be443c56789 Author: Stefan Kangas Date: Sat Dec 23 07:16:53 2023 +0100 ; Silence warning diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 1434db3d1f4..fa9903e13e3 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1150,7 +1150,7 @@ package-read-from-string (end-of-file expr)))) (declare-function lm-header "lisp-mnt" (header)) -(declare-function lm-package-requires "lisp-mnt" (header)) +(declare-function lm-package-requires "lisp-mnt" (&optional file)) (declare-function lm-website "lisp-mnt" (&optional file)) (declare-function lm-keywords-list "lisp-mnt" (&optional file)) (declare-function lm-maintainers "lisp-mnt" (&optional file)) commit a63b206fbde2ead91f1053d80a275f8850e5ffce Author: Gerd Möllmann Date: Sat Dec 23 07:06:06 2023 +0100 Use new safe_calln on NS * src/nsterm.m (ns_in_echo_area_1): Use safe_calln. ([EmacsView draggingUpdated:]): Use safe_calln. diff --git a/src/nsterm.m b/src/nsterm.m index 46a5e8870e8..2f736980ea6 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -7058,13 +7058,9 @@ - (void)unmarkText static Lisp_Object ns_in_echo_area_1 (void *ptr) { - Lisp_Object in_echo_area; - specpdl_ref count; - - count = SPECPDL_INDEX (); + const specpdl_ref count = SPECPDL_INDEX (); specbind (Qinhibit_quit, Qt); - in_echo_area = safe_call (1, Qns_in_echo_area); - + const Lisp_Object in_echo_area = safe_calln (Qns_in_echo_area); return unbind_to (count, in_echo_area); } @@ -8829,8 +8825,8 @@ - (NSDragOperation) draggingUpdated: (id ) sender so call this function instead. */ XSETFRAME (frame, emacsframe); - safe_call (4, Vns_drag_motion_function, frame, - make_fixnum (x), make_fixnum (y)); + safe_calln (Vns_drag_motion_function, frame, + make_fixnum (x), make_fixnum (y)); redisplay (); #endif commit 0fde935b66e43e4d7ec137ba6195de993168587a Author: Stefan Monnier Date: Sat Dec 23 00:25:46 2023 -0500 Split safe_call between redisplay and non-redisplay versions The `safe_call/eval` family of functions started its life in `xdisp.c` for the needs of redisplay but quickly became popular outside of it. This is not ideal because despite their name, they are somewhat specific to the needs of redisplay. So we split them into `safe_call/eval` (in `eval.c`) and `dsafe_call/eval` (in `xdisp.c`). We took this opportunity to slightly change their calling convention to be friendly to the CALLN-style macros. While at it, we introduce a new `calln` macro as well which does all that `call[1-8]` used to do. * src/eval.c (safe_eval_handler, safe_funcall, safe_eval): New functions, Copied from `xdisp.c`. Don't obey `inhibit_eval_during_redisplay` any more. Adjust error message to not claim it happened during redisplay. * src/lisp.h (calln): New macro. (call1, call2, call3, call4, call5, call6, call7, call8): Turn them into aliases of `calln`. (safe_funcall): Declare. (safe_calln): New macro. (safe_call1, safe_call2): Redefine as compatibility macros. (safe_call, safe_call1, safe_call2): Delete. Replace all callers with calls to `safe_calln`. * src/xdisp.c (dsafe_eval_handler): Rename from `safe_eval_handler`. Adjust all users. (dsafe__call): Rename from `safe_call` and change calling convention to work with something like CALLMANY. Adjust all users. (safe_call, safe__call1, safe_call2): Delete functions. (SAFE_CALLMANY, dsafe_calln): New macros. (dsafe_call1, dsafe_eval): Rename from `safe_call1` and `safe_eval`, and rewrite using them. Adjust all users. (clear_message, prepare_menu_bars, redisplay_window): Use `dsafe_calln`. (run_window_scroll_functions): Don't let-bind `Qinhibit_quit` since `safe_run_hooks_2` does it for us. diff --git a/src/buffer.c b/src/buffer.c index a7299f4a49e..ea0c23192b7 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -1739,7 +1739,7 @@ DEFUN ("other-buffer", Fother_buffer, Sother_buffer, 0, 3, 0, if (!NILP (notsogood)) return notsogood; else - return safe_call (1, Qget_scratch_buffer_create); + return safe_calln (Qget_scratch_buffer_create); } /* The following function is a safe variant of Fother_buffer: It doesn't @@ -1760,7 +1760,7 @@ other_buffer_safely (Lisp_Object buffer) becoming dead under our feet. safe_call below could return nil if recreating *scratch* in Lisp, which does some fancy stuff, signals an error in some weird use case. */ - buf = safe_call (1, Qget_scratch_buffer_create); + buf = safe_calln (Qget_scratch_buffer_create); if (NILP (buf)) { AUTO_STRING (scratch, "*scratch*"); diff --git a/src/coding.c b/src/coding.c index b7f4120dc8d..17f982ab2dd 100644 --- a/src/coding.c +++ b/src/coding.c @@ -8170,7 +8170,7 @@ decode_coding_object (struct coding_system *coding, Fcons (undo_list, Fcurrent_buffer ())); bset_undo_list (current_buffer, Qt); TEMP_SET_PT_BOTH (coding->dst_pos, coding->dst_pos_byte); - val = safe_call1 (CODING_ATTR_POST_READ (attrs), + val = safe_calln (CODING_ATTR_POST_READ (attrs), make_fixnum (coding->produced_char)); CHECK_FIXNAT (val); coding->produced_char += Z - prev_Z; @@ -8336,7 +8336,7 @@ encode_coding_object (struct coding_system *coding, set_buffer_internal (XBUFFER (coding->src_object)); } - safe_call2 (CODING_ATTR_PRE_WRITE (attrs), + safe_calln (CODING_ATTR_PRE_WRITE (attrs), make_fixnum (BEG), make_fixnum (Z)); if (XBUFFER (coding->src_object) != current_buffer) kill_src_buffer = 1; diff --git a/src/composite.c b/src/composite.c index 9332c1cb9a3..aeae02fd1ce 100644 --- a/src/composite.c +++ b/src/composite.c @@ -987,7 +987,7 @@ autocmp_chars (Lisp_Object rule, ptrdiff_t charpos, ptrdiff_t bytepos, if (NILP (string)) record_unwind_protect (restore_point_unwind, build_marker (current_buffer, pt, pt_byte)); - lgstring = safe_call (7, Vauto_composition_function, AREF (rule, 2), + lgstring = safe_calln (Vauto_composition_function, AREF (rule, 2), pos, make_fixnum (to), font_object, string, direction); } diff --git a/src/eval.c b/src/eval.c index b3d3fc3132b..30edaccdb62 100644 --- a/src/eval.c +++ b/src/eval.c @@ -3023,6 +3023,35 @@ DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0, } +static Lisp_Object +safe_eval_handler (Lisp_Object arg, ptrdiff_t nargs, Lisp_Object *args) +{ + add_to_log ("Error muted by safe_call: %S signaled %S", + Flist (nargs, args), arg); + return Qnil; +} + +Lisp_Object +safe_funcall (ptrdiff_t nargs, Lisp_Object *args) +{ + specpdl_ref count = SPECPDL_INDEX (); + /* FIXME: This function started its life in 'xdisp.c' for use internally + by the redisplay. So it was important to inhibit redisplay. + Not clear if we still need this 'specbind' now that 'xdisp.c' has its + own version of this code. */ + specbind (Qinhibit_redisplay, Qt); + /* Use Qt to ensure debugger does not run. */ + Lisp_Object val = internal_condition_case_n (Ffuncall, nargs, args, Qt, + safe_eval_handler); + return unbind_to (count, val); +} + +Lisp_Object +safe_eval (Lisp_Object sexp) +{ + return safe_calln (Qeval, sexp, Qt); +} + /* Apply a C subroutine SUBR to the NUMARGS evaluated arguments in ARG_VECTOR and return the result of evaluation. */ diff --git a/src/frame.c b/src/frame.c index 38ac316ce87..b6f92d6f9f5 100644 --- a/src/frame.c +++ b/src/frame.c @@ -2149,7 +2149,7 @@ delete_frame (Lisp_Object frame, Lisp_Object force) x_clipboard_manager_save_frame (frame); #endif - safe_call2 (Qrun_hook_with_args, Qdelete_frame_functions, frame); + safe_calln (Qrun_hook_with_args, Qdelete_frame_functions, frame); } /* delete_frame_functions may have deleted any frame, including this @@ -2461,7 +2461,7 @@ delete_frame (Lisp_Object frame, Lisp_Object force) = Fcons (list3 (Qrun_hook_with_args, Qafter_delete_frame_functions, frame), pending_funcalls); else - safe_call2 (Qrun_hook_with_args, Qafter_delete_frame_functions, frame); + safe_calln (Qrun_hook_with_args, Qafter_delete_frame_functions, frame); if (!NILP (minibuffer_child_frame)) /* If minibuffer_child_frame is non-nil, it was FRAME's minibuffer diff --git a/src/haikuselect.c b/src/haikuselect.c index 608b8e8fe30..567ebd0b302 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -1189,7 +1189,7 @@ haiku_note_drag_wheel (struct input_event *ie) if (!NILP (Vhaiku_drag_wheel_function) && (haiku_dnd_allow_same_frame || XFRAME (ie->frame_or_window) != haiku_dnd_frame)) - safe_call (7, Vhaiku_drag_wheel_function, ie->frame_or_window, + safe_calln (Vhaiku_drag_wheel_function, ie->frame_or_window, ie->x, ie->y, horizontal ? Qt : Qnil, up ? Qt : Qnil, make_int (ie->modifiers)); diff --git a/src/keyboard.c b/src/keyboard.c index 81605e75ba2..39abe07e5dc 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -2226,7 +2226,7 @@ show_help_echo (Lisp_Object help, Lisp_Object window, Lisp_Object object, if (!NILP (help) && !STRINGP (help)) { if (FUNCTIONP (help)) - help = safe_call (4, help, window, object, pos); + help = safe_calln (help, window, object, pos); else help = safe_eval (help); @@ -4654,7 +4654,7 @@ timer_check_2 (Lisp_Object timers, Lisp_Object idle_timers) { Lisp_Object funcall = XCAR (pending_funcalls); pending_funcalls = XCDR (pending_funcalls); - safe_call2 (Qapply, XCAR (funcall), XCDR (funcall)); + safe_calln (Qapply, XCAR (funcall), XCDR (funcall)); } if (CONSP (timers) || CONSP (idle_timers)) diff --git a/src/keymap.c b/src/keymap.c index d710bae02e0..b1d12227113 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -610,7 +610,7 @@ map_keymap_canonical (Lisp_Object map, map_keymap_function_t fun, Lisp_Object ar { /* map_keymap_canonical may be used from redisplay (e.g. when building menus) so be careful to ignore errors and to inhibit redisplay. */ - map = safe_call1 (Qkeymap_canonicalize, map); + map = safe_calln (Qkeymap_canonicalize, map); /* No need to use `map_keymap' here because canonical map has no parent. */ map_keymap_internal (map, fun, args, data); } diff --git a/src/lisp.h b/src/lisp.h index df6cf1df544..ed1b007d4c5 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3233,77 +3233,25 @@ #define CALLMANY(f, array) (f) (ARRAYELTS (array), array) empty initializers), and is overkill for simple usages like 'Finsert (1, &text);'. */ #define CALLN(f, ...) CALLMANY (f, ((Lisp_Object []) {__VA_ARGS__})) - -/* Call function fn on no arguments. */ +#define calln(...) CALLN (Ffuncall, __VA_ARGS__) +/* Compatibility aliases. */ +#define call1 calln +#define call2 calln +#define call3 calln +#define call4 calln +#define call5 calln +#define call6 calln +#define call7 calln +#define call8 calln + +/* Define 'call0' as a function rather than a CPP macro because we + sometimes want to pass it as a first class function. */ INLINE Lisp_Object call0 (Lisp_Object fn) { return Ffuncall (1, &fn); } -/* Call function fn with 1 argument arg1. */ -INLINE Lisp_Object -call1 (Lisp_Object fn, Lisp_Object arg1) -{ - return CALLN (Ffuncall, fn, arg1); -} - -/* Call function fn with 2 arguments arg1, arg2. */ -INLINE Lisp_Object -call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2) -{ - return CALLN (Ffuncall, fn, arg1, arg2); -} - -/* Call function fn with 3 arguments arg1, arg2, arg3. */ -INLINE Lisp_Object -call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3) -{ - return CALLN (Ffuncall, fn, arg1, arg2, arg3); -} - -/* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */ -INLINE Lisp_Object -call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, - Lisp_Object arg4) -{ - return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4); -} - -/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */ -INLINE Lisp_Object -call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, - Lisp_Object arg4, Lisp_Object arg5) -{ - return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5); -} - -/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */ -INLINE Lisp_Object -call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, - Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6) -{ - return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6); -} - -/* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */ -INLINE Lisp_Object -call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, - Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7) -{ - return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7); -} - -/* Call function fn with 8 arguments arg1, arg2, arg3, arg4, arg5, - arg6, arg7, arg8. */ -INLINE Lisp_Object -call8 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, - Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7, - Lisp_Object arg8) -{ - return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); -} - extern void defvar_lisp (struct Lisp_Objfwd const *, char const *); extern void defvar_lisp_nopro (struct Lisp_Objfwd const *, char const *); extern void defvar_bool (struct Lisp_Boolfwd const *, char const *); @@ -4618,9 +4566,10 @@ xsignal (Lisp_Object error_symbol, Lisp_Object data) Lisp_Object nosuffix, Lisp_Object must_suffix); extern Lisp_Object call_debugger (Lisp_Object arg); extern void init_eval_once (void); -extern Lisp_Object safe_call (ptrdiff_t, Lisp_Object, ...); -extern Lisp_Object safe_call1 (Lisp_Object, Lisp_Object); -extern Lisp_Object safe_call2 (Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object safe_funcall (ptrdiff_t, Lisp_Object*); +#define safe_calln(...) \ + CALLMANY (safe_funcall, ((Lisp_Object []) {__VA_ARGS__})) + extern void init_eval (void); extern void syms_of_eval (void); extern void prog_ignore (Lisp_Object); diff --git a/src/print.c b/src/print.c index 09e00329676..96c4d0a5d1e 100644 --- a/src/print.c +++ b/src/print.c @@ -1094,7 +1094,7 @@ print_error_message (Lisp_Object data, Lisp_Object stream, const char *context, /* `substitute-command-keys' may bug out, which would lead to infinite recursion when we're called from skip_debugger, so ignore errors. */ - Lisp_Object subs = safe_call1 (Qsubstitute_command_keys, errmsg); + Lisp_Object subs = safe_calln (Qsubstitute_command_keys, errmsg); if (!NILP (subs)) errmsg = subs; } diff --git a/src/syntax.c b/src/syntax.c index 0cac923bba7..391c7f9bc3e 100644 --- a/src/syntax.c +++ b/src/syntax.c @@ -468,7 +468,7 @@ parse_sexp_propertize (ptrdiff_t charpos) && syntax_propertize__done < zv) { modiff_count modiffs = CHARS_MODIFF; - safe_call1 (Qinternal__syntax_propertize, + safe_calln (Qinternal__syntax_propertize, make_fixnum (min (zv, 1 + charpos))); if (modiffs != CHARS_MODIFF) error ("internal--syntax-propertize modified the buffer!"); diff --git a/src/term.c b/src/term.c index 25184101b78..5b50f169493 100644 --- a/src/term.c +++ b/src/term.c @@ -2235,7 +2235,7 @@ set_tty_color_mode (struct tty_display_info *tty, struct frame *f) tty->previous_color_mode = mode; tty_setup_colors (tty , mode); /* This recomputes all the faces given the new color definitions. */ - safe_call (1, intern ("tty-set-up-initial-frame-faces")); + safe_calln (intern ("tty-set-up-initial-frame-faces")); } } diff --git a/src/terminal.c b/src/terminal.c index 07c37883f0e..9ccc27c6bc6 100644 --- a/src/terminal.c +++ b/src/terminal.c @@ -389,7 +389,7 @@ DEFUN ("delete-terminal", Fdelete_terminal, Sdelete_terminal, 0, 2, 0, Qdelete_terminal_functions, terminal), pending_funcalls); else - safe_call2 (Qrun_hook_with_args, Qdelete_terminal_functions, terminal); + safe_calln (Qrun_hook_with_args, Qdelete_terminal_functions, terminal); if (t->delete_terminal_hook) (*t->delete_terminal_hook) (t); diff --git a/src/treesit.c b/src/treesit.c index c85038e70cf..bbd0a405c29 100644 --- a/src/treesit.c +++ b/src/treesit.c @@ -1040,7 +1040,7 @@ treesit_call_after_change_functions (TSTree *old_tree, TSTree *new_tree, for each of them. */ Lisp_Object functions = XTS_PARSER (parser)->after_change_functions; FOR_EACH_TAIL (functions) - safe_call2 (XCAR (functions), lisp_ranges, parser); + safe_calln (XCAR (functions), lisp_ranges, parser); unbind_to (count, Qnil); } diff --git a/src/window.c b/src/window.c index 3d18d48bfb7..d6b2dd1d959 100644 --- a/src/window.c +++ b/src/window.c @@ -3829,7 +3829,7 @@ run_window_change_functions_1 (Lisp_Object symbol, Lisp_Object buffer, frame. Make sure to record changes for each live frame in window_change_record later. */ window_change_record_frames = true; - safe_call1 (XCAR (funs), window_or_frame); + safe_calln (XCAR (funs), window_or_frame); } funs = XCDR (funs); diff --git a/src/xdisp.c b/src/xdisp.c index 75d769600c4..1f571a2b221 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -3031,10 +3031,10 @@ hscrolling_current_line_p (struct window *w) Lisp form evaluation ***********************************************************************/ -/* Error handler for safe_eval and safe_call. */ +/* Error handler for dsafe_eval and dsafe_call. */ static Lisp_Object -safe_eval_handler (Lisp_Object arg, ptrdiff_t nargs, Lisp_Object *args) +dsafe_eval_handler (Lisp_Object arg, ptrdiff_t nargs, Lisp_Object *args) { add_to_log ("Error during redisplay: %S signaled %S", Flist (nargs, args), arg); @@ -3045,8 +3045,11 @@ safe_eval_handler (Lisp_Object arg, ptrdiff_t nargs, Lisp_Object *args) following. Return the result, or nil if something went wrong. Prevent redisplay during the evaluation. */ +/* FIXME: What's the guiding principle behind the choice + of which calls should set 'inhibit_quit' and which don't. */ static Lisp_Object -safe__call (bool inhibit_quit, ptrdiff_t nargs, Lisp_Object func, va_list ap) +dsafe__call (bool inhibit_quit, Lisp_Object (f) (ptrdiff_t, Lisp_Object *), + ptrdiff_t nargs, Lisp_Object *args) { Lisp_Object val; @@ -3054,84 +3057,38 @@ safe__call (bool inhibit_quit, ptrdiff_t nargs, Lisp_Object func, va_list ap) val = Qnil; else { - ptrdiff_t i; specpdl_ref count = SPECPDL_INDEX (); - Lisp_Object *args; - USE_SAFE_ALLOCA; - SAFE_ALLOCA_LISP (args, nargs); - - args[0] = func; - for (i = 1; i < nargs; i++) - args[i] = va_arg (ap, Lisp_Object); specbind (Qinhibit_redisplay, Qt); if (inhibit_quit) specbind (Qinhibit_quit, Qt); /* Use Qt to ensure debugger does not run, so there is no possibility of wanting to redisplay. */ - val = internal_condition_case_n (Ffuncall, nargs, args, Qt, - safe_eval_handler); - val = SAFE_FREE_UNBIND_TO (count, val); + val = internal_condition_case_n (f, nargs, args, Qt, + dsafe_eval_handler); + val = unbind_to (count, val); } return val; } -Lisp_Object -safe_call (ptrdiff_t nargs, Lisp_Object func, ...) -{ - Lisp_Object retval; - va_list ap; - - va_start (ap, func); - retval = safe__call (false, nargs, func, ap); - va_end (ap); - return retval; -} - -/* Call function FN with one argument ARG. - Return the result, or nil if something went wrong. */ - -Lisp_Object -safe_call1 (Lisp_Object fn, Lisp_Object arg) -{ - return safe_call (2, fn, arg); -} +#define SAFE_CALLMANY(inhibit_quit, f, array) \ + dsafe__call ((inhibit_quit), f, ARRAYELTS (array), array) +#define dsafe_calln(inhibit_quit, ...) \ + SAFE_CALLMANY ((inhibit_quit), Ffuncall, ((Lisp_Object []) {__VA_ARGS__})) static Lisp_Object -safe__call1 (bool inhibit_quit, Lisp_Object fn, ...) -{ - Lisp_Object retval; - va_list ap; - - va_start (ap, fn); - retval = safe__call (inhibit_quit, 2, fn, ap); - va_end (ap); - return retval; -} - -Lisp_Object -safe_eval (Lisp_Object sexpr) +dsafe_call1 (Lisp_Object f, Lisp_Object arg) { - return safe__call1 (false, Qeval, sexpr); + return dsafe_calln (false, f, arg); } static Lisp_Object -safe__eval (bool inhibit_quit, Lisp_Object sexpr) +dsafe_eval (Lisp_Object sexpr) { - return safe__call1 (inhibit_quit, Qeval, sexpr); + return dsafe_calln (true, Qeval, sexpr, Qt); } -/* Call function FN with two arguments ARG1 and ARG2. - Return the result, or nil if something went wrong. */ - -Lisp_Object -safe_call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2) -{ - return safe_call (3, fn, arg1, arg2); -} - - /*********************************************************************** Debugging @@ -4615,7 +4572,7 @@ handle_fontified_prop (struct it *it) it->f->inhibit_clear_image_cache = true; if (!CONSP (val) || EQ (XCAR (val), Qlambda)) - safe_call1 (val, pos); + dsafe_call1 (val, pos); else { Lisp_Object fns, fn; @@ -4639,11 +4596,11 @@ handle_fontified_prop (struct it *it) { fn = XCAR (fns); if (!EQ (fn, Qt)) - safe_call1 (fn, pos); + dsafe_call1 (fn, pos); } } else - safe_call1 (fn, pos); + dsafe_call1 (fn, pos); } } @@ -5855,7 +5812,7 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, /* Save and restore the bidi cache, since FORM could be crazy enough to re-enter redisplay, e.g., by calling 'message'. */ itdata = bidi_shelve_cache (); - form = safe_eval (form); + form = dsafe_eval (form); bidi_unshelve_cache (itdata, false); form = unbind_to (count, form); } @@ -5897,7 +5854,7 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, struct face *face = FACE_FROM_ID (it->f, it->face_id); Lisp_Object height; itdata = bidi_shelve_cache (); - height = safe_call1 (it->font_height, + height = dsafe_call1 (it->font_height, face->lface[LFACE_HEIGHT_INDEX]); bidi_unshelve_cache (itdata, false); if (NUMBERP (height)) @@ -5922,7 +5879,7 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, specbind (Qheight, face->lface[LFACE_HEIGHT_INDEX]); itdata = bidi_shelve_cache (); - value = safe_eval (it->font_height); + value = dsafe_eval (it->font_height); bidi_unshelve_cache (itdata, false); value = unbind_to (count, value); @@ -12801,7 +12758,7 @@ resize_mini_window (struct window *w, bool exact_p) displaying changes from under them. Such a resizing can happen, for instance, when which-func prints a long message while we are running fontification-functions. We're running these - functions with safe_call which binds inhibit-redisplay to t. */ + functions with dsafe_call which binds inhibit-redisplay to t. */ if (!NILP (Vinhibit_redisplay)) return false; @@ -12820,7 +12777,7 @@ resize_mini_window (struct window *w, bool exact_p) if (FRAME_MINIBUF_ONLY_P (f)) { if (!NILP (resize_mini_frames)) - safe_call1 (Qwindow__resize_mini_frame, WINDOW_FRAME (w)); + dsafe_call1 (Qwindow__resize_mini_frame, WINDOW_FRAME (w)); } else { @@ -13067,7 +13024,7 @@ set_message (Lisp_Object string) { specpdl_ref count = SPECPDL_INDEX (); specbind (Qinhibit_quit, Qt); - message = safe_call1 (Vset_message_function, string); + message = dsafe_call1 (Vset_message_function, string); unbind_to (count, Qnil); if (STRINGP (message)) @@ -13146,7 +13103,7 @@ clear_message (bool current_p, bool last_displayed_p) { specpdl_ref count = SPECPDL_INDEX (); specbind (Qinhibit_quit, Qt); - preserve = safe_call (1, Vclear_message_function); + preserve = dsafe_calln (false, Vclear_message_function); unbind_to (count, Qnil); } @@ -13757,7 +13714,7 @@ prepare_menu_bars (void) windows = Fcons (this, windows); } } - safe__call1 (true, Vpre_redisplay_function, windows); + dsafe_calln (true, Vpre_redisplay_function, windows); } /* Update all frame titles based on their buffer names, etc. We do @@ -18591,11 +18548,8 @@ run_window_scroll_functions (Lisp_Object window, struct text_pos startp) if (!NILP (Vwindow_scroll_functions)) { - specpdl_ref count = SPECPDL_INDEX (); - specbind (Qinhibit_quit, Qt); safe_run_hooks_2 (Qwindow_scroll_functions, window, make_fixnum (CHARPOS (startp))); - unbind_to (count, Qnil); SET_TEXT_POS_FROM_MARKER (startp, w->start); /* In case the hook functions switch buffers. */ set_buffer_internal (XBUFFER (w->contents)); @@ -18647,7 +18601,7 @@ cursor_row_fully_visible_p (struct window *w, bool force_p, XSETWINDOW (window, w); /* Implementation note: if the function we call here signals an error, we will NOT scroll when the cursor is partially-visible. */ - Lisp_Object val = safe_call1 (mclfv_p, window); + Lisp_Object val = dsafe_call1 (mclfv_p, window); if (NILP (val)) return true; else if (just_test_user_preference_p) @@ -20215,7 +20169,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) propagated its info to `w' anyway. */ w->redisplay = false; XBUFFER (w->contents)->text->redisplay = false; - safe__call1 (true, Vpre_redisplay_function, Fcons (window, Qnil)); + dsafe_calln (true, Vpre_redisplay_function, Fcons (window, Qnil)); if (w->redisplay || XBUFFER (w->contents)->text->redisplay || ((EQ (Vdisplay_line_numbers, Qrelative) @@ -27092,7 +27046,7 @@ display_mode_lines (struct window *w) can reasonably tell whether a mouse click will select w. */ XSETWINDOW (window, w); if (FUNCTIONP (default_help)) - wset_mode_line_help_echo (w, safe_call1 (default_help, window)); + wset_mode_line_help_echo (w, dsafe_call1 (default_help, window)); else if (STRINGP (default_help)) wset_mode_line_help_echo (w, default_help); else @@ -27431,6 +27385,7 @@ display_mode_element (struct it *it, int depth, int field_width, int precision, /* PROPS might cause set-text-properties to signal an error, so we call it via internal_condition_case_n, to avoid an infloop in redisplay due to the error. */ + /* FIXME: Use 'SAFE_CALLMANY'? */ internal_condition_case_n (safe_set_text_properties, 4, ((Lisp_Object []) @@ -27438,7 +27393,7 @@ display_mode_element (struct it *it, int depth, int field_width, int precision, Flength (elt), props, elt}), - Qt, safe_eval_handler); + Qt, dsafe_eval_handler); /* Add this item to mode_line_proptrans_alist. */ mode_line_proptrans_alist = Fcons (Fcons (elt, props), @@ -27691,7 +27646,7 @@ display_mode_element (struct it *it, int depth, int field_width, int precision, if (CONSP (XCDR (elt))) { Lisp_Object spec; - spec = safe__eval (true, XCAR (XCDR (elt))); + spec = dsafe_eval (XCAR (XCDR (elt))); /* The :eval form could delete the frame stored in the iterator, which will cause a crash if we try to access faces and other fields (e.g., FRAME_KBOARD) @@ -28663,7 +28618,7 @@ decode_mode_spec (struct window *w, register int c, int field_width, Lisp_Object val = Qnil; if (STRINGP (curdir)) - val = safe_call1 (intern ("file-remote-p"), curdir); + val = dsafe_call1 (intern ("file-remote-p"), curdir); val = unbind_to (count, val); diff --git a/src/xfaces.c b/src/xfaces.c index 7385c4c7dd2..a6a20389f7d 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -2232,7 +2232,7 @@ merge_face_heights (Lisp_Object from, Lisp_Object to, Lisp_Object invalid) { /* Call function with current height as argument. From is the new height. */ - result = safe_call1 (from, to); + result = safe_calln (from, to); /* Ensure that if TO was absolute, so is the result. */ if (FIXNUMP (to) && !FIXNUMP (result)) diff --git a/src/xterm.c b/src/xterm.c index 79648a6d6e5..4aad78dc47b 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -5036,7 +5036,7 @@ x_dnd_note_self_drop (struct x_display_info *dpyinfo, Window target, XSETFRAME (lval, f); x_dnd_action = None; x_dnd_action_symbol - = safe_call2 (Vx_dnd_native_test_function, + = safe_calln (Vx_dnd_native_test_function, Fposn_at_x_y (make_fixnum (win_x), make_fixnum (win_y), lval, Qnil), @@ -27202,7 +27202,7 @@ xim_open_dpy (struct x_display_info *dpyinfo, char *resource_name) /* Now try to determine the coding system that should be used. locale is in Host Portable Character Encoding, and as such can be passed to build_string as is. */ - dpyinfo->xim_coding = safe_call1 (Vx_input_coding_function, + dpyinfo->xim_coding = safe_calln (Vx_input_coding_function, build_string (locale)); } } @@ -30661,7 +30661,7 @@ #define NUM_ARGV 10 terminal_list = terminal->next_terminal; unblock_input (); kset_system_key_alist (terminal->kboard, - safe_call1 (Qvendor_specific_keysyms, + safe_calln (Qvendor_specific_keysyms, (vendor ? build_string (vendor) : empty_unibyte_string))); commit 9aea075f5fd6e1d6b7f6d7fe35de8f3da752c3e7 Author: Po Lu Date: Sat Dec 23 11:22:21 2023 +0800 Respect glyph metrics modified by instruction code * src/sfnt.c (sfnt_read_glyph): Clear advance and origin distortion returning an empty glyph. (sfnt_build_instructed_outline): New parameter *ADVANCE_WIDTH, in which the glyph's advance width is saved. (sfnt_interpret_compound_glyph_1): Refine commentary. (sfnt_verbose, main): Adjust tests. * src/sfnt.h: Update prototypes correspondingly. * src/sfntfont.c (sfntfont_get_glyph_outline): If an instructed outline is available, derive the advance and lbearing from the measurements within. (sfntfont_probe_widths): Call sfntfont_measure_pcm to establish average widths. (sfntfont_open): Do so after instruction code initialization completes. (sfntfont_measure_pcm): Revise commentary. diff --git a/src/sfnt.c b/src/sfnt.c index 1397e341aa8..6698c9c27df 100644 --- a/src/sfnt.c +++ b/src/sfnt.c @@ -2421,6 +2421,8 @@ sfnt_read_glyph (sfnt_glyph glyph_code, glyph.ymin = 0; glyph.xmax = 0; glyph.ymax = 0; + glyph.advance_distortion = 0; + glyph.origin_distortion = 0; glyph.simple = xmalloc (sizeof *glyph.simple); glyph.compound = NULL; memset (glyph.simple, 0, sizeof *glyph.simple); @@ -12202,15 +12204,18 @@ sfnt_decompose_instructed_outline (struct sfnt_instructed_outline *outline, /* Decompose and build an outline for the specified instructed outline INSTRUCTED. Return the outline data with a refcount of 0 upon - success, or NULL upon failure. + success, and the advance width of the instructed glyph in + *ADVANCE_WIDTH, or NULL upon failure. This function is not reentrant. */ TEST_STATIC struct sfnt_glyph_outline * -sfnt_build_instructed_outline (struct sfnt_instructed_outline *instructed) +sfnt_build_instructed_outline (struct sfnt_instructed_outline *instructed, + sfnt_fixed *advance_width) { struct sfnt_glyph_outline *outline; int rc; + sfnt_f26dot6 x1, x2; memset (&build_outline_context, 0, sizeof build_outline_context); @@ -12247,10 +12252,23 @@ sfnt_build_instructed_outline (struct sfnt_instructed_outline *instructed) instructed. */ if (instructed->num_points > 1) - outline->origin - = instructed->x_points[instructed->num_points - 2]; + { + x1 = instructed->x_points[instructed->num_points - 2]; + x2 = instructed->x_points[instructed->num_points - 1]; + + /* Convert the origin point to a 16.16 fixed point number. */ + outline->origin = x1 * 1024; + + /* Do the same for the advance width. */ + *advance_width = (x2 - x1) * 1024; + } else - outline->origin = 0; + { + /* Phantom points are absent from this outline, which is + impossible. */ + *advance_width = 0; + outline->origin = 0; + } if (rc) { @@ -13133,8 +13151,8 @@ sfnt_interpret_compound_glyph_1 (struct sfnt_glyph *glyph, } /* Run the program for the entire compound glyph, if any. CONTEXT - should not contain phantom points by this point, so append its - own. */ + should not contain phantom points by this point, so append the + points for this glyph as a whole. */ /* Compute phantom points. */ sfnt_compute_phantom_points (glyph, metrics, interpreter->scale, @@ -20216,6 +20234,7 @@ sfnt_verbose (struct sfnt_interpreter *interpreter) unsigned char opcode; const char *name; static unsigned int instructions; + sfnt_fixed advance; /* Build a temporary outline containing the values of the interpreter's glyph zone. */ @@ -20229,7 +20248,7 @@ sfnt_verbose (struct sfnt_interpreter *interpreter) temp.y_points = interpreter->glyph_zone->y_current; temp.flags = interpreter->glyph_zone->flags; - outline = sfnt_build_instructed_outline (&temp); + outline = sfnt_build_instructed_outline (&temp, &advance); if (!outline) return; @@ -20444,6 +20463,7 @@ main (int argc, char **argv) struct sfnt_instance *instance; struct sfnt_blend blend; struct sfnt_metrics_distortion distortion; + sfnt_fixed advance; if (argc < 2) return 1; @@ -20559,8 +20579,8 @@ main (int argc, char **argv) return 1; } -#define FANCY_PPEM 14 -#define EASY_PPEM 14 +#define FANCY_PPEM 12 +#define EASY_PPEM 12 interpreter = NULL; head = sfnt_read_head_table (fd, font); @@ -20787,6 +20807,8 @@ #define EASY_PPEM 14 if (instance && gvar) sfnt_vary_simple_glyph (&blend, code, glyph, &distortion); + else + memset (&distortion, 0, sizeof distortion); if (sfnt_lookup_glyph_metrics (code, -1, &metrics, @@ -20804,7 +20826,10 @@ #define EASY_PPEM 14 exit (5); } - outline = sfnt_build_instructed_outline (value); + outline = sfnt_build_instructed_outline (value, &advance); + advances[i] = (advance / 65536); + + fprintf (stderr, "advance: %d\n", advances[i]); if (!outline) exit (6); @@ -20819,8 +20844,6 @@ #define EASY_PPEM 14 xfree (outline); rasters[i] = raster; - advances[i] = (sfnt_mul_fixed (metrics.advance, scale) - + sfnt_mul_fixed (distortion.advance, scale)); } sfnt_x_raster (rasters, advances, length, hhea, scale); @@ -21085,7 +21108,7 @@ #define EASY_PPEM 14 fprintf (stderr, "outline origin, rbearing: %" PRIi32" %"PRIi32"\n", outline->origin, - outline->ymax - outline->origin); + outline->xmax - outline->origin); sfnt_test_max = outline->ymax - outline->ymin; for (i = 0; i < outline->outline_used; i++) @@ -21199,9 +21222,20 @@ #define FG sfnt_test_free_glyph printf ("rasterizing instructed outline\n"); if (outline) xfree (outline); - outline = sfnt_build_instructed_outline (value); + outline + = sfnt_build_instructed_outline (value, + &advance); xfree (value); +#define LB outline->xmin - outline->origin +#define RB outline->xmax - outline->origin + printf ("instructed advance, lb, rb: %g %g %g\n", + sfnt_coerce_fixed (advance), + sfnt_coerce_fixed (LB), + sfnt_coerce_fixed (RB)); +#undef LB +#undef RB + if (outline) { raster diff --git a/src/sfnt.h b/src/sfnt.h index 2ae47ad30ce..7baed372212 100644 --- a/src/sfnt.h +++ b/src/sfnt.h @@ -2102,7 +2102,7 @@ #define PROTOTYPE \ #undef PROTOTYPE -#define PROTOTYPE struct sfnt_instructed_outline * +#define PROTOTYPE struct sfnt_instructed_outline *, sfnt_fixed * extern struct sfnt_glyph_outline *sfnt_build_instructed_outline (PROTOTYPE); diff --git a/src/sfntfont.c b/src/sfntfont.c index cecdbeafb8d..078fe6083a6 100644 --- a/src/sfntfont.c +++ b/src/sfntfont.c @@ -2182,6 +2182,7 @@ sfntfont_get_glyph_outline (sfnt_glyph glyph_code, const char *error; struct sfnt_glyph_metrics temp; struct sfnt_metrics_distortion distortion; + sfnt_fixed advance; start = cache->next; distortion.advance = 0; @@ -2284,23 +2285,52 @@ sfntfont_get_glyph_outline (sfnt_glyph glyph_code, if (!error) { - outline = sfnt_build_instructed_outline (value); + /* Now record the advance with that measured from the + phantom points within the instructed glyph outline, and + subsequently replace it once metrics are scaled. */ + + outline = sfnt_build_instructed_outline (value, + &advance); xfree (value); + + if (outline) + { + /* Save the new advance width. */ + temp.advance = advance; + + /* Finally, adjust the left side bearing of the glyph + metrics by the origin point of the outline, should a + transformation have been applied by either + instruction code or glyph variation. The left side + bearing is the distance from the origin point to the + left most point on the X axis. */ + temp.lbearing = outline->xmin - outline->origin; + } } } if (!outline) - outline = sfnt_build_glyph_outline (glyph, scale, - &temp, - sfntfont_get_glyph, - sfntfont_free_glyph, - sfntfont_get_metrics, - &dcontext); - - /* At this point, the glyph metrics are unscaled. Scale them up. - If INTERPRETER is set, use the scale placed within. */ - - sfnt_scale_metrics (&temp, scale); + { + outline = sfnt_build_glyph_outline (glyph, scale, + &temp, + sfntfont_get_glyph, + sfntfont_free_glyph, + sfntfont_get_metrics, + &dcontext); + + /* At this point, the glyph metrics are unscaled. Scale them + up. If INTERPRETER is set, use the scale placed within. */ + sfnt_scale_metrics (&temp, scale); + + /* Finally, adjust the left side bearing of the glyph metrics by + the origin point of the outline, should a transformation have + been applied by either instruction code or glyph variation. + The left side bearing is the distance from the origin point + to the left most point on the X axis. */ + + if (index != -1) + temp.lbearing = outline->xmin - outline->origin; + } fail: @@ -2309,13 +2339,6 @@ sfntfont_get_glyph_outline (sfnt_glyph glyph_code, if (!outline) return NULL; - if (index != -1) - /* Finally, adjust the left side bearing of the glyph metrics by - the origin point of the outline, should a distortion have been - applied. The left side bearing is the distance from the origin - point to the left most point on the X axis. */ - temp.lbearing = outline->xmin - outline->origin; - start = xmalloc (sizeof *start); start->glyph = glyph_code; start->outline = outline; @@ -2625,16 +2648,23 @@ sfntfont_lookup_glyph (struct sfnt_font_info *font_info, int c) return glyph; } +static int sfntfont_measure_pcm (struct sfnt_font_info *, sfnt_glyph, + struct font_metrics *); + /* Probe and set FONT_INFO->font.average_width, FONT_INFO->font.space_width, and FONT_INFO->font.min_width - according to the tables contained therein. */ + according to the tables contained therein. + + As this function generates outlines for all glyphs, outlines for + all ASCII characters will be entered into the outline cache as + well. */ static void sfntfont_probe_widths (struct sfnt_font_info *font_info) { int i, num_characters, total_width; sfnt_glyph glyph; - struct sfnt_glyph_metrics metrics; + struct font_metrics pcm; num_characters = 0; total_width = 0; @@ -2653,29 +2683,27 @@ sfntfont_probe_widths (struct sfnt_font_info *font_info) if (!glyph) continue; - /* Now look up the metrics of this glyph. */ - if (sfnt_lookup_glyph_metrics (glyph, font_info->font.pixel_size, - &metrics, font_info->hmtx, - font_info->hhea, font_info->head, - font_info->maxp)) + /* Now look up the metrics of this glyph. Data from the metrics + table doesn't fit the bill, since variations and instruction + code is not applied to it. */ + if (sfntfont_measure_pcm (font_info, glyph, &pcm)) continue; /* Increase the number of characters. */ num_characters++; /* Add the advance to total_width. */ - total_width += SFNT_CEIL_FIXED (metrics.advance) / 65536; + total_width += pcm.width; /* Update min_width if it hasn't been set yet or is wider. */ if (font_info->font.min_width == 1 - || font_info->font.min_width > metrics.advance / 65536) - font_info->font.min_width = metrics.advance / 65536; + || font_info->font.min_width > pcm.width) + font_info->font.min_width = pcm.width; /* If i is the space character, set the space width. Make sure to round this up. */ if (i == 32) - font_info->font.space_width - = SFNT_CEIL_FIXED (metrics.advance) / 65536; + font_info->font.space_width = pcm.width; } /* Now, if characters were found, set average_width. */ @@ -3263,9 +3291,6 @@ sfntfont_open (struct frame *f, Lisp_Object font_entity, ASET (font_object, FONT_ADSTYLE_INDEX, Qnil); - /* Find out the minimum, maximum and average widths. */ - sfntfont_probe_widths (font_info); - /* Clear various offsets. */ font_info->font.baseline_offset = 0; font_info->font.relative_compose = 0; @@ -3355,6 +3380,10 @@ sfntfont_open (struct frame *f, Lisp_Object font_entity, } cancel_blend: + + /* Find out the minimum, maximum and average widths. */ + sfntfont_probe_widths (font_info); + /* Calculate the xfld name. */ font->props[FONT_NAME_INDEX] = Ffont_xlfd_name (font_object, Qnil, Qt); @@ -3468,7 +3497,7 @@ sfntfont_measure_pcm (struct sfnt_font_info *font, sfnt_glyph glyph, if (!outline) return 1; - /* Round the left side bearing downwards. */ + /* Round the left side bearing down. */ pcm->lbearing = SFNT_FLOOR_FIXED (metrics.lbearing) / 65536; pcm->rbearing = SFNT_CEIL_FIXED (outline->xmax) / 65536; commit e84493eae91f9d94902844ef6e8fb296bde72ca7 Author: Stefan Kangas Date: Sat Dec 23 01:50:18 2023 +0100 Drop footer line warning for packages requiring Emacs 30.1 The reason for warning about a missing footer line (";;; foo.el ends here") is that package.el up until version 27.1 would refuse to install a package without it. Emacs 27.1 or later will install such packages, but will issue a warning, the purpose of which is to encourage package authors not to break backwards-compatibility. However, if the minimum required Emacs version for a package is 30.1, we do not need to worry about compatibility with earlier versions of Emacs -- the package author has already explicitly said that the package will not work on earlier versions. For such packages, there is no need to warn about a missing footer line. In the future, this warning could be removed, but it is premature to do that now. (See Bug#26490.) Thus, for packages that does not specify a minimum version of Emacs, we continue to issue the warning. We will also continue to warn for packages requiring Emacs 27 to 29, since those versions will themselves warn if the footer is missing. * lisp/emacs-lisp/package.el (package-buffer-info): Don't warn if the footer line is missing for packages requiring Emacs 30.1 or later. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 0e21f57fc3f..1434db3d1f4 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1173,8 +1173,14 @@ package-buffer-info ;; requirement for a "footer line" without unduly impacting users ;; on earlier Emacs versions. See Bug#26490 for more details. (unless (search-forward (concat ";;; " file-name ".el ends here") nil 'move) - (lwarn '(package package-format) :warning - "Package lacks a terminating comment")) + ;; Starting in Emacs 30.1, avoid warning if the minimum Emacs + ;; version is specified as 30.1 or later. + (let ((min-emacs (cadar (seq-filter (lambda (x) (eq (car x) 'emacs)) + (lm-package-requires))))) + (when (or (null min-emacs) + (version< min-emacs "30.1")) + (lwarn '(package package-format) :warning + "Package lacks a terminating comment")))) ;; Try to include a trailing newline. (forward-line) (narrow-to-region start (point)) commit bb5399e3cd75450db6db9b3c5829f7bd87ca1308 Author: Stefan Kangas Date: Fri Dec 22 23:41:36 2023 +0100 Introduce new function lm-package-requires * lisp/emacs-lisp/package.el (package--prepare-dependencies): Move from here... * lisp/emacs-lisp/lisp-mnt.el (lm--prepare-package-dependencies): ...to here. (lm-package-requires): New function. (package-buffer-info): Use above new function. * test/lisp/emacs-lisp/lisp-mnt-tests.el (lm--tests-lm-package-requires): New test. diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index cb7cff43555..2c7c6816e9c 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -434,6 +434,38 @@ lm-version header-max t) (match-string-no-properties 1))))))) +(defun lm--prepare-package-dependencies (deps) + "Turn DEPS into an acceptable list of dependencies. + +Any parts missing a version string get a default version string +of \"0\" (meaning any version) and an appropriate level of lists +is wrapped around any parts requiring it." + (cond + ((not (listp deps)) + (error "Invalid requirement specifier: %S" deps)) + (t (mapcar (lambda (dep) + (cond + ((symbolp dep) `(,dep "0")) + ((stringp dep) + (error "Invalid requirement specifier: %S" dep)) + ((and (listp dep) (null (cdr dep))) + (list (car dep) "0")) + (t dep))) + deps)))) + +(declare-function package-read-from-string "package" (str)) + +(defun lm-package-requires (&optional file) + "Return dependencies listed in file FILE, or current buffer if FILE is nil. +The return value is a list of elements of the form (PACKAGE VERSION) +where PACKAGE is the package name (a symbol) and VERSION is the +package version (a string)." + (require 'package) + (lm-with-file file + (and-let* ((require-lines (lm-header-multiline "package-requires"))) + (lm--prepare-package-dependencies + (package-read-from-string (mapconcat #'identity require-lines " ")))))) + (defun lm-keywords (&optional file) "Return the keywords given in file FILE, or current buffer if FILE is nil. The return is a `downcase'-ed string, or nil if no keywords diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index bed6e74c921..0e21f57fc3f 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1149,27 +1149,8 @@ package-read-from-string (error "Can't read whole string")) (end-of-file expr)))) -(defun package--prepare-dependencies (deps) - "Turn DEPS into an acceptable list of dependencies. - -Any parts missing a version string get a default version string -of \"0\" (meaning any version) and an appropriate level of lists -is wrapped around any parts requiring it." - (cond - ((not (listp deps)) - (error "Invalid requirement specifier: %S" deps)) - (t (mapcar (lambda (dep) - (cond - ((symbolp dep) `(,dep "0")) - ((stringp dep) - (error "Invalid requirement specifier: %S" dep)) - ((and (listp dep) (null (cdr dep))) - (list (car dep) "0")) - (t dep))) - deps)))) - (declare-function lm-header "lisp-mnt" (header)) -(declare-function lm-header-multiline "lisp-mnt" (header)) +(declare-function lm-package-requires "lisp-mnt" (header)) (declare-function lm-website "lisp-mnt" (&optional file)) (declare-function lm-keywords-list "lisp-mnt" (&optional file)) (declare-function lm-maintainers "lisp-mnt" (&optional file)) @@ -1212,9 +1193,7 @@ package-buffer-info (error "Package lacks a \"Version\" or \"Package-Version\" header"))) (package-desc-from-define file-name pkg-version desc - (and-let* ((require-lines (lm-header-multiline "package-requires"))) - (package--prepare-dependencies - (package-read-from-string (mapconcat #'identity require-lines " ")))) + (lm-package-requires) :kind 'single :url website :keywords keywords diff --git a/test/lisp/emacs-lisp/lisp-mnt-tests.el b/test/lisp/emacs-lisp/lisp-mnt-tests.el index c056761f0f9..1418abf221f 100644 --- a/test/lisp/emacs-lisp/lisp-mnt-tests.el +++ b/test/lisp/emacs-lisp/lisp-mnt-tests.el @@ -30,6 +30,26 @@ lm--tests-crack-address '(("Bob Weiner" . "rsw@gnu.org") ("Mats Lidell" . "matsl@gnu.org"))))) +(ert-deftest lm--tests-lm-package-requires () + (with-temp-buffer + (insert ";; Package-Requires: ((emacs 29.1))") + (should (equal (lm-package-requires) '((emacs 29.1))))) + (with-temp-buffer + (insert ";; Package-Requires: ((emacs \"26.3\") (jsonrpc \"1.0.16\") (flymake \"1.2.1\") (project \"0.9.8\") (xref \"1.6.2\") (eldoc \"1.14.0\") (seq \"2.23\") (external-completion \"0.1\"))") + (should (equal (lm-package-requires) + '((emacs "26.3") (jsonrpc "1.0.16") (flymake "1.2.1") + (project "0.9.8") (xref "1.6.2") (eldoc "1.14.0") + (seq "2.23") (external-completion "0.1"))))) + (with-temp-buffer + (insert ";; Package-Requires: ((emacs \"26.3\") (jsonrpc \"1.0.16\") (flymake \"1.2.1\")\n" + ";; (project \"0.9.8\") (xref \"1.6.2\") (eldoc \"1.14.0\")\n" + ";; (seq \"2.23\") (external-completion \"0.1\"))") + (should (equal (lm-package-requires) + '((emacs "26.3") (jsonrpc "1.0.16") (flymake "1.2.1") + (project "0.9.8") (xref "1.6.2") (eldoc "1.14.0") + (seq "2.23") (external-completion "0.1")))))) + + (ert-deftest lm--tests-lm-website () (with-temp-buffer (insert ";; URL: https://example.org/foo") commit 9cb85e950dac77b59d48d320c7d40689d019aad4 Author: João Távora Date: Fri Dec 22 17:53:23 2023 -0600 Eglot: declare eglot-lsp-context bound to non-nil Otherwise, it'll be really hard to use it in the recommended fashion: (defun my/project-find-function (dir) (when-let ((match (and (bound-and-true-p eglot-lsp-context) (locate-dominating-file dir "some-marker-file")))) `(transient . ,match))) (add-hook 'project-find-functions #'my/project-find-function) because 'bound-and-true-p' will never return t even when the hook is called from eglot--current-project. Github-reference: https://github.com/joaotavora/eglot/discussions/1336 Github-reference: https://github.com/joaotavora/eglot/discussions/1337 * lisp/progmodes/eglot.el (eglot-lsp-context): Declare normally. diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index c849ff5c37e..fc26e8fabbf 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -1289,9 +1289,8 @@ eglot--guess-contact guess))) (list managed-modes (eglot--current-project) class contact language-ids))) -(defvar eglot-lsp-context) -(put 'eglot-lsp-context 'variable-documentation - "Dynamically non-nil when searching for projects in LSP context.") +(defvar eglot-lsp-context nil + "Dynamically non-nil when searching for projects in LSP context.") (defun eglot--current-project () "Return a project object for Eglot's LSP purposes. commit 9c86dd52475e0ad65359bc964fbe0d62b9d3e464 Author: Michael Albinus Date: Fri Dec 22 19:58:32 2023 +0100 Tramp's direct asynchronous processes use 'tramp-remote-path' * doc/misc/tramp.texi (Remote processes): Remove item about tramp-remote-path. * etc/NEWS: Direct asynchronous processes use 'tramp-remote-path'. * lisp/net/tramp-sh.el (tramp-get-remote-pipe-buf): New defun. (tramp-set-remote-path): Use it. (tramp-get-remote-path): Add ;;;###tramp-autoload cookie. * lisp/net/tramp.el (tramp-handle-make-process): Use `tramp-remote-path' for setting PATH environment. * test/lisp/net/tramp-tests.el (tramp-test35-exec-path-direct-async) (tramp-test35-remote-path-direct-async): New tests. diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 7a95a6dbc98..4eeb75b664d 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -4406,9 +4406,6 @@ Remote processes @item It does not set process property @code{remote-pid}. - -@item -It does not use @code{tramp-remote-path}. @end itemize In order to gain even more performance, it is recommended to bind diff --git a/etc/NEWS b/etc/NEWS index b39dd5f5ab6..03218d08d80 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -78,7 +78,7 @@ removed, as it was considered more dangerous than useful. RFC 9110 'url-personal-mail-address' is now also obsolete. To send an email address in the header of individual HTTP requests, -see the variable `url-request-extra-headers'. +see the variable 'url-request-extra-headers'. * Changes in Emacs 30.1 @@ -809,6 +809,11 @@ buffer must either visit a file, or it must run 'dired-mode'. Another method but "sudo" can be configured with user option 'tramp-file-name-with-method'. +--- +*** Direct asynchronous processes use 'tramp-remote-path'. +When a direct asynchronous process is invoked, it uses 'tramp-remote-path' +for setting the remote PATH environment variable. + ** File Notifications +++ diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index a7ead1f2997..064045584ae 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -4175,18 +4175,6 @@ tramp-find-executable ;; On hydra.nixos.org, the $PATH environment variable is too long to ;; send it. This is likely not due to PATH_MAX, but PIPE_BUF. We ;; check it, and use a temporary file in case of. See Bug#33781. - -;; The PIPE_BUF in POSIX [1] can be as low as 512 [2]. Here are the values -;; on various platforms: -;; - 512 on macOS, FreeBSD, NetBSD, OpenBSD, MirBSD, native Windows. -;; - 4 KiB on Linux, OSF/1, Cygwin, Haiku. -;; - 5 KiB on Solaris. -;; - 8 KiB on HP-UX, Plan9. -;; - 10 KiB on IRIX. -;; - 32 KiB on AIX, Minix. -;; [1] https://pubs.opengroup.org/onlinepubs/9699919799/functions/write.html -;; [2] https://pubs.opengroup.org/onlinepubs/9699919799/basedefs/limits.h.html -;; See Bug#65324. (defun tramp-set-remote-path (vec) "Set the remote environment PATH to existing directories. I.e., for each directory in `tramp-remote-path', it is tested @@ -4196,13 +4184,7 @@ tramp-set-remote-path (format "PATH=%s && export PATH" (string-join (tramp-get-remote-path vec) ":"))) - (pipe-buf - (with-tramp-connection-property vec "pipe-buf" - (tramp-send-command-and-read - vec - (format "getconf PIPE_BUF / 2>%s || echo 4096" - (tramp-get-remote-null-device vec)) - 'noerror))) + (pipe-buf (tramp-get-remote-pipe-buf vec)) tmpfile chunk chunksize) (tramp-message vec 5 "Setting $PATH environment variable") (if (tramp-compat-length< command pipe-buf) @@ -5597,6 +5579,7 @@ tramp-check-remote-uname "Check whether REGEXP matches the connection property \"uname\"." (string-match-p regexp (tramp-get-connection-property vec "uname" ""))) +;;;###tramp-autoload (defun tramp-get-remote-path (vec) "Compile list of remote directories for PATH. Nonexistent directories are removed from spec." @@ -5680,6 +5663,27 @@ tramp-get-remote-path (lambda (x) (not (tramp-get-file-property vec x "file-directory-p"))) remote-path)))))) +;; The PIPE_BUF in POSIX [1] can be as low as 512 [2]. Here are the values +;; on various platforms: +;; - 512 on macOS, FreeBSD, NetBSD, OpenBSD, MirBSD, native Windows. +;; - 4 KiB on Linux, OSF/1, Cygwin, Haiku. +;; - 5 KiB on Solaris. +;; - 8 KiB on HP-UX, Plan9. +;; - 10 KiB on IRIX. +;; - 32 KiB on AIX, Minix. +;; [1] https://pubs.opengroup.org/onlinepubs/9699919799/functions/write.html +;; [2] https://pubs.opengroup.org/onlinepubs/9699919799/basedefs/limits.h.html +;; See Bug#65324. +;;;###tramp-autoload +(defun tramp-get-remote-pipe-buf (vec) + "Return PIPE_BUF config from the remote side." + (with-tramp-connection-property vec "pipe-buf" + (tramp-send-command-and-read + vec + (format "getconf PIPE_BUF / 2>%s || echo 4096" + (tramp-get-remote-null-device vec)) + 'noerror))) + (defun tramp-get-remote-locale (vec) "Determine remote locale, supporting UTF8 if possible." (with-tramp-connection-property vec "locale" diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 88cbfa2d88c..0207805c720 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -4849,7 +4849,12 @@ tramp-handle-make-process (unless (or (null stderr) (bufferp stderr)) (signal 'wrong-type-argument (list #'bufferp stderr))) - (let* ((buffer + ;; Check for `tramp-sh-file-name-handler', because something + ;; is different between tramp-sh.el, and tramp-adb.el or + ;; tramp-sshfs.el. + (let* ((sh-file-name-handler-p (tramp-sh-file-name-handler-p v)) + (adb-file-name-handler-p (tramp-adb-file-name-p v)) + (buffer (if buffer (get-buffer-create buffer) ;; BUFFER can be nil. We use a temporary buffer. @@ -4869,6 +4874,12 @@ tramp-handle-make-process (member elt (default-toplevel-value 'process-environment)))) (setq env (cons elt env))))) + ;; Add remote path if exists. + (env (if-let ((sh-file-name-handler-p) + (remote-path + (string-join (tramp-get-remote-path v) ":"))) + (setenv-internal env "PATH" remote-path 'keep) + env)) (env (setenv-internal env "INSIDE_EMACS" (tramp-inside-emacs) 'keep)) (env (mapcar #'tramp-shell-quote-argument (delq nil env))) @@ -4879,83 +4890,83 @@ tramp-handle-make-process (append `("cd" ,(tramp-shell-quote-argument localname) "&&" "(" "env") env `(,command ")"))) - ;; Add remote shell if needed. + ;; Add remote shell if needed. (command (if (consp (tramp-get-method-parameter v 'tramp-direct-async)) (append (tramp-get-method-parameter v 'tramp-direct-async) `(,(string-join command " "))) - command))) - - ;; Check for `tramp-sh-file-name-handler', because something - ;; is different between tramp-sh.el, and tramp-adb.el or - ;; tramp-sshfs.el. - (let* ((sh-file-name-handler-p (tramp-sh-file-name-handler-p v)) - (adb-file-name-handler-p (tramp-adb-file-name-p v)) - (login-program - (tramp-get-method-parameter v 'tramp-login-program)) - ;; We don't create the temporary file. In fact, it - ;; is just a prefix for the ControlPath option of - ;; ssh; the real temporary file has another name, and - ;; it is created and protected by ssh. It is also - ;; removed by ssh when the connection is closed. The - ;; temporary file name is cached in the main - ;; connection process, therefore we cannot use - ;; `tramp-get-connection-process'. - (tmpfile - (when sh-file-name-handler-p - (with-tramp-connection-property - (tramp-get-process v) "temp-file" - (tramp-compat-make-temp-name)))) - (options - (when sh-file-name-handler-p - (tramp-compat-funcall - 'tramp-ssh-controlmaster-options v))) - (device - (when adb-file-name-handler-p - (tramp-compat-funcall - 'tramp-adb-get-device v))) - (pta (unless (eq connection-type 'pipe) "-t")) - login-args p) - - ;; Replace `login-args' place holders. Split - ;; ControlMaster options. - (setq - login-args - (append - (flatten-tree (tramp-get-method-parameter v 'tramp-async-args)) - (flatten-tree - (mapcar - (lambda (x) (split-string x " ")) - (tramp-expand-args - v 'tramp-login-args - ?h (or host "") ?u (or user "") ?p (or port "") - ?c (format-spec (or options "") (format-spec-make ?t tmpfile)) - ?d (or device "") ?a (or pta "") ?l "")))) - p (make-process - :name name :buffer buffer - :command (append `(,login-program) login-args command) - :coding coding :noquery noquery :connection-type connection-type - :sentinel sentinel :stderr stderr)) - ;; Set filter. Prior Emacs 29.1, it doesn't work reliably - ;; to provide it as `make-process' argument when filter is - ;; t. See Bug#51177. - (when filter - (set-process-filter p filter)) - (tramp-post-process-creation p v) - ;; Query flag is overwritten in `tramp-post-process-creation', - ;; so we reset it. - (set-process-query-on-exit-flag p (null noquery)) - ;; This is needed for ssh or PuTTY based processes, and - ;; only if the respective options are set. Perhaps, the - ;; setting could be more fine-grained. - ;; (process-put p 'tramp-shared-socket t) - (process-put p 'remote-command orig-command) - (tramp-set-connection-property p "remote-command" orig-command) - (when (bufferp stderr) - (tramp-taint-remote-process-buffer stderr)) - - p)))))) + command)) + (login-program + (tramp-get-method-parameter v 'tramp-login-program)) + ;; We don't create the temporary file. In fact, it is + ;; just a prefix for the ControlPath option of ssh; the + ;; real temporary file has another name, and it is + ;; created and protected by ssh. It is also removed by + ;; ssh when the connection is closed. The temporary + ;; file name is cached in the main connection process, + ;; therefore we cannot use + ;; `tramp-get-connection-process'. + (tmpfile + (when sh-file-name-handler-p + (with-tramp-connection-property + (tramp-get-process v) "temp-file" + (tramp-compat-make-temp-name)))) + (options + (when sh-file-name-handler-p + (tramp-compat-funcall + 'tramp-ssh-controlmaster-options v))) + (device + (when adb-file-name-handler-p + (tramp-compat-funcall + 'tramp-adb-get-device v))) + (pta (unless (eq connection-type 'pipe) "-t")) + login-args p) + + ;; Command could be too long, for example due to a longish PATH. + (when (and sh-file-name-handler-p + (tramp-compat-length> + (string-join command) (tramp-get-remote-pipe-buf v))) + (signal 'error (cons "Command too long:" command))) + + ;; Replace `login-args' place holders. Split ControlMaster + ;; options. + (setq + login-args + (append + (flatten-tree (tramp-get-method-parameter v 'tramp-async-args)) + (flatten-tree + (mapcar + (lambda (x) (split-string x " ")) + (tramp-expand-args + v 'tramp-login-args + ?h (or host "") ?u (or user "") ?p (or port "") + ?c (format-spec (or options "") (format-spec-make ?t tmpfile)) + ?d (or device "") ?a (or pta "") ?l "")))) + p (make-process + :name name :buffer buffer + :command (append `(,login-program) login-args command) + :coding coding :noquery noquery :connection-type connection-type + :sentinel sentinel :stderr stderr)) + ;; Set filter. Prior Emacs 29.1, it doesn't work reliably + ;; to provide it as `make-process' argument when filter is + ;; t. See Bug#51177. + (when filter + (set-process-filter p filter)) + (tramp-post-process-creation p v) + ;; Query flag is overwritten in `tramp-post-process-creation', + ;; so we reset it. + (set-process-query-on-exit-flag p (null noquery)) + ;; This is needed for ssh or PuTTY based processes, and + ;; only if the respective options are set. Perhaps, the + ;; setting could be more fine-grained. + ;; (process-put p 'tramp-shared-socket t) + (process-put p 'remote-command orig-command) + (tramp-set-connection-property p "remote-command" orig-command) + (when (bufferp stderr) + (tramp-taint-remote-process-buffer stderr)) + + p))))) (defun tramp-handle-make-symbolic-link (_target linkname &optional _ok-if-already-exists) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 68bf928eb62..209eb1a055c 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -6347,6 +6347,8 @@ tramp-test35-exec-path ;; Cleanup. (ignore-errors (delete-file tmp-name))))) +(tramp--test-deftest-direct-async-process tramp-test35-exec-path) + ;; This test is inspired by Bug#33781. (ert-deftest tramp-test35-remote-path () "Check loooong `tramp-remote-path'." @@ -6411,6 +6413,8 @@ tramp-test35-remote-path (setq tramp-remote-path orig-tramp-remote-path) (ignore-errors (delete-directory tmp-name 'recursive))))) +(tramp--test-deftest-direct-async-process tramp-test35-remote-path) + (ert-deftest tramp-test36-vc-registered () "Check `vc-registered'." :tags '(:expensive-test) commit dceffddbfe78f3f9fd299e736ceb50a00b0fa75e Author: João Távora Date: Fri Dec 22 07:44:39 2023 -0600 Jsonrpc: clean up previous change * lisp/jsonrpc.el (jsonrpc-connection): Rework slot names. (jsonrpc-connection-receive): Rework. (jsonrpc--call-deferred): Fix typo. (jsonrpc--process-sentinel) (jsonrpc--remove): Use new slot names. (jsonrpc--continue): Rework. (jsonrpc--async-request-1): Rework. (jsonrpc--event): Remember to remove :jsonrpc-json from foreign-message (jsonrpc--connection-receive): Revamp. (jsonrpc--connection-send) (jsonrpc--connection-reply): Rework. (jsonrpc--log-event): Revamp. (jsonrpc-continuation-count): Use new slot name. diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 8951954f842..a1f8892da64 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -68,9 +68,9 @@ jsonrpc-connection :initform nil :accessor jsonrpc-last-error :documentation "Last JSONRPC error message received from endpoint.") - (-request-continuations + (-continuations :initform nil - :accessor jsonrpc--request-continuations + :accessor jsonrpc--continuations :documentation "An alist of request IDs to continuation specs.") (-events-buffer :initform nil @@ -221,7 +221,7 @@ jsonrpc-events-buffer (defun jsonrpc-forget-pending-continuations (connection) "Stop waiting for responses from the current JSONRPC CONNECTION." - (setf (jsonrpc--request-continuations connection) nil)) + (setf (jsonrpc--continuations connection) nil)) (defvar jsonrpc-inhibit-debug-on-error nil "Inhibit `debug-on-error' when answering requests. @@ -231,67 +231,96 @@ jsonrpc-inhibit-debug-on-error variable can be set around calls like `jsonrpc-request' to circumvent that.") -(defun jsonrpc-connection-receive (conn message) - "Process MESSAGE just received from CONN. +(defun jsonrpc-connection-receive (conn foreign-message) + "Process FOREIGN-MESSAGE just received from CONN. This function will destructure MESSAGE and call the appropriate dispatcher in CONN." (cl-destructuring-bind (&rest whole &key method id error params result _jsonrpc) - (jsonrpc-convert-from-endpoint conn message) + (jsonrpc-convert-from-endpoint conn foreign-message) (unwind-protect - (with-slots (last-error - (rdispatcher -request-dispatcher) - (ndispatcher -notification-dispatcher) - (sr-alist -sync-request-alist)) - conn - (setf last-error error) - (cond - (;; A remote request - (and method id) - (let* ((debug-on-error (and debug-on-error - (not jsonrpc-inhibit-debug-on-error))) - (reply - (condition-case-unless-debug _ignore - (condition-case oops - `(:result ,(funcall rdispatcher conn (intern method) - params)) - (jsonrpc-error - `(:error - (:code - ,(or (alist-get 'jsonrpc-error-code (cdr oops)) - -32603) - :message ,(or (alist-get 'jsonrpc-error-message - (cdr oops)) - "Internal error"))))) - (error - '(:error (:code -32603 :message "Internal error")))))) - (apply #'jsonrpc--reply conn id method reply))) - (;; A remote notification - method - (funcall ndispatcher conn (intern method) params)) - (id - (let ((cont - ;; remove the continuation - (jsonrpc--remove conn id))) - (pcase-let ((`(,_ ,method ,_ ,_ ,_) cont)) - (if (keywordp method) - (setq method (substring (symbol-name method) 1))) - (setq whole (plist-put whole :method method))) - (cond (;; A remote response, but it can't run yet, - ;; because there's an outstanding sync request - ;; (bug#67945) - (and sr-alist (not (eq id (caar sr-alist)))) - (push (cons cont (list result error)) - (cdr (car sr-alist)))) - (;; A remote response that can run - (jsonrpc--continue conn id cont result error))))))) - (jsonrpc--run-event-hook - conn 'server - :json (plist-get message :jsonrpc-json) - :kind (cond ((and method id) 'request) - (method 'notification) - (id 'reply)) - :message whole - :foreign-message message) + (let* ((log-plist (list :json (plist-get foreign-message :jsonrpc-json) + :kind (cond ((and method id) 'request) + (method 'notification) + (id 'reply)) + :message whole + :foreign-message foreign-message)) + (response-p (and (null method) id)) + (cont (and response-p (jsonrpc--remove conn id)))) + (cl-remf foreign-message :jsonrpc-json) + ;; Do this pre-processing of the response so we can always + ;; log richer information _before_ any non-local calls + ;; further ahead. Putting the `jsonrpc--event' as + ;; an unwind-form would make us log after the fact. + (when cont + (pcase-let ((`(,_ ,method ,_ ,_ ,_) cont)) + (if (keywordp method) + (setq method (substring (symbol-name method) 1))) + ;; TODO: also set the depth + (setq whole (plist-put whole :method method)))) + + ;; Do the logging + (apply #'jsonrpc--event conn 'server log-plist) + (with-slots (last-error + (rdispatcher -request-dispatcher) + (ndispatcher -notification-dispatcher) + (sr-alist -sync-request-alist)) + conn + (setf last-error error) + (cond + (;; A remote response whose request has been cancelled + ;; (i.e. timeout or C-g) + ;; + (and response-p (null cont)) + (jsonrpc--event + conn 'internal + :log-text + (format "Response to request %s which has been cancelled" + id) + :id id) + ;; TODO: food for thought: this seems to be also where + ;; notifying the server of the cancellation would come + ;; in. + ) + (;; A remote response that can't run yet (bug#67945) + (and response-p + (and sr-alist (not (eq id (caar sr-alist))))) + (jsonrpc--event + conn 'internal + :log-text + (format "anxious continuation to %s can't run, held up by %s" + id + (mapcar #'car sr-alist))) + (push (cons cont (list result error)) + (cdr (car sr-alist)))) + (;; A remote response that can continue now + response-p + (jsonrpc--continue conn id cont result error)) + (;; A remote request + (and method id) + (let* ((debug-on-error (and debug-on-error + (not jsonrpc-inhibit-debug-on-error))) + (reply + (condition-case-unless-debug _ignore + (condition-case oops + `(:result ,(funcall rdispatcher conn (intern method) + params)) + (jsonrpc-error + `(:error + (:code + ,(or (alist-get 'jsonrpc-error-code (cdr oops)) + -32603) + :message ,(or (alist-get 'jsonrpc-error-message + (cdr oops)) + "Internal error"))))) + (error + '(:error (:code -32603 :message "Internal error")))))) + (apply #'jsonrpc--reply conn id method reply))) + (;; A remote notification + method + (funcall ndispatcher conn (intern method) params)) + (t + (jsonrpc--event conn 'internal + :log-text "Malformed message" ))))) (jsonrpc--call-deferred conn)))) @@ -408,15 +437,18 @@ jsonrpc-request (setq canceled t)) `(canceled ,cancel-on-input-retval)) (t (while t (accept-process-output nil 30))))) - ;; In normal operation, cancellation is handled by the - ;; timeout function and response filter, but we still have - ;; to protect against user-quit (C-g) or the - ;; `cancel-on-input' case. + ;; In normal operation, continuations for error/success is + ;; handled by `jsonrpc-continue'. Timeouts also remove + ;; the continuation... (pcase-let* ((`(,id ,_) id-and-timer)) - ;; Discard the continuation + ;; ...but we still have to guard against exist explicit + ;; user-quit (C-g) or the `cancel-on-input' case, so + ;; discard the continuation. (jsonrpc--remove connection id (list deferred (current-buffer))) - ;; We still call `jsonrpc--continue' to run any - ;; "anxious" continuations. + ;; ...finally, whatever may have happened to this sync + ;; request, it might have been holding up any outer + ;; "anxious" continuations. The following ensures we + ;; cll them. (jsonrpc--continue connection id))))) (when (eq 'error (car retval)) (signal 'jsonrpc-error @@ -527,8 +559,8 @@ jsonrpc-connection-send ((stringp method) method) (t (error "[jsonrpc] invalid method %s" method)))))) (let* ((kind (cond ((or result-supplied-p error) 'reply) - (id 'request) - (method 'notification))) + (id 'request) + (method 'notification))) (converted (jsonrpc-convert-to-endpoint connection args kind)) (json (jsonrpc--json-encode converted)) (headers @@ -540,7 +572,7 @@ jsonrpc-connection-send (cl-loop for (header . value) in headers concat (concat header ": " value "\r\n") into header-section finally return (format "%s\r\n%s" header-section json))) - (jsonrpc--run-event-hook + (jsonrpc--event connection 'client :json json @@ -624,7 +656,7 @@ jsonrpc--reply (defun jsonrpc--call-deferred (connection) "Call CONNECTION's deferred actions, who may again defer themselves." (when-let ((actions (hash-table-values (jsonrpc--deferred-actions connection)))) - (jsonrpc--run-event-hook + (jsonrpc--event connection 'internal :log-text (format "re-attempting deferred requests %s" (mapcar (apply-partially #'nth 2) actions))) @@ -641,7 +673,7 @@ jsonrpc--process-sentinel ;; Cancel outstanding timers (mapc (jsonrpc-lambda (_id _method _success-fn _error-fn timer) (when timer (cancel-timer timer))) - (jsonrpc--request-continuations connection)) + (jsonrpc--continuations connection)) (maphash (lambda (_ triplet) (pcase-let ((`(,_ ,timer ,_) triplet)) (when timer (cancel-timer timer)))) @@ -651,7 +683,7 @@ jsonrpc--process-sentinel ;; Call all outstanding error handlers (mapc (jsonrpc-lambda (_id _method _success-fn error-fn _timer) (funcall error-fn '(:code -1 :message "Server died"))) - (jsonrpc--request-continuations connection)) + (jsonrpc--continuations connection)) (jsonrpc--message "Server exited with status %s" (process-exit-status proc)) (delete-process proc) (when-let (p (slot-value connection '-autoport-inferior)) (delete-process p)) @@ -746,48 +778,53 @@ jsonrpc--remove "Cancel CONN's continuations for ID, including its timer, if it exists. Also cancel \"deferred actions\" if DEFERRED-SPEC. Return the full continuation (ID SUCCESS-FN ERROR-FN TIMER)" - (with-slots ((conts -request-continuations) (defs -deferred-actions)) conn + (with-slots ((conts -continuations) (defs -deferred-actions)) conn (if deferred-spec (remhash deferred-spec defs)) (when-let ((ass (assq id conts))) (cl-destructuring-bind (_ _ _ _ timer) ass - (cancel-timer timer)) + (cancel-timer timer)) (setf conts (delete ass conts)) ass))) (defun jsonrpc--schedule (conn id method success-fn error-fn timer) (push (list id method success-fn error-fn timer) - (jsonrpc--request-continuations conn))) + (jsonrpc--continuations conn))) (defun jsonrpc--continue (conn id &optional cont result error) (pcase-let* ((`(,cont-id ,_method ,success-fn ,error-fn ,_timer) cont) (head (pop (jsonrpc--sync-request-alist conn))) (anxious (cdr head))) - (cond (anxious - (when (not (= (car head) id)) ; sanity check - (error "internal error: please report this bug")) - ;; If there are "anxious" `jsonrpc-request' continuations - ;; that should already have been run, they should run now. - ;; The main continuation -- if it exists -- should run - ;; before them. This order is important to preserve the - ;; throw to the catch tags in `jsonrpc-request' in - ;; order (bug#67945). - (cl-flet ((later (f arg) (run-at-time 0 nil f arg))) - (when cont-id - (if error (later error-fn error) - (later success-fn result))) - (cl-loop for (acont ares aerr) in anxious - for (_id _method success-fn error-fn) = acont - if aerr do (later error-fn aerr) - else do (later success-fn ares)))) - (cont-id - ;; Else, just run the normal one, with plain funcall. - (if error (funcall error-fn error) - (funcall success-fn result))) - (t - ;; For clarity. This happens if the `jsonrpc-request' was - ;; canceled - )))) + (cond + (anxious + (when (not (= (car head) id)) ; sanity check + (error "internal error: please report this bug")) + ;; If there are "anxious" `jsonrpc-request' continuations + ;; that should already have been run, they should run now. + ;; The main continuation -- if it exists -- should run + ;; before them. This order is important to preserve the + ;; throw to the catch tags in `jsonrpc-request' in + ;; order (bug#67945). + (cl-flet ((later (f arg) (run-at-time 0 nil f arg))) + (when cont-id + (if error (later error-fn error) + (later success-fn result))) + (cl-loop + for (acont ares aerr) in anxious + for (anx-id _method success-fn error-fn) = acont + do (jsonrpc--event + conn 'internal + :log-text (format "anxious continuation to %s running now" anx-id)) + if aerr do (later error-fn aerr) + else do (later success-fn ares)))) + (cont-id + ;; Else, just run the normal one, with plain funcall. + (if error (funcall error-fn error) + (funcall success-fn result))) + (t + ;; For clarity. This happens if the `jsonrpc-request' was + ;; cancelled + )))) (cl-defun jsonrpc--async-request-1 (connection method @@ -817,20 +854,20 @@ jsonrpc--async-request-1 timeout nil (lambda () (jsonrpc--remove connection id (list deferred buf)) - (if timeout-fn (funcall timeout-fn) - (jsonrpc--run-event-hook - connection 'internal - :log-text (format "timed-out '%s' (id=%s)" method id) - :id id)))))))))) + (jsonrpc--event + connection 'internal + :log-text (format "timed-out request '%s'" method) + :id id) + (when timeout-fn (funcall timeout-fn)))))))))) (when deferred (if (jsonrpc-connection-ready-p connection deferred) ;; Server is ready, we jump below and send it immediately. (remhash (list deferred buf) (jsonrpc--deferred-actions connection)) ;; Otherwise, save in `jsonrpc--deferred-actions' and exit non-locally (unless old-id - (jsonrpc--run-event-hook + (jsonrpc--event connection 'internal - :log-text (format "deferring '%s' (id=%s)" method id) + :log-text (format "deferring request '%s'" method) :id id)) (puthash (list deferred buf) (list (lambda () @@ -858,13 +895,13 @@ jsonrpc--async-request-1 connection id method (or success-fn (lambda (&rest _ignored) - (jsonrpc--run-event-hook + (jsonrpc--event connection 'internal :log-text (format "success ignored") :id id))) (or error-fn (jsonrpc-lambda (&key code message &allow-other-keys) - (jsonrpc--run-event-hook + (jsonrpc--event connection 'internal :log-text (format "error %s ignored: %s ignored" code message) @@ -892,15 +929,20 @@ jsonrpc--warn (apply #'format format args) :warning))) -(cl-defun jsonrpc--run-event-hook (connection - origin - &rest plist - &key _kind _json _message _foreign-message _log-text - &allow-other-keys) +(cl-defun jsonrpc--event (connection + origin + &rest plist + &key _kind _json _message _foreign-message _log-text + &allow-other-keys) (with-current-buffer (jsonrpc-events-buffer connection) (run-hook-wrapped 'jsonrpc-event-hook (lambda (fn) - (apply fn connection origin plist))))) + (condition-case oops + (apply fn connection origin plist) + (error + (jsonrpc--message "event hook '%s' errored (%s). Removing it" + fn oops) + (remove-hook 'jsonrpc-event-hook fn))))))) (defvar jsonrpc-event-hook (list #'jsonrpc--log-event) "Hook run when JSON-RPC events are emitted. @@ -931,9 +973,9 @@ jsonrpc-event-hook of the API instead.") (cl-defun jsonrpc--log-event (connection origin - &key kind message + &key _kind message foreign-message log-text json - type + type ((:id ref-id)) &allow-other-keys) "Log a JSONRPC-related event. Installed in `jsonrpc-event-hook'." (let* ((props (slot-value connection '-events-buffer-config)) @@ -942,32 +984,35 @@ jsonrpc--log-event (when (or (null max) (cl-plusp max)) (cl-destructuring-bind (&key method id error &allow-other-keys) message (let* ((inhibit-read-only t) - (depth (length (jsonrpc--sync-request-alist connection))) + (depth (length + (jsonrpc--sync-request-alist connection))) + (preamble (format "[jsonrpc] %s[%s]%s " + (pcase type ('error "E") ('debug "D") + (_ (pcase origin + ('internal "i") + (_ "e")))) + (format-time-string "%H:%M:%S.%3N") + (if (eq origin 'internal) + (if ref-id (format " [%s]" ref-id) "") + (format " %s%s %s%s" + (make-string (* 2 depth) ? ) + (pcase origin + ('client "-->") + ('server "<--") + (_ "")) + (or method "") + (if id (format "[%s]" id) ""))))) (msg (cond ((eq format 'full) - (format "[jsonrpc] %s[%s]%s %s\n" - (pcase type ('error "E") ('debug "D") (_ "e")) - (format-time-string "%H:%M:%S.%3N") - (if (eq origin 'internal) - "" - (format " %s%s %s%s" - (make-string (* 2 depth) ? ) - (pcase origin - ('client "-->") - ('server "<--") - (_ "")) - (or method "") - (if id (format "(%s)" id) ""))) - (or json log-text))) + (format "%s%s\n" preamble (or json log-text))) + ((eq format 'short) + (format "%s%s\n" preamble (or log-text ""))) (t - (format "[%s]%s%s %s:\n%s" - (concat (format "%s" (or origin 'internal)) - (if origin (format "-%s" (or kind 'message)))) - (if id (format " (id:%s)" id) "") - (if error " ERROR" "") - (format-time-string "%H:%M:%S.%3N") - (if foreign-message (pp-to-string foreign-message) - log-text)))))) + (format "%s%s" preamble + (or (and foreign-message + (concat "\n" (pp-to-string + foreign-message))) + (concat log-text "\n"))))))) (goto-char (point-max)) ;; XXX: could use `run-at-time' to delay server logs ;; slightly to play nice with verbose servers' stderr. @@ -976,13 +1021,13 @@ jsonrpc--log-event (insert-before-markers msg) ;; Trim the buffer if it's too large (when max - (save-excursion - (goto-char (point-min)) - (while (> (buffer-size) max) - (delete-region (point) (progn (forward-line 1) - (forward-sexp 1) - (forward-line 2) - (point))))))))))) + (save-excursion + (goto-char (point-min)) + (while (> (buffer-size) max) + (delete-region (point) (progn (forward-line 1) + (forward-sexp 1) + (forward-line 2) + (point))))))))))) (defun jsonrpc--forwarding-buffer (name prefix conn) "Helper for `jsonrpc-process-connection' helpers. @@ -1092,7 +1137,7 @@ jsonrpc-autoport-bootstrap (defun jsonrpc-continuation-count (conn) "Number of outstanding continuations for CONN." - (length (jsonrpc--request-continuations conn))) + (length (jsonrpc--continuations conn))) (provide 'jsonrpc) ;;; jsonrpc.el ends here commit 27d23958793b5b97dc7d9606c692972410f51c8b Author: Stefan Kangas Date: Fri Dec 22 17:14:09 2023 +0100 ; Fix typos diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 453452b4520..8951954f842 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -626,7 +626,7 @@ jsonrpc--call-deferred (when-let ((actions (hash-table-values (jsonrpc--deferred-actions connection)))) (jsonrpc--run-event-hook connection 'internal - :log-text (format "re-attempting deffered requests %s" + :log-text (format "re-attempting deferred requests %s" (mapcar (apply-partially #'nth 2) actions))) (mapc #'funcall (mapcar #'car actions)))) @@ -786,7 +786,7 @@ jsonrpc--continue (funcall success-fn result))) (t ;; For clarity. This happens if the `jsonrpc-request' was - ;; cancelled + ;; canceled )))) (cl-defun jsonrpc--async-request-1 (connection commit 9370bc9d1a10e67d4ac0d79e31b4abab8427d752 Author: Mattias Engdegård Date: Fri Dec 22 15:46:45 2023 +0100 Remove byte-compile-form-stack backstop * lisp/emacs-lisp/cconv.el (cconv-closure-convert): Eliminate a binding that probably isn't useful after all. diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 1c9b7fc6730..42bddbb8352 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -123,8 +123,7 @@ cconv-closure-convert Returns a form where all lambdas don't have any free variables." (let ((cconv--dynbound-variables dynbound-vars) (cconv-freevars-alist '()) - (cconv-var-classification '()) - (byte-compile-form-stack byte-compile-form-stack)) + (cconv-var-classification '())) ;; Analyze form - fill these variables with new information. (cconv-analyze-form form '()) (setq cconv-freevars-alist (nreverse cconv-freevars-alist)) commit 61190b5146abfda05d2c756af99867d6b1278f2c Author: Mattias Engdegård Date: Fri Dec 22 14:53:04 2023 +0100 * lisp/emacs-lisp/byte-opt.el (byte-compile-nilconstp): Extend list. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 5a72011c609..a9fe1d06275 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -810,8 +810,29 @@ byte-compile-nilconstp (or (not form) ; assume (quote nil) always being normalized to nil (and (consp form) (let ((head (car form))) - ;; FIXME: There are many other expressions that are statically nil. - (cond ((memq head '(while ignore)) t) + (cond ((memq head + ;; Some forms that are statically nil. + ;; FIXME: Replace with a function property? + '( while ignore + insert insert-and-inherit insert-before-markers + insert-before-markers-and-inherit + insert-char insert-byte insert-buffer-substring + delete-region delete-char + widen narrow-to-region transpose-regions + forward-char backward-char + beginning-of-line end-of-line + erase-buffer buffer-swap-text + delete-overlay delete-all-overlays + remhash + maphash + map-charset-chars map-char-table + mapbacktrace + mapatoms + ding beep sleep-for + json-insert + set-match-data + )) + t) ((eq head 'if) (and (byte-compile-nilconstp (nth 2 form)) (byte-compile-nilconstp (car (last (cdddr form)))))) commit 1ece474c69cfcf6f8ef14d54e469eb387a7a6983 Author: Mattias Engdegård Date: Tue Nov 21 11:23:57 2023 +0100 Slight funcall_subr optimisation * src/eval.c (funcall_subr): Help the compiler by reducing aliasing problems, and compensate for a missed-optimisation bug in LLVM where switches sometimes forget to use variable range information (reported in https://github.com/llvm/llvm-project/issues/76085). diff --git a/src/eval.c b/src/eval.c index 5c9052cb9ab..b3d3fc3132b 100644 --- a/src/eval.c +++ b/src/eval.c @@ -3033,21 +3033,21 @@ funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args) if (numargs >= subr->min_args) { /* Conforming call to finite-arity subr. */ - if (numargs <= subr->max_args - && subr->max_args <= 8) + ptrdiff_t maxargs = subr->max_args; + if (numargs <= maxargs && maxargs <= 8) { Lisp_Object argbuf[8]; Lisp_Object *a; - if (numargs < subr->max_args) + if (numargs < maxargs) { - eassume (subr->max_args <= ARRAYELTS (argbuf)); + eassume (maxargs <= ARRAYELTS (argbuf)); a = argbuf; memcpy (a, args, numargs * word_size); - memclear (a + numargs, (subr->max_args - numargs) * word_size); + memclear (a + numargs, (maxargs - numargs) * word_size); } else a = args; - switch (subr->max_args) + switch (maxargs) { case 0: return subr->function.a0 (); @@ -3069,14 +3069,12 @@ funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args) case 8: return subr->function.a8 (a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7]); - default: - emacs_abort (); /* Can't happen. */ } + eassume (false); /* In case the compiler is too stupid. */ } /* Call to n-adic subr. */ - if (subr->max_args == MANY - || subr->max_args > 8) + if (maxargs == MANY || maxargs > 8) return subr->function.aMANY (numargs, args); } commit c638a40d88f6ca105babbf9078b086491b649797 Author: Mattias Engdegård Date: Thu Dec 21 18:56:04 2023 +0100 Ensure proper mode of *Compile-Log* buffer (bug#67920) Reported by OGAWA Hirofumi. * lisp/emacs-lisp/bytecomp.el (displaying-byte-compile-warnings): Move most of the innards to... (bytecomp--displaying-warnings): ...this new function, for ease of maintenance. * lisp/emacs-lisp/bytecomp.el (byte-compile-file): Wrap early warning about missing lexbind declaration in `displaying-byte-compile-warnings` so that it doesn't cause the creation of a compile-log buffer with the wrong mode. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index d2f1e6886ef..6c5051d70c4 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1876,35 +1876,37 @@ byte-compile-close-variables (defmacro displaying-byte-compile-warnings (&rest body) (declare (debug (def-body))) - `(let* ((--displaying-byte-compile-warnings-fn (lambda () ,@body)) - (warning-series-started - (and (markerp warning-series) - (eq (marker-buffer warning-series) - (get-buffer byte-compile-log-buffer)))) - (byte-compile-form-stack byte-compile-form-stack)) - (if (or (eq warning-series 'byte-compile-warning-series) - warning-series-started) - ;; warning-series does come from compilation, - ;; so don't bind it, but maybe do set it. - (let (tem) - ;; Log the file name. Record position of that text. - (setq tem (byte-compile-log-file)) - (unless warning-series-started - (setq warning-series (or tem 'byte-compile-warning-series))) - (if byte-compile-debug - (funcall --displaying-byte-compile-warnings-fn) - (condition-case error-info - (funcall --displaying-byte-compile-warnings-fn) - (error (byte-compile-report-error error-info))))) - ;; warning-series does not come from compilation, so bind it. - (let ((warning-series - ;; Log the file name. Record position of that text. - (or (byte-compile-log-file) 'byte-compile-warning-series))) - (if byte-compile-debug - (funcall --displaying-byte-compile-warnings-fn) - (condition-case error-info - (funcall --displaying-byte-compile-warnings-fn) - (error (byte-compile-report-error error-info)))))))) + `(bytecomp--displaying-warnings (lambda () ,@body))) + +(defun bytecomp--displaying-warnings (body-fn) + (let* ((warning-series-started + (and (markerp warning-series) + (eq (marker-buffer warning-series) + (get-buffer byte-compile-log-buffer)))) + (byte-compile-form-stack byte-compile-form-stack)) + (if (or (eq warning-series 'byte-compile-warning-series) + warning-series-started) + ;; warning-series does come from compilation, + ;; so don't bind it, but maybe do set it. + (let (tem) + ;; Log the file name. Record position of that text. + (setq tem (byte-compile-log-file)) + (unless warning-series-started + (setq warning-series (or tem 'byte-compile-warning-series))) + (if byte-compile-debug + (funcall body-fn) + (condition-case error-info + (funcall body-fn) + (error (byte-compile-report-error error-info))))) + ;; warning-series does not come from compilation, so bind it. + (let ((warning-series + ;; Log the file name. Record position of that text. + (or (byte-compile-log-file) 'byte-compile-warning-series))) + (if byte-compile-debug + (funcall body-fn) + (condition-case error-info + (funcall body-fn) + (error (byte-compile-report-error error-info)))))))) ;;;###autoload (defun byte-force-recompile (directory) @@ -2202,9 +2204,10 @@ byte-compile-file ;; Don't inherit lexical-binding from caller (bug#12938). (unless (local-variable-p 'lexical-binding) (let ((byte-compile-current-buffer (current-buffer))) - (byte-compile-warn-x - (position-symbol 'a (point-min)) - "file has no `lexical-binding' directive on its first line")) + (displaying-byte-compile-warnings + (byte-compile-warn-x + (position-symbol 'a (point-min)) + "file has no `lexical-binding' directive on its first line"))) (setq-local lexical-binding nil)) ;; Set the default directory, in case an eval-when-compile uses it. (setq default-directory (file-name-directory filename))) commit 9db1fe638ecfdd2d8dd32e3ee47f97c5ed3312c1 Author: Mattias Engdegård Date: Thu Dec 21 13:33:27 2023 +0100 Encapsulate byte-compile-form-stack maintenance * lisp/emacs-lisp/bytecomp.el (byte-compile-toplevel-file-form) (byte-compile-form): * lisp/emacs-lisp/macroexp.el (macroexp--expand-all): Use `macroexp--with-extended-form-stack` instead of explicit push and pop. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 950ae77803c..d2f1e6886ef 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2663,16 +2663,12 @@ byte-compile-preprocess ;; byte-hunk-handlers cannot call this! (defun byte-compile-toplevel-file-form (top-level-form) - ;; (let ((byte-compile-form-stack - ;; (cons top-level-form byte-compile-form-stack))) - (push top-level-form byte-compile-form-stack) - (prog1 - (byte-compile-recurse-toplevel - top-level-form - (lambda (form) - (let ((byte-compile-current-form nil)) ; close over this for warnings. - (byte-compile-file-form (byte-compile-preprocess form t))))) - (pop byte-compile-form-stack))) + (macroexp--with-extended-form-stack top-level-form + (byte-compile-recurse-toplevel + top-level-form + (lambda (form) + (let ((byte-compile-current-form nil)) ; close over this for warnings. + (byte-compile-file-form (byte-compile-preprocess form t))))))) ;; byte-hunk-handlers can call this. (defun byte-compile-file-form (form) @@ -3483,122 +3479,121 @@ byte-compile-macroexpand-declare-function ;; (defun byte-compile-form (form &optional for-effect) (let ((byte-compile--for-effect for-effect)) - (push form byte-compile-form-stack) - (cond - ((not (consp form)) - (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) - (byte-compile-constant form)) - ((and byte-compile--for-effect byte-compile-delete-errors) - (setq byte-compile--for-effect nil)) - (t (byte-compile-variable-ref form)))) - ((symbolp (car form)) - (let* ((fn (car form)) - (handler (get fn 'byte-compile)) - (interactive-only - (or (function-get fn 'interactive-only) - (memq fn byte-compile-interactive-only-functions)))) - (when (memq fn '(set symbol-value run-hooks ;; add-to-list - add-hook remove-hook run-hook-with-args - run-hook-with-args-until-success - run-hook-with-args-until-failure)) - (pcase (cdr form) - (`(',var . ,_) - (when (and (memq var byte-compile-lexical-variables) - (byte-compile-warning-enabled-p 'lexical var)) - (byte-compile-warn - (format-message "%s cannot use lexical var `%s'" fn var)))))) - ;; Warn about using obsolete hooks. - (if (memq fn '(add-hook remove-hook)) - (let ((hook (car-safe (cdr form)))) - (if (eq (car-safe hook) 'quote) - (byte-compile-check-variable (cadr hook) nil)))) - (when (and (byte-compile-warning-enabled-p 'suspicious) - (macroexp--const-symbol-p fn)) - (byte-compile-warn-x fn "`%s' called as a function" fn)) - (when (and (byte-compile-warning-enabled-p 'interactive-only fn) - interactive-only) - (byte-compile-warn-x fn "`%s' is for interactive use only%s" - fn - (cond ((stringp interactive-only) - (format "; %s" - (substitute-command-keys - interactive-only))) - ((and (symbolp interactive-only) - (not (eq interactive-only t))) - (format-message "; use `%s' instead." - interactive-only)) - (t ".")))) - (let ((mutargs (function-get (car form) 'mutates-arguments))) - (when mutargs - (dolist (idx (if (eq mutargs 'all-but-last) - (number-sequence 1 (- (length form) 2)) - mutargs)) - (let ((arg (nth idx form))) - (when (and (or (and (eq (car-safe arg) 'quote) - (consp (nth 1 arg))) - (arrayp arg)) - (byte-compile-warning-enabled-p - 'mutate-constant (car form))) - (byte-compile-warn-x form "`%s' on constant %s (arg %d)" - (car form) - (if (consp arg) "list" (type-of arg)) - idx)))))) - - (let ((funargs (function-get (car form) 'funarg-positions))) - (dolist (funarg funargs) - (let ((arg (if (numberp funarg) - (nth funarg form) - (cadr (memq funarg form))))) - (when (and (eq 'quote (car-safe arg)) - (eq 'lambda (car-safe (cadr arg)))) + (macroexp--with-extended-form-stack form + (cond + ((not (consp form)) + (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) + (byte-compile-constant form)) + ((and byte-compile--for-effect byte-compile-delete-errors) + (setq byte-compile--for-effect nil)) + (t (byte-compile-variable-ref form)))) + ((symbolp (car form)) + (let* ((fn (car form)) + (handler (get fn 'byte-compile)) + (interactive-only + (or (function-get fn 'interactive-only) + (memq fn byte-compile-interactive-only-functions)))) + (when (memq fn '(set symbol-value run-hooks ;; add-to-list + add-hook remove-hook run-hook-with-args + run-hook-with-args-until-success + run-hook-with-args-until-failure)) + (pcase (cdr form) + (`(',var . ,_) + (when (and (memq var byte-compile-lexical-variables) + (byte-compile-warning-enabled-p 'lexical var)) + (byte-compile-warn + (format-message "%s cannot use lexical var `%s'" fn var)))))) + ;; Warn about using obsolete hooks. + (if (memq fn '(add-hook remove-hook)) + (let ((hook (car-safe (cdr form)))) + (if (eq (car-safe hook) 'quote) + (byte-compile-check-variable (cadr hook) nil)))) + (when (and (byte-compile-warning-enabled-p 'suspicious) + (macroexp--const-symbol-p fn)) + (byte-compile-warn-x fn "`%s' called as a function" fn)) + (when (and (byte-compile-warning-enabled-p 'interactive-only fn) + interactive-only) + (byte-compile-warn-x fn "`%s' is for interactive use only%s" + fn + (cond ((stringp interactive-only) + (format "; %s" + (substitute-command-keys + interactive-only))) + ((and (symbolp interactive-only) + (not (eq interactive-only t))) + (format-message "; use `%s' instead." + interactive-only)) + (t ".")))) + (let ((mutargs (function-get (car form) 'mutates-arguments))) + (when mutargs + (dolist (idx (if (eq mutargs 'all-but-last) + (number-sequence 1 (- (length form) 2)) + mutargs)) + (let ((arg (nth idx form))) + (when (and (or (and (eq (car-safe arg) 'quote) + (consp (nth 1 arg))) + (arrayp arg)) + (byte-compile-warning-enabled-p + 'mutate-constant (car form))) + (byte-compile-warn-x form "`%s' on constant %s (arg %d)" + (car form) + (if (consp arg) "list" (type-of arg)) + idx)))))) + + (let ((funargs (function-get (car form) 'funarg-positions))) + (dolist (funarg funargs) + (let ((arg (if (numberp funarg) + (nth funarg form) + (cadr (memq funarg form))))) + (when (and (eq 'quote (car-safe arg)) + (eq 'lambda (car-safe (cadr arg)))) + (byte-compile-warn-x + arg "(lambda %s ...) quoted with %s rather than with #%s" + (or (nth 1 (cadr arg)) "()") + "'" "'"))))) ; avoid styled quotes + + (if (eq (car-safe (symbol-function (car form))) 'macro) + (byte-compile-report-error + (format-message "`%s' defined after use in %S (missing `require' of a library file?)" + (car form) form))) + + (when byte-compile--for-effect + (let ((sef (function-get (car form) 'side-effect-free))) + (cond + ((and sef (or (eq sef 'error-free) + byte-compile-delete-errors)) + ;; This transform is normally done in the Lisp optimizer, + ;; so maybe we don't need to bother about it here? + (setq form (cons 'progn (cdr form))) + (setq handler #'byte-compile-progn)) + ((and (or sef (function-get (car form) 'important-return-value)) + ;; Don't warn for arguments to `ignore'. + (not (eq byte-compile--for-effect 'for-effect-no-warn)) + (byte-compile-warning-enabled-p + 'ignored-return-value (car form))) (byte-compile-warn-x - arg "(lambda %s ...) quoted with %s rather than with #%s" - (or (nth 1 (cadr arg)) "()") - "'" "'"))))) ; avoid styled quotes - - (if (eq (car-safe (symbol-function (car form))) 'macro) - (byte-compile-report-error - (format-message "`%s' defined after use in %S (missing `require' of a library file?)" - (car form) form))) - - (when byte-compile--for-effect - (let ((sef (function-get (car form) 'side-effect-free))) - (cond - ((and sef (or (eq sef 'error-free) - byte-compile-delete-errors)) - ;; This transform is normally done in the Lisp optimizer, - ;; so maybe we don't need to bother about it here? - (setq form (cons 'progn (cdr form))) - (setq handler #'byte-compile-progn)) - ((and (or sef (function-get (car form) 'important-return-value)) - ;; Don't warn for arguments to `ignore'. - (not (eq byte-compile--for-effect 'for-effect-no-warn)) - (byte-compile-warning-enabled-p - 'ignored-return-value (car form))) - (byte-compile-warn-x - (car form) - "value from call to `%s' is unused%s" - (car form) - (cond ((eq (car form) 'mapcar) - "; use `mapc' or `dolist' instead") - (t ""))))))) - - (if (and handler - ;; Make sure that function exists. - (and (functionp handler) - ;; Ignore obsolete byte-compile function used by former - ;; CL code to handle compiler macros (we do it - ;; differently now). - (not (eq handler 'cl-byte-compile-compiler-macro)))) - (funcall handler form) - (byte-compile-normal-call form)))) - ((and (byte-code-function-p (car form)) - (memq byte-optimize '(t lap))) - (byte-compile-unfold-bcf form)) - ((byte-compile-normal-call form))) - (if byte-compile--for-effect - (byte-compile-discard)) - (pop byte-compile-form-stack))) + (car form) + "value from call to `%s' is unused%s" + (car form) + (cond ((eq (car form) 'mapcar) + "; use `mapc' or `dolist' instead") + (t ""))))))) + + (if (and handler + ;; Make sure that function exists. + (and (functionp handler) + ;; Ignore obsolete byte-compile function used by former + ;; CL code to handle compiler macros (we do it + ;; differently now). + (not (eq handler 'cl-byte-compile-compiler-macro)))) + (funcall handler form) + (byte-compile-normal-call form)))) + ((and (byte-code-function-p (car form)) + (memq byte-optimize '(t lap))) + (byte-compile-unfold-bcf form)) + ((byte-compile-normal-call form))) + (if byte-compile--for-effect + (byte-compile-discard))))) (let ((important-return-value-fns '( diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 2a646be9725..78601c0648e 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -334,8 +334,7 @@ macroexp--expand-all "Expand all macros in FORM. This is an internal version of `macroexpand-all'. Assumes the caller has bound `macroexpand-all-environment'." - (push form byte-compile-form-stack) - (prog1 + (macroexp--with-extended-form-stack form (if (eq (car-safe form) 'backquote-list*) ;; Special-case `backquote-list*', as it is normally a macro that ;; generates exceedingly deep expansions from relatively shallow input @@ -520,8 +519,7 @@ macroexp--expand-all newform (macroexp--expand-all form))) (macroexp--expand-all newform)))))) - (_ form)))) - (pop byte-compile-form-stack))) + (_ form)))))) ;;;###autoload (defun macroexpand-all (form &optional environment)