diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/.gdbinit | 6 | ||||
| -rw-r--r-- | src/ChangeLog.10 | 14 | ||||
| -rw-r--r-- | src/ChangeLog.11 | 22 | ||||
| -rw-r--r-- | src/ChangeLog.12 | 10 | ||||
| -rw-r--r-- | src/ChangeLog.13 | 32 | ||||
| -rw-r--r-- | src/ChangeLog.3 | 6 | ||||
| -rw-r--r-- | src/ChangeLog.8 | 10 | ||||
| -rw-r--r-- | src/ChangeLog.9 | 2 | ||||
| -rw-r--r-- | src/Makefile.in | 14 | ||||
| -rw-r--r-- | src/alloc.c | 1134 | ||||
| -rw-r--r-- | src/bidi.c | 24 | ||||
| -rw-r--r-- | src/bignum.c | 40 | ||||
| -rw-r--r-- | src/bignum.h | 12 | ||||
| -rw-r--r-- | src/buffer.c | 264 | ||||
| -rw-r--r-- | src/buffer.h | 167 | ||||
| -rw-r--r-- | src/bytecode.c | 50 | ||||
| -rw-r--r-- | src/callint.c | 11 | ||||
| -rw-r--r-- | src/callproc.c | 536 | ||||
| -rw-r--r-- | src/casefiddle.c | 45 | ||||
| -rw-r--r-- | src/ccl.c | 130 | ||||
| -rw-r--r-- | src/character.c | 185 | ||||
| -rw-r--r-- | src/character.h | 839 | ||||
| -rw-r--r-- | src/charset.c | 46 | ||||
| -rw-r--r-- | src/chartab.c | 10 | ||||
| -rw-r--r-- | src/cmds.c | 40 | ||||
| -rw-r--r-- | src/coding.c | 313 | ||||
| -rw-r--r-- | src/coding.h | 13 | ||||
| -rw-r--r-- | src/commands.h | 8 | ||||
| -rw-r--r-- | src/composite.c | 108 | ||||
| -rw-r--r-- | src/composite.h | 12 | ||||
| -rw-r--r-- | src/conf_post.h | 111 | ||||
| -rw-r--r-- | src/data.c | 220 | ||||
| -rw-r--r-- | src/dbusbind.c | 334 | ||||
| -rw-r--r-- | src/deps.mk | 3 | ||||
| -rw-r--r-- | src/dired.c | 59 | ||||
| -rw-r--r-- | src/dispextern.h | 71 | ||||
| -rw-r--r-- | src/dispnew.c | 99 | ||||
| -rw-r--r-- | src/doc.c | 369 | ||||
| -rw-r--r-- | src/doprnt.c | 260 | ||||
| -rw-r--r-- | src/editfns.c | 320 | ||||
| -rw-r--r-- | src/emacs-module.c | 391 | ||||
| -rw-r--r-- | src/emacs-module.h.in | 54 | ||||
| -rw-r--r-- | src/emacs.c | 125 | ||||
| -rw-r--r-- | src/eval.c | 230 | ||||
| -rw-r--r-- | src/fileio.c | 191 | ||||
| -rw-r--r-- | src/filelock.c | 35 | ||||
| -rw-r--r-- | src/fns.c | 735 | ||||
| -rw-r--r-- | src/font.c | 169 | ||||
| -rw-r--r-- | src/font.h | 6 | ||||
| -rw-r--r-- | src/fontset.c | 27 | ||||
| -rw-r--r-- | src/frame.c | 210 | ||||
| -rw-r--r-- | src/frame.h | 73 | ||||
| -rw-r--r-- | src/fringe.c | 21 | ||||
| -rw-r--r-- | src/ftcrfont.c | 18 | ||||
| -rw-r--r-- | src/ftfont.c | 23 | ||||
| -rw-r--r-- | src/ftxfont.c | 371 | ||||
| -rw-r--r-- | src/gmalloc.c | 16 | ||||
| -rw-r--r-- | src/gnutls.c | 22 | ||||
| -rw-r--r-- | src/gtkutil.c | 25 | ||||
| -rw-r--r-- | src/hbfont.c | 11 | ||||
| -rw-r--r-- | src/image.c | 775 | ||||
| -rw-r--r-- | src/indent.c | 64 | ||||
| -rw-r--r-- | src/insdel.c | 9 | ||||
| -rw-r--r-- | src/intervals.c | 15 | ||||
| -rw-r--r-- | src/intervals.h | 24 | ||||
| -rw-r--r-- | src/json.c | 23 | ||||
| -rw-r--r-- | src/keyboard.c | 273 | ||||
| -rw-r--r-- | src/keyboard.h | 3 | ||||
| -rw-r--r-- | src/keymap.c | 1119 | ||||
| -rw-r--r-- | src/keymap.h | 4 | ||||
| -rw-r--r-- | src/kqueue.c | 5 | ||||
| -rw-r--r-- | src/lcms.c | 7 | ||||
| -rw-r--r-- | src/lisp.h | 361 | ||||
| -rw-r--r-- | src/lread.c | 385 | ||||
| -rw-r--r-- | src/macfont.m | 97 | ||||
| -rw-r--r-- | src/macros.c | 5 | ||||
| -rw-r--r-- | src/marker.c | 10 | ||||
| -rw-r--r-- | src/menu.c | 26 | ||||
| -rw-r--r-- | src/mini-gmp-emacs.c | 32 | ||||
| -rw-r--r-- | src/mini-gmp.c | 4559 | ||||
| -rw-r--r-- | src/mini-gmp.h | 300 | ||||
| -rw-r--r-- | src/minibuf.c | 390 | ||||
| -rw-r--r-- | src/module-env-25.h | 71 | ||||
| -rw-r--r-- | src/module-env-27.h | 2 | ||||
| -rw-r--r-- | src/module-env-28.h | 23 | ||||
| -rw-r--r-- | src/msdos.c | 4 | ||||
| -rw-r--r-- | src/nsfns.m | 308 | ||||
| -rw-r--r-- | src/nsfont.m | 261 | ||||
| -rw-r--r-- | src/nsimage.m | 118 | ||||
| -rw-r--r-- | src/nsmenu.m | 657 | ||||
| -rw-r--r-- | src/nsselect.m | 27 | ||||
| -rw-r--r-- | src/nsterm.h | 145 | ||||
| -rw-r--r-- | src/nsterm.m | 2260 | ||||
| -rw-r--r-- | src/nsxwidget.h | 80 | ||||
| -rw-r--r-- | src/nsxwidget.m | 590 | ||||
| -rw-r--r-- | src/pdumper.c | 386 | ||||
| -rw-r--r-- | src/pdumper.h | 1 | ||||
| -rw-r--r-- | src/print.c | 199 | ||||
| -rw-r--r-- | src/process.c | 639 | ||||
| -rw-r--r-- | src/process.h | 2 | ||||
| -rw-r--r-- | src/ptr-bounds.h | 79 | ||||
| -rw-r--r-- | src/regex-emacs.c | 132 | ||||
| -rw-r--r-- | src/search.c | 106 | ||||
| -rw-r--r-- | src/syntax.c | 152 | ||||
| -rw-r--r-- | src/sysdep.c | 556 | ||||
| -rw-r--r-- | src/systhread.c | 8 | ||||
| -rw-r--r-- | src/systhread.h | 12 | ||||
| -rw-r--r-- | src/systime.h | 3 | ||||
| -rw-r--r-- | src/term.c | 221 | ||||
| -rw-r--r-- | src/termcap.c | 8 | ||||
| -rw-r--r-- | src/termchar.h | 2 | ||||
| -rw-r--r-- | src/termhooks.h | 9 | ||||
| -rw-r--r-- | src/terminfo.c | 6 | ||||
| -rw-r--r-- | src/textprop.c | 27 | ||||
| -rw-r--r-- | src/thread.c | 20 | ||||
| -rw-r--r-- | src/thread.h | 1 | ||||
| -rw-r--r-- | src/timefns.c | 133 | ||||
| -rw-r--r-- | src/unexmacosx.c | 2 | ||||
| -rw-r--r-- | src/w16select.c | 18 | ||||
| -rw-r--r-- | src/w32.c | 211 | ||||
| -rw-r--r-- | src/w32.h | 6 | ||||
| -rw-r--r-- | src/w32common.h | 5 | ||||
| -rw-r--r-- | src/w32fns.c | 337 | ||||
| -rw-r--r-- | src/w32gui.h | 7 | ||||
| -rw-r--r-- | src/w32heap.c | 16 | ||||
| -rw-r--r-- | src/w32image.c | 477 | ||||
| -rw-r--r-- | src/w32menu.c | 12 | ||||
| -rw-r--r-- | src/w32proc.c | 16 | ||||
| -rw-r--r-- | src/w32select.c | 4 | ||||
| -rw-r--r-- | src/w32term.c | 215 | ||||
| -rw-r--r-- | src/w32term.h | 8 | ||||
| -rw-r--r-- | src/window.c | 196 | ||||
| -rw-r--r-- | src/window.h | 6 | ||||
| -rw-r--r-- | src/xdisp.c | 1201 | ||||
| -rw-r--r-- | src/xfaces.c | 235 | ||||
| -rw-r--r-- | src/xfns.c | 124 | ||||
| -rw-r--r-- | src/xfont.c | 4 | ||||
| -rw-r--r-- | src/xgselect.c | 42 | ||||
| -rw-r--r-- | src/xgselect.h | 2 | ||||
| -rw-r--r-- | src/xmenu.c | 16 | ||||
| -rw-r--r-- | src/xrdb.c | 2 | ||||
| -rw-r--r-- | src/xselect.c | 21 | ||||
| -rw-r--r-- | src/xterm.c | 319 | ||||
| -rw-r--r-- | src/xterm.h | 3 | ||||
| -rw-r--r-- | src/xwidget.c | 278 | ||||
| -rw-r--r-- | src/xwidget.h | 48 |
146 files changed, 13499 insertions, 14768 deletions
diff --git a/src/.gdbinit b/src/.gdbinit index 4eb6a330282..f74e295f7ea 100644 --- a/src/.gdbinit +++ b/src/.gdbinit @@ -500,6 +500,9 @@ define pgx # IMAGE_GLYPH if ($g.type == 3) printf "IMAGE[%d]", $g.u.img_id + if ($g.slice.img.x || $g.slice.img.y || $g.slice.img.width || $g.slice.img.height) + printf " slice=%d,%d,%d,%d" ,$g.slice.img.x, $g.slice.img.y, $g.slice.img.width, $g.slice.img.height + end end # STRETCH_GLYPH if ($g.type == 4) @@ -551,9 +554,6 @@ define pgx if ($g.right_box_line_p) printf " ]" end - if ($g.slice.img.x || $g.slice.img.y || $g.slice.img.width || $g.slice.img.height) - printf " slice=%d,%d,%d,%d" ,$g.slice.img.x, $g.slice.img.y, $g.slice.img.width, $g.slice.img.height - end printf "\n" end document pgx diff --git a/src/ChangeLog.10 b/src/ChangeLog.10 index 8845adb2c50..bba161d3428 100644 --- a/src/ChangeLog.10 +++ b/src/ChangeLog.10 @@ -9344,7 +9344,7 @@ * dispextern.h (struct glyph_row): New member overlay_arrow_bitmap. It replaces the corresponding member from struct window, as a window may now show multiple overlay arrows. - Remove member overlay_arrow_p, superseeded by overlay_arrow_bitmap. + Remove member overlay_arrow_p, superseded by overlay_arrow_bitmap. * dispnew.c (row_equal_p, update_window_line, scrolling_window): Compare overlay_arrow_bitmap than overlay_arrow_p members. @@ -11141,7 +11141,7 @@ * eval.c (Fdefun, Fdefmacro): Use (defun . FN_NAME) in LOADHIST_ATTACH. (Fdefvaralias, Fdefvar, Fdefconst): Use just SYM in LOADHIST_ATTACH. (Qdefvar): Var deleted. - (syms_of_eval): Don't initialze it. + (syms_of_eval): Don't initialize it. * lread.c (syms_of_lread) <load-history>: Doc fix. @@ -18716,7 +18716,7 @@ and line_height, and use corresponding new members in struct frame. All uses changed. (FRAME_LINE_HEIGHT, FRAME_INTERNAL_BORDER_WIDTH): Remove macros; - superseeded by corresponding macros in frame.h. + superseded by corresponding macros in frame.h. * msdos.c: Make (several) trivial substitutions for renamed and new macros in dispextern.h, frame.h and window.h. @@ -19145,7 +19145,7 @@ (syms_of_xfaces): Declare Vface_font_rescale_alist as a Lisp variable. * lread.c (read1): Before calling index, check if the 2nd - arguemnt is in ASCII range. + argument is in ASCII range. 2003-04-08 Richard M. Stallman <rms@gnu.org> @@ -19945,7 +19945,7 @@ 2003-03-09 David Kastrup <dak@gnu.org> * process.c (read_process_output): We have allocated enough space - for readmax and carryover, so actually use the alloted space. + for readmax and carryover, so actually use the allotted space. 2003-03-09 Jan Djärv <jan.h.d@swipnet.se> @@ -24638,7 +24638,7 @@ * w32gui.h (struct XImage): Define. * w32term.c (w32_read_socket) <WM_XBUTTONUP>: Use XFASTINT to - extract mouse co-ordinates. + extract mouse coordinates. 2002-03-20 Jason Rumney <jasonr@gnu.org> @@ -25377,7 +25377,7 @@ Handle literal output of strings by sharing the main-line code for strings, using local var `literal'. Handle :propertize feature. - (syms_of_xdisp): Initialze and staticpro QCpropertize and + (syms_of_xdisp): Initialize and staticpro QCpropertize and mode_line_proptrans_alist. 2002-02-11 Kim F. Storm <storm@cua.dk> diff --git a/src/ChangeLog.11 b/src/ChangeLog.11 index 78f5599a4bd..41c35babda0 100644 --- a/src/ChangeLog.11 +++ b/src/ChangeLog.11 @@ -947,7 +947,7 @@ (c_string_pos, number_of_chars, message_dolog): (message_log_check_duplicate, set_message_1, store_mode_line_noprop): (display_mode_element, display_string): - Switch between char * and unsigned char * to stay compatible wth + Switch between char * and unsigned char * to stay compatible with C89 pointer rules. * regex.c: Conform to C89 pointer rules. @@ -9492,7 +9492,7 @@ * coding.c (decode_coding_ccl): Fix previous change for the multibyte case. (encode_coding_ccl): Don't setup ccl program here. Fix for the - case that the output buffer is fullfilled. + case that the output buffer is fulfilled. (encode_coding): Setup ccl program here. 2010-03-23 Dan Nicolaescu <dann@ics.uci.edu> @@ -9772,10 +9772,10 @@ 2010-02-17 Kenichi Handa <handa@m17n.org> * coding.c (decode_coding_ccl): Don't setup ccl program here. - Fix for the case that the output buffer is fullfilled. + Fix for the case that the output buffer is fulfilled. (decode_coding): Setup ccl program here. Keep looping when the decoder stopped because the output buffer is - fullfilled (bug#5534). + fulfilled (bug#5534). * ccl.c (ccl_driver): Never reset ic to CCL_HEADER_MAIN. @@ -10126,7 +10126,7 @@ 2010-01-06 Jan Djärv <jan.h.d@swipnet.se> - * font.c (font_open_entity): Enable chache and call cached_font_ok + * font.c (font_open_entity): Enable cache and call cached_font_ok for the driver if defined. (QCuser_spec): New symbol. (font_spec_from_name): Save name as user-spec. @@ -23923,7 +23923,7 @@ 2008-02-01 Kenichi Handa <handa@m17n.org> - * alloc.c (NSTATICS): Increas to 0x600. + * alloc.c (NSTATICS): Increase to 0x600. 2008-02-01 Kenichi Handa <handa@m17n.org> @@ -25309,12 +25309,12 @@ * coding.c (enum iso_code_class_type): Delete ISO_carriage_return. (CODING_GET_INFO): Delete argument eol_type. Change callers. - (decode_coding_utf_8): Don't do eol converion. + (decode_coding_utf_8): Don't do eol conversion. (detect_coding_utf_16): Check coding->src_chars, not coding->src_bytes. Add heuristics for those that have no signature. (decode_coding_emacs_mule, decode_coding_iso_2022) (decode_coding_sjis, decode_coding_big5, decode_coding_charset): - Don't do eol converion. + Don't do eol conversion. (adjust_coding_eol_type): Return a new coding system. (detect_coding): Don't detect eol. Fix for utf-16 detection. (decode_eol): In case of CRLF->LF conversion, use del_range_2 on @@ -25952,7 +25952,7 @@ (font_list): The argument REGISTRY is now a list of registry names. (choose_face_font): If we are choosing an ASCII font, and ATTRS specifies an explicit font name, return the name as is. Make a - list of registy names. + list of registry names. * xfns.c (x_set_font, x_create_tip_frame): Adjust for the change of x_new_fontset. @@ -26647,7 +26647,7 @@ (fontset_set): Delete. (fontset_face): New arg FACE. Return face ID, not face. Complete re-write to handle new fontset structure. Change caller. - (free_face_fontset): Use ASET istead of AREF (X) = Y. + (free_face_fontset): Use ASET instead of AREF (X) = Y. (face_for_char): Don't call lookup_face. (make_fontset_for_ascii_face): New arg FACE. (fs_load_font): New arg CHARSET_ID. Don't check @@ -31141,7 +31141,7 @@ * term.c (term_mouse_highlight): Remove unused variables. (Fterm_open_connection): Set gpm_zerobased to 1. (term_mouse_movement, term_mouse_click, handle_one_term_event): - Use zero based co-ordinates. + Use zero based coordinates. (handle_one_term_event): Report a drag as mouse movement too. * Makefile.in (MOUSE_SUPPORT): Define for HAVE_GPM. diff --git a/src/ChangeLog.12 b/src/ChangeLog.12 index f0ed2222050..77540ee5b11 100644 --- a/src/ChangeLog.12 +++ b/src/ChangeLog.12 @@ -239,7 +239,7 @@ * lisp.h (find_next_newline_no_quit): Rename to find_next_newline. * xdisp.c (back_to_previous_line_start, forward_to_next_line_start) - (get_visually_first_element, move_it_vertically_backward): Ajust users. + (get_visually_first_element, move_it_vertically_backward): Adjust users. * bidi.c (bidi_find_paragraph_start): Likewise. * indent.c (vmotion): Likewise. @@ -7335,7 +7335,7 @@ 2012-08-17 Chong Yidong <cyd@gnu.org> - * xfaces.c (merge_face_vectors): If the target font specfies a + * xfaces.c (merge_face_vectors): If the target font specifies a font spec, make the font's attributes take precedence over directly-specified attributes. (merge_face_ref): Recognize :font. @@ -9265,7 +9265,7 @@ * nsmenu.m (ns_update_menubar, ns_menu_show, process_dialog) (initFromContents): Use SSDATA where appropriate. - (ns_update_menubar): Add braces to ambigous if-else. + (ns_update_menubar): Add braces to ambiguous if-else. (initWithTitle): Put () around assignment in if statement. (ns_menu_show): Remove unused variables window and keymap. (update_frame_tool_bar): Remove unused variable selected_p. @@ -14333,7 +14333,7 @@ 2011-11-21 Lars Magne Ingebrigtsen <larsi@gnus.org> - * process.c (wait_reading_process_output): Fix asynchrounous + * process.c (wait_reading_process_output): Fix asynchronous GnuTLS socket handling on some versions of the GnuTLS library. (wait_reading_process_output): Add comment and URL. @@ -21271,7 +21271,7 @@ not the number of arguments given. This is simpler and lets GCC 4.6.0 generate slightly better code. - * ftfont.c: Distingish more carefully between FcChar8 and char. + * ftfont.c: Distinguish more carefully between FcChar8 and char. The previous code passed unsigned char * to a functions like strlen and xstrcasecmp that expect char *, which does not conform to the C standard. diff --git a/src/ChangeLog.13 b/src/ChangeLog.13 index 79714518cf4..3fb23ceff3d 100644 --- a/src/ChangeLog.13 +++ b/src/ChangeLog.13 @@ -580,7 +580,7 @@ (x_intersect_rectangles, clear_mouse_face, display_tty_menu_item): * lisp.h (setup_echo_area_for_printing, message_with_string) (pos_visible_p): Use bool for boolean. - * xdisp.c: Use bool, true, false intstead of int, 1, 0. + * xdisp.c: Use bool, true, false instead of int, 1, 0. Remove unnecessary forward decls. (trace_move) [DEBUG_TRACE_MOVE]: Now static. (CHECK_IT, CHECK_WINDOW_END): @@ -685,7 +685,7 @@ Inhibit resizing fullwidth-/height frames in one direction only. Update frame_size_history. (adjust_frame_size): Call frame_size_history_add. - (make_frame): Initalize after_make_frame slot. + (make_frame): Initialize after_make_frame slot. (Fmake_terminal_frame): Adjust adjust_frame_size call. (Fcan_run_window_configuration_change_hook): Rename to Fframe_after_make_frame. Set after_make_frame slot. @@ -1419,7 +1419,7 @@ 2015-01-12 Paul Eggert <eggert@cs.ucla.edu> - Port to 32-bit MingGW --with-wide-int + Port to 32-bit MinGW --with-wide-int Problem reported by Eli Zaretskii in: https://lists.gnu.org/r/emacs-devel/2015-01/msg00265.html * lisp.h (struct Lisp_Sub_Char_Table): Check that offset matches @@ -1635,7 +1635,7 @@ 2015-01-06 Jan Djärv <jan.h.d@swipnet.se> * nsterm.m (x_set_window_size): Call updateFrameSize to get real - size instead of using widht/height. The frame may be + size instead of using width/height. The frame may be constrained (Bug#19482). 2015-01-05 Paul Eggert <eggert@cs.ucla.edu> @@ -2102,7 +2102,7 @@ Partially disabled previous change. * image.c (svg_load): Temporarily disabled filename thing for - not-a-file case as it can cause crashs. + not-a-file case as it can cause crashes. 2014-12-17 Ulf Jasper <ulf.jasper@web.de> @@ -2807,7 +2807,7 @@ * nsselect.m (QCLIPBOARD, QSECONDARY, QTEXT, QFILE_NAME) (NXPrimaryPboard, NXSecondaryPboard): Declare static. (Qforeign_selection): Remove. - (ns_get_local_selection): Identation fix. + (ns_get_local_selection): Indentation fix. (syms_of_nsselect): Remove Qforeign_selection, ns-lost-selection-hooks * nsselect.m (ns_get_local_selection): Remove calling of @@ -5162,7 +5162,7 @@ 2014-07-27 Jan Djärv <jan.h.d@swipnet.se> * nsterm.m (applicationDidFinishLaunching antialiasThresholdDidChange): - Reinstate code removed by the prevoius commit to this file. + Reinstate code removed by the previous commit to this file. 2014-07-27 Martin Rudalics <rudalics@gmx.at> @@ -7847,11 +7847,11 @@ * w32.c (unsetenv): Remove unused var `retval'. (emacs_gnutls_pull): Remove unused vars `fdset' and `timeout'. - * w32notify.c (watch_worker): Remove unnecesary var sleep_result. + * w32notify.c (watch_worker): Remove unnecessary var sleep_result. (start_watching): Remove unused var `thr'. * w32proc.c (sys_spawnve): Comment out unused vars `first', `last'. - (find_child_console): Remove unnecesary var `thread_id'. + (find_child_console): Remove unnecessary var `thread_id'. * w32term.c (w32_read_socket): Comment out unused vars `row', `columns'. (x_focus_frame): #ifdef 0 unused variable `dpyinfo'. @@ -9004,7 +9004,7 @@ * widget.c (pixel_to_text_size): New function. (update_wm_hints): Have size hints respect value of frame_resize_pixelwise. - (EmacsFrameResize): Alway process resize requests pixelwise. + (EmacsFrameResize): Always process resize requests pixelwise. * window.c (grow_mini_window): Make sure mini window is at least one line tall. * xdisp.c (display_menu_bar): Make sure menubar extends till @@ -10768,7 +10768,7 @@ * search.c (find_newline): Rewrite to prefer offsets to pointers. This avoids undefined behavior when subtracting pointers into - different aways. On my platform it also makes the code a tad + different always. On my platform it also makes the code a tad smaller and presumably faster. 2013-11-11 Stefan Monnier <monnier@iro.umontreal.ca> @@ -13849,7 +13849,7 @@ 2013-08-13 Jan Djärv <jan.h.d@swipnet.se> - * nsterm.m (ns_set_vertical_scroll_bar): Fix breakage intruduced by + * nsterm.m (ns_set_vertical_scroll_bar): Fix breakage introduced by 2013-08-13 checkin below. Change bool to BOOL, rule is: All Obj-C code uses BOOL, except for interfaces callable from C. @@ -14041,7 +14041,7 @@ the caller. Do not lock the temp file. Unwind-protect the file and the file-descriptor. (Fcall_process_region): If the input is /dev/null, unwind-protect it. - If an asynchrounous process, record it here, not in call_process. + If an asynchronous process, record it here, not in call_process. (syms_of_callproc) [MSDOS]: Initialize synch_process_tempfile. * eval.c (set_unwind_protect): New function. * fileio.c (write_region): New function, generalized from the @@ -14764,7 +14764,7 @@ All callers changed. (create_process): Recover pty_flag from process, not from volatile local. (create_pty): Stay inside array even when pty allocation fails. - (Fmake_serial_process): Omit unnecessary initializaiton of pty_flag. + (Fmake_serial_process): Omit unnecessary initialization of pty_flag. * lread.c (Fload): Avoid initialization only when lint checking. Mention that it's needed only for older GCCs. @@ -17372,7 +17372,7 @@ 2013-03-31 Dmitry Antipov <dmantipov@yandex.ru> * frame.h (struct frame): Drop scroll_bottom_vpos - member becaue all real users are dead long ago. + member because all real users are dead long ago. (FRAME_SCROLL_BOTTOM_VPOS): Remove. * xdisp.c (redisplay_internal): Adjust user. @@ -17394,7 +17394,7 @@ (menuNeedsUpdate:): Add check for ! COCOA || OSX < 10.5 (Bug#12698). * nsterm.m (menu_will_open_state, menu_mouse_point) - (menu_pending_title): New varaibles. + (menu_pending_title): New variables. (ns_get_pending_menu_title, ns_check_menu_open) (ns_check_pending_open_menu): New functions. diff --git a/src/ChangeLog.3 b/src/ChangeLog.3 index b990ae17703..1cae9bfc655 100644 --- a/src/ChangeLog.3 +++ b/src/ChangeLog.3 @@ -11656,8 +11656,8 @@ pixel_to_glyph_translation, and rewritten. Just get coordinates, don't return anything. (buffer_posn_from_coords): New function - given a window and - co-ordinates on the screen, find the buffer position at those - co-ordinates. + coordinates on the screen, find the buffer position at those + coordinates. 1991-01-08 Jim Blandy (jimb@geech.ai.mit.edu) @@ -16140,7 +16140,7 @@ New format %S converts everything (even strings) with prin1. * doprnt.c (doprnt): Treat %s like %S. - * print.c (Fprin1_to_string): Opt 3nd arg non-nil does princ. + * print.c (Fprin1_to_string): Opt 3rd arg non-nil does princ. 1988-12-31 Richard Stallman (rms@sugar-bombs.ai.mit.edu) diff --git a/src/ChangeLog.8 b/src/ChangeLog.8 index c6f09172c2f..8587a14f2ce 100644 --- a/src/ChangeLog.8 +++ b/src/ChangeLog.8 @@ -1572,7 +1572,7 @@ (wait_reading_process_input): Use emacs_strerror, not strerror. * process.c (status_message, sigchld_handler): Synchronize locale, - then use strsignal istead of sys_siglist. + then use strsignal instead of sys_siglist. * w32proc.c (sys_wait): Likewise. * s/aix3-1.h, s/bsd4-1.h, s/dgux.h, s/gnu-linux.h, s/hiuxmpp.h: @@ -7560,7 +7560,7 @@ (recompute_basic_faces): Realize basic faces only if face cache is allocated, i.e. after init_frame_faces has been called. - * frame.c (make_frame): Initialze face cache with null. + * frame.c (make_frame): Initialize face cache with null. * xfaces.c (same_size_fonts): Remove. @@ -9810,7 +9810,7 @@ 1997-10-13 Gerd Moellmann <gerd@acm.org> * xdisp.c (redisplay_window): Use available current matrix to - skip faster when only point is moved withing the window. + skip faster when only point is moved within the window. * intervals.c: Include stdio.h. (find_interval): Trace to stderr to catch some nasty error @@ -9859,7 +9859,7 @@ * emacs.c: FreeBSD headers for profiling removed. * dispnew.c (direct_output_for_insert): Don't use PT-1 for - display cursor, use DEC_POS instread. + display cursor, use DEC_POS instead. * xfaces.c (load_font): Use x_load_font to load fonts so that all fonts are in the font table. @@ -11940,7 +11940,7 @@ This avoids a conflict with a system header file paths.h on GNU/Linux. * callproc.c, lread.c, w32fns.c, xfns.c, xrdb.c: - Use epaths.h istead of paths.h. + Use epaths.h instead of paths.h. 1999-02-26 Andreas Schwab <schwab@gnu.org> diff --git a/src/ChangeLog.9 b/src/ChangeLog.9 index 0264eb6863b..25a17e74fe7 100644 --- a/src/ChangeLog.9 +++ b/src/ChangeLog.9 @@ -10388,7 +10388,7 @@ ISO_control_0 and ISO_control_1. * coding.h (enum iso_code_class_type): Member ISO_control_code is - devided into ISO_control_0 and ISO_control_1. + divided into ISO_control_0 and ISO_control_1. (struct coding_system): New members src_multibyte, dst_multibyte, errors, and result. Delete member fake_multibyte. (CODING_REQUIRE_DECODING): Return 1 if coding->dst_multibyte is diff --git a/src/Makefile.in b/src/Makefile.in index 39fd7085640..4100edf4712 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -295,8 +295,8 @@ EMACSRES = @EMACSRES@ W32_RES_LINK=@W32_RES_LINK@ ## Empty if !HAVE_X_WINDOWS -## xfont.o ftfont.o xftfont.o ftxfont.o if HAVE_XFT -## xfont.o ftfont.o ftxfont.o if HAVE_FREETYPE +## xfont.o ftfont.o xftfont.o if HAVE_XFT +## xfont.o ftfont.o if HAVE_FREETYPE ## xfont.o ftfont.o ftcrfont.o if USE_CAIRO ## else xfont.o ## if HAVE_HARFBUZZ, hbfont.o is added regardless of the rest @@ -323,8 +323,7 @@ INTERVALS_H = dispextern.h intervals.h composite.h GETLOADAVG_LIBS = @GETLOADAVG_LIBS@ -GMP_LIB = @GMP_LIB@ -GMP_OBJ = @GMP_OBJ@ +LIBGMP = @LIBGMP@ RUN_TEMACS = ./temacs @@ -339,7 +338,7 @@ HAVE_PDUMPER = @HAVE_PDUMPER@ ## ARM Macs require that all code have a valid signature. Since pump ## invalidates the signature, we must re-sign to fix it. -DO_CODESIGN=$(patsubst arm-apple-darwin%,yes,@configuration@) +DO_CODESIGN=$(patsubst aarch64-apple-darwin%,yes,@configuration@) # 'make' verbosity. AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ @@ -438,9 +437,10 @@ SOME_MACHINE_OBJECTS = dosfns.o msdos.o \ xterm.o xfns.o xmenu.o xselect.o xrdb.o xsmfns.o fringe.o image.o \ fontset.o dbusbind.o cygw32.o \ nsterm.o nsfns.o nsmenu.o nsselect.o nsimage.o nsfont.o macfont.o \ + nsxwidget.o \ w32.o w32console.o w32cygwinx.o w32fns.o w32heap.o w32inevt.o w32notify.o \ w32menu.o w32proc.o w32reg.o w32select.o w32term.o w32xfns.o \ - w16select.o widget.o xfont.o ftfont.o xftfont.o ftxfont.o gtkutil.o \ + w16select.o widget.o xfont.o ftfont.o xftfont.o gtkutil.o \ xsettings.o xgselect.o termcap.o hbfont.o ## gmalloc.o if !SYSTEM_MALLOC && !DOUG_LEA_MALLOC, else empty. @@ -535,7 +535,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(HARFBUZZ_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LCMS2_LIBS) \ $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \ - $(JSON_LIBS) $(GMP_LIB) + $(JSON_LIBS) $(LIBGMP) ## FORCE it so that admin/unidata can decide whether this file is ## up-to-date. Although since charprop depends on bootstrap-emacs, diff --git a/src/alloc.c b/src/alloc.c index 4c76f4a554e..b86ed4ed262 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -34,7 +34,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "bignum.h" #include "dispextern.h" #include "intervals.h" -#include "ptr-bounds.h" #include "puresize.h" #include "sheap.h" #include "sysstdio.h" @@ -67,7 +66,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ # include <malloc.h> #endif -#if defined HAVE_VALGRIND_VALGRIND_H && !defined USE_VALGRIND +#if (defined ENABLE_CHECKING \ + && defined HAVE_VALGRIND_VALGRIND_H && !defined USE_VALGRIND) # define USE_VALGRIND 1 #endif @@ -104,6 +104,66 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "w32heap.h" /* for sbrk */ #endif +/* A type with alignment at least as large as any object that Emacs + allocates. This is not max_align_t because some platforms (e.g., + mingw) have buggy malloc implementations that do not align for + max_align_t. This union contains types of all GCALIGNED_STRUCT + components visible here. */ +union emacs_align_type +{ + struct frame frame; + struct Lisp_Bignum Lisp_Bignum; + struct Lisp_Bool_Vector Lisp_Bool_Vector; + struct Lisp_Char_Table Lisp_Char_Table; + struct Lisp_CondVar Lisp_CondVar; + struct Lisp_Finalizer Lisp_Finalizer; + struct Lisp_Float Lisp_Float; + struct Lisp_Hash_Table Lisp_Hash_Table; + struct Lisp_Marker Lisp_Marker; + struct Lisp_Misc_Ptr Lisp_Misc_Ptr; + struct Lisp_Mutex Lisp_Mutex; + struct Lisp_Overlay Lisp_Overlay; + struct Lisp_Sub_Char_Table Lisp_Sub_Char_Table; + struct Lisp_Subr Lisp_Subr; + struct Lisp_User_Ptr Lisp_User_Ptr; + struct Lisp_Vector Lisp_Vector; + struct terminal terminal; + struct thread_state thread_state; + struct window window; + + /* Omit the following since they would require including process.h + etc. In practice their alignments never exceed that of the + structs already listed. */ +#if 0 + struct Lisp_Module_Function Lisp_Module_Function; + struct Lisp_Process Lisp_Process; + struct save_window_data save_window_data; + struct scroll_bar scroll_bar; + struct xwidget_view xwidget_view; + struct xwidget xwidget; +#endif +}; + +/* MALLOC_SIZE_NEAR (N) is a good number to pass to malloc when + allocating a block of memory with size close to N bytes. + For best results N should be a power of 2. + + When calculating how much memory to allocate, GNU malloc (SIZE) + adds sizeof (size_t) to SIZE for internal overhead, and then rounds + up to a multiple of MALLOC_ALIGNMENT. Emacs can improve + performance a bit on GNU platforms by arranging for the resulting + size to be a power of two. This heuristic is good for glibc 2.26 + (2017) and later, and does not affect correctness on other + platforms. */ + +#define MALLOC_SIZE_NEAR(n) \ + (ROUNDUP (max (n, sizeof (size_t)), MALLOC_ALIGNMENT) - sizeof (size_t)) +#ifdef __i386 +enum { MALLOC_ALIGNMENT = 16 }; +#else +enum { MALLOC_ALIGNMENT = max (2 * sizeof (size_t), alignof (long double)) }; +#endif + #ifdef DOUG_LEA_MALLOC /* Specify maximum number of areas to mmap. It would be nice to use a @@ -412,7 +472,6 @@ inline static void set_interval_marked (INTERVAL i); enum mem_type { MEM_TYPE_NON_LISP, - MEM_TYPE_BUFFER, MEM_TYPE_CONS, MEM_TYPE_STRING, MEM_TYPE_SYMBOL, @@ -605,7 +664,7 @@ display_malloc_warning (void) call3 (intern ("display-warning"), intern ("alloc"), build_string (pending_malloc_warning), - intern ("emergency")); + intern (":emergency")); pending_malloc_warning = 0; } @@ -636,25 +695,19 @@ buffer_memory_full (ptrdiff_t nbytes) #define COMMON_MULTIPLE(a, b) \ ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b)) -/* LISP_ALIGNMENT is the alignment of Lisp objects. It must be at - least GCALIGNMENT so that pointers can be tagged. It also must be - at least as strict as the alignment of all the C types used to - implement Lisp objects; since pseudovectors can contain any C type, - this is max_align_t. On recent GNU/Linux x86 and x86-64 this can - often waste up to 8 bytes, since alignof (max_align_t) is 16 but - typical vectors need only an alignment of 8. Although shrinking - the alignment to 8 would save memory, it cost a 20% hit to Emacs - CPU performance on Fedora 28 x86-64 when compiled with gcc -m32. */ -enum { LISP_ALIGNMENT = alignof (union { max_align_t x; +/* Alignment needed for memory blocks that are allocated via malloc + and that contain Lisp objects. On typical hosts malloc already + aligns sufficiently, but extra work is needed on oddball hosts + where Emacs would crash if malloc returned a non-GCALIGNED pointer. */ +enum { LISP_ALIGNMENT = alignof (union { union emacs_align_type x; GCALIGNED_UNION_MEMBER }) }; verify (LISP_ALIGNMENT % GCALIGNMENT == 0); /* True if malloc (N) is known to return storage suitably aligned for Lisp objects whenever N is a multiple of LISP_ALIGNMENT. In practice this is true whenever alignof (max_align_t) is also a - multiple of LISP_ALIGNMENT. This works even for x86, where some - platform combinations (e.g., GCC 7 and later, glibc 2.25 and - earlier) have bugs where alignof (max_align_t) is 16 even though + multiple of LISP_ALIGNMENT. This works even for buggy platforms + like MinGW circa 2020, where alignof (max_align_t) is 16 even though the malloc alignment is only 8, and where Emacs still works because it never does anything that requires an alignment of 16. */ enum { MALLOC_IS_LISP_ALIGNED = alignof (max_align_t) % LISP_ALIGNMENT == 0 }; @@ -679,7 +732,11 @@ static void malloc_unblock_input (void) { if (block_input_in_memory_allocators) - unblock_input (); + { + int err = errno; + unblock_input (); + errno = err; + } } # define MALLOC_BLOCK_INPUT malloc_block_input () # define MALLOC_UNBLOCK_INPUT malloc_unblock_input () @@ -694,7 +751,7 @@ malloc_unblock_input (void) malloc_probe (size); \ } while (0) -static void *lmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1)); +static void *lmalloc (size_t, bool) ATTRIBUTE_MALLOC_SIZE ((1)); static void *lrealloc (void *, size_t); /* Like malloc but check for no memory and block interrupt input. */ @@ -705,7 +762,7 @@ xmalloc (size_t size) void *val; MALLOC_BLOCK_INPUT; - val = lmalloc (size); + val = lmalloc (size, false); MALLOC_UNBLOCK_INPUT; if (!val && size) @@ -722,12 +779,11 @@ xzalloc (size_t size) void *val; MALLOC_BLOCK_INPUT; - val = lmalloc (size); + val = lmalloc (size, true); MALLOC_UNBLOCK_INPUT; if (!val && size) memory_full (size); - memset (val, 0, size); MALLOC_PROBE (size); return val; } @@ -743,7 +799,7 @@ xrealloc (void *block, size_t size) /* We must call malloc explicitly when BLOCK is 0, since some reallocs don't do this. */ if (! block) - val = lmalloc (size); + val = lmalloc (size, false); else val = lrealloc (block, size); MALLOC_UNBLOCK_INPUT; @@ -939,7 +995,7 @@ void *lisp_malloc_loser EXTERNALLY_VISIBLE; #endif static void * -lisp_malloc (size_t nbytes, enum mem_type type) +lisp_malloc (size_t nbytes, bool clearit, enum mem_type type) { register void *val; @@ -949,7 +1005,7 @@ lisp_malloc (size_t nbytes, enum mem_type type) allocated_mem_type = type; #endif - val = lmalloc (nbytes); + val = lmalloc (nbytes, clearit); #if ! USE_LSB_TAG /* If the memory just allocated cannot be addressed thru a Lisp @@ -1290,16 +1346,21 @@ laligned (void *p, size_t size) that's never really exercised) for little benefit. */ static void * -lmalloc (size_t size) +lmalloc (size_t size, bool clearit) { #ifdef USE_ALIGNED_ALLOC if (! MALLOC_IS_LISP_ALIGNED && size % LISP_ALIGNMENT == 0) - return aligned_alloc (LISP_ALIGNMENT, size); + { + void *p = aligned_alloc (LISP_ALIGNMENT, size); + if (clearit && p) + memclear (p, size); + return p; + } #endif while (true) { - void *p = malloc (size); + void *p = clearit ? calloc (1, size) : malloc (size); if (laligned (p, size)) return p; free (p); @@ -1328,11 +1389,11 @@ lrealloc (void *p, size_t size) Interval Allocation ***********************************************************************/ -/* Number of intervals allocated in an interval_block structure. - The 1020 is 1024 minus malloc overhead. */ +/* Number of intervals allocated in an interval_block structure. */ -#define INTERVAL_BLOCK_SIZE \ - ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval)) +enum { INTERVAL_BLOCK_SIZE + = ((MALLOC_SIZE_NEAR (1024) - sizeof (struct interval_block *)) + / sizeof (struct interval)) }; /* Intervals are allocated in chunks in the form of an interval_block structure. */ @@ -1377,7 +1438,7 @@ make_interval (void) if (interval_block_index == INTERVAL_BLOCK_SIZE) { struct interval_block *newi - = lisp_malloc (sizeof *newi, MEM_TYPE_NON_LISP); + = lisp_malloc (sizeof *newi, false, MEM_TYPE_NON_LISP); newi->next = interval_block; interval_block = newi; @@ -1444,10 +1505,9 @@ mark_interval_tree (INTERVAL i) longer used, can be easily recognized, and it's easy to compact the sblocks of small strings which we do in compact_small_strings. */ -/* Size in bytes of an sblock structure used for small strings. This - is 8192 minus malloc overhead. */ +/* Size in bytes of an sblock structure used for small strings. */ -#define SBLOCK_SIZE 8188 +enum { SBLOCK_SIZE = MALLOC_SIZE_NEAR (8192) }; /* Strings larger than this are considered large strings. String data for large strings is allocated from individual sblocks. */ @@ -1522,11 +1582,11 @@ struct sblock sdata data[FLEXIBLE_ARRAY_MEMBER]; }; -/* Number of Lisp strings in a string_block structure. The 1020 is - 1024 minus malloc overhead. */ +/* Number of Lisp strings in a string_block structure. */ -#define STRING_BLOCK_SIZE \ - ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String)) +enum { STRING_BLOCK_SIZE + = ((MALLOC_SIZE_NEAR (1024) - sizeof (struct string_block *)) + / sizeof (struct Lisp_String)) }; /* Structure describing a block from which Lisp_String structures are allocated. */ @@ -1567,8 +1627,7 @@ static struct Lisp_String *string_free_list; a pointer to the `u.data' member of its sdata structure; the structure starts at a constant offset in front of that. */ -#define SDATA_OF_STRING(S) ((sdata *) ptr_bounds_init ((S)->u.s.data \ - - SDATA_DATA_OFFSET)) +#define SDATA_OF_STRING(S) ((sdata *) ((S)->u.s.data - SDATA_DATA_OFFSET)) #ifdef GC_CHECK_STRING_OVERRUN @@ -1603,7 +1662,7 @@ sdata_size (ptrdiff_t n) #define GC_STRING_EXTRA GC_STRING_OVERRUN_COOKIE_SIZE /* Exact bound on the number of bytes in a string, not counting the - terminating NUL. A string cannot contain more bytes than + terminating null. A string cannot contain more bytes than STRING_BYTES_BOUND, nor can it be so long that the size_t arithmetic in allocate_string_data would overflow while it is calculating a value to be passed to malloc. */ @@ -1730,7 +1789,7 @@ allocate_string (void) add all the Lisp_Strings in it to the free-list. */ if (string_free_list == NULL) { - struct string_block *b = lisp_malloc (sizeof *b, MEM_TYPE_STRING); + struct string_block *b = lisp_malloc (sizeof *b, false, MEM_TYPE_STRING); int i; b->next = string_blocks; @@ -1742,7 +1801,7 @@ allocate_string (void) /* Every string on a free list should have NULL data pointer. */ s->u.s.data = NULL; NEXT_FREE_LISP_STRING (s) = string_free_list; - string_free_list = ptr_bounds_clip (s, sizeof *s); + string_free_list = s; } } @@ -1778,15 +1837,16 @@ allocate_string (void) plus a NUL byte at the end. Allocate an sdata structure DATA for S, and set S->u.s.data to SDATA->u.data. Store a NUL byte at the end of S->u.s.data. Set S->u.s.size to NCHARS and S->u.s.size_byte - to NBYTES. Free S->u.s.data if it was initially non-null. */ + to NBYTES. Free S->u.s.data if it was initially non-null. -void + If CLEARIT, also clear the other bytes of S->u.s.data. */ + +static void allocate_string_data (struct Lisp_String *s, - EMACS_INT nchars, EMACS_INT nbytes) + EMACS_INT nchars, EMACS_INT nbytes, bool clearit) { - sdata *data, *old_data; + sdata *data; struct sblock *b; - ptrdiff_t old_nbytes; if (STRING_BYTES_MAX < nbytes) string_overflow (); @@ -1794,13 +1854,6 @@ allocate_string_data (struct Lisp_String *s, /* Determine the number of bytes needed to store NBYTES bytes of string data. */ ptrdiff_t needed = sdata_size (nbytes); - if (s->u.s.data) - { - old_data = SDATA_OF_STRING (s); - old_nbytes = STRING_BYTES (s); - } - else - old_data = NULL; MALLOC_BLOCK_INPUT; @@ -1813,7 +1866,7 @@ allocate_string_data (struct Lisp_String *s, mallopt (M_MMAP_MAX, 0); #endif - b = lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP); + b = lisp_malloc (size + GC_STRING_EXTRA, clearit, MEM_TYPE_NON_LISP); #ifdef DOUG_LEA_MALLOC if (!mmap_lisp_allowed_p ()) @@ -1825,27 +1878,30 @@ allocate_string_data (struct Lisp_String *s, b->next_free = data; large_sblocks = b; } - else if (current_sblock == NULL - || (((char *) current_sblock + SBLOCK_SIZE - - (char *) current_sblock->next_free) - < (needed + GC_STRING_EXTRA))) - { - /* Not enough room in the current sblock. */ - b = lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP); - data = b->data; - b->next = NULL; - b->next_free = data; - - if (current_sblock) - current_sblock->next = b; - else - oldest_sblock = b; - current_sblock = b; - } else { b = current_sblock; + + if (b == NULL + || (SBLOCK_SIZE - GC_STRING_EXTRA + < (char *) b->next_free - (char *) b + needed)) + { + /* Not enough room in the current sblock. */ + b = lisp_malloc (SBLOCK_SIZE, false, MEM_TYPE_NON_LISP); + data = b->data; + b->next = NULL; + b->next_free = data; + + if (current_sblock) + current_sblock->next = b; + else + oldest_sblock = b; + current_sblock = b; + } + data = b->next_free; + if (clearit) + memset (SDATA_DATA (data), 0, nbytes); } data->string = s; @@ -1854,7 +1910,7 @@ allocate_string_data (struct Lisp_String *s, MALLOC_UNBLOCK_INPUT; - s->u.s.data = ptr_bounds_clip (SDATA_DATA (data), nbytes + 1); + s->u.s.data = SDATA_DATA (data); #ifdef GC_CHECK_STRING_BYTES SDATA_NBYTES (data) = nbytes; #endif @@ -1866,16 +1922,58 @@ allocate_string_data (struct Lisp_String *s, GC_STRING_OVERRUN_COOKIE_SIZE); #endif - /* Note that Faset may call to this function when S has already data - assigned. In this case, mark data as free by setting it's string - back-pointer to null, and record the size of the data in it. */ - if (old_data) + tally_consing (needed); +} + +/* Reallocate multibyte STRING data when a single character is replaced. + The character is at byte offset CIDX_BYTE in the string. + The character being replaced is CLEN bytes long, + and the character that will replace it is NEW_CLEN bytes long. + Return the address of where the caller should store the + the new character. */ + +unsigned char * +resize_string_data (Lisp_Object string, ptrdiff_t cidx_byte, + int clen, int new_clen) +{ + eassume (STRING_MULTIBYTE (string)); + sdata *old_sdata = SDATA_OF_STRING (XSTRING (string)); + ptrdiff_t nchars = SCHARS (string); + ptrdiff_t nbytes = SBYTES (string); + ptrdiff_t new_nbytes = nbytes + (new_clen - clen); + unsigned char *data = SDATA (string); + unsigned char *new_charaddr; + + if (sdata_size (nbytes) == sdata_size (new_nbytes)) + { + /* No need to reallocate, as the size change falls within the + alignment slop. */ + XSTRING (string)->u.s.size_byte = new_nbytes; +#ifdef GC_CHECK_STRING_BYTES + SDATA_NBYTES (old_sdata) = new_nbytes; +#endif + new_charaddr = data + cidx_byte; + memmove (new_charaddr + new_clen, new_charaddr + clen, + nbytes - (cidx_byte + (clen - 1))); + } + else { - SDATA_NBYTES (old_data) = old_nbytes; - old_data->string = NULL; + allocate_string_data (XSTRING (string), nchars, new_nbytes, false); + unsigned char *new_data = SDATA (string); + new_charaddr = new_data + cidx_byte; + memcpy (new_charaddr + new_clen, data + cidx_byte + clen, + nbytes - (cidx_byte + clen)); + memcpy (new_data, data, cidx_byte); + + /* Mark old string data as free by setting its string back-pointer + to null, and record the size of the data in it. */ + SDATA_NBYTES (old_sdata) = nbytes; + old_sdata->string = NULL; } - tally_consing (needed); + clear_string_char_byte_cache (); + + return new_charaddr; } @@ -1940,7 +2038,7 @@ sweep_strings (void) /* Put the string on the free-list. */ NEXT_FREE_LISP_STRING (s) = string_free_list; - string_free_list = ptr_bounds_clip (s, sizeof *s); + string_free_list = s; ++nfree; } } @@ -1948,7 +2046,7 @@ sweep_strings (void) { /* S was on the free-list before. Put it there again. */ NEXT_FREE_LISP_STRING (s) = string_free_list; - string_free_list = ptr_bounds_clip (s, sizeof *s); + string_free_list = s; ++nfree; } } @@ -2075,8 +2173,7 @@ compact_small_strings (void) { eassert (tb != b || to < from); memmove (to, from, size + GC_STRING_EXTRA); - to->string->u.s.data - = ptr_bounds_clip (SDATA_DATA (to), nbytes + 1); + to->string->u.s.data = SDATA_DATA (to); } /* Advance past the sdata we copied to. */ @@ -2110,6 +2207,9 @@ string_overflow (void) error ("Maximum string size exceeded"); } +static Lisp_Object make_clear_string (EMACS_INT, bool); +static Lisp_Object make_clear_multibyte_string (EMACS_INT, EMACS_INT, bool); + DEFUN ("make-string", Fmake_string, Smake_string, 2, 3, 0, doc: /* Return a newly created string of length LENGTH, with INIT in each element. LENGTH must be an integer. @@ -2118,19 +2218,20 @@ If optional argument MULTIBYTE is non-nil, the result will be a multibyte string even if INIT is an ASCII character. */) (Lisp_Object length, Lisp_Object init, Lisp_Object multibyte) { - register Lisp_Object val; - int c; + Lisp_Object val; EMACS_INT nbytes; CHECK_FIXNAT (length); CHECK_CHARACTER (init); - c = XFIXNAT (init); + int c = XFIXNAT (init); + bool clearit = !c; + if (ASCII_CHAR_P (c) && NILP (multibyte)) { nbytes = XFIXNUM (length); - val = make_uninit_string (nbytes); - if (nbytes) + val = make_clear_string (nbytes, clearit); + if (nbytes && !clearit) { memset (SDATA (val), c, nbytes); SDATA (val)[nbytes] = 0; @@ -2141,26 +2242,27 @@ a multibyte string even if INIT is an ASCII character. */) unsigned char str[MAX_MULTIBYTE_LENGTH]; ptrdiff_t len = CHAR_STRING (c, str); EMACS_INT string_len = XFIXNUM (length); - unsigned char *p, *beg, *end; if (INT_MULTIPLY_WRAPV (len, string_len, &nbytes)) string_overflow (); - val = make_uninit_multibyte_string (string_len, nbytes); - for (beg = SDATA (val), p = beg, end = beg + nbytes; p < end; p += len) + val = make_clear_multibyte_string (string_len, nbytes, clearit); + if (!clearit) { - /* First time we just copy `str' to the data of `val'. */ - if (p == beg) - memcpy (p, str, len); - else + unsigned char *beg = SDATA (val), *end = beg + nbytes; + for (unsigned char *p = beg; p < end; p += len) { - /* Next time we copy largest possible chunk from - initialized to uninitialized part of `val'. */ - len = min (p - beg, end - p); - memcpy (p, beg, len); + /* First time we just copy STR to the data of VAL. */ + if (p == beg) + memcpy (p, str, len); + else + { + /* Next time we copy largest possible chunk from + initialized to uninitialized part of VAL. */ + len = min (p - beg, end - p); + memcpy (p, beg, len); + } } } - if (nbytes) - *p = 0; } return val; @@ -2330,26 +2432,37 @@ make_specified_string (const char *contents, /* Return a unibyte Lisp_String set up to hold LENGTH characters - occupying LENGTH bytes. */ + occupying LENGTH bytes. If CLEARIT, clear its contents to null + bytes; otherwise, the contents are uninitialized. */ -Lisp_Object -make_uninit_string (EMACS_INT length) +static Lisp_Object +make_clear_string (EMACS_INT length, bool clearit) { Lisp_Object val; if (!length) return empty_unibyte_string; - val = make_uninit_multibyte_string (length, length); + val = make_clear_multibyte_string (length, length, clearit); STRING_SET_UNIBYTE (val); return val; } +/* Return a unibyte Lisp_String set up to hold LENGTH characters + occupying LENGTH bytes. */ + +Lisp_Object +make_uninit_string (EMACS_INT length) +{ + return make_clear_string (length, false); +} + /* Return a multibyte Lisp_String set up to hold NCHARS characters - which occupy NBYTES bytes. */ + which occupy NBYTES bytes. If CLEARIT, clear its contents to null + bytes; otherwise, the contents are uninitialized. */ -Lisp_Object -make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes) +static Lisp_Object +make_clear_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes, bool clearit) { Lisp_Object string; struct Lisp_String *s; @@ -2361,12 +2474,21 @@ make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes) s = allocate_string (); s->u.s.intervals = NULL; - allocate_string_data (s, nchars, nbytes); + allocate_string_data (s, nchars, nbytes, clearit); XSETSTRING (string, s); string_chars_consed += nbytes; return string; } +/* Return a multibyte Lisp_String set up to hold NCHARS characters + which occupy NBYTES bytes. */ + +Lisp_Object +make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes) +{ + return make_clear_multibyte_string (nchars, nbytes, false); +} + /* Print arguments to BUF according to a FORMAT, then return a Lisp_String initialized with the data from BUF. */ @@ -2838,7 +2960,6 @@ Lisp_Object zero_vector; static void setup_on_free_list (struct Lisp_Vector *v, ptrdiff_t nbytes) { - v = ptr_bounds_clip (v, nbytes); eassume (header_size <= nbytes); ptrdiff_t nwords = (nbytes - header_size) / word_size; XSETPVECTYPESIZE (v, PVEC_FREE, 0, nwords); @@ -3023,6 +3144,14 @@ cleanup_vector (struct Lisp_Vector *vector) if (uptr->finalizer) uptr->finalizer (uptr->p); } +#ifdef HAVE_MODULES + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MODULE_FUNCTION)) + { + ATTRIBUTE_MAY_ALIAS struct Lisp_Module_Function *function + = (struct Lisp_Module_Function *) vector; + module_finalize_function (function); + } +#endif } /* Reclaim space used by unmarked vectors. */ @@ -3137,7 +3266,7 @@ sweep_vectors (void) at most VECTOR_ELTS_MAX. */ static struct Lisp_Vector * -allocate_vectorlike (ptrdiff_t len) +allocate_vectorlike (ptrdiff_t len, bool clearit) { eassert (0 < len && len <= VECTOR_ELTS_MAX); ptrdiff_t nbytes = header_size + len * word_size; @@ -3151,11 +3280,15 @@ allocate_vectorlike (ptrdiff_t len) #endif if (nbytes <= VBLOCK_BYTES_MAX) - p = allocate_vector_from_block (vroundup (nbytes)); + { + p = allocate_vector_from_block (vroundup (nbytes)); + if (clearit) + memclear (p, nbytes); + } else { struct large_vector *lv = lisp_malloc (large_vector_offset + nbytes, - MEM_TYPE_VECTORLIKE); + clearit, MEM_TYPE_VECTORLIKE); lv->next = large_vectors; large_vectors = lv; p = large_vector_vec (lv); @@ -3174,24 +3307,41 @@ allocate_vectorlike (ptrdiff_t len) MALLOC_UNBLOCK_INPUT; - return ptr_bounds_clip (p, nbytes); + return p; } -/* Allocate a vector with LEN slots. */ +/* Allocate a vector with LEN slots. If CLEARIT, clear its slots; + otherwise the vector's slots are uninitialized. */ -struct Lisp_Vector * -allocate_vector (ptrdiff_t len) +static struct Lisp_Vector * +allocate_clear_vector (ptrdiff_t len, bool clearit) { if (len == 0) return XVECTOR (zero_vector); if (VECTOR_ELTS_MAX < len) memory_full (SIZE_MAX); - struct Lisp_Vector *v = allocate_vectorlike (len); + struct Lisp_Vector *v = allocate_vectorlike (len, clearit); v->header.size = len; return v; } +/* Allocate a vector with LEN uninitialized slots. */ + +struct Lisp_Vector * +allocate_vector (ptrdiff_t len) +{ + return allocate_clear_vector (len, false); +} + +/* Allocate a vector with LEN nil slots. */ + +struct Lisp_Vector * +allocate_nil_vector (ptrdiff_t len) +{ + return allocate_clear_vector (len, true); +} + /* Allocate other vector-like structures. */ @@ -3208,7 +3358,7 @@ allocate_pseudovector (int memlen, int lisplen, eassert (lisplen <= size_max); eassert (memlen <= size_max + rest_max); - struct Lisp_Vector *v = allocate_vectorlike (memlen); + struct Lisp_Vector *v = allocate_vectorlike (memlen, false); /* Only the first LISPLEN slots will be traced normally by the GC. */ memclear (v->contents, zerolen * word_size); XSETPVECTYPESIZE (v, tag, lisplen, memlen - lisplen); @@ -3218,12 +3368,10 @@ allocate_pseudovector (int memlen, int lisplen, struct buffer * allocate_buffer (void) { - struct buffer *b = lisp_malloc (sizeof *b, MEM_TYPE_BUFFER); - + struct buffer *b + = ALLOCATE_PSEUDOVECTOR (struct buffer, cursor_in_non_selected_windows_, + PVEC_BUFFER); BUFFER_PVEC_INIT (b); - /* Put B on the chain of all buffers including killed ones. */ - b->next = all_buffers; - all_buffers = b; /* Note that the rest fields of B are not initialized. */ return b; } @@ -3238,7 +3386,7 @@ allocate_record (EMACS_INT count) if (count > PSEUDOVECTOR_SIZE_MASK) error ("Attempt to allocate a record of %"pI"d slots; max is %d", count, PSEUDOVECTOR_SIZE_MASK); - struct Lisp_Vector *p = allocate_vectorlike (count); + struct Lisp_Vector *p = allocate_vectorlike (count, false); p->header.size = count; XSETPVECTYPE (p, PVEC_RECORD); return p; @@ -3291,9 +3439,11 @@ See also the function `vector'. */) Lisp_Object make_vector (ptrdiff_t length, Lisp_Object init) { - struct Lisp_Vector *p = allocate_vector (length); - for (ptrdiff_t i = 0; i < length; i++) - p->contents[i] = init; + bool clearit = NIL_IS_ZERO && NILP (init); + struct Lisp_Vector *p = allocate_clear_vector (length, clearit); + if (!clearit) + for (ptrdiff_t i = 0; i < length; i++) + p->contents[i] = init; return make_lisp_ptr (p, Lisp_Vectorlike); } @@ -3309,23 +3459,6 @@ usage: (vector &rest OBJECTS) */) return val; } -void -make_byte_code (struct Lisp_Vector *v) -{ - /* Don't allow the global zero_vector to become a byte code object. */ - eassert (0 < v->header.size); - - if (v->header.size > 1 && STRINGP (v->contents[1]) - && STRING_MULTIBYTE (v->contents[1])) - /* BYTECODE-STRING must have been produced by Emacs 20.2 or the - earlier because they produced a raw 8-bit string for byte-code - and now such a byte-code string is loaded as multibyte while - raw 8-bit characters converted to multibyte form. Thus, now we - must convert them back to the original unibyte form. */ - v->contents[1] = Fstring_as_unibyte (v->contents[1]); - XSETPVECTYPE (v, PVEC_COMPILED); -} - DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, doc: /* Create a byte-code object with specified arguments as elements. The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant @@ -3344,8 +3477,14 @@ stack before executing the byte-code. usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */) (ptrdiff_t nargs, Lisp_Object *args) { - Lisp_Object val = make_uninit_vector (nargs); - struct Lisp_Vector *p = XVECTOR (val); + if (! ((FIXNUMP (args[COMPILED_ARGLIST]) + || CONSP (args[COMPILED_ARGLIST]) + || NILP (args[COMPILED_ARGLIST])) + && STRINGP (args[COMPILED_BYTECODE]) + && !STRING_MULTIBYTE (args[COMPILED_BYTECODE]) + && VECTORP (args[COMPILED_CONSTANTS]) + && FIXNATP (args[COMPILED_STACK_DEPTH]))) + error ("Invalid byte-code object"); /* We used to purecopy everything here, if purify-flag was set. This worked OK for Emacs-23, but with Emacs-24's lexical binding code, it can be @@ -3354,10 +3493,8 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT copied into pure space, including its free variables, which is sometimes just wasteful and other times plainly wrong (e.g. those free vars may want to be setcar'd). */ - - memcpy (p->contents, args, nargs * sizeof *args); - make_byte_code (p); - XSETCOMPILED (val, p); + Lisp_Object val = Fvector (nargs, args); + XSETPVECTYPE (XVECTOR (val), PVEC_COMPILED); return val; } @@ -3442,7 +3579,7 @@ Its value is void, and its function definition and property list are nil. */) if (symbol_block_index == SYMBOL_BLOCK_SIZE) { struct symbol_block *new - = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL); + = lisp_malloc (sizeof *new, false, MEM_TYPE_SYMBOL); new->next = symbol_block; symbol_block = new; symbol_block_index = 0; @@ -3904,10 +4041,10 @@ refill_memory_reserve (void) MEM_TYPE_SPARE); if (spare_memory[5] == 0) spare_memory[5] = lisp_malloc (sizeof (struct string_block), - MEM_TYPE_SPARE); + false, MEM_TYPE_SPARE); if (spare_memory[6] == 0) spare_memory[6] = lisp_malloc (sizeof (struct string_block), - MEM_TYPE_SPARE); + false, MEM_TYPE_SPARE); if (spare_memory[0] && spare_memory[1] && spare_memory[5]) Vmemory_full = Qnil; #endif @@ -4304,7 +4441,7 @@ mem_delete_fixup (struct mem_node *x) /* If P is a pointer into a live Lisp string object on the heap, - return the object. Otherwise, return nil. M is a pointer to the + return the object's address. Otherwise, return NULL. M points to the mem_block for P. This and other *_holding functions look for a pointer anywhere into @@ -4312,277 +4449,239 @@ mem_delete_fixup (struct mem_node *x) because some compilers sometimes optimize away the latter. See Bug#28213. */ -static Lisp_Object +static struct Lisp_String * live_string_holding (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_STRING) - { - struct string_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->strings[0]; + eassert (m->type == MEM_TYPE_STRING); + struct string_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->strings[0]; - /* P must point into a Lisp_String structure, and it - must not be on the free-list. */ - if (0 <= offset && offset < STRING_BLOCK_SIZE * sizeof b->strings[0]) + /* P must point into a Lisp_String structure, and it + must not be on the free-list. */ + if (0 <= offset && offset < sizeof b->strings) + { + ptrdiff_t off = offset % sizeof b->strings[0]; + if (off == Lisp_String + || off == 0 + || off == offsetof (struct Lisp_String, u.s.size_byte) + || off == offsetof (struct Lisp_String, u.s.intervals) + || off == offsetof (struct Lisp_String, u.s.data)) { - cp = ptr_bounds_copy (cp, b); - struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0]; + struct Lisp_String *s = p = cp -= off; if (s->u.s.data) - return make_lisp_ptr (s, Lisp_String); + return s; } } - return Qnil; + return NULL; } static bool live_string_p (struct mem_node *m, void *p) { - return !NILP (live_string_holding (m, p)); + return live_string_holding (m, p) == p; } /* If P is a pointer into a live Lisp cons object on the heap, return - the object. Otherwise, return nil. M is a pointer to the + the object's address. Otherwise, return NULL. M points to the mem_block for P. */ -static Lisp_Object +static struct Lisp_Cons * live_cons_holding (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_CONS) + eassert (m->type == MEM_TYPE_CONS); + struct cons_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->conses[0]; + + /* P must point into a Lisp_Cons, not be + one of the unused cells in the current cons block, + and not be on the free-list. */ + if (0 <= offset && offset < sizeof b->conses + && (b != cons_block + || offset / sizeof b->conses[0] < cons_block_index)) { - struct cons_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->conses[0]; - - /* P must point into a Lisp_Cons, not be - one of the unused cells in the current cons block, - and not be on the free-list. */ - if (0 <= offset && offset < CONS_BLOCK_SIZE * sizeof b->conses[0] - && (b != cons_block - || offset / sizeof b->conses[0] < cons_block_index)) + ptrdiff_t off = offset % sizeof b->conses[0]; + if (off == Lisp_Cons + || off == 0 + || off == offsetof (struct Lisp_Cons, u.s.u.cdr)) { - cp = ptr_bounds_copy (cp, b); - struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0]; + struct Lisp_Cons *s = p = cp -= off; if (!deadp (s->u.s.car)) - return make_lisp_ptr (s, Lisp_Cons); + return s; } } - return Qnil; + return NULL; } static bool live_cons_p (struct mem_node *m, void *p) { - return !NILP (live_cons_holding (m, p)); + return live_cons_holding (m, p) == p; } /* If P is a pointer into a live Lisp symbol object on the heap, - return the object. Otherwise, return nil. M is a pointer to the + return the object's address. Otherwise, return NULL. M points to the mem_block for P. */ -static Lisp_Object +static struct Lisp_Symbol * live_symbol_holding (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_SYMBOL) + eassert (m->type == MEM_TYPE_SYMBOL); + struct symbol_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->symbols[0]; + + /* P must point into the Lisp_Symbol, not be + one of the unused cells in the current symbol block, + and not be on the free-list. */ + if (0 <= offset && offset < sizeof b->symbols + && (b != symbol_block + || offset / sizeof b->symbols[0] < symbol_block_index)) { - struct symbol_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->symbols[0]; - - /* P must point into the Lisp_Symbol, not be - one of the unused cells in the current symbol block, - and not be on the free-list. */ - if (0 <= offset && offset < SYMBOL_BLOCK_SIZE * sizeof b->symbols[0] - && (b != symbol_block - || offset / sizeof b->symbols[0] < symbol_block_index)) + ptrdiff_t off = offset % sizeof b->symbols[0]; + if (off == Lisp_Symbol + + /* Plain '|| off == 0' would run afoul of GCC 10.2 + -Wlogical-op, as Lisp_Symbol happens to be zero. */ + || (Lisp_Symbol != 0 && off == 0) + + || off == offsetof (struct Lisp_Symbol, u.s.name) + || off == offsetof (struct Lisp_Symbol, u.s.val) + || off == offsetof (struct Lisp_Symbol, u.s.function) + || off == offsetof (struct Lisp_Symbol, u.s.plist) + || off == offsetof (struct Lisp_Symbol, u.s.next)) { - cp = ptr_bounds_copy (cp, b); - struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0]; + struct Lisp_Symbol *s = p = cp -= off; if (!deadp (s->u.s.function)) - return make_lisp_symbol (s); + return s; } } - return Qnil; + return NULL; } static bool live_symbol_p (struct mem_node *m, void *p) { - return !NILP (live_symbol_holding (m, p)); + return live_symbol_holding (m, p) == p; } -/* Return true if P is a pointer to a live Lisp float on - the heap. M is a pointer to the mem_block for P. */ - -static bool -live_float_p (struct mem_node *m, void *p) -{ - if (m->type == MEM_TYPE_FLOAT) - { - struct float_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->floats[0]; - - /* P must point to the start of a Lisp_Float and not be - one of the unused cells in the current float block. */ - return (offset >= 0 - && offset % sizeof b->floats[0] == 0 - && offset < (FLOAT_BLOCK_SIZE * sizeof b->floats[0]) - && (b != float_block - || offset / sizeof b->floats[0] < float_block_index)); - } - else - return 0; -} - -/* If P is a pointer to a live vector-like object, return the object. - Otherwise, return nil. +/* If P is a (possibly-tagged) pointer to a live Lisp_Float on the + heap, return the address of the Lisp_Float. Otherwise, return NULL. M is a pointer to the mem_block for P. */ -static Lisp_Object -live_vector_holding (struct mem_node *m, void *p) +static struct Lisp_Float * +live_float_holding (struct mem_node *m, void *p) { - struct Lisp_Vector *vp = p; + eassert (m->type == MEM_TYPE_FLOAT); + struct float_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->floats[0]; - if (m->type == MEM_TYPE_VECTOR_BLOCK) + /* P must point to (or be a tagged pointer to) the start of a + Lisp_Float and not be one of the unused cells in the current + float block. */ + if (0 <= offset && offset < sizeof b->floats) { - /* This memory node corresponds to a vector block. */ - struct vector_block *block = m->start; - struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data; - - /* P is in the block's allocation range. Scan the block - up to P and see whether P points to the start of some - vector which is not on a free list. FIXME: check whether - some allocation patterns (probably a lot of short vectors) - may cause a substantial overhead of this loop. */ - while (VECTOR_IN_BLOCK (vector, block) && vector <= vp) + int off = offset % sizeof b->floats[0]; + if ((off == Lisp_Float || off == 0) + && (b != float_block + || offset / sizeof b->floats[0] < float_block_index)) { - struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); - if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE)) - return make_lisp_ptr (vector, Lisp_Vectorlike); - vector = next; + p = cp - off; + return p; } } - else if (m->type == MEM_TYPE_VECTORLIKE) - { - /* This memory node corresponds to a large vector. */ - struct Lisp_Vector *vector = large_vector_vec (m->start); - struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); - if (vector <= vp && vp < next) - return make_lisp_ptr (vector, Lisp_Vectorlike); - } - return Qnil; + return NULL; } static bool -live_vector_p (struct mem_node *m, void *p) +live_float_p (struct mem_node *m, void *p) { - return !NILP (live_vector_holding (m, p)); + return live_float_holding (m, p) == p; } -/* If P is a pointer into a live buffer, return the buffer. - Otherwise, return nil. M is a pointer to the mem_block for P. */ +/* Return VECTOR if P points within it, NULL otherwise. */ -static Lisp_Object -live_buffer_holding (struct mem_node *m, void *p) +static struct Lisp_Vector * +live_vector_pointer (struct Lisp_Vector *vector, void *p) +{ + void *vvector = vector; + char *cvector = vvector; + char *cp = p; + ptrdiff_t offset = cp - cvector; + return ((offset == Lisp_Vectorlike + || offset == 0 + || (sizeof vector->header <= offset + && offset < vector_nbytes (vector) + && (! (vector->header.size & PSEUDOVECTOR_FLAG) + ? (offsetof (struct Lisp_Vector, contents) <= offset + && (((offset - offsetof (struct Lisp_Vector, contents)) + % word_size) + == 0)) + /* For non-bool-vector pseudovectors, treat any pointer + past the header as valid since it's too much of a pain + to write special-case code for every pseudovector. */ + : (! PSEUDOVECTOR_TYPEP (&vector->header, PVEC_BOOL_VECTOR) + || offset == offsetof (struct Lisp_Bool_Vector, size) + || (offsetof (struct Lisp_Bool_Vector, data) <= offset + && (((offset + - offsetof (struct Lisp_Bool_Vector, data)) + % sizeof (bits_word)) + == 0)))))) + ? vector : NULL); +} + +/* If P is a pointer to a live, large vector-like object, return the object. + Otherwise, return nil. + M is a pointer to the mem_block for P. */ + +static struct Lisp_Vector * +live_large_vector_holding (struct mem_node *m, void *p) { - /* P must point into the block, and the buffer - must not have been killed. */ - if (m->type == MEM_TYPE_BUFFER) - { - struct buffer *b = m->start; - char *cb = m->start; - char *cp = p; - ptrdiff_t offset = cp - cb; - if (0 <= offset && offset < sizeof *b && !NILP (b->name_)) - { - Lisp_Object obj; - XSETBUFFER (obj, b); - return obj; - } - } - return Qnil; + eassert (m->type == MEM_TYPE_VECTORLIKE); + return live_vector_pointer (large_vector_vec (m->start), p); } static bool -live_buffer_p (struct mem_node *m, void *p) +live_large_vector_p (struct mem_node *m, void *p) { - return !NILP (live_buffer_holding (m, p)); + return live_large_vector_holding (m, p) == p; } -/* Mark OBJ if we can prove it's a Lisp_Object. */ +/* If P is a pointer to a live, small vector-like object, return the object. + Otherwise, return NULL. + M is a pointer to the mem_block for P. */ -static void -mark_maybe_object (Lisp_Object obj) +static struct Lisp_Vector * +live_small_vector_holding (struct mem_node *m, void *p) { -#if USE_VALGRIND - VALGRIND_MAKE_MEM_DEFINED (&obj, sizeof (obj)); -#endif - - if (FIXNUMP (obj)) - return; - - void *po = XPNTR (obj); - - /* If the pointer is in the dump image and the dump has a record - of the object starting at the place where the pointer points, we - definitely have an object. If the pointer is in the dump image - and the dump has no idea what the pointer is pointing at, we - definitely _don't_ have an object. */ - if (pdumper_object_p (po)) - { - /* Don't use pdumper_object_p_precise here! It doesn't check the - tag bits. OBJ here might be complete garbage, so we need to - verify both the pointer and the tag. */ - if (XTYPE (obj) == pdumper_find_object_type (po)) - mark_object (obj); - return; - } - - struct mem_node *m = mem_find (po); - - if (m != MEM_NIL) + eassert (m->type == MEM_TYPE_VECTOR_BLOCK); + struct Lisp_Vector *vp = p; + struct vector_block *block = m->start; + struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data; + + /* P is in the block's allocation range. Scan the block + up to P and see whether P points to the start of some + vector which is not on a free list. FIXME: check whether + some allocation patterns (probably a lot of short vectors) + may cause a substantial overhead of this loop. */ + while (VECTOR_IN_BLOCK (vector, block) && vector <= vp) { - bool mark_p = false; - - switch (XTYPE (obj)) - { - case Lisp_String: - mark_p = EQ (obj, live_string_holding (m, po)); - break; - - case Lisp_Cons: - mark_p = EQ (obj, live_cons_holding (m, po)); - break; - - case Lisp_Symbol: - mark_p = EQ (obj, live_symbol_holding (m, po)); - break; - - case Lisp_Float: - mark_p = live_float_p (m, po); - break; - - case Lisp_Vectorlike: - mark_p = (EQ (obj, live_vector_holding (m, po)) - || EQ (obj, live_buffer_holding (m, po))); - break; - - default: - break; - } - - if (mark_p) - mark_object (obj); + struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); + if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE)) + return live_vector_pointer (vector, vp); + vector = next; } + return NULL; } -void -mark_maybe_objects (Lisp_Object const *array, ptrdiff_t nelts) +static bool +live_small_vector_p (struct mem_node *m, void *p) { - for (Lisp_Object const *lim = array + nelts; array < lim; array++) - mark_maybe_object (*array); + return live_small_vector_holding (m, p) == p; } /* If P points to Lisp data, mark that as live if it isn't already @@ -4593,65 +4692,99 @@ mark_maybe_pointer (void *p) { struct mem_node *m; -#ifdef USE_VALGRIND +#if USE_VALGRIND VALGRIND_MAKE_MEM_DEFINED (&p, sizeof (p)); #endif + /* If the pointer is in the dump image and the dump has a record + of the object starting at the place where the pointer points, we + definitely have an object. If the pointer is in the dump image + and the dump has no idea what the pointer is pointing at, we + definitely _don't_ have an object. */ if (pdumper_object_p (p)) { + /* Don't use pdumper_object_p_precise here! It doesn't check the + tag bits. OBJ here might be complete garbage, so we need to + verify both the pointer and the tag. */ int type = pdumper_find_object_type (p); if (pdumper_valid_object_type_p (type)) mark_object (type == Lisp_Symbol ? make_lisp_symbol (p) : make_lisp_ptr (p, type)); - /* See mark_maybe_object for why we can confidently return. */ return; } m = mem_find (p); if (m != MEM_NIL) { - Lisp_Object obj = Qnil; + Lisp_Object obj; switch (m->type) { case MEM_TYPE_NON_LISP: case MEM_TYPE_SPARE: /* Nothing to do; not a pointer to Lisp memory. */ - break; - - case MEM_TYPE_BUFFER: - obj = live_buffer_holding (m, p); - break; + return; case MEM_TYPE_CONS: - obj = live_cons_holding (m, p); + { + struct Lisp_Cons *h = live_cons_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_Cons); + } break; case MEM_TYPE_STRING: - obj = live_string_holding (m, p); + { + struct Lisp_String *h = live_string_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_String); + } break; case MEM_TYPE_SYMBOL: - obj = live_symbol_holding (m, p); + { + struct Lisp_Symbol *h = live_symbol_holding (m, p); + if (!h) + return; + obj = make_lisp_symbol (h); + } break; case MEM_TYPE_FLOAT: - if (live_float_p (m, p)) - obj = make_lisp_ptr (p, Lisp_Float); + { + struct Lisp_Float *h = live_float_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_Float); + } break; case MEM_TYPE_VECTORLIKE: + { + struct Lisp_Vector *h = live_large_vector_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_Vectorlike); + } + break; + case MEM_TYPE_VECTOR_BLOCK: - obj = live_vector_holding (m, p); + { + struct Lisp_Vector *h = live_small_vector_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_Vectorlike); + } break; default: emacs_abort (); } - if (!NILP (obj)) - mark_object (obj); + mark_object (obj); } } @@ -4700,7 +4833,7 @@ mark_memory (void const *start, void const *end) for (pp = start; (void const *) pp < end; pp += GC_POINTER_ALIGNMENT) { - char *p = *(char *const *) pp; + void *p = *(void *const *) pp; mark_maybe_pointer (p); /* Unmask any struct Lisp_Symbol pointer that make_lisp_symbol @@ -4708,13 +4841,9 @@ mark_memory (void const *start, void const *end) On a host with 32-bit pointers and 64-bit Lisp_Objects, a Lisp_Object might be split into registers saved into non-adjacent words and P might be the low-order word's value. */ - p += (intptr_t) lispsym; - mark_maybe_pointer (p); - - verify (alignof (Lisp_Object) % GC_POINTER_ALIGNMENT == 0); - if (alignof (Lisp_Object) == GC_POINTER_ALIGNMENT - || (uintptr_t) pp % alignof (Lisp_Object) == 0) - mark_maybe_object (*(Lisp_Object const *) pp); + intptr_t ip; + INT_ADD_WRAPV ((intptr_t) p, (intptr_t) lispsym, &ip); + mark_maybe_pointer ((void *) ip); } } @@ -4815,36 +4944,16 @@ test_setjmp (void) as a stack scan limit. */ typedef union { - /* Align the stack top properly. Even if !HAVE___BUILTIN_UNWIND_INIT, - jmp_buf may not be aligned enough on darwin-ppc64. */ - max_align_t o; + /* Make sure stack_top and m_stack_bottom are properly aligned as GC + expects. */ + Lisp_Object o; + void *p; #ifndef HAVE___BUILTIN_UNWIND_INIT sys_jmp_buf j; char c; #endif } stacktop_sentry; -/* Force callee-saved registers and register windows onto the stack. - Use the platform-defined __builtin_unwind_init if available, - obviating the need for machine dependent methods. */ -#ifndef HAVE___BUILTIN_UNWIND_INIT -# ifdef __sparc__ - /* This trick flushes the register windows so that all the state of - the process is contained in the stack. - FreeBSD does not have a ta 3 handler, so handle it specially. - FIXME: Code in the Boehm GC suggests flushing (with 'flushrs') is - needed on ia64 too. See mach_dep.c, where it also says inline - assembler doesn't work with relevant proprietary compilers. */ -# if defined __sparc64__ && defined __FreeBSD__ -# define __builtin_unwind_init() asm ("flushw") -# else -# define __builtin_unwind_init() asm ("ta 3") -# endif -# else -# define __builtin_unwind_init() ((void) 0) -# endif -#endif - /* Yield an address close enough to the top of the stack that the garbage collector need not scan above it. Callers should be declared NO_INLINE. */ @@ -4861,12 +4970,10 @@ typedef union #ifdef HAVE___BUILTIN_UNWIND_INIT # define SET_STACK_TOP_ADDRESS(p) \ stacktop_sentry sentry; \ - __builtin_unwind_init (); \ *(p) = NEAR_STACK_TOP (&sentry) #else # define SET_STACK_TOP_ADDRESS(p) \ stacktop_sentry sentry; \ - __builtin_unwind_init (); \ test_setjmp (); \ sys_setjmp (sentry.j); \ *(p) = NEAR_STACK_TOP (&sentry + (stack_bottom < &sentry.c)) @@ -4882,16 +4989,14 @@ typedef union We have to mark Lisp objects in CPU registers that can hold local variables or are used to pass parameters. - This code assumes that calling setjmp saves registers we need + If __builtin_unwind_init is available, it should suffice to save + registers. + + Otherwise, assume that calling setjmp saves registers we need to see in a jmp_buf which itself lies on the stack. This doesn't have to be true! It must be verified for each system, possibly by taking a look at the source code of setjmp. - If __builtin_unwind_init is available (defined by GCC >= 2.8) we - can use it as a machine independent method to store all registers - to the stack. In this case the macros described in the previous - two paragraphs are not used. - Stack Layout Architectures differ in the way their processor stack is organized. @@ -4930,8 +5035,9 @@ mark_stack (char const *bottom, char const *end) #endif } -/* This is a trampoline function that flushes registers to the stack, - and then calls FUNC. ARG is passed through to FUNC verbatim. +/* flush_stack_call_func is the trampoline function that flushes + registers to the stack, and then calls FUNC. ARG is passed through + to FUNC verbatim. This function must be called whenever Emacs is about to release the global interpreter lock. This lets the garbage collector easily @@ -4939,10 +5045,23 @@ mark_stack (char const *bottom, char const *end) Lisp. It is invalid to run any Lisp code or to allocate any GC memory - from FUNC. */ + from FUNC. + + Note: all register spilling is done in flush_stack_call_func before + flush_stack_call_func1 is activated. + + flush_stack_call_func1 is responsible for identifying the stack + address range to be scanned. It *must* be carefully kept as + noinline to make sure that registers has been spilled before it is + called, otherwise given __builtin_frame_address (0) typically + returns the frame pointer (base pointer) and not the stack pointer + [1] GC will miss to scan callee-saved registers content + (Bug#41357). + + [1] <https://gcc.gnu.org/onlinedocs/gcc/Return-Address.html>. */ NO_INLINE void -flush_stack_call_func (void (*func) (void *arg), void *arg) +flush_stack_call_func1 (void (*func) (void *arg), void *arg) { void *end; struct thread_state *self = current_thread; @@ -5032,9 +5151,6 @@ valid_lisp_object_p (Lisp_Object obj) case MEM_TYPE_SPARE: return 0; - case MEM_TYPE_BUFFER: - return live_buffer_p (m, p) ? 1 : 2; - case MEM_TYPE_CONS: return live_cons_p (m, p); @@ -5048,8 +5164,10 @@ valid_lisp_object_p (Lisp_Object obj) return live_float_p (m, p); case MEM_TYPE_VECTORLIKE: + return live_large_vector_p (m, p); + case MEM_TYPE_VECTOR_BLOCK: - return live_vector_p (m, p); + return live_small_vector_p (m, p); default: break; @@ -5099,7 +5217,7 @@ pure_alloc (size_t size, int type) pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp; if (pure_bytes_used <= pure_size) - return ptr_bounds_clip (result, size); + return result; /* Don't allocate a large amount here, because it might get mmap'd and then its address @@ -5190,7 +5308,7 @@ find_string_data_in_pure (const char *data, ptrdiff_t nbytes) /* Check the remaining characters. */ if (memcmp (data, non_lisp_beg + start, nbytes) == 0) /* Found. */ - return ptr_bounds_clip (non_lisp_beg + start, nbytes + 1); + return non_lisp_beg + start; start += last_char_skip; } @@ -5571,7 +5689,7 @@ compact_font_cache_entry (Lisp_Object entry) struct font *font = GC_XFONT_OBJECT (val); if (!NILP (AREF (val, FONT_TYPE_INDEX)) - && vectorlike_marked_p(&font->header)) + && vectorlike_marked_p (&font->header)) break; } if (CONSP (objlist)) @@ -5851,7 +5969,7 @@ maybe_garbage_collect (void) void garbage_collect (void) { - struct buffer *nextb; + Lisp_Object tail, buffer; char stack_top_variable; bool message_p; ptrdiff_t count = SPECPDL_INDEX (); @@ -5867,8 +5985,8 @@ garbage_collect (void) /* Don't keep undo information around forever. Do this early on, so it is no problem if the user quits. */ - FOR_EACH_BUFFER (nextb) - compact_buffer (nextb); + FOR_EACH_LIVE_BUFFER (tail, buffer) + compact_buffer (XBUFFER (buffer)); byte_ct tot_before = (profiler_memory_running ? total_bytes_of_live_objects () @@ -5914,7 +6032,6 @@ garbage_collect (void) stack_copy = xrealloc (stack_copy, stack_size); stack_copy_size = stack_size; } - stack = ptr_bounds_set (stack, stack_size); no_sanitize_memcpy (stack_copy, stack, stack_size); } } @@ -5948,18 +6065,15 @@ garbage_collect (void) mark_fringe_data (); #endif -#ifdef HAVE_MODULES - mark_modules (); -#endif - /* Everything is now marked, except for the data in font caches, undo lists, and finalizers. The first two are compacted by removing an items which aren't reachable otherwise. */ compact_font_caches (); - FOR_EACH_BUFFER (nextb) + FOR_EACH_LIVE_BUFFER (tail, buffer) { + struct buffer *nextb = XBUFFER (buffer); if (!EQ (BVAR (nextb, undo_list), Qt)) bset_undo_list (nextb, compact_undo_list (BVAR (nextb, undo_list))); /* Now that we have stripped the elements that need not be @@ -6046,10 +6160,17 @@ where each entry has the form (NAME SIZE USED FREE), where: - FREE is the number of those objects that are not live but that Emacs keeps around for future allocations (maybe because it does not know how to return them to the OS). + However, if there was overflow in pure space, and Emacs was dumped using the 'unexec' method, `garbage-collect' returns nil, because real GC can't be done. -See Info node `(elisp)Garbage Collection'. */) + +Note that calling this function does not guarantee that absolutely all +unreachable objects will be garbage-collected. Emacs uses a +mark-and-sweep garbage collector, but is conservative when it comes to +collecting objects in some circumstances. + +For further details, see Info node `(elisp)Garbage Collection'. */) (void) { if (garbage_collection_inhibited) @@ -6094,6 +6215,30 @@ See Info node `(elisp)Garbage Collection'. */) return CALLMANY (Flist, total); } +DEFUN ("garbage-collect-maybe", Fgarbage_collect_maybe, +Sgarbage_collect_maybe, 1, 1, "", + doc: /* Call `garbage-collect' if enough allocation happened. +FACTOR determines what "enough" means here: +If FACTOR is a positive number N, it means to run GC if more than +1/Nth of the allocations needed to trigger automatic allocation took +place. +Therefore, as N gets higher, this is more likely to perform a GC. +Returns non-nil if GC happened, and nil otherwise. */) + (Lisp_Object factor) +{ + CHECK_FIXNAT (factor); + EMACS_INT fact = XFIXNAT (factor); + + EMACS_INT since_gc = gc_threshold - consing_until_gc; + if (fact >= 1 && since_gc > gc_threshold / fact) + { + garbage_collect (); + return Qt; + } + else + return Qnil; +} + /* Mark Lisp objects in glyph matrix MATRIX. Currently the only interesting objects referenced from glyphs are strings. */ @@ -6135,7 +6280,6 @@ mark_vectorlike (union vectorlike_header *header) { struct Lisp_Vector *ptr = (struct Lisp_Vector *) header; ptrdiff_t size = ptr->header.size; - ptrdiff_t i; eassert (!vector_marked_p (ptr)); @@ -6150,8 +6294,7 @@ mark_vectorlike (union vectorlike_header *header) the number of Lisp_Object fields that we should trace. The distinction is used e.g. by Lisp_Process which places extra non-Lisp_Object fields at the end of the structure... */ - for (i = 0; i < size; i++) /* ...and then mark its elements. */ - mark_object (ptr->contents[i]); + mark_objects (ptr->contents, size); } /* Like mark_vectorlike but optimized for char-tables (and @@ -6226,7 +6369,12 @@ mark_buffer (struct buffer *buffer) /* For now, we just don't mark the undo_list. It's done later in a special way just before the sweep phase, and after stripping - some of its elements that are not needed any more. */ + some of its elements that are not needed any more. + Note: this later processing is only done for live buffers, so + for dead buffers, the undo_list should be nil (set by Fkill_buffer), + but just to be on the safe side, we mark it here. */ + if (!BUFFER_LIVE_P (buffer)) + mark_object (BVAR (buffer, undo_list)); mark_overlay (buffer->overlays_before); mark_overlay (buffer->overlays_after); @@ -6245,8 +6393,7 @@ mark_face_cache (struct face_cache *c) { if (c) { - int i, j; - for (i = 0; i < c->used; ++i) + for (int i = 0; i < c->used; i++) { struct face *face = FACE_FROM_ID_OR_NULL (c->f, i); @@ -6255,8 +6402,7 @@ mark_face_cache (struct face_cache *c) if (face->font && !vectorlike_marked_p (&face->font->header)) mark_vectorlike (&face->font->header); - for (j = 0; j < LFACE_VECTOR_SIZE; ++j) - mark_object (face->lface[j]); + mark_objects (face->lface, LFACE_VECTOR_SIZE); } } } @@ -6369,6 +6515,13 @@ mark_hash_table (struct Lisp_Vector *ptr) } } +void +mark_objects (Lisp_Object *obj, ptrdiff_t n) +{ + for (ptrdiff_t i = 0; i < n; i++) + mark_object (obj[i]); +} + /* Determine type of generic Lisp_Object and mark it accordingly. This function implements a straightforward depth-first marking @@ -6406,7 +6559,7 @@ mark_object (Lisp_Object arg) structure allocated from the heap. */ #define CHECK_ALLOCATED() \ do { \ - if (pdumper_object_p(po)) \ + if (pdumper_object_p (po)) \ { \ if (!pdumper_object_p_precise (po)) \ emacs_abort (); \ @@ -6419,19 +6572,19 @@ mark_object (Lisp_Object arg) /* Check that the object pointed to by PO is live, using predicate function LIVEP. */ -#define CHECK_LIVE(LIVEP) \ +#define CHECK_LIVE(LIVEP, MEM_TYPE) \ do { \ - if (pdumper_object_p(po)) \ + if (pdumper_object_p (po)) \ break; \ - if (!LIVEP (m, po)) \ + if (! (m->type == MEM_TYPE && LIVEP (m, po))) \ emacs_abort (); \ } while (0) /* Check both of the above conditions, for non-symbols. */ -#define CHECK_ALLOCATED_AND_LIVE(LIVEP) \ +#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) \ do { \ CHECK_ALLOCATED (); \ - CHECK_LIVE (LIVEP); \ + CHECK_LIVE (LIVEP, MEM_TYPE); \ } while (false) /* Check both of the above conditions, for symbols. */ @@ -6440,15 +6593,14 @@ mark_object (Lisp_Object arg) if (!c_symbol_p (ptr)) \ { \ CHECK_ALLOCATED (); \ - CHECK_LIVE (live_symbol_p); \ + CHECK_LIVE (live_symbol_p, MEM_TYPE_SYMBOL); \ } \ } while (false) #else /* not GC_CHECK_MARKED_OBJECTS */ -#define CHECK_LIVE(LIVEP) ((void) 0) -#define CHECK_ALLOCATED_AND_LIVE(LIVEP) ((void) 0) -#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0) +#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) ((void) 0) +#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0) #endif /* not GC_CHECK_MARKED_OBJECTS */ @@ -6459,7 +6611,7 @@ mark_object (Lisp_Object arg) register struct Lisp_String *ptr = XSTRING (obj); if (string_marked_p (ptr)) break; - CHECK_ALLOCATED_AND_LIVE (live_string_p); + CHECK_ALLOCATED_AND_LIVE (live_string_p, MEM_TYPE_STRING); set_string_marked (ptr); mark_interval_tree (ptr->u.s.intervals); #ifdef GC_CHECK_STRING_BYTES @@ -6477,36 +6629,25 @@ mark_object (Lisp_Object arg) if (vector_marked_p (ptr)) break; + enum pvec_type pvectype + = PSEUDOVECTOR_TYPE (ptr); + #ifdef GC_CHECK_MARKED_OBJECTS - if (!pdumper_object_p(po)) + if (!pdumper_object_p (po) && !SUBRP (obj) && !main_thread_p (po)) { m = mem_find (po); - if (m == MEM_NIL && !SUBRP (obj) && !main_thread_p (po)) + if (m == MEM_NIL) emacs_abort (); + if (m->type == MEM_TYPE_VECTORLIKE) + CHECK_LIVE (live_large_vector_p, MEM_TYPE_VECTORLIKE); + else + CHECK_LIVE (live_small_vector_p, MEM_TYPE_VECTOR_BLOCK); } -#endif /* GC_CHECK_MARKED_OBJECTS */ - - enum pvec_type pvectype - = PSEUDOVECTOR_TYPE (ptr); - - if (pvectype != PVEC_SUBR && - pvectype != PVEC_BUFFER && - !main_thread_p (po)) - CHECK_LIVE (live_vector_p); +#endif switch (pvectype) { case PVEC_BUFFER: -#if GC_CHECK_MARKED_OBJECTS - { - struct buffer *b; - FOR_EACH_BUFFER (b) - if (b == po) - break; - if (b == NULL) - emacs_abort (); - } -#endif /* GC_CHECK_MARKED_OBJECTS */ mark_buffer ((struct buffer *) ptr); break; @@ -6541,7 +6682,7 @@ mark_object (Lisp_Object arg) /* bool vectors in a dump are permanently "marked", since they're in the old section and don't have mark bits. If we're looking at a dumped bool vector, we should - have aborted above when we called vector_marked_p(), so + have aborted above when we called vector_marked_p, so we should never get here. */ eassert (!pdumper_object_p (ptr)); set_vector_marked (ptr); @@ -6572,7 +6713,7 @@ mark_object (Lisp_Object arg) if (symbol_marked_p (ptr)) break; CHECK_ALLOCATED_AND_LIVE_SYMBOL (); - set_symbol_marked(ptr); + set_symbol_marked (ptr); /* Attempt to catch bogus objects. */ eassert (valid_lisp_object_p (ptr->u.s.function)); mark_object (ptr->u.s.function); @@ -6613,7 +6754,7 @@ mark_object (Lisp_Object arg) struct Lisp_Cons *ptr = XCONS (obj); if (cons_marked_p (ptr)) break; - CHECK_ALLOCATED_AND_LIVE (live_cons_p); + CHECK_ALLOCATED_AND_LIVE (live_cons_p, MEM_TYPE_CONS); set_cons_marked (ptr); /* If the cdr is nil, avoid recursion for the car. */ if (NILP (ptr->u.s.u.cdr)) @@ -6631,7 +6772,7 @@ mark_object (Lisp_Object arg) } case Lisp_Float: - CHECK_ALLOCATED_AND_LIVE (live_float_p); + CHECK_ALLOCATED_AND_LIVE (live_float_p, MEM_TYPE_FLOAT); /* Do not mark floats stored in a dump image: these floats are "cold" and do not have mark bits. */ if (pdumper_object_p (XFLOAT (obj))) @@ -6758,8 +6899,7 @@ sweep_conses (void) for (pos = start; pos < stop; pos++) { - struct Lisp_Cons *acons - = ptr_bounds_copy (&cblk->conses[pos], cblk); + struct Lisp_Cons *acons = &cblk->conses[pos]; if (!XCONS_MARKED_P (acons)) { this_free++; @@ -6812,7 +6952,7 @@ sweep_floats (void) int this_free = 0; for (int i = 0; i < lim; i++) { - struct Lisp_Float *afloat = ptr_bounds_copy (&fblk->floats[i], fblk); + struct Lisp_Float *afloat = &fblk->floats[i]; if (!XFLOAT_MARKED_P (afloat)) { this_free++; @@ -6985,25 +7125,17 @@ NO_INLINE /* For better stack traces */ static void sweep_buffers (void) { - struct buffer *buffer, **bprev = &all_buffers; + Lisp_Object tail, buf; gcstat.total_buffers = 0; - for (buffer = all_buffers; buffer; buffer = *bprev) - if (!vectorlike_marked_p (&buffer->header)) - { - *bprev = buffer->next; - lisp_free (buffer); - } - else - { - if (!pdumper_object_p (buffer)) - XUNMARK_VECTOR (buffer); - /* Do not use buffer_(set|get)_intervals here. */ - buffer->text->intervals = balance_intervals (buffer->text->intervals); - unchain_dead_markers (buffer); - gcstat.total_buffers++; - bprev = &buffer->next; - } + FOR_EACH_LIVE_BUFFER (tail, buf) + { + struct buffer *buffer = XBUFFER (buf); + /* Do not use buffer_(set|get)_intervals here. */ + buffer->text->intervals = balance_intervals (buffer->text->intervals); + unchain_dead_markers (buffer); + gcstat.total_buffers++; + } } /* Sweep: find all structures not marked, and free them. */ @@ -7095,6 +7227,20 @@ Frames, windows, buffers, and subprocesses count as vectors make_int (strings_consed)); } +#ifdef GNU_LINUX +DEFUN ("malloc-info", Fmalloc_info, Smalloc_info, 0, 0, "", + doc: /* Report malloc information to stderr. +This function outputs to stderr an XML-formatted +description of the current state of the memory-allocation +arenas. */) + (void) +{ + if (malloc_info (0, stderr)) + error ("malloc_info failed: %s", emacs_strerror (errno)); + return Qnil; +} +#endif + static bool symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj) { @@ -7437,8 +7583,12 @@ N should be nonnegative. */); defsubr (&Smake_finalizer); defsubr (&Spurecopy); defsubr (&Sgarbage_collect); + defsubr (&Sgarbage_collect_maybe); defsubr (&Smemory_info); defsubr (&Smemory_use_counts); +#ifdef GNU_LINUX + defsubr (&Smalloc_info); +#endif defsubr (&Ssuspicious_object); Lisp_Object watcher; diff --git a/src/bidi.c b/src/bidi.c index 60630c82c13..1413ba6b888 100644 --- a/src/bidi.c +++ b/src/bidi.c @@ -109,7 +109,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ ------------------- In a nutshell, fetching the next character boils down to calling - STRING_CHAR_AND_LENGTH, passing it the address of a buffer or + string_char_and_length, passing it the address of a buffer or string position. See bidi_fetch_char. However, if the next character is "covered" by a display property of some kind, bidi_fetch_char returns the u+FFFC "object replacement character" @@ -1269,7 +1269,6 @@ bidi_fetch_char (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t *disp_pos, ptrdiff_t endpos = (string->s || STRINGP (string->lstring)) ? string->schars : ZV; struct text_pos pos; - int len; /* If we got past the last known position of display string, compute the position of the next one. That position could be at CHARPOS. */ @@ -1341,10 +1340,10 @@ bidi_fetch_char (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t *disp_pos, normal_char: if (string->s) { - if (!string->unibyte) { - ch = STRING_CHAR_AND_LENGTH (string->s + bytepos, len); + int len; + ch = string_char_and_length (string->s + bytepos, &len); *ch_len = len; } else @@ -1357,8 +1356,9 @@ bidi_fetch_char (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t *disp_pos, { if (!string->unibyte) { - ch = STRING_CHAR_AND_LENGTH (SDATA (string->lstring) + bytepos, - len); + int len; + ch = string_char_and_length (SDATA (string->lstring) + bytepos, + &len); *ch_len = len; } else @@ -1369,9 +1369,11 @@ bidi_fetch_char (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t *disp_pos, } else { - ch = STRING_CHAR_AND_LENGTH (BYTE_POS_ADDR (bytepos), len); + int len; + ch = string_char_and_length (BYTE_POS_ADDR (bytepos), &len); *ch_len = len; } + *nchars = 1; } @@ -1561,7 +1563,7 @@ bidi_find_paragraph_start (ptrdiff_t pos, ptrdiff_t pos_byte) display string? And what if a display string covering some of the text over which we scan back includes paragraph_start_re? */ - DEC_BOTH (pos, pos_byte); + dec_both (&pos, &pos_byte); if (bpc && region_cache_backward (cache_buffer, bpc, pos, &next)) { pos = next, pos_byte = CHAR_TO_BYTE (pos); @@ -1775,7 +1777,7 @@ bidi_paragraph_init (bidi_dir_t dir, struct bidi_it *bidi_it, bool no_default_p) /* FXIME: What if p is covered by a display string? See also a FIXME inside bidi_find_paragraph_start. */ - DEC_BOTH (p, pbyte); + dec_both (&p, &pbyte); prevpbyte = bidi_find_paragraph_start (p, pbyte); } pstartbyte = prevpbyte; @@ -2348,7 +2350,7 @@ bidi_resolve_weak (struct bidi_it *bidi_it) and make it L right away, to avoid the potentially costly loop below. This is important when the buffer has a long series of - control characters, like binary NULs, and no + control characters, like binary nulls, and no R2L characters at all. */ && new_level == 0 && !bidi_explicit_dir_char (bidi_it->ch) @@ -3006,7 +3008,7 @@ bidi_resolve_neutral (struct bidi_it *bidi_it) } /* The next two "else if" clauses are shortcuts for the important special case when we have a long sequence of - neutral or WEAK_BN characters, such as whitespace or NULs or + neutral or WEAK_BN characters, such as whitespace or nulls or other control characters, on the base embedding level of the paragraph, and that sequence goes all the way to the end of the paragraph and follows a character whose resolved diff --git a/src/bignum.c b/src/bignum.c index 0dd18fcff73..1ac75c19e24 100644 --- a/src/bignum.c +++ b/src/bignum.c @@ -353,7 +353,7 @@ emacs_mpz_pow_ui (mpz_t rop, mpz_t const base, unsigned long exp) /* Yield an upper bound on the buffer size needed to contain a C string representing the NUM in base BASE. This includes any - preceding '-' and the terminating NUL. */ + preceding '-' and the terminating null. */ static ptrdiff_t mpz_bufsize (mpz_t const num, int base) { @@ -418,7 +418,7 @@ bignum_to_string (Lisp_Object num, int base) /* Create a bignum by scanning NUM, with digits in BASE. NUM must consist of an optional '-', a nonempty sequence - of base-BASE digits, and a terminating NUL byte, and + of base-BASE digits, and a terminating null byte, and the represented number must not be in fixnum range. */ Lisp_Object @@ -431,3 +431,39 @@ make_bignum_str (char const *num, int base) eassert (check == 0); return make_lisp_ptr (b, Lisp_Vectorlike); } + +/* Check that X is a Lisp integer in the range LO..HI. + Return X's value as an intmax_t. */ + +intmax_t +check_integer_range (Lisp_Object x, intmax_t lo, intmax_t hi) +{ + CHECK_INTEGER (x); + intmax_t i; + if (! (integer_to_intmax (x, &i) && lo <= i && i <= hi)) + args_out_of_range_3 (x, make_int (lo), make_int (hi)); + return i; +} + +/* Check that X is a Lisp integer in the range 0..HI. + Return X's value as an uintmax_t. */ + +uintmax_t +check_uinteger_max (Lisp_Object x, uintmax_t hi) +{ + CHECK_INTEGER (x); + uintmax_t i; + if (! (integer_to_uintmax (x, &i) && i <= hi)) + args_out_of_range_3 (x, make_fixnum (0), make_uint (hi)); + return i; +} + +/* Check that X is a Lisp integer no greater than INT_MAX, + and return its value or zero, whichever is greater. */ + +int +check_int_nonnegative (Lisp_Object x) +{ + CHECK_INTEGER (x); + return NILP (Fnatnump (x)) ? 0 : check_integer_range (x, 0, INT_MAX); +} diff --git a/src/bignum.h b/src/bignum.h index e14f7be99eb..33a540e9093 100644 --- a/src/bignum.h +++ b/src/bignum.h @@ -22,12 +22,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #ifndef BIGNUM_H #define BIGNUM_H -#ifdef HAVE_GMP -# include <gmp.h> -#else -# include "mini-gmp.h" -#endif - +#include <gmp.h> #include "lisp.h" /* Number of data bits in a limb. */ @@ -55,7 +50,7 @@ extern void emacs_mpz_mul_2exp (mpz_t, mpz_t const, EMACS_INT) ARG_NONNULL ((1, 2)); extern void emacs_mpz_pow_ui (mpz_t, mpz_t const, unsigned long) ARG_NONNULL ((1, 2)); -extern double mpz_get_d_rounded (mpz_t const); +extern double mpz_get_d_rounded (mpz_t const) ATTRIBUTE_CONST; INLINE_HEADER_BEGIN @@ -108,7 +103,8 @@ bignum_integer (mpz_t *tmp, Lisp_Object i) if (FIXNUMP (i)) { mpz_set_intmax (*tmp, XFIXNUM (i)); - return tmp; + /* The unnecessary cast pacifies a buggy GCC 4.8.5. */ + return (mpz_t const *) tmp; } return xbignum_val (i); } diff --git a/src/buffer.c b/src/buffer.c index a60327bb6ca..80c799e719b 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -37,7 +37,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "window.h" #include "commands.h" #include "character.h" -#include "coding.h" #include "buffer.h" #include "region-cache.h" #include "indent.h" @@ -51,11 +50,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "w32heap.h" /* for mmap_* */ #endif -/* First buffer in chain of all buffers (in reverse order of creation). - Threaded through ->header.next.buffer. */ - -struct buffer *all_buffers; - /* This structure holds the default values of the buffer-local variables defined with DEFVAR_PER_BUFFER, that have special slots in each buffer. The default value occupies the same slot in this structure @@ -125,6 +119,7 @@ static void free_buffer_text (struct buffer *b); static struct Lisp_Overlay * copy_overlays (struct buffer *, struct Lisp_Overlay *); static void modify_overlay (struct buffer *, ptrdiff_t, ptrdiff_t); static Lisp_Object buffer_lisp_local_variables (struct buffer *, bool); +static Lisp_Object buffer_local_variables_1 (struct buffer *buf, int offset, Lisp_Object sym); static void CHECK_OVERLAY (Lisp_Object x) @@ -132,6 +127,23 @@ CHECK_OVERLAY (Lisp_Object x) CHECK_TYPE (OVERLAYP (x), Qoverlayp, x); } +/* Convert the position POS to an EMACS_INT that fits in a fixnum. + Yield POS's value if POS is already a fixnum, POS's marker position + if POS is a marker, and MOST_NEGATIVE_FIXNUM or + MOST_POSITIVE_FIXNUM if POS is a negative or positive bignum. + Signal an error if POS is not of the proper form. */ + +EMACS_INT +fix_position (Lisp_Object pos) +{ + if (FIXNUMP (pos)) + return XFIXNUM (pos); + if (MARKERP (pos)) + return marker_position (pos); + CHECK_TYPE (BIGNUMP (pos), Qinteger_or_marker_p, pos); + return !NILP (Fnatnump (pos)) ? MOST_POSITIVE_FIXNUM : MOST_NEGATIVE_FIXNUM; +} + /* These setters are used only in this file, so they can be private. The public setters are inline functions defined in buffer.h. */ static void @@ -285,11 +297,6 @@ bset_mark (struct buffer *b, Lisp_Object val) b->mark_ = val; } static void -bset_minor_modes (struct buffer *b, Lisp_Object val) -{ - b->minor_modes_ = val; -} -static void bset_mode_line_format (struct buffer *b, Lisp_Object val) { b->mode_line_format_ = val; @@ -506,16 +513,33 @@ get_truename_buffer (register Lisp_Object filename) return Qnil; } -DEFUN ("get-buffer-create", Fget_buffer_create, Sget_buffer_create, 1, 1, 0, +/* Run buffer-list-update-hook if Vrun_hooks is non-nil, and BUF is NULL + or does not have buffer hooks inhibited. BUF is NULL when called by + make-indirect-buffer, since it does not inhibit buffer hooks. */ + +static void +run_buffer_list_update_hook (struct buffer *buf) +{ + if (! (NILP (Vrun_hooks) || (buf && buf->inhibit_buffer_hooks))) + call1 (Vrun_hooks, Qbuffer_list_update_hook); +} + +DEFUN ("get-buffer-create", Fget_buffer_create, Sget_buffer_create, 1, 2, 0, doc: /* Return the buffer specified by BUFFER-OR-NAME, creating a new one if needed. If BUFFER-OR-NAME is a string and a live buffer with that name exists, return that buffer. If no such buffer exists, create a new buffer with -that name and return it. If BUFFER-OR-NAME starts with a space, the new -buffer does not keep undo information. +that name and return it. + +If BUFFER-OR-NAME starts with a space, the new buffer does not keep undo +information. If optional argument INHIBIT-BUFFER-HOOKS is non-nil, the +new buffer does not run the hooks `kill-buffer-hook', +`kill-buffer-query-functions', and `buffer-list-update-hook'. This +avoids slowing down internal or temporary buffers that are never +presented to users or passed on to other applications. If BUFFER-OR-NAME is a buffer instead of a string, return it as given, even if it is dead. The return value is never nil. */) - (register Lisp_Object buffer_or_name) + (register Lisp_Object buffer_or_name, Lisp_Object inhibit_buffer_hooks) { register Lisp_Object buffer, name; register struct buffer *b; @@ -590,11 +614,7 @@ even if it is dead. The return value is never nil. */) set_string_intervals (name, NULL); bset_name (b, name); - b->inhibit_buffer_hooks - = (STRINGP (Vcode_conversion_workbuf_name) - && strncmp (SSDATA (name), SSDATA (Vcode_conversion_workbuf_name), - SBYTES (Vcode_conversion_workbuf_name)) == 0); - + b->inhibit_buffer_hooks = !NILP (inhibit_buffer_hooks); bset_undo_list (b, SREF (name, 0) != ' ' ? Qnil : Qt); reset_buffer (b); @@ -606,9 +626,8 @@ even if it is dead. The return value is never nil. */) /* Put this in the alist of all live buffers. */ XSETBUFFER (buffer, b); Vbuffer_alist = nconc2 (Vbuffer_alist, list1 (Fcons (name, buffer))); - /* And run buffer-list-update-hook. */ - if (!NILP (Vrun_hooks) && !b->inhibit_buffer_hooks) - call1 (Vrun_hooks, Qbuffer_list_update_hook); + + run_buffer_list_update_hook (b); return buffer; } @@ -882,9 +901,7 @@ CLONE nil means the indirect buffer's state is reset to default values. */) set_buffer_internal_1 (old_b); } - /* Run buffer-list-update-hook. */ - if (!NILP (Vrun_hooks)) - call1 (Vrun_hooks, Qbuffer_list_update_hook); + run_buffer_list_update_hook (NULL); return buf; } @@ -992,7 +1009,6 @@ reset_buffer_local_variables (struct buffer *b, bool permanent_too) bset_major_mode (b, Qfundamental_mode); bset_keymap (b, Qnil); bset_mode_name (b, QSFundamental); - bset_minor_modes (b, Qnil); /* If the standard case table has been altered and invalidated, fix up its insides first. */ @@ -1289,6 +1305,25 @@ buffer_lisp_local_variables (struct buffer *buf, bool clone) return result; } + +/* If the variable at position index OFFSET in buffer BUF has a + buffer-local value, return (name . value). If SYM is non-nil, + it replaces name. */ + +static Lisp_Object +buffer_local_variables_1 (struct buffer *buf, int offset, Lisp_Object sym) +{ + int idx = PER_BUFFER_IDX (offset); + if ((idx == -1 || PER_BUFFER_VALUE_P (buf, idx)) + && SYMBOLP (PER_BUFFER_SYMBOL (offset))) + { + sym = NILP (sym) ? PER_BUFFER_SYMBOL (offset) : sym; + Lisp_Object val = per_buffer_value (buf, offset); + return EQ (val, Qunbound) ? sym : Fcons (sym, val); + } + return Qnil; +} + DEFUN ("buffer-local-variables", Fbuffer_local_variables, Sbuffer_local_variables, 0, 1, 0, doc: /* Return an alist of variables that are buffer-local in BUFFER. @@ -1300,25 +1335,25 @@ No argument or nil as argument means use current buffer as BUFFER. */) { struct buffer *buf = decode_buffer (buffer); Lisp_Object result = buffer_lisp_local_variables (buf, 0); + Lisp_Object tem; /* Add on all the variables stored in special slots. */ { - int offset, idx; + int offset; FOR_EACH_PER_BUFFER_OBJECT_AT (offset) { - idx = PER_BUFFER_IDX (offset); - if ((idx == -1 || PER_BUFFER_VALUE_P (buf, idx)) - && SYMBOLP (PER_BUFFER_SYMBOL (offset))) - { - Lisp_Object sym = PER_BUFFER_SYMBOL (offset); - Lisp_Object val = per_buffer_value (buf, offset); - result = Fcons (EQ (val, Qunbound) ? sym : Fcons (sym, val), - result); - } + tem = buffer_local_variables_1 (buf, offset, Qnil); + if (!NILP (tem)) + result = Fcons (tem, result); } } + tem = buffer_local_variables_1 (buf, PER_BUFFER_VAR_OFFSET (undo_list), + intern ("buffer-undo-list")); + if (!NILP (tem)) + result = Fcons (tem, result); + return result; } @@ -1510,9 +1545,7 @@ This does not change the name of the visited file (if any). */) && !NILP (BVAR (current_buffer, auto_save_file_name))) call0 (intern ("rename-auto-save-file")); - /* Run buffer-list-update-hook. */ - if (!NILP (Vrun_hooks) && !current_buffer->inhibit_buffer_hooks) - call1 (Vrun_hooks, Qbuffer_list_update_hook); + run_buffer_list_update_hook (current_buffer); /* Refetch since that last call may have done GC. */ return BVAR (current_buffer, name); @@ -1586,7 +1619,7 @@ exists, return the buffer `*scratch*' (creating it if necessary). */) buf = Fget_buffer (scratch); if (NILP (buf)) { - buf = Fget_buffer_create (scratch); + buf = Fget_buffer_create (scratch, Qnil); Fset_buffer_major_mode (buf); } return buf; @@ -1610,7 +1643,7 @@ other_buffer_safely (Lisp_Object buffer) buf = Fget_buffer (scratch); if (NILP (buf)) { - buf = Fget_buffer_create (scratch); + buf = Fget_buffer_create (scratch, Qnil); Fset_buffer_major_mode (buf); } @@ -1687,7 +1720,9 @@ buffer to be killed as the current buffer. If any of them returns nil, the buffer is not killed. The hook `kill-buffer-hook' is run before the buffer is actually killed. The buffer being killed will be current while the hook is running. Functions called by any of these hooks are -supposed to not change the current buffer. +supposed to not change the current buffer. Neither hook is run for +internal or temporary buffers created by `get-buffer-create' or +`generate-new-buffer' with argument INHIBIT-BUFFER-HOOKS non-nil. Any processes that have this buffer as the `process-buffer' are killed with SIGHUP. This function calls `replace-buffer-in-windows' for @@ -1770,15 +1805,11 @@ cleaning up all windows currently displaying the buffer to be killed. */) ask questions or their hooks get errors. */ if (!b->base_buffer && b->indirections > 0) { - struct buffer *other; + Lisp_Object tail, other; - FOR_EACH_BUFFER (other) - if (other->base_buffer == b) - { - Lisp_Object buf; - XSETBUFFER (buf, other); - Fkill_buffer (buf); - } + FOR_EACH_LIVE_BUFFER (tail, other) + if (XBUFFER (other)->base_buffer == b) + Fkill_buffer (other); /* Exit if we now have killed the base buffer (Bug#11665). */ if (!BUFFER_LIVE_P (b)) @@ -1833,6 +1864,9 @@ cleaning up all windows currently displaying the buffer to be killed. */) tem = Vinhibit_quit; Vinhibit_quit = Qt; + /* Once the buffer is removed from Vbuffer_alist, its undo_list field is + not traced by the GC in the same way. So set it to nil early. */ + bset_undo_list (b, Qnil); /* Remove the buffer from the list of all buffers. */ Vbuffer_alist = Fdelq (Frassq (buffer, Vbuffer_alist), Vbuffer_alist); /* If replace_buffer_in_windows didn't do its job fix that now. */ @@ -1947,11 +1981,8 @@ cleaning up all windows currently displaying the buffer to be killed. */) } bset_width_table (b, Qnil); unblock_input (); - bset_undo_list (b, Qnil); - /* Run buffer-list-update-hook. */ - if (!NILP (Vrun_hooks) && !b->inhibit_buffer_hooks) - call1 (Vrun_hooks, Qbuffer_list_update_hook); + run_buffer_list_update_hook (b); return Qt; } @@ -1991,9 +2022,7 @@ record_buffer (Lisp_Object buffer) fset_buffer_list (f, Fcons (buffer, Fdelq (buffer, f->buffer_list))); fset_buried_buffer_list (f, Fdelq (buffer, f->buried_buffer_list)); - /* Run buffer-list-update-hook. */ - if (!NILP (Vrun_hooks) && !XBUFFER (buffer)->inhibit_buffer_hooks) - call1 (Vrun_hooks, Qbuffer_list_update_hook); + run_buffer_list_update_hook (XBUFFER (buffer)); } @@ -2030,9 +2059,7 @@ DEFUN ("bury-buffer-internal", Fbury_buffer_internal, Sbury_buffer_internal, fset_buried_buffer_list (f, Fcons (buffer, Fdelq (buffer, f->buried_buffer_list))); - /* Run buffer-list-update-hook. */ - if (!NILP (Vrun_hooks) && !XBUFFER (buffer)->inhibit_buffer_hooks) - call1 (Vrun_hooks, Qbuffer_list_update_hook); + run_buffer_list_update_hook (XBUFFER (buffer)); return Qnil; } @@ -2258,19 +2285,20 @@ so the buffer is truly empty after this. */) } void -validate_region (register Lisp_Object *b, register Lisp_Object *e) +validate_region (Lisp_Object *b, Lisp_Object *e) { - CHECK_FIXNUM_COERCE_MARKER (*b); - CHECK_FIXNUM_COERCE_MARKER (*e); + EMACS_INT beg = fix_position (*b), end = fix_position (*e); - if (XFIXNUM (*b) > XFIXNUM (*e)) + if (end < beg) { - Lisp_Object tem; - tem = *b; *b = *e; *e = tem; + EMACS_INT tem = beg; beg = end; end = tem; } - if (! (BEGV <= XFIXNUM (*b) && XFIXNUM (*e) <= ZV)) + if (! (BEGV <= beg && end <= ZV)) args_out_of_range_3 (Fcurrent_buffer (), *b, *e); + + *b = make_fixnum (beg); + *e = make_fixnum (end); } /* Advance BYTE_POS up to a character boundary @@ -2298,7 +2326,7 @@ advance_to_char_boundary (ptrdiff_t byte_pos) c = FETCH_BYTE (byte_pos); } while (! CHAR_HEAD_P (c) && byte_pos > BEG); - INC_POS (byte_pos); + byte_pos += next_char_len (byte_pos); if (byte_pos < orig_byte_pos) byte_pos = orig_byte_pos; /* If C is a constituent of a multibyte sequence, BYTE_POS was @@ -2334,10 +2362,10 @@ results, see Info node `(elisp)Swapping Text'. */) error ("Cannot swap indirect buffers's text"); { /* This is probably harder to make work. */ - struct buffer *other; - FOR_EACH_BUFFER (other) - if (other->base_buffer == other_buffer - || other->base_buffer == current_buffer) + Lisp_Object tail, other; + FOR_EACH_LIVE_BUFFER (tail, other) + if (XBUFFER (other)->base_buffer == other_buffer + || XBUFFER (other)->base_buffer == current_buffer) error ("One of the buffers to swap has indirect buffers"); } @@ -2485,7 +2513,7 @@ current buffer is cleared. */) (Lisp_Object flag) { struct Lisp_Marker *tail, *markers; - struct buffer *other; + Lisp_Object btail, other; ptrdiff_t begv, zv; bool narrowed = (BEG != BEGV || Z != ZV); bool modified_p = !NILP (Fbuffer_modified_p (Qnil)); @@ -2542,8 +2570,6 @@ current buffer is cleared. */) p = BEG_ADDR; while (1) { - int c, bytes; - if (pos == stop) { if (pos == Z) @@ -2555,7 +2581,7 @@ current buffer is cleared. */) p++, pos++; else if (CHAR_BYTE8_HEAD_P (*p)) { - c = STRING_CHAR_AND_LENGTH (p, bytes); + int bytes, c = string_char_and_length (p, &bytes); /* Delete all bytes for this 8-bit character but the last one, and change the last one to the character code. */ @@ -2572,12 +2598,10 @@ current buffer is cleared. */) } else { - bytes = BYTES_BY_CHAR_HEAD (*p); + int bytes = BYTES_BY_CHAR_HEAD (*p); p += bytes, pos += bytes; } } - if (narrowed) - Fnarrow_to_region (make_fixnum (begv), make_fixnum (zv)); } else { @@ -2626,8 +2650,7 @@ current buffer is cleared. */) if (ASCII_CHAR_P (*p)) p++, pos++; else if (EQ (flag, Qt) - && ! CHAR_BYTE8_HEAD_P (*p) - && (bytes = MULTIBYTE_LENGTH (p, pend)) > 0) + && 0 < (bytes = multibyte_length (p, pend, true, false))) p += bytes, pos += bytes; else { @@ -2657,9 +2680,6 @@ current buffer is cleared. */) if (pt != PT) TEMP_SET_PT (pt); - if (narrowed) - Fnarrow_to_region (make_fixnum (begv), make_fixnum (zv)); - /* Do this first, so that chars_in_text asks the right question. set_intervals_multibyte needs it too. */ bset_enable_multibyte_characters (current_buffer, Qt); @@ -2738,13 +2758,16 @@ current buffer is cleared. */) /* Copy this buffer's new multibyte status into all of its indirect buffers. */ - FOR_EACH_BUFFER (other) - if (other->base_buffer == current_buffer && BUFFER_LIVE_P (other)) - { - BVAR (other, enable_multibyte_characters) - = BVAR (current_buffer, enable_multibyte_characters); - other->prevent_redisplay_optimizations_p = 1; - } + FOR_EACH_LIVE_BUFFER (btail, other) + { + struct buffer *o = XBUFFER (other); + if (o->base_buffer == current_buffer && BUFFER_LIVE_P (o)) + { + BVAR (o, enable_multibyte_characters) + = BVAR (current_buffer, enable_multibyte_characters); + o->prevent_redisplay_optimizations_p = true; + } + } /* Restore the modifiedness of the buffer. */ if (!modified_p && !NILP (Fbuffer_modified_p (Qnil))) @@ -2789,7 +2812,7 @@ the normal hook `change-major-mode-hook'. */) /* Force mode-line redisplay. Useful here because all major mode commands call this function. */ - update_mode_lines = 12; + bset_update_mode_line (current_buffer); return Qnil; } @@ -4762,7 +4785,7 @@ mmap_init (void) if (mmap_fd <= 0) { /* No anonymous mmap -- we need the file descriptor. */ - mmap_fd = emacs_open ("/dev/zero", O_RDONLY, 0); + mmap_fd = emacs_open_noquit ("/dev/zero", O_RDONLY, 0); if (mmap_fd == -1) fatal ("Cannot open /dev/zero: %s", emacs_strerror (errno)); } @@ -5053,6 +5076,7 @@ enlarge_buffer_text (struct buffer *b, ptrdiff_t delta) #else p = xrealloc (b->text->beg, new_nbytes); #endif + __lsan_ignore_object (p); if (p == NULL) { @@ -5149,7 +5173,6 @@ init_buffer_once (void) bset_upcase_table (&buffer_local_flags, make_fixnum (0)); bset_case_canon_table (&buffer_local_flags, make_fixnum (0)); bset_case_eqv_table (&buffer_local_flags, make_fixnum (0)); - bset_minor_modes (&buffer_local_flags, make_fixnum (0)); bset_width_table (&buffer_local_flags, make_fixnum (0)); bset_pt_marker (&buffer_local_flags, make_fixnum (0)); bset_begv_marker (&buffer_local_flags, make_fixnum (0)); @@ -5310,8 +5333,6 @@ init_buffer_once (void) Vbuffer_alist = Qnil; current_buffer = 0; pdumper_remember_lv_ptr_raw (¤t_buffer, Lisp_Vectorlike); - all_buffers = 0; - pdumper_remember_lv_ptr_raw (&all_buffers, Lisp_Vectorlike); QSFundamental = build_pure_c_string ("Fundamental"); @@ -5326,10 +5347,11 @@ init_buffer_once (void) Fput (Qkill_buffer_hook, Qpermanent_local, Qt); /* Super-magic invisible buffer. */ - Vprin1_to_string_buffer = Fget_buffer_create (build_pure_c_string (" prin1")); + Vprin1_to_string_buffer = + Fget_buffer_create (build_pure_c_string (" prin1"), Qt); Vbuffer_alist = Qnil; - Fset_buffer (Fget_buffer_create (build_pure_c_string ("*scratch*"))); + Fset_buffer (Fget_buffer_create (build_pure_c_string ("*scratch*"), Qnil)); inhibit_modification_hooks = 0; } @@ -5342,7 +5364,7 @@ init_buffer (void) #ifdef USE_MMAP_FOR_BUFFERS if (dumped_with_unexec_p ()) { - struct buffer *b; + Lisp_Object tail, buffer; #ifndef WINDOWSNT /* These must be reset in the dumped Emacs, to avoid stale @@ -5364,27 +5386,17 @@ init_buffer (void) " *code-conversion-work*". They are created by init_buffer_once and init_window_once (which are not called in the dumped Emacs), and by the first call to coding.c routines. */ - FOR_EACH_BUFFER (b) + FOR_EACH_LIVE_BUFFER (tail, buffer) { + struct buffer *b = XBUFFER (buffer); b->text->beg = NULL; enlarge_buffer_text (b, 0); } } - else - { - struct buffer *b; - - /* Only buffers with allocated buffer text should be present at - this point in temacs. */ - FOR_EACH_BUFFER (b) - { - eassert (b->text->beg != NULL); - } - } #endif /* USE_MMAP_FOR_BUFFERS */ AUTO_STRING (scratch, "*scratch*"); - Fset_buffer (Fget_buffer_create (scratch)); + Fset_buffer (Fget_buffer_create (scratch, Qnil)); if (NILP (BVAR (&buffer_defaults, enable_multibyte_characters))) Fset_buffer_multibyte (Qnil); @@ -6251,6 +6263,9 @@ Values are interpreted as follows: t use the cursor specified for the frame nil don't display a cursor box display a filled box cursor + (box . SIZE) display a filled box cursor, but make it + hollow if cursor is under masked image larger than + SIZE pixels in either dimension. hollow display a hollow box cursor bar display a vertical bar cursor with default width (bar . WIDTH) display a vertical bar cursor with width WIDTH @@ -6284,9 +6299,14 @@ Use Custom to set this variable and update the display. */); DEFVAR_LISP ("kill-buffer-query-functions", Vkill_buffer_query_functions, doc: /* List of functions called with no args to query before killing a buffer. The buffer being killed will be current while the functions are running. +See `kill-buffer'. If any of them returns nil, the buffer is not killed. Functions run by -this hook are supposed to not change the current buffer. */); +this hook are supposed to not change the current buffer. + +This hook is not run for internal or temporary buffers created by +`get-buffer-create' or `generate-new-buffer' with argument +INHIBIT-BUFFER-HOOKS non-nil. */); Vkill_buffer_query_functions = Qnil; DEFVAR_LISP ("change-major-mode-hook", Vchange_major_mode_hook, @@ -6299,9 +6319,12 @@ The function `kill-all-local-variables' runs this before doing anything else. * doc: /* Hook run when the buffer list changes. Functions (implicitly) running this hook are `get-buffer-create', `make-indirect-buffer', `rename-buffer', `kill-buffer', `bury-buffer' -and `select-window'. Functions run by this hook should avoid calling -`select-window' with a nil NORECORD argument or `with-temp-buffer' -since either may lead to infinite recursion. */); +and `select-window'. This hook is not run for internal or temporary +buffers created by `get-buffer-create' or `generate-new-buffer' with +argument INHIBIT-BUFFER-HOOKS non-nil. + +Functions run by this hook should avoid calling `select-window' with a +nil NORECORD argument since it may lead to infinite recursion. */); Vbuffer_list_update_hook = Qnil; DEFSYM (Qbuffer_list_update_hook, "buffer-list-update-hook"); @@ -6357,10 +6380,3 @@ since either may lead to infinite recursion. */); Fput (intern_c_string ("erase-buffer"), Qdisabled, Qt); } - -void -keys_of_buffer (void) -{ - initial_define_key (control_x_map, 'b', "switch-to-buffer"); - initial_define_key (control_x_map, 'k', "kill-buffer"); -} diff --git a/src/buffer.h b/src/buffer.h index 9e0d9121b50..790291f1185 100644 --- a/src/buffer.h +++ b/src/buffer.h @@ -419,9 +419,6 @@ struct buffer /* Non-nil means show ... at end of line followed by invisible lines. */ Lisp_Object selective_display_ellipses_; - /* Alist of (FUNCTION . STRING) for each minor mode enabled in buffer. */ - Lisp_Object minor_modes_; - /* t if "self-insertion" should overwrite; `binary' if it should also overwrite newlines and tabs - for editing executables and the like. */ Lisp_Object overwrite_mode_; @@ -570,9 +567,6 @@ struct buffer In an indirect buffer, this is the own_text field of another buffer. */ struct buffer_text *text; - /* Next buffer, in chain of all buffers, including killed ones. */ - struct buffer *next; - /* Char position of point in buffer. */ ptrdiff_t pt; @@ -669,11 +663,11 @@ struct buffer /* Non-zero whenever the narrowing is changed in this buffer. */ bool_bf clip_changed : 1; - /* Non-zero for internally used temporary buffers that don't need to - run hooks kill-buffer-hook, buffer-list-update-hook, and - kill-buffer-query-functions. This is used in coding.c to avoid - slowing down en/decoding when there are a lot of these hooks - defined. */ + /* Non-zero for internal or temporary buffers that don't need to + run hooks kill-buffer-hook, kill-buffer-query-functions, and + buffer-list-update-hook. This is used in coding.c to avoid + slowing down en/decoding when a lot of these hooks are + defined, as well as by with-temp-buffer, for example. */ bool_bf inhibit_buffer_hooks : 1; /* List of overlays that end at or before the current center, @@ -1104,15 +1098,6 @@ BUFFER_CHECK_INDIRECTION (struct buffer *b) } } -/* Chain of all buffers, including killed ones. */ - -extern struct buffer *all_buffers; - -/* Used to iterate over the chain above. */ - -#define FOR_EACH_BUFFER(b) \ - for ((b) = all_buffers; (b); (b) = (b)->next) - /* This structure holds the default values of the buffer-local variables that have special slots in each buffer. The default value occupies the same slot in this structure @@ -1150,6 +1135,8 @@ extern Lisp_Object interval_insert_behind_hooks; extern Lisp_Object interval_insert_in_front_hooks; +extern EMACS_INT fix_position (Lisp_Object); +#define CHECK_FIXNUM_COERCE_MARKER(x) ((x) = make_fixnum (fix_position (x))) extern void delete_all_overlays (struct buffer *); extern void reset_buffer (struct buffer *); extern void compact_buffer (struct buffer *); @@ -1533,6 +1520,146 @@ lowercasep (int c) return !uppercasep (c) && upcase (c) != c; } +/* Return a non-outlandish value for the tab width. */ + +INLINE int +sanitize_tab_width (Lisp_Object width) +{ + return (FIXNUMP (width) && 0 < XFIXNUM (width) && XFIXNUM (width) <= 1000 + ? XFIXNUM (width) : 8); +} + +INLINE int +SANE_TAB_WIDTH (struct buffer *buf) +{ + return sanitize_tab_width (BVAR (buf, tab_width)); +} + +/* Return a non-outlandish value for a character width. */ + +INLINE int +sanitize_char_width (EMACS_INT width) +{ + return 0 <= width && width <= 1000 ? width : 1000; +} + +/* Return the width of character C. The width is measured by how many + columns C will occupy on the screen when displayed in the current + buffer. The name CHARACTER_WIDTH avoids a collision with <limits.h> + CHAR_WIDTH. */ + +INLINE int +CHARACTER_WIDTH (int c) +{ + return (0x20 <= c && c < 0x7f ? 1 + : 0x7f < c ? (sanitize_char_width + (XFIXNUM (CHAR_TABLE_REF (Vchar_width_table, c)))) + : c == '\t' ? SANE_TAB_WIDTH (current_buffer) + : c == '\n' ? 0 + : !NILP (BVAR (current_buffer, ctl_arrow)) ? 2 : 4); +} + + +/* Like fetch_string_char_advance, but fetch character from the current + buffer. */ + +INLINE int +fetch_char_advance (ptrdiff_t *charidx, ptrdiff_t *byteidx) +{ + int output; + ptrdiff_t c = *charidx, b = *byteidx; + c++; + unsigned char *chp = BYTE_POS_ADDR (b); + if (!NILP (BVAR (current_buffer, enable_multibyte_characters))) + { + int chlen; + output = string_char_and_length (chp, &chlen); + b += chlen; + } + else + { + output = *chp; + b++; + } + *charidx = c; + *byteidx = b; + return output; +} + + +/* Like fetch_char_advance, but assumes the current buffer is multibyte. */ + +INLINE int +fetch_char_advance_no_check (ptrdiff_t *charidx, ptrdiff_t *byteidx) +{ + int output; + ptrdiff_t c = *charidx, b = *byteidx; + c++; + unsigned char *chp = BYTE_POS_ADDR (b); + int chlen; + output = string_char_and_length (chp, &chlen); + b += chlen; + *charidx = c; + *byteidx = b; + return output; +} + +/* Return the number of bytes in the multibyte character in BUF + that starts at position POS_BYTE. This relies on the fact that + *GPT_ADDR and *Z_ADDR are always accessible and the values are + '\0'. No range checking of POS_BYTE. */ + +INLINE int +buf_next_char_len (struct buffer *buf, ptrdiff_t pos_byte) +{ + unsigned char *chp = BUF_BYTE_ADDRESS (buf, pos_byte); + return BYTES_BY_CHAR_HEAD (*chp); +} + +INLINE int +next_char_len (ptrdiff_t pos_byte) +{ + return buf_next_char_len (current_buffer, pos_byte); +} + +/* Return the number of bytes in the multibyte character in BUF just + before POS_BYTE. No range checking of POS_BYTE. */ + +INLINE int +buf_prev_char_len (struct buffer *buf, ptrdiff_t pos_byte) +{ + unsigned char *chp + = (BUF_BEG_ADDR (buf) + pos_byte - BEG_BYTE + + (pos_byte <= BUF_GPT_BYTE (buf) ? 0 : BUF_GAP_SIZE (buf))); + return raw_prev_char_len (chp); +} + +INLINE int +prev_char_len (ptrdiff_t pos_byte) +{ + return buf_prev_char_len (current_buffer, pos_byte); +} + +/* Increment both *CHARPOS and *BYTEPOS, each in the appropriate way. */ + +INLINE void +inc_both (ptrdiff_t *charpos, ptrdiff_t *bytepos) +{ + (*charpos)++; + (*bytepos) += (!NILP (BVAR (current_buffer, enable_multibyte_characters)) + ? next_char_len (*bytepos) : 1); +} + +/* Decrement both *CHARPOS and *BYTEPOS, each in the appropriate way. */ + +INLINE void +dec_both (ptrdiff_t *charpos, ptrdiff_t *bytepos) +{ + (*charpos)--; + (*bytepos) -= (!NILP (BVAR (current_buffer, enable_multibyte_characters)) + ? prev_char_len (*bytepos) : 1); +} + INLINE_HEADER_END #endif /* EMACS_BUFFER_H */ diff --git a/src/bytecode.c b/src/bytecode.c index e169a906f98..4fd41acab85 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -24,7 +24,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "character.h" #include "buffer.h" #include "keyboard.h" -#include "ptr-bounds.h" #include "syntax.h" #include "window.h" @@ -47,7 +46,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ indirect threaded, using GCC's computed goto extension. This code, as currently implemented, is incompatible with BYTE_CODE_SAFE and BYTE_CODE_METER. */ -#if (defined __GNUC__ && !defined __STRICT_ANSI__ && !defined __CHKP__ \ +#if (defined __GNUC__ && !defined __STRICT_ANSI__ \ && !BYTE_CODE_SAFE && !defined BYTE_CODE_METER) #define BYTE_CODE_THREADED #endif @@ -220,10 +219,10 @@ DEFINE (Bdup, 0211) \ DEFINE (Bsave_excursion, 0212) \ DEFINE (Bsave_window_excursion, 0213) /* Obsolete since Emacs-24.1. */ \ DEFINE (Bsave_restriction, 0214) \ -DEFINE (Bcatch, 0215) \ +DEFINE (Bcatch, 0215) /* Obsolete since Emacs-25. */ \ \ DEFINE (Bunwind_protect, 0216) \ -DEFINE (Bcondition_case, 0217) \ +DEFINE (Bcondition_case, 0217) /* Obsolete since Emacs-25. */ \ DEFINE (Btemp_output_buffer_setup, 0220) /* Obsolete since Emacs-24.1. */ \ DEFINE (Btemp_output_buffer_show, 0221) /* Obsolete since Emacs-24.1. */ \ \ @@ -319,6 +318,19 @@ the third, MAXDEPTH, the maximum stack depth used in this function. If the third argument is incorrect, Emacs may crash. */) (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth) { + if (! (STRINGP (bytestr) && VECTORP (vector) && FIXNATP (maxdepth))) + error ("Invalid byte-code"); + + if (STRING_MULTIBYTE (bytestr)) + { + /* BYTESTR must have been produced by Emacs 20.2 or earlier + because it produced a raw 8-bit string for byte-code and now + such a byte-code string is loaded as multibyte with raw 8-bit + characters converted to multibyte form. Convert them back to + the original unibyte form. */ + bytestr = Fstring_as_unibyte (bytestr); + } + return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL); } @@ -344,21 +356,10 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, int volatile this_op = 0; #endif - CHECK_STRING (bytestr); - CHECK_VECTOR (vector); - CHECK_FIXNAT (maxdepth); + eassert (!STRING_MULTIBYTE (bytestr)); ptrdiff_t const_length = ASIZE (vector); - - if (STRING_MULTIBYTE (bytestr)) - /* BYTESTR must have been produced by Emacs 20.2 or the earlier - because they produced a raw 8-bit string for byte-code and now - such a byte-code string is loaded as multibyte while raw 8-bit - characters converted to multibyte form. Thus, now we must - convert them back to the originally intended unibyte form. */ - bytestr = Fstring_as_unibyte (bytestr); - - ptrdiff_t bytestr_length = SBYTES (bytestr); + ptrdiff_t bytestr_length = SCHARS (bytestr); Lisp_Object *vectorp = XVECTOR (vector)->contents; unsigned char quitcounter = 1; @@ -366,14 +367,12 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, USE_SAFE_ALLOCA; void *alloc; SAFE_ALLOCA_LISP_EXTRA (alloc, stack_items, bytestr_length); - ptrdiff_t item_bytes = stack_items * word_size; - Lisp_Object *stack_base = ptr_bounds_clip (alloc, item_bytes); + Lisp_Object *stack_base = alloc; Lisp_Object *top = stack_base; *top = vector; /* Ensure VECTOR survives GC (Bug#33014). */ Lisp_Object *stack_lim = stack_base + stack_items; - unsigned char *bytestr_data = alloc; - bytestr_data = ptr_bounds_clip (bytestr_data + item_bytes, bytestr_length); - memcpy (bytestr_data, SDATA (bytestr), bytestr_length); + unsigned char const *bytestr_data = memcpy (stack_lim, + SDATA (bytestr), bytestr_length); unsigned char const *pc = bytestr_data; ptrdiff_t count = SPECPDL_INDEX (); @@ -763,7 +762,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, save_restriction_save ()); NEXT; - CASE (Bcatch): /* Obsolete since 24.4. */ + CASE (Bcatch): /* Obsolete since 25. */ { Lisp_Object v1 = POP; TOP = internal_catch (TOP, eval_sub, v1); @@ -807,7 +806,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, NEXT; } - CASE (Bcondition_case): /* Obsolete since 24.4. */ + CASE (Bcondition_case): /* Obsolete since 25. */ { Lisp_Object handlers = POP, body = POP; TOP = internal_lisp_condition_case (TOP, body, handlers); @@ -1172,7 +1171,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CHECK_CHARACTER (TOP); int c = XFIXNAT (TOP); if (NILP (BVAR (current_buffer, enable_multibyte_characters))) - MAKE_CHAR_MULTIBYTE (c); + c = make_char_multibyte (c); XSETFASTINT (TOP, syntax_code_spec[SYNTAX (c)]); } NEXT; @@ -1402,7 +1401,6 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, Lisp_Object v1 = POP; ptrdiff_t i; struct Lisp_Hash_Table *h = XHASH_TABLE (jmp_table); - hash_rehash_if_needed (h); /* h->count is a faster approximation for HASH_TABLE_SIZE (h) here. */ diff --git a/src/callint.c b/src/callint.c index 051d21801a5..d3f49bc35d1 100644 --- a/src/callint.c +++ b/src/callint.c @@ -21,7 +21,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <config.h> #include "lisp.h" -#include "ptr-bounds.h" #include "character.h" #include "buffer.h" #include "keyboard.h" @@ -284,6 +283,11 @@ invoke it (via an `interactive' spec that contains, for instance, an Lisp_Object save_real_this_command = Vreal_this_command; Lisp_Object save_last_command = KVAR (current_kboard, Vlast_command); + /* Bound recursively so that code can check the current command from + code running from minibuffer hooks (and the like), without being + overwritten by subsequent minibuffer calls. */ + specbind (Qcurrent_minibuffer_command, Vthis_command); + if (NILP (keys)) keys = this_command_keys, key_count = this_command_key_count; else @@ -440,9 +444,6 @@ invoke it (via an `interactive' spec that contains, for instance, an signed char *varies = (signed char *) (visargs + nargs); memclear (args, nargs * (2 * word_size + 1)); - args = ptr_bounds_clip (args, nargs * sizeof *args); - visargs = ptr_bounds_clip (visargs, nargs * sizeof *visargs); - varies = ptr_bounds_clip (varies, nargs * sizeof *varies); if (!NILP (enable)) specbind (Qenable_recursive_minibuffers, Qt); @@ -716,7 +717,7 @@ invoke it (via an `interactive' spec that contains, for instance, an default: { /* How many bytes are left unprocessed in the specs string? - (Note that this excludes the trailing NUL byte.) */ + (Note that this excludes the trailing null byte.) */ ptrdiff_t bytes_left = string_len - (tem - string); unsigned letter; diff --git a/src/callproc.c b/src/callproc.c index 5b1d8bfb765..cb72b070b7b 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -30,6 +30,11 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "lisp.h" +#ifdef SETUP_SLAVE_PTY +# include <sys/stream.h> +# include <sys/stropts.h> +#endif + #ifdef WINDOWSNT #include <sys/socket.h> /* for fcntl */ #include <windows.h> @@ -100,6 +105,15 @@ enum }; static Lisp_Object call_process (ptrdiff_t, Lisp_Object *, int, ptrdiff_t); + +#ifdef DOS_NT +# define CHILD_SETUP_TYPE int +#else +# define CHILD_SETUP_TYPE _Noreturn void +#endif + +static CHILD_SETUP_TYPE child_setup (int, int, int, char **, char **, + const char *); /* Return the current buffer's working directory, or the home directory if it's unreachable, as a string suitable for a system call. @@ -231,6 +245,9 @@ DESTINATION can also have the form (REAL-BUFFER STDERR-FILE); in that case, Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted. Remaining arguments ARGS are strings passed as command arguments to PROGRAM. +If PROGRAM is not an absolute file name, `call-process' will look for +PROGRAM in `exec-path' (which is a list of directories). + If executable PROGRAM can't be found as an executable, `call-process' signals a Lisp error. `call-process' reports errors in execution of the program only through its return and output. @@ -298,7 +315,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, char *tempfile = NULL; #else sigset_t oldset; - pid_t pid; + pid_t pid = -1; #endif int child_errno; int fd_output, fd_error; @@ -402,9 +419,8 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, if (! (NILP (buffer) || EQ (buffer, Qt) || FIXNUMP (buffer))) { - Lisp_Object spec_buffer; - spec_buffer = buffer; - buffer = Fget_buffer_create (buffer); + Lisp_Object spec_buffer = buffer; + buffer = Fget_buffer_create (buffer, Qnil); /* Mention the buffer name for a better error message. */ if (NILP (buffer)) CHECK_BUFFER (spec_buffer); @@ -539,8 +555,11 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, callproc_fd[CALLPROC_STDERR] = fd_error; } + char **env = make_environment_block (current_dir); + #ifdef MSDOS /* MW, July 1993 */ - status = child_setup (filefd, fd_output, fd_error, new_argv, 0, current_dir); + status = child_setup (filefd, fd_output, fd_error, new_argv, env, + SSDATA (current_dir)); if (status < 0) { @@ -586,70 +605,10 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd, block_input (); block_child_signal (&oldset); -#ifdef WINDOWSNT - pid = child_setup (filefd, fd_output, fd_error, new_argv, 0, current_dir); -#else /* not WINDOWSNT */ - - /* vfork, and prevent local vars from being clobbered by the vfork. */ - { - Lisp_Object volatile buffer_volatile = buffer; - Lisp_Object volatile coding_systems_volatile = coding_systems; - Lisp_Object volatile current_dir_volatile = current_dir; - bool volatile display_p_volatile = display_p; - int volatile fd_error_volatile = fd_error; - int volatile filefd_volatile = filefd; - ptrdiff_t volatile count_volatile = count; - ptrdiff_t volatile sa_avail_volatile = sa_avail; - ptrdiff_t volatile sa_count_volatile = sa_count; - char **volatile new_argv_volatile = new_argv; - int volatile callproc_fd_volatile[CALLPROC_FDS]; - for (i = 0; i < CALLPROC_FDS; i++) - callproc_fd_volatile[i] = callproc_fd[i]; - - pid = vfork (); - - buffer = buffer_volatile; - coding_systems = coding_systems_volatile; - current_dir = current_dir_volatile; - display_p = display_p_volatile; - fd_error = fd_error_volatile; - filefd = filefd_volatile; - count = count_volatile; - sa_avail = sa_avail_volatile; - sa_count = sa_count_volatile; - new_argv = new_argv_volatile; - - for (i = 0; i < CALLPROC_FDS; i++) - callproc_fd[i] = callproc_fd_volatile[i]; - fd_output = callproc_fd[CALLPROC_STDOUT]; - } - - if (pid == 0) - { -#ifdef DARWIN_OS - /* Work around a macOS bug, where SIGCHLD is apparently - delivered to a vforked child instead of to its parent. See: - https://lists.gnu.org/r/emacs-devel/2017-05/msg00342.html - */ - signal (SIGCHLD, SIG_DFL); -#endif - - unblock_child_signal (&oldset); - dissociate_controlling_tty (); - - /* Emacs ignores SIGPIPE, but the child should not. */ - signal (SIGPIPE, SIG_DFL); - /* Likewise for SIGPROF. */ -#ifdef SIGPROF - signal (SIGPROF, SIG_DFL); -#endif - - child_setup (filefd, fd_output, fd_error, new_argv, 0, current_dir); - } - -#endif /* not WINDOWSNT */ - - child_errno = errno; + child_errno + = emacs_spawn (&pid, filefd, fd_output, fd_error, new_argv, env, + SSDATA (current_dir), NULL, &oldset); + eassert ((child_errno == 0) == (0 < pid)); if (pid > 0) { @@ -1060,6 +1019,9 @@ Sixth arg DISPLAY non-nil means redisplay buffer as output is inserted. Remaining arguments ARGS are passed to PROGRAM at startup as command-line arguments. +If PROGRAM is not an absolute file name, `call-process-region' will +look for PROGRAM in `exec-path' (which is a list of directories). + If BUFFER is 0, `call-process-region' returns immediately with value nil. Otherwise it waits for PROGRAM to terminate and returns a numeric exit status or a signal description string. @@ -1099,7 +1061,17 @@ usage: (call-process-region START END PROGRAM &optional DELETE BUFFER DISPLAY &r } if (nargs > 3 && !NILP (args[3])) - Fdelete_region (start, end); + { + if (NILP (start)) + { + /* No need to save restrictions since we delete everything + anyway. */ + Fwiden (); + del_range (BEG, Z); + } + else + Fdelete_region (start, end); + } if (nargs > 3) { @@ -1172,16 +1144,6 @@ exec_failed (char const *name, int err) _exit (err == ENOENT ? EXIT_ENOENT : EXIT_CANNOT_INVOKE); } -#else - -/* Do nothing. There is no need to fail, as DOS_NT platforms do not - fork and exec, and handle alloca exhaustion in a different way. */ - -static void -exec_failed (char const *name, int err) -{ -} - #endif /* This is the last thing run in a newly forked inferior @@ -1190,8 +1152,6 @@ exec_failed (char const *name, int err) Initialize inferior's priority, pgrp, connected dir and environment. then exec another program based on new_argv. - If SET_PGRP, put the subprocess into a separate process group. - CURRENT_DIR is an elisp string giving the path of the current directory the subprocess should have. Since we can't really signal a decent error from within the child, this should be verified as an @@ -1201,12 +1161,10 @@ exec_failed (char const *name, int err) On MS-Windows, either return a pid or return -1 and set errno. On MS-DOS, either return an exit status or signal an error. */ -CHILD_SETUP_TYPE -child_setup (int in, int out, int err, char **new_argv, bool set_pgrp, - Lisp_Object current_dir) +static CHILD_SETUP_TYPE +child_setup (int in, int out, int err, char **new_argv, char **env, + const char *current_dir) { - char **env; - char *pwd_var; #ifdef WINDOWSNT int cpid; HANDLE handles[3]; @@ -1220,24 +1178,6 @@ child_setup (int in, int out, int err, char **new_argv, bool set_pgrp, src/alloca.c) it is safe because that changes the superior's static variables as if the superior had done alloca and will be cleaned up in the usual way. */ - { - char *temp; - ptrdiff_t i; - - i = SBYTES (current_dir); -#ifdef MSDOS - /* MSDOS must have all environment variables malloc'ed, because - low-level libc functions that launch subsidiary processes rely - on that. */ - pwd_var = xmalloc (i + 5); -#else - if (MAX_ALLOCA - 5 < i) - exec_failed (new_argv[0], ENOMEM); - pwd_var = alloca (i + 5); -#endif - temp = pwd_var + 4; - memcpy (pwd_var, "PWD=", 4); - lispstpcpy (temp, current_dir); #ifndef DOS_NT /* We can't signal an Elisp error here; we're in a vfork. Since @@ -1245,101 +1185,13 @@ child_setup (int in, int out, int err, char **new_argv, bool set_pgrp, should only return an error if the directory's permissions are changed between the check and this chdir, but we should at least check. */ - if (chdir (temp) < 0) + if (chdir (current_dir) < 0) _exit (EXIT_CANCELED); -#else /* DOS_NT */ - /* Get past the drive letter, so that d:/ is left alone. */ - if (i > 2 && IS_DEVICE_SEP (temp[1]) && IS_DIRECTORY_SEP (temp[2])) - { - temp += 2; - i -= 2; - } -#endif /* DOS_NT */ - - /* Strip trailing slashes for PWD, but leave "/" and "//" alone. */ - while (i > 2 && IS_DIRECTORY_SEP (temp[i - 1])) - temp[--i] = 0; - } - - /* Set `env' to a vector of the strings in the environment. */ - { - register Lisp_Object tem; - register char **new_env; - char **p, **q; - register int new_length; - Lisp_Object display = Qnil; - - new_length = 0; - - for (tem = Vprocess_environment; - CONSP (tem) && STRINGP (XCAR (tem)); - tem = XCDR (tem)) - { - if (strncmp (SSDATA (XCAR (tem)), "DISPLAY", 7) == 0 - && (SDATA (XCAR (tem)) [7] == '\0' - || SDATA (XCAR (tem)) [7] == '=')) - /* DISPLAY is specified in process-environment. */ - display = Qt; - new_length++; - } - - /* If not provided yet, use the frame's DISPLAY. */ - if (NILP (display)) - { - Lisp_Object tmp = Fframe_parameter (selected_frame, Qdisplay); - if (!STRINGP (tmp) && CONSP (Vinitial_environment)) - /* If still not found, Look for DISPLAY in Vinitial_environment. */ - tmp = Fgetenv_internal (build_string ("DISPLAY"), - Vinitial_environment); - if (STRINGP (tmp)) - { - display = tmp; - new_length++; - } - } - - /* new_length + 2 to include PWD and terminating 0. */ - if (MAX_ALLOCA / sizeof *env - 2 < new_length) - exec_failed (new_argv[0], ENOMEM); - env = new_env = alloca ((new_length + 2) * sizeof *env); - /* If we have a PWD envvar, pass one down, - but with corrected value. */ - if (egetenv ("PWD")) - *new_env++ = pwd_var; - - if (STRINGP (display)) - { - if (MAX_ALLOCA - sizeof "DISPLAY=" < SBYTES (display)) - exec_failed (new_argv[0], ENOMEM); - char *vdata = alloca (sizeof "DISPLAY=" + SBYTES (display)); - lispstpcpy (stpcpy (vdata, "DISPLAY="), display); - new_env = add_env (env, new_env, vdata); - } - - /* Overrides. */ - for (tem = Vprocess_environment; - CONSP (tem) && STRINGP (XCAR (tem)); - tem = XCDR (tem)) - new_env = add_env (env, new_env, SSDATA (XCAR (tem))); - - *new_env = 0; - - /* Remove variable names without values. */ - p = q = env; - while (*p != 0) - { - while (*q != 0 && strchr (*q, '=') == NULL) - q++; - *p = *q++; - if (*p != 0) - p++; - } - } - +#endif #ifdef WINDOWSNT prepare_standard_handles (in, out, err, handles); - set_process_dir (SSDATA (current_dir)); + set_process_dir (current_dir); /* Spawn the child. (See w32proc.c:sys_spawnve). */ cpid = spawnve (_P_NOWAIT, new_argv[0], new_argv, env); reset_standard_handles (in, out, err, handles); @@ -1375,6 +1227,185 @@ child_setup (int in, int out, int err, char **new_argv, bool set_pgrp, #endif /* not WINDOWSNT */ } +/* Start a new asynchronous subprocess. If successful, return zero + and store the process identifier of the new process in *NEWPID. + Use STDIN, STDOUT, and STDERR as standard streams for the new + process. Use ARGV as argument vector for the new process; use + process image file ARGV[0]. Use ENVP for the environment block for + the new process. Use CWD as working directory for the new process. + If PTY is not NULL, it must be a pseudoterminal device. If PTY is + NULL, don't perform any terminal setup. OLDSET must be a pointer + to a signal set initialized by `block_child_signal'. Before + calling this function, call `block_input' and `block_child_signal'; + afterwards, call `unblock_input' and `unblock_child_signal'. Be + sure to call `unblock_child_signal' only after registering NEWPID + in a list where `handle_child_signal' can find it! */ + +int +emacs_spawn (pid_t *newpid, int std_in, int std_out, int std_err, + char **argv, char **envp, const char *cwd, + const char *pty, const sigset_t *oldset) +{ + int pid; + + eassert (input_blocked_p ()); + +#ifndef WINDOWSNT + /* vfork, and prevent local vars from being clobbered by the vfork. */ + pid_t *volatile newpid_volatile = newpid; + const char *volatile cwd_volatile = cwd; + const char *volatile pty_volatile = pty; + char **volatile argv_volatile = argv; + int volatile stdin_volatile = std_in; + int volatile stdout_volatile = std_out; + int volatile stderr_volatile = std_err; + char **volatile envp_volatile = envp; + const sigset_t *volatile oldset_volatile = oldset; + +#ifdef DARWIN_OS + /* Darwin doesn't let us run setsid after a vfork, so use fork when + necessary. Below, we reset SIGCHLD handling after a vfork, as + apparently macOS can mistakenly deliver SIGCHLD to the child. */ + if (pty != NULL) + pid = fork (); + else + pid = vfork (); +#else + pid = vfork (); +#endif + + newpid = newpid_volatile; + cwd = cwd_volatile; + pty = pty_volatile; + argv = argv_volatile; + std_in = stdin_volatile; + std_out = stdout_volatile; + std_err = stderr_volatile; + envp = envp_volatile; + oldset = oldset_volatile; + + if (pid == 0) +#endif /* not WINDOWSNT */ + { + bool pty_flag = pty != NULL; + /* Make the pty be the controlling terminal of the process. */ +#ifdef HAVE_PTYS + dissociate_controlling_tty (); + + /* Make the pty's terminal the controlling terminal. */ + if (pty_flag && std_in >= 0) + { +#ifdef TIOCSCTTY + /* We ignore the return value + because faith@cs.unc.edu says that is necessary on Linux. */ + ioctl (std_in, TIOCSCTTY, 0); +#endif + } +#if defined (LDISC1) + if (pty_flag && std_in >= 0) + { + struct termios t; + tcgetattr (std_in, &t); + t.c_lflag = LDISC1; + if (tcsetattr (std_in, TCSANOW, &t) < 0) + emacs_perror ("create_process/tcsetattr LDISC1"); + } +#else +#if defined (NTTYDISC) && defined (TIOCSETD) + if (pty_flag && std_in >= 0) + { + /* Use new line discipline. */ + int ldisc = NTTYDISC; + ioctl (std_in, TIOCSETD, &ldisc); + } +#endif +#endif + +#if !defined (DONT_REOPEN_PTY) +/*** There is a suggestion that this ought to be a + conditional on TIOCSPGRP, or !defined TIOCSCTTY. + Trying the latter gave the wrong results on Debian GNU/Linux 1.1; + that system does seem to need this code, even though + both TIOCSCTTY is defined. */ + /* Now close the pty (if we had it open) and reopen it. + This makes the pty the controlling terminal of the subprocess. */ + if (pty_flag) + { + + /* I wonder if emacs_close (emacs_open (pty, ...)) + would work? */ + if (std_in >= 0) + emacs_close (std_in); + std_out = std_in = emacs_open_noquit (pty, O_RDWR, 0); + + if (std_in < 0) + { + emacs_perror (pty); + _exit (EXIT_CANCELED); + } + + } +#endif /* not DONT_REOPEN_PTY */ + +#ifdef SETUP_SLAVE_PTY + if (pty_flag) + { + SETUP_SLAVE_PTY; + } +#endif /* SETUP_SLAVE_PTY */ +#endif /* HAVE_PTYS */ + +#ifdef DARWIN_OS + /* Work around a macOS bug, where SIGCHLD is apparently + delivered to a vforked child instead of to its parent. See: + https://lists.gnu.org/r/emacs-devel/2017-05/msg00342.html + */ + signal (SIGCHLD, SIG_DFL); +#endif + + signal (SIGINT, SIG_DFL); + signal (SIGQUIT, SIG_DFL); +#ifdef SIGPROF + signal (SIGPROF, SIG_DFL); +#endif + + /* Emacs ignores SIGPIPE, but the child should not. */ + signal (SIGPIPE, SIG_DFL); + /* Likewise for SIGPROF. */ +#ifdef SIGPROF + signal (SIGPROF, SIG_DFL); +#endif + + /* Stop blocking SIGCHLD in the child. */ + unblock_child_signal (oldset); + + if (pty_flag) + child_setup_tty (std_out); + + if (std_err < 0) + std_err = std_out; +#ifdef WINDOWSNT + pid = child_setup (std_in, std_out, std_err, argv, envp, cwd); +#else /* not WINDOWSNT */ + child_setup (std_in, std_out, std_err, argv, envp, cwd); +#endif /* not WINDOWSNT */ + } + + /* Back in the parent process. */ + + int vfork_error = pid < 0 ? errno : 0; + + if (pid < 0) + { + eassert (0 < vfork_error); + return vfork_error; + } + + eassert (0 < pid); + *newpid = pid; + return 0; +} + static bool getenv_internal_1 (const char *var, ptrdiff_t varlen, char **value, ptrdiff_t *valuelen, Lisp_Object env) @@ -1498,6 +1529,119 @@ egetenv_internal (const char *var, ptrdiff_t len) return 0; } +/* Create a new environment block. You can pass the returned pointer + to `execve'. Add unwind protections for all newly-allocated + objects. Don't call any Lisp code or the garbage collector while + the block is active. */ + +char ** +make_environment_block (Lisp_Object current_dir) +{ + char **env; + char *pwd_var; + + { + char *temp; + ptrdiff_t i; + + i = SBYTES (current_dir); + pwd_var = xmalloc (i + 5); + record_unwind_protect_ptr (xfree, pwd_var); + temp = pwd_var + 4; + memcpy (pwd_var, "PWD=", 4); + lispstpcpy (temp, current_dir); + +#ifdef DOS_NT + /* Get past the drive letter, so that d:/ is left alone. */ + if (i > 2 && IS_DEVICE_SEP (temp[1]) && IS_DIRECTORY_SEP (temp[2])) + { + temp += 2; + i -= 2; + } +#endif /* DOS_NT */ + + /* Strip trailing slashes for PWD, but leave "/" and "//" alone. */ + while (i > 2 && IS_DIRECTORY_SEP (temp[i - 1])) + temp[--i] = 0; + } + + /* Set `env' to a vector of the strings in the environment. */ + + { + register Lisp_Object tem; + register char **new_env; + char **p, **q; + register int new_length; + Lisp_Object display = Qnil; + + new_length = 0; + + for (tem = Vprocess_environment; + CONSP (tem) && STRINGP (XCAR (tem)); + tem = XCDR (tem)) + { + if (strncmp (SSDATA (XCAR (tem)), "DISPLAY", 7) == 0 + && (SDATA (XCAR (tem)) [7] == '\0' + || SDATA (XCAR (tem)) [7] == '=')) + /* DISPLAY is specified in process-environment. */ + display = Qt; + new_length++; + } + + /* If not provided yet, use the frame's DISPLAY. */ + if (NILP (display)) + { + Lisp_Object tmp = Fframe_parameter (selected_frame, Qdisplay); + if (!STRINGP (tmp) && CONSP (Vinitial_environment)) + /* If still not found, Look for DISPLAY in Vinitial_environment. */ + tmp = Fgetenv_internal (build_string ("DISPLAY"), + Vinitial_environment); + if (STRINGP (tmp)) + { + display = tmp; + new_length++; + } + } + + /* new_length + 2 to include PWD and terminating 0. */ + env = new_env = xnmalloc (new_length + 2, sizeof *env); + record_unwind_protect_ptr (xfree, env); + /* If we have a PWD envvar, pass one down, + but with corrected value. */ + if (egetenv ("PWD")) + *new_env++ = pwd_var; + + if (STRINGP (display)) + { + char *vdata = xmalloc (sizeof "DISPLAY=" + SBYTES (display)); + record_unwind_protect_ptr (xfree, vdata); + lispstpcpy (stpcpy (vdata, "DISPLAY="), display); + new_env = add_env (env, new_env, vdata); + } + + /* Overrides. */ + for (tem = Vprocess_environment; + CONSP (tem) && STRINGP (XCAR (tem)); + tem = XCDR (tem)) + new_env = add_env (env, new_env, SSDATA (XCAR (tem))); + + *new_env = 0; + + /* Remove variable names without values. */ + p = q = env; + while (*p != 0) + { + while (*q != 0 && strchr (*q, '=') == NULL) + q++; + *p = *q++; + if (*p != 0) + p++; + } + } + + return env; +} + /* This is run before init_cmdargs. */ diff --git a/src/casefiddle.c b/src/casefiddle.c index 3bed33d044f..a7a25414909 100644 --- a/src/casefiddle.c +++ b/src/casefiddle.c @@ -220,6 +220,13 @@ case_character (struct casing_str_buf *buf, struct casing_context *ctx, return changed; } +/* If C is not ASCII, make it unibyte. */ +static inline int +make_char_unibyte (int c) +{ + return ASCII_CHAR_P (c) ? c : CHAR_TO_BYTE8 (c); +} + static Lisp_Object do_casify_natnum (struct casing_context *ctx, Lisp_Object obj) { @@ -229,7 +236,7 @@ do_casify_natnum (struct casing_context *ctx, Lisp_Object obj) /* If the character has higher bits set above the flags, return it unchanged. It is not a real character. */ - if (UNSIGNED_CMP (ch, >, flagbits)) + if (! (0 <= ch && ch <= flagbits)) return obj; int flags = ch & flagbits; @@ -243,13 +250,13 @@ do_casify_natnum (struct casing_context *ctx, Lisp_Object obj) || !NILP (BVAR (current_buffer, enable_multibyte_characters))); if (! multibyte) - MAKE_CHAR_MULTIBYTE (ch); + ch = make_char_multibyte (ch); int cased = case_single_character (ctx, ch); if (cased == ch) return obj; if (! multibyte) - MAKE_CHAR_UNIBYTE (cased); + cased = make_char_unibyte (cased); return make_fixed_natnum (cased | flags); } @@ -278,7 +285,7 @@ do_casify_multibyte_string (struct casing_context *ctx, Lisp_Object obj) { if (dst_end - o < sizeof (struct casing_str_buf)) string_overflow (); - int ch = STRING_CHAR_ADVANCE (src); + int ch = string_char_advance (&src); case_character ((struct casing_str_buf *) o, ctx, ch, size > 1 ? src : NULL); n += ((struct casing_str_buf *) o)->len_chars; @@ -299,15 +306,14 @@ do_casify_unibyte_string (struct casing_context *ctx, Lisp_Object obj) obj = Fcopy_sequence (obj); for (i = 0; i < size; i++) { - ch = SREF (obj, i); - MAKE_CHAR_MULTIBYTE (ch); + ch = make_char_multibyte (SREF (obj, i)); cased = case_single_character (ctx, ch); if (ch == cased) continue; - MAKE_CHAR_UNIBYTE (cased); + cased = make_char_unibyte (cased); /* If the char can't be converted to a valid byte, just don't change it. */ - if (cased >= 0 && cased < 256) + if (SINGLE_BYTE_CHAR_P (cased)) SSET (obj, i, cased); } return obj; @@ -397,9 +403,7 @@ do_casify_unibyte_region (struct casing_context *ctx, for (ptrdiff_t pos = *startp; pos < end; ++pos) { - int ch = FETCH_BYTE (pos); - MAKE_CHAR_MULTIBYTE (ch); - + int ch = make_char_multibyte (FETCH_BYTE (pos)); int cased = case_single_character (ctx, ch); if (cased == ch) continue; @@ -408,8 +412,7 @@ do_casify_unibyte_region (struct casing_context *ctx, if (first < 0) first = pos; - MAKE_CHAR_UNIBYTE (cased); - FETCH_BYTE (pos) = cased; + FETCH_BYTE (pos) = make_char_unibyte (cased); } *startp = first; @@ -433,8 +436,7 @@ do_casify_multibyte_region (struct casing_context *ctx, for (; size; --size) { - int len; - int ch = STRING_CHAR_AND_LENGTH (BYTE_POS_ADDR (pos_byte), len); + int len, ch = string_char_and_length (BYTE_POS_ADDR (pos_byte), &len); struct casing_str_buf buf; if (!case_character (&buf, ctx, ch, size > 1 ? BYTE_POS_ADDR (pos_byte + len) : NULL)) @@ -680,16 +682,3 @@ Called with one argument METHOD which can be: defsubr (&Sdowncase_word); defsubr (&Scapitalize_word); } - -void -keys_of_casefiddle (void) -{ - initial_define_key (control_x_map, Ctl ('U'), "upcase-region"); - Fput (intern ("upcase-region"), Qdisabled, Qt); - initial_define_key (control_x_map, Ctl ('L'), "downcase-region"); - Fput (intern ("downcase-region"), Qdisabled, Qt); - - initial_define_key (meta_map, 'u', "upcase-word"); - initial_define_key (meta_map, 'l', "downcase-word"); - initial_define_key (meta_map, 'c', "capitalize-word"); -} diff --git a/src/ccl.c b/src/ccl.c index af101bb2739..7c033afc882 100644 --- a/src/ccl.c +++ b/src/ccl.c @@ -855,6 +855,13 @@ struct ccl_prog_stack /* For the moment, we only support depth 256 of stack. */ static struct ccl_prog_stack ccl_prog_stack_struct[256]; +/* Return a translation table of id number ID. */ +static inline Lisp_Object +GET_TRANSLATION_TABLE (int id) +{ + return XCDR (XVECTOR (Vtranslation_table_vector)->contents[id]); +} + void ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size, int dst_size, Lisp_Object charset_list) { @@ -1135,19 +1142,52 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size ccl_expr_self: switch (op) { - case CCL_PLUS: reg[rrr] += i; break; - case CCL_MINUS: reg[rrr] -= i; break; - case CCL_MUL: reg[rrr] *= i; break; - case CCL_DIV: reg[rrr] /= i; break; - case CCL_MOD: reg[rrr] %= i; break; + case CCL_PLUS: INT_ADD_WRAPV (reg[rrr], i, ®[rrr]); break; + case CCL_MINUS: INT_SUBTRACT_WRAPV (reg[rrr], i, ®[rrr]); break; + case CCL_MUL: INT_MULTIPLY_WRAPV (reg[rrr], i, ®[rrr]); break; + case CCL_DIV: + if (!i) + CCL_INVALID_CMD; + if (!INT_DIVIDE_OVERFLOW (reg[rrr], i)) + reg[rrr] /= i; + break; + case CCL_MOD: + if (!i) + CCL_INVALID_CMD; + reg[rrr] = i == -1 ? 0 : reg[rrr] % i; + break; case CCL_AND: reg[rrr] &= i; break; case CCL_OR: reg[rrr] |= i; break; case CCL_XOR: reg[rrr] ^= i; break; - case CCL_LSH: reg[rrr] <<= i; break; - case CCL_RSH: reg[rrr] >>= i; break; - case CCL_LSH8: reg[rrr] <<= 8; reg[rrr] |= i; break; + case CCL_LSH: + if (i < 0) + CCL_INVALID_CMD; + reg[rrr] = i < UINT_WIDTH ? (unsigned) reg[rrr] << i : 0; + break; + case CCL_RSH: + if (i < 0) + CCL_INVALID_CMD; + reg[rrr] = reg[rrr] >> min (i, INT_WIDTH - 1); + break; + case CCL_LSH8: + reg[rrr] = (unsigned) reg[rrr] << 8; + reg[rrr] |= i; + break; case CCL_RSH8: reg[7] = reg[rrr] & 0xFF; reg[rrr] >>= 8; break; - case CCL_DIVMOD: reg[7] = reg[rrr] % i; reg[rrr] /= i; break; + case CCL_DIVMOD: + if (!i) + CCL_INVALID_CMD; + if (i == -1) + { + reg[7] = 0; + INT_SUBTRACT_WRAPV (0, reg[rrr], ®[rrr]); + } + else + { + reg[7] = reg[rrr] % i; + reg[rrr] /= i; + } + break; case CCL_LS: reg[rrr] = reg[rrr] < i; break; case CCL_GT: reg[rrr] = reg[rrr] > i; break; case CCL_EQ: reg[rrr] = reg[rrr] == i; break; @@ -1197,19 +1237,52 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size ccl_set_expr: switch (op) { - case CCL_PLUS: reg[rrr] = i + j; break; - case CCL_MINUS: reg[rrr] = i - j; break; - case CCL_MUL: reg[rrr] = i * j; break; - case CCL_DIV: reg[rrr] = i / j; break; - case CCL_MOD: reg[rrr] = i % j; break; + case CCL_PLUS: INT_ADD_WRAPV (i, j, ®[rrr]); break; + case CCL_MINUS: INT_SUBTRACT_WRAPV (i, j, ®[rrr]); break; + case CCL_MUL: INT_MULTIPLY_WRAPV (i, j, ®[rrr]); break; + case CCL_DIV: + if (!j) + CCL_INVALID_CMD; + if (!INT_DIVIDE_OVERFLOW (i, j)) + i /= j; + reg[rrr] = i; + break; + case CCL_MOD: + if (!j) + CCL_INVALID_CMD; + reg[rrr] = j == -1 ? 0 : i % j; + break; case CCL_AND: reg[rrr] = i & j; break; case CCL_OR: reg[rrr] = i | j; break; case CCL_XOR: reg[rrr] = i ^ j; break; - case CCL_LSH: reg[rrr] = i << j; break; - case CCL_RSH: reg[rrr] = i >> j; break; - case CCL_LSH8: reg[rrr] = (i << 8) | j; break; + case CCL_LSH: + if (j < 0) + CCL_INVALID_CMD; + reg[rrr] = j < UINT_WIDTH ? (unsigned) i << j : 0; + break; + case CCL_RSH: + if (j < 0) + CCL_INVALID_CMD; + reg[rrr] = i >> min (j, INT_WIDTH - 1); + break; + case CCL_LSH8: + reg[rrr] = ((unsigned) i << 8) | j; + break; case CCL_RSH8: reg[rrr] = i >> 8; reg[7] = i & 0xFF; break; - case CCL_DIVMOD: reg[rrr] = i / j; reg[7] = i % j; break; + case CCL_DIVMOD: + if (!j) + CCL_INVALID_CMD; + if (j == -1) + { + INT_SUBTRACT_WRAPV (0, reg[rrr], ®[rrr]); + reg[7] = 0; + } + else + { + reg[rrr] = i / j; + reg[7] = i % j; + } + break; case CCL_LS: reg[rrr] = i < j; break; case CCL_GT: reg[rrr] = i > j; break; case CCL_EQ: reg[rrr] = i == j; break; @@ -1218,7 +1291,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size case CCL_NE: reg[rrr] = i != j; break; case CCL_DECODE_SJIS: { - i = (i << 8) | j; + i = ((unsigned) i << 8) | j; SJIS_TO_JIS (i); reg[rrr] = i >> 8; reg[7] = i & 0xFF; @@ -1226,7 +1299,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size } case CCL_ENCODE_SJIS: { - i = (i << 8) | j; + i = ((unsigned) i << 8) | j; JIS_TO_SJIS (i); reg[rrr] = i >> 8; reg[7] = i & 0xFF; @@ -1301,7 +1374,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size if (! (IN_INT_RANGE (eop) && CHARACTERP (opl))) CCL_INVALID_CMD; reg[RRR] = charset_unicode; - reg[rrr] = eop; + reg[rrr] = XFIXNUM (opl); reg[7] = 1; /* r7 true for success */ } else @@ -2101,7 +2174,7 @@ usage: (ccl-execute-on-string CCL-PROGRAM STATUS STRING &optional CONTINUE UNIBY source[j++] = *p++; else while (j < CCL_EXECUTE_BUF_SIZE && p < endp) - source[j++] = STRING_CHAR_ADVANCE (p); + source[j++] = string_char_advance (&p); consumed_chars += j; consumed_bytes = p - SDATA (str); @@ -2126,7 +2199,7 @@ usage: (ccl-execute-on-string CCL-PROGRAM STATUS STRING &optional CONTINUE UNIBY if (NILP (unibyte_p)) { for (j = 0; j < ccl.produced; j++) - CHAR_STRING_ADVANCE (destination[j], outp); + outp += CHAR_STRING (destination[j], outp); } else { @@ -2212,15 +2285,8 @@ Return index number of the registered CCL program. */) /* Extend the table. */ Vccl_program_table = larger_vector (Vccl_program_table, 1, -1); - { - Lisp_Object elt = make_uninit_vector (4); - - ASET (elt, 0, name); - ASET (elt, 1, ccl_prog); - ASET (elt, 2, resolved); - ASET (elt, 3, Qt); - ASET (Vccl_program_table, idx, elt); - } + ASET (Vccl_program_table, idx, + CALLN (Fvector, name, ccl_prog, resolved, Qt)); Fput (name, Qccl_program_idx, make_fixnum (idx)); return make_fixnum (idx); diff --git a/src/character.c b/src/character.c index 9300c2bce49..a599a0355f4 100644 --- a/src/character.c +++ b/src/character.c @@ -141,58 +141,6 @@ char_string (unsigned int c, unsigned char *p) } -/* Return a character whose multibyte form is at P. If LEN is not - NULL, it must be a pointer to integer. In that case, set *LEN to - the byte length of the multibyte form. If ADVANCED is not NULL, it - must be a pointer to unsigned char. In that case, set *ADVANCED to - the ending address (i.e., the starting address of the next - character) of the multibyte form. */ - -int -string_char (const unsigned char *p, const unsigned char **advanced, int *len) -{ - int c; - const unsigned char *saved_p = p; - - if (*p < 0x80 || ! (*p & 0x20) || ! (*p & 0x10)) - { - /* 1-, 2-, and 3-byte sequences can be handled by the macro. */ - c = STRING_CHAR_ADVANCE (p); - } - else if (! (*p & 0x08)) - { - /* A 4-byte sequence of this form: - 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx */ - c = ((((p)[0] & 0x7) << 18) - | (((p)[1] & 0x3F) << 12) - | (((p)[2] & 0x3F) << 6) - | ((p)[3] & 0x3F)); - p += 4; - } - else - { - /* A 5-byte sequence of this form: - - 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx - - Note that the top 4 `x's are always 0, so shifting p[1] can - never exceed the maximum valid character codepoint. */ - c = (/* (((p)[0] & 0x3) << 24) ... always 0, so no need to shift. */ - (((p)[1] & 0x3F) << 18) - | (((p)[2] & 0x3F) << 12) - | (((p)[3] & 0x3F) << 6) - | ((p)[4] & 0x3F)); - p += 5; - } - - if (len) - *len = p - saved_p; - if (advanced) - *advanced = p; - return c; -} - - /* Translate character C by translation table TABLE. If no translation is found in TABLE, return the untranslated character. If TABLE is a list, elements are char tables. In that case, recursively translate C by all the @@ -248,8 +196,7 @@ DEFUN ("unibyte-char-to-multibyte", Funibyte_char_to_multibyte, c = XFIXNAT (ch); if (c >= 0x100) error ("Not a unibyte character: %d", c); - MAKE_CHAR_MULTIBYTE (c); - return make_fixnum (c); + return make_fixnum (make_char_multibyte (c)); } DEFUN ("multibyte-char-to-unibyte", Fmultibyte_char_to_unibyte, @@ -340,8 +287,7 @@ c_string_width (const unsigned char *str, ptrdiff_t len, int precision, while (i_byte < len) { - int bytes; - int c = STRING_CHAR_AND_LENGTH (str + i_byte, bytes); + int bytes, c = string_char_and_length (str + i_byte, &bytes); ptrdiff_t thiswidth = char_width (c, dp); if (0 < precision && precision - width < thiswidth) @@ -418,7 +364,7 @@ lisp_string_width (Lisp_Object string, ptrdiff_t precision, if (multibyte) { int cbytes; - c = STRING_CHAR_AND_LENGTH (str + i_byte, cbytes); + c = string_char_and_length (str + i_byte, &cbytes); bytes = cbytes; } else @@ -495,7 +441,7 @@ multibyte_chars_in_text (const unsigned char *ptr, ptrdiff_t nbytes) while (ptr < endp) { - int len = MULTIBYTE_LENGTH (ptr, endp); + int len = multibyte_length (ptr, endp, true, true); if (len == 0) emacs_abort (); @@ -517,16 +463,15 @@ parse_str_as_multibyte (const unsigned char *str, ptrdiff_t len, ptrdiff_t *nchars, ptrdiff_t *nbytes) { const unsigned char *endp = str + len; - int n; ptrdiff_t chars = 0, bytes = 0; if (len >= MAX_MULTIBYTE_LENGTH) { - const unsigned char *adjusted_endp = endp - MAX_MULTIBYTE_LENGTH; + const unsigned char *adjusted_endp = endp - (MAX_MULTIBYTE_LENGTH - 1); while (str < adjusted_endp) { - if (! CHAR_BYTE8_HEAD_P (*str) - && (n = MULTIBYTE_LENGTH_NO_CHECK (str)) > 0) + int n = multibyte_length (str, NULL, false, false); + if (0 < n) str += n, bytes += n; else str++, bytes += 2; @@ -535,8 +480,8 @@ parse_str_as_multibyte (const unsigned char *str, ptrdiff_t len, } while (str < endp) { - if (! CHAR_BYTE8_HEAD_P (*str) - && (n = MULTIBYTE_LENGTH (str, endp)) > 0) + int n = multibyte_length (str, endp, true, false); + if (0 < n) str += n, bytes += n; else str++, bytes += 2; @@ -563,20 +508,25 @@ str_as_multibyte (unsigned char *str, ptrdiff_t len, ptrdiff_t nbytes, unsigned char *p = str, *endp = str + nbytes; unsigned char *to; ptrdiff_t chars = 0; - int n; if (nbytes >= MAX_MULTIBYTE_LENGTH) { - unsigned char *adjusted_endp = endp - MAX_MULTIBYTE_LENGTH; - while (p < adjusted_endp - && ! CHAR_BYTE8_HEAD_P (*p) - && (n = MULTIBYTE_LENGTH_NO_CHECK (p)) > 0) - p += n, chars++; + unsigned char *adjusted_endp = endp - (MAX_MULTIBYTE_LENGTH - 1); + while (p < adjusted_endp) + { + int n = multibyte_length (p, NULL, false, false); + if (n <= 0) + break; + p += n, chars++; + } + } + while (true) + { + int n = multibyte_length (p, endp, true, false); + if (n <= 0) + break; + p += n, chars++; } - while (p < endp - && ! CHAR_BYTE8_HEAD_P (*p) - && (n = MULTIBYTE_LENGTH (p, endp)) > 0) - p += n, chars++; if (nchars) *nchars = chars; if (p == endp) @@ -590,11 +540,11 @@ str_as_multibyte (unsigned char *str, ptrdiff_t len, ptrdiff_t nbytes, if (nbytes >= MAX_MULTIBYTE_LENGTH) { - unsigned char *adjusted_endp = endp - MAX_MULTIBYTE_LENGTH; + unsigned char *adjusted_endp = endp - (MAX_MULTIBYTE_LENGTH - 1); while (p < adjusted_endp) { - if (! CHAR_BYTE8_HEAD_P (*p) - && (n = MULTIBYTE_LENGTH_NO_CHECK (p)) > 0) + int n = multibyte_length (p, NULL, false, false); + if (0 < n) { while (n--) *to++ = *p++; @@ -610,8 +560,8 @@ str_as_multibyte (unsigned char *str, ptrdiff_t len, ptrdiff_t nbytes, } while (p < endp) { - if (! CHAR_BYTE8_HEAD_P (*p) - && (n = MULTIBYTE_LENGTH (p, endp)) > 0) + int n = multibyte_length (p, endp, true, false); + if (0 < n) { while (n--) *to++ = *p++; @@ -706,7 +656,7 @@ str_as_unibyte (unsigned char *str, ptrdiff_t bytes) len = BYTES_BY_CHAR_HEAD (c); if (CHAR_BYTE8_HEAD_P (c)) { - c = STRING_CHAR_ADVANCE (p); + c = string_char_advance (&p); *to++ = CHAR_TO_BYTE8 (c); } else @@ -730,7 +680,7 @@ str_to_unibyte (const unsigned char *src, unsigned char *dst, ptrdiff_t chars) for (i = 0; i < chars; i++) { - int c = STRING_CHAR_ADVANCE (src); + int c = string_char_advance (&src); if (CHAR_BYTE8_P (c)) c = CHAR_TO_BYTE8 (c); @@ -823,7 +773,7 @@ string_escape_byte8 (Lisp_Object string) if (CHAR_BYTE8_HEAD_P (c)) { - c = STRING_CHAR_ADVANCE (src); + c = string_char_advance (&src); c = CHAR_TO_BYTE8 (c); dst += sprintf ((char *) dst, "\\%03o", c + 0u); } @@ -849,24 +799,22 @@ Concatenate all the argument characters and make the result a string. usage: (string &rest CHARACTERS) */) (ptrdiff_t n, Lisp_Object *args) { - ptrdiff_t i; - int c; - unsigned char *buf, *p; - Lisp_Object str; - USE_SAFE_ALLOCA; - - SAFE_NALLOCA (buf, MAX_MULTIBYTE_LENGTH, n); - p = buf; - - for (i = 0; i < n; i++) + ptrdiff_t nbytes = 0; + for (ptrdiff_t i = 0; i < n; i++) { CHECK_CHARACTER (args[i]); - c = XFIXNUM (args[i]); + nbytes += CHAR_BYTES (XFIXNUM (args[i])); + } + if (nbytes == n) + return Funibyte_string (n, args); + Lisp_Object str = make_uninit_multibyte_string (n, nbytes); + unsigned char *p = SDATA (str); + for (ptrdiff_t i = 0; i < n; i++) + { + eassume (CHARACTERP (args[i])); + int c = XFIXNUM (args[i]); p += CHAR_STRING (c, p); } - - str = make_string_from_bytes ((char *) buf, n, p - buf); - SAFE_FREE (); return str; } @@ -875,20 +823,10 @@ DEFUN ("unibyte-string", Funibyte_string, Sunibyte_string, 0, MANY, 0, usage: (unibyte-string &rest BYTES) */) (ptrdiff_t n, Lisp_Object *args) { - ptrdiff_t i; - Lisp_Object str; - USE_SAFE_ALLOCA; - unsigned char *buf = SAFE_ALLOCA (n); - unsigned char *p = buf; - - for (i = 0; i < n; i++) - { - CHECK_RANGED_INTEGER (args[i], 0, 255); - *p++ = XFIXNUM (args[i]); - } - - str = make_string_from_bytes ((char *) buf, n, p - buf); - SAFE_FREE (); + Lisp_Object str = make_uninit_string (n); + unsigned char *p = SDATA (str); + for (ptrdiff_t i = 0; i < n; i++) + *p++ = check_integer_range (args[i], 0, 255); return str; } @@ -931,10 +869,10 @@ character is not ASCII nor 8-bit character, an error is signaled. */) } else { - CHECK_FIXNUM_COERCE_MARKER (position); - if (XFIXNUM (position) < BEGV || XFIXNUM (position) >= ZV) + EMACS_INT fixed_pos = fix_position (position); + if (! (BEGV <= fixed_pos && fixed_pos < ZV)) args_out_of_range_3 (position, make_fixnum (BEGV), make_fixnum (ZV)); - pos = XFIXNAT (position); + pos = fixed_pos; p = CHAR_POS_ADDR (pos); } if (NILP (BVAR (current_buffer, enable_multibyte_characters))) @@ -1044,6 +982,27 @@ printablep (int c) || gen_cat == UNICODE_CATEGORY_Cn)); /* unassigned */ } +/* Return true if C is graphic character that can be printed independently. */ +bool +graphic_base_p (int c) +{ + Lisp_Object category = CHAR_TABLE_REF (Vunicode_category_table, c); + if (! FIXNUMP (category)) + return false; + EMACS_INT gen_cat = XFIXNUM (category); + + return (!(gen_cat == UNICODE_CATEGORY_Mn /* mark, nonspacing */ + || gen_cat == UNICODE_CATEGORY_Mc /* mark, combining */ + || gen_cat == UNICODE_CATEGORY_Me /* mark, enclosing */ + || gen_cat == UNICODE_CATEGORY_Zs /* separator, space */ + || gen_cat == UNICODE_CATEGORY_Zl /* separator, line */ + || gen_cat == UNICODE_CATEGORY_Zp /* separator, paragraph */ + || gen_cat == UNICODE_CATEGORY_Cc /* other, control */ + || gen_cat == UNICODE_CATEGORY_Cs /* other, surrogate */ + || gen_cat == UNICODE_CATEGORY_Cf /* other, format */ + || gen_cat == UNICODE_CATEGORY_Cn)); /* other, unassigned */ +} + /* Return true if C is a horizontal whitespace character, as defined by https://www.unicode.org/reports/tr18/tr18-19.html#blank. */ bool diff --git a/src/character.h b/src/character.h index 3642a540448..cbf43097ae2 100644 --- a/src/character.h +++ b/src/character.h @@ -31,35 +31,39 @@ INLINE_HEADER_BEGIN /* character code 1st byte byte sequence -------------- -------- ------------- 0-7F 00..7F 0xxxxxxx - 80-7FF C2..DF 110xxxxx 10xxxxxx - 800-FFFF E0..EF 1110xxxx 10xxxxxx 10xxxxxx - 10000-1FFFFF F0..F7 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx - 200000-3FFF7F F8 11111000 1000xxxx 10xxxxxx 10xxxxxx 10xxxxxx + 80-7FF C2..DF 110yyyyx 10xxxxxx + 800-FFFF E0..EF 1110yyyy 10yxxxxx 10xxxxxx + 10000-1FFFFF F0..F7 11110yyy 10yyxxxx 10xxxxxx 10xxxxxx + 200000-3FFF7F F8 11111000 1000yxxx 10xxxxxx 10xxxxxx 10xxxxxx 3FFF80-3FFFFF C0..C1 1100000x 10xxxxxx (for eight-bit-char) 400000-... invalid invalid 1st byte 80..BF 10xxxxxx - F9..FF 11111xxx (xxx != 000) + F9..FF 11111yyy + + In each bit pattern, 'x' and 'y' each represent a single bit of the + character code payload, and least one 'y' must be a 1 bit. + In the 5-byte sequence, the 22-bit payload cannot exceed 3FFF7F. */ /* Maximum character code ((1 << CHARACTERBITS) - 1). */ -#define MAX_CHAR 0x3FFFFF +enum { MAX_CHAR = 0x3FFFFF }; /* Maximum Unicode character code. */ -#define MAX_UNICODE_CHAR 0x10FFFF +enum { MAX_UNICODE_CHAR = 0x10FFFF }; /* Maximum N-byte character codes. */ -#define MAX_1_BYTE_CHAR 0x7F -#define MAX_2_BYTE_CHAR 0x7FF -#define MAX_3_BYTE_CHAR 0xFFFF -#define MAX_4_BYTE_CHAR 0x1FFFFF -#define MAX_5_BYTE_CHAR 0x3FFF7F +enum { MAX_1_BYTE_CHAR = 0x7F }; +enum { MAX_2_BYTE_CHAR = 0x7FF }; +enum { MAX_3_BYTE_CHAR = 0xFFFF }; +enum { MAX_4_BYTE_CHAR = 0x1FFFFF }; +enum { MAX_5_BYTE_CHAR = 0x3FFF7F }; /* Minimum leading code of multibyte characters. */ -#define MIN_MULTIBYTE_LEADING_CODE 0xC0 +enum { MIN_MULTIBYTE_LEADING_CODE = 0xC0 }; /* Maximum leading code of multibyte characters. Note: this must be updated if we ever increase MAX_CHAR above. */ -#define MAX_MULTIBYTE_LEADING_CODE 0xF8 +enum { MAX_MULTIBYTE_LEADING_CODE = 0xF8 }; /* Unicode character values. */ enum @@ -80,533 +84,432 @@ enum OBJECT_REPLACEMENT_CHARACTER = 0xFFFC, }; +extern int char_string (unsigned, unsigned char *); + /* UTF-8 encodings. Use \x escapes, so they are portable to pre-C11 compilers and can be concatenated with ordinary string literals. */ #define uLSQM "\xE2\x80\x98" /* U+2018 LEFT SINGLE QUOTATION MARK */ #define uRSQM "\xE2\x80\x99" /* U+2019 RIGHT SINGLE QUOTATION MARK */ -/* Nonzero iff C is a character that corresponds to a raw 8-bit +/* True iff C is a character of code less than 0x100. */ +INLINE bool +SINGLE_BYTE_CHAR_P (intmax_t c) +{ + return 0 <= c && c < 0x100; +} + +/* True iff C is a character that corresponds to a raw 8-bit byte. */ -#define CHAR_BYTE8_P(c) ((c) > MAX_5_BYTE_CHAR) +INLINE bool +CHAR_BYTE8_P (int c) +{ + return MAX_5_BYTE_CHAR < c; +} /* Return the character code for raw 8-bit byte BYTE. */ -#define BYTE8_TO_CHAR(byte) ((byte) + 0x3FFF00) +INLINE int +BYTE8_TO_CHAR (int byte) +{ + return byte + 0x3FFF00; +} -#define UNIBYTE_TO_CHAR(byte) \ - (ASCII_CHAR_P (byte) ? (byte) : BYTE8_TO_CHAR (byte)) +INLINE int +UNIBYTE_TO_CHAR (int byte) +{ + return ASCII_CHAR_P (byte) ? byte : BYTE8_TO_CHAR (byte); +} /* Return the raw 8-bit byte for character C. */ -#define CHAR_TO_BYTE8(c) (CHAR_BYTE8_P (c) ? (c) - 0x3FFF00 : (c & 0xFF)) +INLINE int +CHAR_TO_BYTE8 (int c) +{ + return CHAR_BYTE8_P (c) ? c - 0x3FFF00 : c & 0xFF; +} /* Return the raw 8-bit byte for character C, or -1 if C doesn't correspond to a byte. */ -#define CHAR_TO_BYTE_SAFE(c) \ - (ASCII_CHAR_P (c) ? c : (CHAR_BYTE8_P (c) ? (c) - 0x3FFF00 : -1)) +INLINE int +CHAR_TO_BYTE_SAFE (int c) +{ + return ASCII_CHAR_P (c) ? c : CHAR_BYTE8_P (c) ? c - 0x3FFF00 : -1; +} -/* Nonzero iff BYTE is the 1st byte of a multibyte form of a character +/* True iff BYTE is the 1st byte of a multibyte form of a character that corresponds to a raw 8-bit byte. */ -#define CHAR_BYTE8_HEAD_P(byte) ((byte) == 0xC0 || (byte) == 0xC1) - -/* If C is not ASCII, make it unibyte. */ -#define MAKE_CHAR_UNIBYTE(c) \ - do { \ - if (! ASCII_CHAR_P (c)) \ - c = CHAR_TO_BYTE8 (c); \ - } while (false) - +INLINE bool +CHAR_BYTE8_HEAD_P (int byte) +{ + return byte == 0xC0 || byte == 0xC1; +} /* If C is not ASCII, make it multibyte. Assumes C < 256. */ -#define MAKE_CHAR_MULTIBYTE(c) \ - (eassert ((c) >= 0 && (c) < 256), (c) = UNIBYTE_TO_CHAR (c)) +INLINE int +make_char_multibyte (int c) +{ + eassert (SINGLE_BYTE_CHAR_P (c)); + return UNIBYTE_TO_CHAR (c); +} /* This is the maximum byte length of multibyte form. */ -#define MAX_MULTIBYTE_LENGTH 5 - -/* Nonzero iff X is a character. */ -#define CHARACTERP(x) (FIXNATP (x) && XFIXNAT (x) <= MAX_CHAR) +enum { MAX_MULTIBYTE_LENGTH = 5 }; /* Nonzero iff C is valid as a character code. */ -#define CHAR_VALID_P(c) UNSIGNED_CMP (c, <=, MAX_CHAR) +INLINE bool +CHAR_VALID_P (intmax_t c) +{ + return 0 <= c && c <= MAX_CHAR; +} -/* Check if Lisp object X is a character or not. */ -#define CHECK_CHARACTER(x) \ - CHECK_TYPE (CHARACTERP (x), Qcharacterp, x) +/* Nonzero iff X is a character. */ +INLINE bool +CHARACTERP (Lisp_Object x) +{ + return FIXNUMP (x) && CHAR_VALID_P (XFIXNUM (x)); +} -#define CHECK_CHARACTER_CAR(x) \ - do { \ - Lisp_Object tmp = XCAR (x); \ - CHECK_CHARACTER (tmp); \ - } while (false) +/* Check if Lisp object X is a character or not. */ +INLINE void +CHECK_CHARACTER (Lisp_Object x) +{ + CHECK_TYPE (CHARACTERP (x), Qcharacterp, x); +} -#define CHECK_CHARACTER_CDR(x) \ - do { \ - Lisp_Object tmp = XCDR (x); \ - CHECK_CHARACTER (tmp); \ - } while (false) +INLINE void +CHECK_CHARACTER_CAR (Lisp_Object x) +{ + CHECK_CHARACTER (XCAR (x)); +} -/* Nonzero iff C is a character of code less than 0x100. */ -#define SINGLE_BYTE_CHAR_P(c) UNSIGNED_CMP (c, <, 0x100) +INLINE void +CHECK_CHARACTER_CDR (Lisp_Object x) +{ + CHECK_CHARACTER (XCDR (x)); +} -/* Nonzero if character C has a printable glyph. */ -#define CHAR_PRINTABLE_P(c) \ - (((c) >= 32 && (c) < 127) \ - || ! NILP (CHAR_TABLE_REF (Vprintable_chars, (c)))) +/* True if character C has a printable glyph. */ +INLINE bool +CHAR_PRINTABLE_P (int c) +{ + return ((32 <= c && c < 127) + || ! NILP (CHAR_TABLE_REF (Vprintable_chars, c))); +} /* Return byte length of multibyte form for character C. */ -#define CHAR_BYTES(c) \ - ( (c) <= MAX_1_BYTE_CHAR ? 1 \ - : (c) <= MAX_2_BYTE_CHAR ? 2 \ - : (c) <= MAX_3_BYTE_CHAR ? 3 \ - : (c) <= MAX_4_BYTE_CHAR ? 4 \ - : (c) <= MAX_5_BYTE_CHAR ? 5 \ - : 2) - +INLINE int +CHAR_BYTES (int c) +{ + return ((MAX_5_BYTE_CHAR < c ? -2 : 1) + + (MAX_1_BYTE_CHAR < c) + + (MAX_2_BYTE_CHAR < c) + + (MAX_3_BYTE_CHAR < c) + + (MAX_4_BYTE_CHAR < c)); +} /* Return the leading code of multibyte form of C. */ -#define CHAR_LEADING_CODE(c) \ - ((c) <= MAX_1_BYTE_CHAR ? c \ - : (c) <= MAX_2_BYTE_CHAR ? (0xC0 | ((c) >> 6)) \ - : (c) <= MAX_3_BYTE_CHAR ? (0xE0 | ((c) >> 12)) \ - : (c) <= MAX_4_BYTE_CHAR ? (0xF0 | ((c) >> 18)) \ - : (c) <= MAX_5_BYTE_CHAR ? 0xF8 \ - : (0xC0 | (((c) >> 6) & 0x01))) +INLINE int +CHAR_LEADING_CODE (int c) +{ + return (c <= MAX_1_BYTE_CHAR ? c + : c <= MAX_2_BYTE_CHAR ? 0xC0 | (c >> 6) + : c <= MAX_3_BYTE_CHAR ? 0xE0 | (c >> 12) + : c <= MAX_4_BYTE_CHAR ? 0xF0 | (c >> 18) + : c <= MAX_5_BYTE_CHAR ? 0xF8 + : 0xC0 | ((c >> 6) & 0x01)); +} /* Store multibyte form of the character C in P. The caller should allocate at least MAX_MULTIBYTE_LENGTH bytes area at P in advance. Returns the length of the multibyte form. */ -#define CHAR_STRING(c, p) \ - (UNSIGNED_CMP (c, <=, MAX_1_BYTE_CHAR) \ - ? ((p)[0] = (c), \ - 1) \ - : UNSIGNED_CMP (c, <=, MAX_2_BYTE_CHAR) \ - ? ((p)[0] = (0xC0 | ((c) >> 6)), \ - (p)[1] = (0x80 | ((c) & 0x3F)), \ - 2) \ - : UNSIGNED_CMP (c, <=, MAX_3_BYTE_CHAR) \ - ? ((p)[0] = (0xE0 | ((c) >> 12)), \ - (p)[1] = (0x80 | (((c) >> 6) & 0x3F)), \ - (p)[2] = (0x80 | ((c) & 0x3F)), \ - 3) \ - : verify_expr (sizeof (c) <= sizeof (unsigned), char_string (c, p))) +INLINE int +CHAR_STRING (int c, unsigned char *p) +{ + eassume (0 <= c); + if (c <= MAX_1_BYTE_CHAR) + { + p[0] = c; + return 1; + } + if (c <= MAX_2_BYTE_CHAR) + { + p[0] = 0xC0 | (c >> 6); + p[1] = 0x80 | (c & 0x3F); + return 2; + } + if (c <= MAX_3_BYTE_CHAR) + { + p[0] = 0xE0 | (c >> 12); + p[1] = 0x80 | ((c >> 6) & 0x3F); + p[2] = 0x80 | (c & 0x3F); + return 3; + } + int len = char_string (c, p); + eassume (0 < len && len <= MAX_MULTIBYTE_LENGTH); + return len; +} /* Store multibyte form of byte B in P. The caller should allocate at least MAX_MULTIBYTE_LENGTH bytes area at P in advance. Returns the length of the multibyte form. */ -#define BYTE8_STRING(b, p) \ - ((p)[0] = (0xC0 | (((b) >> 6) & 0x01)), \ - (p)[1] = (0x80 | ((b) & 0x3F)), \ - 2) - - -/* Store multibyte form of the character C in P and advance P to the - end of the multibyte form. The caller should allocate at least - MAX_MULTIBYTE_LENGTH bytes area at P in advance. */ - -#define CHAR_STRING_ADVANCE(c, p) \ - do { \ - if ((c) <= MAX_1_BYTE_CHAR) \ - *(p)++ = (c); \ - else if ((c) <= MAX_2_BYTE_CHAR) \ - *(p)++ = (0xC0 | ((c) >> 6)), \ - *(p)++ = (0x80 | ((c) & 0x3F)); \ - else if ((c) <= MAX_3_BYTE_CHAR) \ - *(p)++ = (0xE0 | ((c) >> 12)), \ - *(p)++ = (0x80 | (((c) >> 6) & 0x3F)), \ - *(p)++ = (0x80 | ((c) & 0x3F)); \ - else \ - { \ - verify (sizeof (c) <= sizeof (unsigned)); \ - (p) += char_string (c, p); \ - } \ - } while (false) - - -/* Nonzero iff BYTE starts a non-ASCII character in a multibyte - form. */ -#define LEADING_CODE_P(byte) (((byte) & 0xC0) == 0xC0) - -/* Nonzero iff BYTE is a trailing code of a non-ASCII character in a +INLINE int +BYTE8_STRING (int b, unsigned char *p) +{ + p[0] = 0xC0 | ((b >> 6) & 0x01); + p[1] = 0x80 | (b & 0x3F); + return 2; +} + + +/* True iff BYTE starts a non-ASCII character in a multibyte form. */ +INLINE bool +LEADING_CODE_P (int byte) +{ + return (byte & 0xC0) == 0xC0; +} + +/* True iff BYTE is a trailing code of a non-ASCII character in a multibyte form. */ -#define TRAILING_CODE_P(byte) (((byte) & 0xC0) == 0x80) +INLINE bool +TRAILING_CODE_P (int byte) +{ + return (byte & 0xC0) == 0x80; +} -/* Nonzero iff BYTE starts a character in a multibyte form. +/* True iff BYTE starts a character in a multibyte form. This is equivalent to: (ASCII_CHAR_P (byte) || LEADING_CODE_P (byte)) */ -#define CHAR_HEAD_P(byte) (((byte) & 0xC0) != 0x80) +INLINE bool +CHAR_HEAD_P (int byte) +{ + return (byte & 0xC0) != 0x80; +} /* How many bytes a character that starts with BYTE occupies in a - multibyte form. Unlike MULTIBYTE_LENGTH below, this macro does not + multibyte form. Unlike multibyte_length, this function does not validate the multibyte form, but looks only at its first byte. */ -#define BYTES_BY_CHAR_HEAD(byte) \ - (!((byte) & 0x80) ? 1 \ - : !((byte) & 0x20) ? 2 \ - : !((byte) & 0x10) ? 3 \ - : !((byte) & 0x08) ? 4 \ - : 5) +INLINE int +BYTES_BY_CHAR_HEAD (int byte) +{ + return (!(byte & 0x80) ? 1 + : !(byte & 0x20) ? 2 + : !(byte & 0x10) ? 3 + : !(byte & 0x08) ? 4 + : 5); +} -/* The byte length of multibyte form at unibyte string P ending at - PEND. If the string doesn't point to a valid multibyte form, - return 0. Unlike BYTES_BY_CHAR_HEAD, this macro validates the - multibyte form. */ +/* The byte length of the multibyte form at the unibyte string P, + ending at PEND if CHECK, and without a length check if !CHECK. + If ALLOW_8BIT, allow multibyte forms of eight-bit characters. + If the string doesn't point to a valid multibyte form, return 0. + Unlike BYTES_BY_CHAR_HEAD, this function validates the multibyte form. */ + +INLINE int +multibyte_length (unsigned char const *p, unsigned char const *pend, + bool check, bool allow_8bit) +{ + if (!check || p < pend) + { + unsigned char c = p[0]; + if (c < 0x80) + return 1; + if (!check || p + 1 < pend) + { + unsigned char d = p[1]; + int w = ((d & 0xC0) << 2) + c; + if ((allow_8bit ? 0x2C0 : 0x2C2) <= w && w <= 0x2DF) + return 2; + if (!check || p + 2 < pend) + { + unsigned char e = p[2]; + w += (e & 0xC0) << 4; + int w1 = w | ((d & 0x20) >> 2); + if (0xAE1 <= w1 && w1 <= 0xAEF) + return 3; + if (!check || p + 3 < pend) + { + unsigned char f = p[3]; + w += (f & 0xC0) << 6; + int w2 = w | ((d & 0x30) >> 3); + if (0x2AF1 <= w2 && w2 <= 0x2AF7) + return 4; + if (!check || p + 4 < pend) + { + int_fast64_t lw = w + ((p[4] & 0xC0) << 8), + w3 = (lw << 24) + (d << 16) + (e << 8) + f; + if (0xAAF8888080 <= w3 && w3 <= 0xAAF88FBFBD) + return 5; + } + } + } + } + } + + return 0; +} + -#define MULTIBYTE_LENGTH(p, pend) \ - (p >= pend ? 0 \ - : !((p)[0] & 0x80) ? 1 \ - : ((p + 1 >= pend) || (((p)[1] & 0xC0) != 0x80)) ? 0 \ - : ((p)[0] & 0xE0) == 0xC0 ? 2 \ - : ((p + 2 >= pend) || (((p)[2] & 0xC0) != 0x80)) ? 0 \ - : ((p)[0] & 0xF0) == 0xE0 ? 3 \ - : ((p + 3 >= pend) || (((p)[3] & 0xC0) != 0x80)) ? 0 \ - : ((p)[0] & 0xF8) == 0xF0 ? 4 \ - : ((p + 4 >= pend) || (((p)[4] & 0xC0) != 0x80)) ? 0 \ - : (p)[0] == 0xF8 && ((p)[1] & 0xF0) == 0x80 ? 5 \ - : 0) - - -/* Like MULTIBYTE_LENGTH, but don't check the ending address. The - multibyte form is still validated, unlike BYTES_BY_CHAR_HEAD. */ - -#define MULTIBYTE_LENGTH_NO_CHECK(p) \ - (!((p)[0] & 0x80) ? 1 \ - : ((p)[1] & 0xC0) != 0x80 ? 0 \ - : ((p)[0] & 0xE0) == 0xC0 ? 2 \ - : ((p)[2] & 0xC0) != 0x80 ? 0 \ - : ((p)[0] & 0xF0) == 0xE0 ? 3 \ - : ((p)[3] & 0xC0) != 0x80 ? 0 \ - : ((p)[0] & 0xF8) == 0xF0 ? 4 \ - : ((p)[4] & 0xC0) != 0x80 ? 0 \ - : (p)[0] == 0xF8 && ((p)[1] & 0xF0) == 0x80 ? 5 \ - : 0) - -/* If P is before LIMIT, advance P to the next character boundary. +/* Return number of bytes in the multibyte character just before P. Assumes that P is already at a character boundary of the same - multibyte form whose end address is LIMIT. */ + multibyte form, and is not at the start of that form. */ -#define NEXT_CHAR_BOUNDARY(p, limit) \ - do { \ - if ((p) < (limit)) \ - (p) += BYTES_BY_CHAR_HEAD (*(p)); \ - } while (false) +INLINE int +raw_prev_char_len (unsigned char const *p) +{ + for (int len = 1; ; len++) + if (CHAR_HEAD_P (p[-len])) + return len; +} -/* If P is after LIMIT, advance P to the previous character boundary. - Assumes that P is already at a character boundary of the same - multibyte form whose beginning address is LIMIT. */ - -#define PREV_CHAR_BOUNDARY(p, limit) \ - do { \ - if ((p) > (limit)) \ - { \ - const unsigned char *chp = (p); \ - do { \ - chp--; \ - } while (chp >= limit && ! CHAR_HEAD_P (*chp)); \ - (p) = (BYTES_BY_CHAR_HEAD (*chp) == (p) - chp) ? chp : (p) - 1; \ - } \ - } while (false) +/* Return the character code of character whose multibyte form is at P, + and set *LENGTH to its length. */ + +INLINE int +string_char_and_length (unsigned char const *p, int *length) +{ + int c = p[0]; + if (! (c & 0x80)) + { + *length = 1; + return c; + } + eassume (0xC0 <= c); + + int d = (c << 6) + p[1] - ((0xC0 << 6) + 0x80); + if (! (c & 0x20)) + { + *length = 2; + return d + (c < 0xC2 ? 0x3FFF80 : 0); + } + + d = (d << 6) + p[2] - ((0x20 << 12) + 0x80); + if (! (c & 0x10)) + { + *length = 3; + eassume (MAX_2_BYTE_CHAR < d && d <= MAX_3_BYTE_CHAR); + return d; + } + + d = (d << 6) + p[3] - ((0x10 << 18) + 0x80); + if (! (c & 0x08)) + { + *length = 4; + eassume (MAX_3_BYTE_CHAR < d && d <= MAX_4_BYTE_CHAR); + return d; + } + + d = (d << 6) + p[4] - ((0x08 << 24) + 0x80); + *length = 5; + eassume (MAX_4_BYTE_CHAR < d && d <= MAX_5_BYTE_CHAR); + return d; +} /* Return the character code of character whose multibyte form is at P. */ -#define STRING_CHAR(p) \ - (!((p)[0] & 0x80) \ - ? (p)[0] \ - : ! ((p)[0] & 0x20) \ - ? (((((p)[0] & 0x1F) << 6) \ - | ((p)[1] & 0x3F)) \ - + (((unsigned char) (p)[0]) < 0xC2 ? 0x3FFF80 : 0)) \ - : ! ((p)[0] & 0x10) \ - ? ((((p)[0] & 0x0F) << 12) \ - | (((p)[1] & 0x3F) << 6) \ - | ((p)[2] & 0x3F)) \ - : string_char ((p), NULL, NULL)) - - -/* Like STRING_CHAR, but set ACTUAL_LEN to the length of multibyte - form. */ - -#define STRING_CHAR_AND_LENGTH(p, actual_len) \ - (!((p)[0] & 0x80) \ - ? ((actual_len) = 1, (p)[0]) \ - : ! ((p)[0] & 0x20) \ - ? ((actual_len) = 2, \ - (((((p)[0] & 0x1F) << 6) \ - | ((p)[1] & 0x3F)) \ - + (((unsigned char) (p)[0]) < 0xC2 ? 0x3FFF80 : 0))) \ - : ! ((p)[0] & 0x10) \ - ? ((actual_len) = 3, \ - ((((p)[0] & 0x0F) << 12) \ - | (((p)[1] & 0x3F) << 6) \ - | ((p)[2] & 0x3F))) \ - : string_char ((p), NULL, &actual_len)) - - -/* Like STRING_CHAR, but advance P to the end of multibyte form. */ - -#define STRING_CHAR_ADVANCE(p) \ - (!((p)[0] & 0x80) \ - ? *(p)++ \ - : ! ((p)[0] & 0x20) \ - ? ((p) += 2, \ - ((((p)[-2] & 0x1F) << 6) \ - | ((p)[-1] & 0x3F) \ - | ((unsigned char) ((p)[-2]) < 0xC2 ? 0x3FFF80 : 0))) \ - : ! ((p)[0] & 0x10) \ - ? ((p) += 3, \ - ((((p)[-3] & 0x0F) << 12) \ - | (((p)[-2] & 0x3F) << 6) \ - | ((p)[-1] & 0x3F))) \ - : string_char ((p), &(p), NULL)) - - -/* Fetch the "next" character from Lisp string STRING at byte position - BYTEIDX, character position CHARIDX. Store it into OUTPUT. - - All the args must be side-effect-free. - BYTEIDX and CHARIDX must be lvalues; - we increment them past the character fetched. */ - -#define FETCH_STRING_CHAR_ADVANCE(OUTPUT, STRING, CHARIDX, BYTEIDX) \ - do \ - { \ - CHARIDX++; \ - if (STRING_MULTIBYTE (STRING)) \ - { \ - unsigned char *chp = &SDATA (STRING)[BYTEIDX]; \ - int chlen; \ - \ - OUTPUT = STRING_CHAR_AND_LENGTH (chp, chlen); \ - BYTEIDX += chlen; \ - } \ - else \ - { \ - OUTPUT = SREF (STRING, BYTEIDX); \ - BYTEIDX++; \ - } \ - } \ - while (false) - -/* Like FETCH_STRING_CHAR_ADVANCE, but return a multibyte character - even if STRING is unibyte. */ +INLINE int +STRING_CHAR (unsigned char const *p) +{ + int len; + return string_char_and_length (p, &len); +} + -#define FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE(OUTPUT, STRING, CHARIDX, BYTEIDX) \ - do \ - { \ - CHARIDX++; \ - if (STRING_MULTIBYTE (STRING)) \ - { \ - unsigned char *chp = &SDATA (STRING)[BYTEIDX]; \ - int chlen; \ - \ - OUTPUT = STRING_CHAR_AND_LENGTH (chp, chlen); \ - BYTEIDX += chlen; \ - } \ - else \ - { \ - OUTPUT = SREF (STRING, BYTEIDX); \ - BYTEIDX++; \ - MAKE_CHAR_MULTIBYTE (OUTPUT); \ - } \ - } \ - while (false) - - -/* Like FETCH_STRING_CHAR_ADVANCE, but assumes STRING is multibyte. */ - -#define FETCH_STRING_CHAR_ADVANCE_NO_CHECK(OUTPUT, STRING, CHARIDX, BYTEIDX) \ - do \ - { \ - unsigned char *fetch_ptr = &SDATA (STRING)[BYTEIDX]; \ - int fetch_len; \ - \ - OUTPUT = STRING_CHAR_AND_LENGTH (fetch_ptr, fetch_len); \ - BYTEIDX += fetch_len; \ - CHARIDX++; \ - } \ - while (false) - - -/* Like FETCH_STRING_CHAR_ADVANCE, but fetch character from the current - buffer. */ - -#define FETCH_CHAR_ADVANCE(OUTPUT, CHARIDX, BYTEIDX) \ - do \ - { \ - CHARIDX++; \ - if (!NILP (BVAR (current_buffer, enable_multibyte_characters))) \ - { \ - unsigned char *chp = BYTE_POS_ADDR (BYTEIDX); \ - int chlen; \ - \ - OUTPUT = STRING_CHAR_AND_LENGTH (chp, chlen); \ - BYTEIDX += chlen; \ - } \ - else \ - { \ - OUTPUT = *(BYTE_POS_ADDR (BYTEIDX)); \ - BYTEIDX++; \ - } \ - } \ - while (false) - - -/* Like FETCH_CHAR_ADVANCE, but assumes the current buffer is multibyte. */ - -#define FETCH_CHAR_ADVANCE_NO_CHECK(OUTPUT, CHARIDX, BYTEIDX) \ - do \ - { \ - unsigned char *chp = BYTE_POS_ADDR (BYTEIDX); \ - int chlen; \ - \ - OUTPUT = STRING_CHAR_AND_LENGTH (chp, chlen); \ - BYTEIDX += chlen; \ - CHARIDX++; \ - } \ - while (false) - - -/* Increment the buffer byte position POS_BYTE of the current buffer to - the next character boundary. No range checking of POS. */ - -#define INC_POS(pos_byte) \ - do { \ - unsigned char *chp = BYTE_POS_ADDR (pos_byte); \ - pos_byte += BYTES_BY_CHAR_HEAD (*chp); \ - } while (false) - - -/* Decrement the buffer byte position POS_BYTE of the current buffer to - the previous character boundary. No range checking of POS. */ - -#define DEC_POS(pos_byte) \ - do { \ - unsigned char *chp; \ - \ - pos_byte--; \ - if (pos_byte < GPT_BYTE) \ - chp = BEG_ADDR + pos_byte - BEG_BYTE; \ - else \ - chp = BEG_ADDR + GAP_SIZE + pos_byte - BEG_BYTE; \ - while (!CHAR_HEAD_P (*chp)) \ - { \ - chp--; \ - pos_byte--; \ - } \ - } while (false) - -/* Increment both CHARPOS and BYTEPOS, each in the appropriate way. */ - -#define INC_BOTH(charpos, bytepos) \ - do \ - { \ - (charpos)++; \ - if (NILP (BVAR (current_buffer, enable_multibyte_characters))) \ - (bytepos)++; \ - else \ - INC_POS ((bytepos)); \ - } \ - while (false) - - -/* Decrement both CHARPOS and BYTEPOS, each in the appropriate way. */ - -#define DEC_BOTH(charpos, bytepos) \ - do \ - { \ - (charpos)--; \ - if (NILP (BVAR (current_buffer, enable_multibyte_characters))) \ - (bytepos)--; \ - else \ - DEC_POS ((bytepos)); \ - } \ - while (false) - - -/* Increment the buffer byte position POS_BYTE of the current buffer to - the next character boundary. This macro relies on the fact that - *GPT_ADDR and *Z_ADDR are always accessible and the values are - '\0'. No range checking of POS_BYTE. */ - -#define BUF_INC_POS(buf, pos_byte) \ - do { \ - unsigned char *chp = BUF_BYTE_ADDRESS (buf, pos_byte); \ - pos_byte += BYTES_BY_CHAR_HEAD (*chp); \ - } while (false) - - -/* Decrement the buffer byte position POS_BYTE of the current buffer to - the previous character boundary. No range checking of POS_BYTE. */ - -#define BUF_DEC_POS(buf, pos_byte) \ - do { \ - unsigned char *chp; \ - pos_byte--; \ - if (pos_byte < BUF_GPT_BYTE (buf)) \ - chp = BUF_BEG_ADDR (buf) + pos_byte - BEG_BYTE; \ - else \ - chp = BUF_BEG_ADDR (buf) + BUF_GAP_SIZE (buf) + pos_byte - BEG_BYTE;\ - while (!CHAR_HEAD_P (*chp)) \ - { \ - chp--; \ - pos_byte--; \ - } \ - } while (false) - - -/* Return a non-outlandish value for the tab width. */ - -#define SANE_TAB_WIDTH(buf) sanitize_tab_width (BVAR (buf, tab_width)) +/* Like STRING_CHAR (*PP), but advance *PP to the end of multibyte form. */ INLINE int -sanitize_tab_width (Lisp_Object width) +string_char_advance (unsigned char const **pp) { - return (FIXNUMP (width) && 0 < XFIXNUM (width) && XFIXNUM (width) <= 1000 - ? XFIXNUM (width) : 8); + unsigned char const *p = *pp; + int len, c = string_char_and_length (p, &len); + *pp = p + len; + return c; } -/* Return the width of ASCII character C. The width is measured by - how many columns C will occupy on the screen when displayed in the - current buffer. */ -#define ASCII_CHAR_WIDTH(c) \ - (c < 0x20 \ - ? (c == '\t' \ - ? SANE_TAB_WIDTH (current_buffer) \ - : (c == '\n' ? 0 : (NILP (BVAR (current_buffer, ctl_arrow)) ? 4 : 2))) \ - : (c < 0x7f \ - ? 1 \ - : ((NILP (BVAR (current_buffer, ctl_arrow)) ? 4 : 2)))) +/* Return the next character from Lisp string STRING at byte position + *BYTEIDX, character position *CHARIDX. Update *BYTEIDX and + *CHARIDX past the character fetched. */ + +INLINE int +fetch_string_char_advance (Lisp_Object string, + ptrdiff_t *charidx, ptrdiff_t *byteidx) +{ + int output; + ptrdiff_t b = *byteidx; + unsigned char *chp = SDATA (string) + b; + if (STRING_MULTIBYTE (string)) + { + int chlen; + output = string_char_and_length (chp, &chlen); + b += chlen; + } + else + { + output = *chp; + b++; + } + (*charidx)++; + *byteidx = b; + return output; +} -/* Return a non-outlandish value for a character width. */ +/* Like fetch_string_char_advance, but return a multibyte character + even if STRING is unibyte. */ INLINE int -sanitize_char_width (EMACS_INT width) +fetch_string_char_as_multibyte_advance (Lisp_Object string, + ptrdiff_t *charidx, ptrdiff_t *byteidx) { - return 0 <= width && width <= 1000 ? width : 1000; + int output; + ptrdiff_t b = *byteidx; + unsigned char *chp = SDATA (string) + b; + if (STRING_MULTIBYTE (string)) + { + int chlen; + output = string_char_and_length (chp, &chlen); + b += chlen; + } + else + { + output = make_char_multibyte (*chp); + b++; + } + (*charidx)++; + *byteidx = b; + return output; } -/* Return the width of character C. The width is measured by how many - columns C will occupy on the screen when displayed in the current - buffer. The name CHARACTER_WIDTH avoids a collision with <limits.h> - CHAR_WIDTH when enabled; see ISO/IEC TS 18661-1:2014. */ -#define CHARACTER_WIDTH(c) \ - (ASCII_CHAR_P (c) \ - ? ASCII_CHAR_WIDTH (c) \ - : sanitize_char_width (XFIXNUM (CHAR_TABLE_REF (Vchar_width_table, c)))) +/* Like fetch_string_char_advance, but assumes STRING is multibyte. */ + +INLINE int +fetch_string_char_advance_no_check (Lisp_Object string, + ptrdiff_t *charidx, ptrdiff_t *byteidx) +{ + ptrdiff_t b = *byteidx; + unsigned char *chp = SDATA (string) + b; + int chlen, output = string_char_and_length (chp, &chlen); + (*charidx)++; + *byteidx = b + chlen; + return output; +} + /* If C is a variation selector, return the index of the variation selector (1..256). Otherwise, return 0. */ -#define CHAR_VARIATION_SELECTOR_P(c) \ - ((c) < 0xFE00 ? 0 \ - : (c) <= 0xFE0F ? (c) - 0xFE00 + 1 \ - : (c) < 0xE0100 ? 0 \ - : (c) <= 0xE01EF ? (c) - 0xE0100 + 17 \ - : 0) +INLINE int +CHAR_VARIATION_SELECTOR_P (int c) +{ + return (c < 0xFE00 ? 0 + : c <= 0xFE0F ? c - 0xFE00 + 1 + : c < 0xE0100 ? 0 + : c <= 0xE01EF ? c - 0xE0100 + 17 + : 0); +} /* Return true if C is a surrogate. */ @@ -657,9 +560,6 @@ typedef enum { } unicode_category_t; extern EMACS_INT char_resolve_modifier_mask (EMACS_INT) ATTRIBUTE_CONST; -extern int char_string (unsigned, unsigned char *); -extern int string_char (const unsigned char *, - const unsigned char **, int *); extern int translate_char (Lisp_Object, int c); extern ptrdiff_t count_size_as_multibyte (const unsigned char *, ptrdiff_t); @@ -683,10 +583,7 @@ extern bool alphanumericp (int); extern bool graphicp (int); extern bool printablep (int); extern bool blankp (int); - -/* Return a translation table of id number ID. */ -#define GET_TRANSLATION_TABLE(id) \ - (XCDR (XVECTOR (Vtranslation_table_vector)->contents[(id)])) +extern bool graphic_base_p (int); /* Look up the element in char table OBJ at index CH, and return it as an integer. If the element is not a character, return CH itself. */ diff --git a/src/charset.c b/src/charset.c index 355de0ca37f..eb388d1868b 100644 --- a/src/charset.c +++ b/src/charset.c @@ -868,15 +868,10 @@ usage: (define-charset-internal ...) */) val = args[charset_arg_code_space]; for (i = 0, dimension = 0, nchars = 1; ; i++) { - Lisp_Object min_byte_obj, max_byte_obj; - int min_byte, max_byte; - - min_byte_obj = Faref (val, make_fixnum (i * 2)); - max_byte_obj = Faref (val, make_fixnum (i * 2 + 1)); - CHECK_RANGED_INTEGER (min_byte_obj, 0, 255); - min_byte = XFIXNUM (min_byte_obj); - CHECK_RANGED_INTEGER (max_byte_obj, min_byte, 255); - max_byte = XFIXNUM (max_byte_obj); + Lisp_Object min_byte_obj = Faref (val, make_fixnum (i * 2)); + Lisp_Object max_byte_obj = Faref (val, make_fixnum (i * 2 + 1)); + int min_byte = check_integer_range (min_byte_obj, 0, 255); + int max_byte = check_integer_range (max_byte_obj, min_byte, 255); charset.code_space[i * 4] = min_byte; charset.code_space[i * 4 + 1] = max_byte; charset.code_space[i * 4 + 2] = max_byte - min_byte + 1; @@ -889,13 +884,8 @@ usage: (define-charset-internal ...) */) } val = args[charset_arg_dimension]; - if (NILP (val)) - charset.dimension = dimension; - else - { - CHECK_RANGED_INTEGER (val, 1, 4); - charset.dimension = XFIXNUM (val); - } + charset.dimension + = !NILP (val) ? check_integer_range (val, 1, 4) : dimension; charset.code_linear_p = (charset.dimension == 1 @@ -981,13 +971,7 @@ usage: (define-charset-internal ...) */) } val = args[charset_arg_iso_revision]; - if (NILP (val)) - charset.iso_revision = -1; - else - { - CHECK_RANGED_INTEGER (val, -1, 63); - charset.iso_revision = XFIXNUM (val); - } + charset.iso_revision = !NILP (val) ? check_integer_range (val, -1, 63) : -1; val = args[charset_arg_emacs_mule_id]; if (NILP (val)) @@ -1053,12 +1037,9 @@ usage: (define-charset-internal ...) */) CHECK_FIXNAT (parent_max_code); parent_code_offset = Fnth (make_fixnum (3), val); CHECK_FIXNUM (parent_code_offset); - val = make_uninit_vector (4); - ASET (val, 0, make_fixnum (parent_charset->id)); - ASET (val, 1, parent_min_code); - ASET (val, 2, parent_max_code); - ASET (val, 3, parent_code_offset); - ASET (attrs, charset_subset, val); + ASET (attrs, charset_subset, + CALLN (Fvector, make_fixnum (parent_charset->id), + parent_min_code, parent_max_code, parent_code_offset)); charset.method = CHARSET_METHOD_SUBSET; /* Here, we just copy the parent's fast_map. It's not accurate, @@ -1092,8 +1073,7 @@ usage: (define-charset-internal ...) */) car_part = XCAR (elt); cdr_part = XCDR (elt); CHECK_CHARSET_GET_ID (car_part, this_id); - CHECK_TYPE_RANGED_INTEGER (int, cdr_part); - offset = XFIXNUM (cdr_part); + offset = check_integer_range (cdr_part, INT_MIN, INT_MAX); } else { @@ -1479,7 +1459,7 @@ string_xstring_p (Lisp_Object string) while (p < endp) { - int c = STRING_CHAR_ADVANCE (p); + int c = string_char_advance (&p); if (c >= 0x100) return 2; @@ -1523,7 +1503,7 @@ find_charsets_in_text (const unsigned char *ptr, ptrdiff_t nchars, { while (ptr < pend) { - int c = STRING_CHAR_ADVANCE (ptr); + int c = string_char_advance (&ptr); struct charset *charset; if (!NILP (table)) diff --git a/src/chartab.c b/src/chartab.c index a39ffa756e4..331e8595ebe 100644 --- a/src/chartab.c +++ b/src/chartab.c @@ -1117,10 +1117,10 @@ uniprop_table_uncompress (Lisp_Object table, int idx) { /* SIMPLE TABLE */ p++; - idx = STRING_CHAR_ADVANCE (p); + idx = string_char_advance (&p); while (p < pend && idx < chartab_chars[2]) { - int v = STRING_CHAR_ADVANCE (p); + int v = string_char_advance (&p); set_sub_char_table_contents (sub, idx++, v > 0 ? make_fixnum (v) : Qnil); } @@ -1131,13 +1131,13 @@ uniprop_table_uncompress (Lisp_Object table, int idx) p++; for (idx = 0; p < pend; ) { - int v = STRING_CHAR_ADVANCE (p); + int v = string_char_advance (&p); int count = 1; - int len; if (p < pend) { - count = STRING_CHAR_AND_LENGTH (p, len); + int len; + count = string_char_and_length (p, &len); if (count < 128) count = 1; else diff --git a/src/cmds.c b/src/cmds.c index c771eeb9683..c8a96d918cd 100644 --- a/src/cmds.c +++ b/src/cmds.c @@ -31,15 +31,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ static int internal_self_insert (int, EMACS_INT); -DEFUN ("forward-point", Fforward_point, Sforward_point, 1, 1, 0, - doc: /* Return buffer position N characters after (before if N negative) point. */) - (Lisp_Object n) -{ - CHECK_FIXNUM (n); - - return make_fixnum (PT + XFIXNUM (n)); -} - /* Add N to point; or subtract N if FORWARD is false. N defaults to 1. Validate the new location. Return nil. */ static Lisp_Object @@ -399,8 +390,8 @@ internal_self_insert (int c, EMACS_INT n) /* We will delete too many columns. Let's fill columns by spaces so that the remaining text won't move. */ ptrdiff_t actual = PT_BYTE; - DEC_POS (actual); - if (FETCH_CHAR (actual) == '\t') + actual -= prev_char_len (actual); + if (FETCH_BYTE (actual) == '\t') /* Rather than add spaces, let's just keep the tab. */ chars_to_delete--; else @@ -461,7 +452,10 @@ internal_self_insert (int c, EMACS_INT n) string = concat2 (string, tem); } - replace_range (PT, PT + chars_to_delete, string, 1, 1, 1, 0); + ptrdiff_t to; + if (INT_ADD_WRAPV (PT, chars_to_delete, &to)) + to = PTRDIFF_MAX; + replace_range (PT, to, string, 1, 1, 1, 0); Fforward_char (make_fixnum (n)); } else if (n > 1) @@ -527,7 +521,6 @@ syms_of_cmds (void) This is run after inserting the character. */); Vpost_self_insert_hook = Qnil; - defsubr (&Sforward_point); defsubr (&Sforward_char); defsubr (&Sbackward_char); defsubr (&Sforward_line); @@ -537,24 +530,3 @@ This is run after inserting the character. */); defsubr (&Sdelete_char); defsubr (&Sself_insert_command); } - -void -keys_of_cmds (void) -{ - int n; - - initial_define_key (global_map, Ctl ('I'), "self-insert-command"); - for (n = 040; n < 0177; n++) - initial_define_key (global_map, n, "self-insert-command"); -#ifdef MSDOS - for (n = 0200; n < 0240; n++) - initial_define_key (global_map, n, "self-insert-command"); -#endif - for (n = 0240; n < 0400; n++) - initial_define_key (global_map, n, "self-insert-command"); - - initial_define_key (global_map, Ctl ('A'), "beginning-of-line"); - initial_define_key (global_map, Ctl ('B'), "backward-char"); - initial_define_key (global_map, Ctl ('E'), "end-of-line"); - initial_define_key (global_map, Ctl ('F'), "forward-char"); -} diff --git a/src/coding.c b/src/coding.c index 6f9676d8cc7..739dd6adcb5 100644 --- a/src/coding.c +++ b/src/coding.c @@ -643,7 +643,7 @@ growable_destination (struct coding_system *coding) else \ { \ src--; \ - c = - string_char (src, &src, NULL); \ + c = - string_char_advance (&src); \ record_conversion_result \ (coding, CODING_RESULT_INVALID_SRC); \ } \ @@ -728,7 +728,7 @@ growable_destination (struct coding_system *coding) unsigned ch = (c); \ if (ch >= 0x80) \ ch = BYTE8_TO_CHAR (ch); \ - CHAR_STRING_ADVANCE (ch, dst); \ + dst += CHAR_STRING (ch, dst); \ } \ else \ *dst++ = (c); \ @@ -747,11 +747,11 @@ growable_destination (struct coding_system *coding) ch = (c1); \ if (ch >= 0x80) \ ch = BYTE8_TO_CHAR (ch); \ - CHAR_STRING_ADVANCE (ch, dst); \ + dst += CHAR_STRING (ch, dst); \ ch = (c2); \ if (ch >= 0x80) \ ch = BYTE8_TO_CHAR (ch); \ - CHAR_STRING_ADVANCE (ch, dst); \ + dst += CHAR_STRING (ch, dst); \ } \ else \ { \ @@ -884,18 +884,18 @@ record_conversion_result (struct coding_system *coding, /* Store multibyte form of the character C in P, and advance P to the - end of the multibyte form. This used to be like CHAR_STRING_ADVANCE + end of the multibyte form. This used to be like adding CHAR_STRING without ever calling MAYBE_UNIFY_CHAR, but nowadays we don't call - MAYBE_UNIFY_CHAR in CHAR_STRING_ADVANCE. */ + MAYBE_UNIFY_CHAR in CHAR_STRING. */ -#define CHAR_STRING_ADVANCE_NO_UNIFY(c, p) CHAR_STRING_ADVANCE(c, p) +#define CHAR_STRING_ADVANCE_NO_UNIFY(c, p) ((p) += CHAR_STRING (c, p)) /* Return the character code of character whose multibyte form is at P, and advance P to the end of the multibyte form. This used to be - like STRING_CHAR_ADVANCE without ever calling MAYBE_UNIFY_CHAR, but - nowadays STRING_CHAR_ADVANCE doesn't call MAYBE_UNIFY_CHAR. */ + like string_char_advance without ever calling MAYBE_UNIFY_CHAR, but + nowadays string_char_advance doesn't call MAYBE_UNIFY_CHAR. */ -#define STRING_CHAR_ADVANCE_NO_UNIFY(p) STRING_CHAR_ADVANCE(p) +#define STRING_CHAR_ADVANCE_NO_UNIFY(p) string_char_advance (&(p)) /* Set coding->source from coding->src_object. */ @@ -5131,7 +5131,7 @@ decode_coding_ccl (struct coding_system *coding) while (i < 1024 && p < src_end) { source_byteidx[i] = p - src; - source_charbuf[i++] = STRING_CHAR_ADVANCE (p); + source_charbuf[i++] = string_char_advance (&p); } source_byteidx[i] = p - src; } @@ -5308,15 +5308,10 @@ encode_coding_raw_text (struct coding_system *coding) } else { - unsigned char str[MAX_MULTIBYTE_LENGTH], *p0 = str, *p1 = str; - - CHAR_STRING_ADVANCE (c, p1); - do - { - EMIT_ONE_BYTE (*p0); - p0++; - } - while (p0 < p1); + unsigned char str[MAX_MULTIBYTE_LENGTH]; + int len = CHAR_STRING (c, str); + for (int i = 0; i < len; i++) + EMIT_ONE_BYTE (str[i]); } } else @@ -5342,7 +5337,7 @@ encode_coding_raw_text (struct coding_system *coding) else if (CHAR_BYTE8_P (c)) *dst++ = CHAR_TO_BYTE8 (c); else - CHAR_STRING_ADVANCE (c, dst); + dst += CHAR_STRING (c, dst); } } else @@ -5712,7 +5707,7 @@ setup_coding_system (Lisp_Object coding_system, struct coding_system *coding) coding->common_flags |= CODING_REQUIRE_DETECTION_MASK; coding->spec.undecided.inhibit_nbd = (encode_inhibit_flag - (AREF (attrs, coding_attr_undecided_inhibit_nul_byte_detection))); + (AREF (attrs, coding_attr_undecided_inhibit_null_byte_detection))); coding->spec.undecided.inhibit_ied = (encode_inhibit_flag (AREF (attrs, coding_attr_undecided_inhibit_iso_escape_detection))); @@ -6540,9 +6535,9 @@ detect_coding (struct coding_system *coding) { int c, i; struct coding_detection_info detect_info; - bool nul_byte_found = 0, eight_bit_found = 0; + bool null_byte_found = 0, eight_bit_found = 0; bool inhibit_nbd = inhibit_flag (coding->spec.undecided.inhibit_nbd, - inhibit_nul_byte_detection); + inhibit_null_byte_detection); bool inhibit_ied = inhibit_flag (coding->spec.undecided.inhibit_ied, inhibit_iso_escape_detection); bool prefer_utf_8 = coding->spec.undecided.prefer_utf_8; @@ -6555,7 +6550,7 @@ detect_coding (struct coding_system *coding) if (c & 0x80) { eight_bit_found = 1; - if (nul_byte_found) + if (null_byte_found) break; } else if (c < 0x20) @@ -6570,7 +6565,7 @@ detect_coding (struct coding_system *coding) if (! (detect_info.rejected & CATEGORY_MASK_ISO_7_ELSE)) { /* We didn't find an 8-bit code. We may - have found a NUL-byte, but it's very + have found a null-byte, but it's very rare that a binary file conforms to ISO-2022. */ src = src_end; @@ -6582,7 +6577,7 @@ detect_coding (struct coding_system *coding) } else if (! c && !inhibit_nbd) { - nul_byte_found = 1; + null_byte_found = 1; if (eight_bit_found) break; } @@ -6614,7 +6609,7 @@ detect_coding (struct coding_system *coding) coding->head_ascii++; } - if (nul_byte_found || eight_bit_found + if (null_byte_found || eight_bit_found || coding->head_ascii < coding->src_bytes || detect_info.found) { @@ -6632,7 +6627,7 @@ detect_coding (struct coding_system *coding) } else { - if (nul_byte_found) + if (null_byte_found) { detect_info.checked |= ~CATEGORY_MASK_UTF_16; detect_info.rejected |= ~CATEGORY_MASK_UTF_16; @@ -6705,7 +6700,7 @@ detect_coding (struct coding_system *coding) else found = CODING_ID_NAME (this->id); } - else if (nul_byte_found) + else if (null_byte_found) found = Qno_conversion; else if ((detect_info.rejected & CATEGORY_MASK_ANY) == CATEGORY_MASK_ANY) @@ -7457,7 +7452,7 @@ decode_coding (struct coding_system *coding) if (coding->src_multibyte && CHAR_BYTE8_HEAD_P (*src) && nbytes > 0) { - c = STRING_CHAR_ADVANCE (src); + c = string_char_advance (&src); nbytes--; } else @@ -7551,10 +7546,8 @@ handle_composition_annotation (ptrdiff_t pos, ptrdiff_t limit, len = SCHARS (components); i = i_byte = 0; while (i < len) - { - FETCH_STRING_CHAR_ADVANCE (*buf, components, i, i_byte); - buf++; - } + *buf++ = fetch_string_char_advance (components, + &i, &i_byte); } else if (FIXNUMP (components)) { @@ -7677,15 +7670,17 @@ consume_chars (struct coding_system *coding, Lisp_Object translation_table, if (! multibytep) { - int bytes; - if (coding->encoder == encode_coding_raw_text || coding->encoder == encode_coding_ccl) c = *src++, pos++; - else if ((bytes = MULTIBYTE_LENGTH (src, src_end)) > 0) - c = STRING_CHAR_ADVANCE_NO_UNIFY (src), pos += bytes; else - c = BYTE8_TO_CHAR (*src), src++, pos++; + { + int bytes = multibyte_length (src, src_end, true, true); + if (0 < bytes) + c = STRING_CHAR_ADVANCE_NO_UNIFY (src), pos += bytes; + else + c = BYTE8_TO_CHAR (*src), src++, pos++; + } } else c = STRING_CHAR_ADVANCE_NO_UNIFY (src), pos++; @@ -7715,7 +7710,7 @@ consume_chars (struct coding_system *coding, Lisp_Object translation_table, lookup_buf[0] = c; for (i = 1; i < max_lookup && p < src_end; i++) - lookup_buf[i] = STRING_CHAR_ADVANCE (p); + lookup_buf[i] = string_char_advance (&p); lookup_buf_end = lookup_buf + i; trans = get_translation (trans, lookup_buf, lookup_buf_end, &from_nchars); @@ -7734,7 +7729,7 @@ consume_chars (struct coding_system *coding, Lisp_Object translation_table, for (i = 1; i < to_nchars; i++) *buf++ = XFIXNUM (AREF (trans, i)); for (i = 1; i < from_nchars; i++, pos++) - src += MULTIBYTE_LENGTH_NO_CHECK (src); + src += multibyte_length (src, NULL, false, true); } } @@ -7826,7 +7821,7 @@ encode_coding (struct coding_system *coding) /* A string that serves as name of the reusable work buffer, and as base name of temporary work buffers used for code-conversion operations. */ -Lisp_Object Vcode_conversion_workbuf_name; +static Lisp_Object Vcode_conversion_workbuf_name; /* The reusable working buffer, created once and never killed. */ static Lisp_Object Vcode_conversion_reused_workbuf; @@ -7844,7 +7839,7 @@ code_conversion_restore (Lisp_Object arg) if (! NILP (workbuf)) { if (EQ (workbuf, Vcode_conversion_reused_workbuf)) - reused_workbuf_in_use = 0; + reused_workbuf_in_use = false; else Fkill_buffer (workbuf); } @@ -7862,13 +7857,13 @@ code_conversion_save (bool with_work_buf, bool multibyte) { Lisp_Object name = Fgenerate_new_buffer_name (Vcode_conversion_workbuf_name, Qnil); - workbuf = Fget_buffer_create (name); + workbuf = Fget_buffer_create (name, Qt); } else { if (NILP (Fbuffer_live_p (Vcode_conversion_reused_workbuf))) Vcode_conversion_reused_workbuf - = Fget_buffer_create (Vcode_conversion_workbuf_name); + = Fget_buffer_create (Vcode_conversion_workbuf_name, Qt); workbuf = Vcode_conversion_reused_workbuf; } } @@ -7886,7 +7881,7 @@ code_conversion_save (bool with_work_buf, bool multibyte) bset_undo_list (current_buffer, Qt); bset_enable_multibyte_characters (current_buffer, multibyte ? Qt : Qnil); if (EQ (workbuf, Vcode_conversion_reused_workbuf)) - reused_workbuf_in_use = 1; + reused_workbuf_in_use = true; set_buffer_internal (current); } @@ -8481,7 +8476,7 @@ from_unicode (Lisp_Object str) Lisp_Object from_unicode_buffer (const wchar_t *wstr) { - /* We get one of the two final NUL bytes for free. */ + /* We get one of the two final null bytes for free. */ ptrdiff_t len = 1 + sizeof (wchar_t) * wcslen (wstr); AUTO_STRING_WITH_LEN (str, (char *) wstr, len); return from_unicode (str); @@ -8494,7 +8489,7 @@ to_unicode (Lisp_Object str, Lisp_Object *buf) /* We need to make another copy (in addition to the one made by code_convert_string_norecord) to ensure that the final string is _doubly_ zero terminated --- that is, that the string is - terminated by two zero bytes and one utf-16le NUL character. + terminated by two zero bytes and one utf-16le null character. Because strings are already terminated with a single zero byte, we just add one additional zero. */ str = make_uninit_string (SBYTES (*buf) + 1); @@ -8610,7 +8605,7 @@ detect_coding_system (const unsigned char *src, ptrdiff_t id; struct coding_detection_info detect_info; enum coding_category base_category; - bool nul_byte_found = 0, eight_bit_found = 0; + bool null_byte_found = 0, eight_bit_found = 0; if (NILP (coding_system)) coding_system = Qundecided; @@ -8637,7 +8632,7 @@ detect_coding_system (const unsigned char *src, struct coding_system *this UNINIT; int c, i; bool inhibit_nbd = inhibit_flag (coding.spec.undecided.inhibit_nbd, - inhibit_nul_byte_detection); + inhibit_null_byte_detection); bool inhibit_ied = inhibit_flag (coding.spec.undecided.inhibit_ied, inhibit_iso_escape_detection); bool prefer_utf_8 = coding.spec.undecided.prefer_utf_8; @@ -8649,7 +8644,7 @@ detect_coding_system (const unsigned char *src, if (c & 0x80) { eight_bit_found = 1; - if (nul_byte_found) + if (null_byte_found) break; } else if (c < 0x20) @@ -8664,7 +8659,7 @@ detect_coding_system (const unsigned char *src, if (! (detect_info.rejected & CATEGORY_MASK_ISO_7_ELSE)) { /* We didn't find an 8-bit code. We may - have found a NUL-byte, but it's very + have found a null-byte, but it's very rare that a binary file confirm to ISO-2022. */ src = src_end; @@ -8676,7 +8671,7 @@ detect_coding_system (const unsigned char *src, } else if (! c && !inhibit_nbd) { - nul_byte_found = 1; + null_byte_found = 1; if (eight_bit_found) break; } @@ -8687,7 +8682,7 @@ detect_coding_system (const unsigned char *src, coding.head_ascii++; } - if (nul_byte_found || eight_bit_found + if (null_byte_found || eight_bit_found || coding.head_ascii < coding.src_bytes || detect_info.found) { @@ -8702,7 +8697,7 @@ detect_coding_system (const unsigned char *src, } else { - if (nul_byte_found) + if (null_byte_found) { detect_info.checked |= ~CATEGORY_MASK_UTF_16; detect_info.rejected |= ~CATEGORY_MASK_UTF_16; @@ -8749,7 +8744,7 @@ detect_coding_system (const unsigned char *src, } if ((detect_info.rejected & CATEGORY_MASK_ANY) == CATEGORY_MASK_ANY - || nul_byte_found) + || null_byte_found) { detect_info.found = CATEGORY_MASK_RAW_TEXT; id = CODING_SYSTEM_ID (Qno_conversion); @@ -8851,7 +8846,7 @@ detect_coding_system (const unsigned char *src, { if (detect_info.found & ~CATEGORY_MASK_UTF_16) { - if (nul_byte_found) + if (null_byte_found) normal_eol = EOL_SEEN_LF; else normal_eol = detect_eol (coding.source, src_bytes, @@ -9023,23 +9018,23 @@ DEFUN ("find-coding-systems-region-internal", } else { - CHECK_FIXNUM_COERCE_MARKER (start); - CHECK_FIXNUM_COERCE_MARKER (end); - if (XFIXNUM (start) < BEG || XFIXNUM (end) > Z || XFIXNUM (start) > XFIXNUM (end)) + EMACS_INT s = fix_position (start); + EMACS_INT e = fix_position (end); + if (! (BEG <= s && s <= e && e <= Z)) args_out_of_range (start, end); if (NILP (BVAR (current_buffer, enable_multibyte_characters))) return Qt; - start_byte = CHAR_TO_BYTE (XFIXNUM (start)); - end_byte = CHAR_TO_BYTE (XFIXNUM (end)); - if (XFIXNUM (end) - XFIXNUM (start) == end_byte - start_byte) + start_byte = CHAR_TO_BYTE (s); + end_byte = CHAR_TO_BYTE (e); + if (e - s == end_byte - start_byte) return Qt; - if (XFIXNUM (start) < GPT && XFIXNUM (end) > GPT) + if (s < GPT && GPT < e) { - if ((GPT - XFIXNUM (start)) < (XFIXNUM (end) - GPT)) - move_gap_both (XFIXNUM (start), start_byte); + if (GPT - s < e - GPT) + move_gap_both (s, start_byte); else - move_gap_both (XFIXNUM (end), end_byte); + move_gap_both (e, end_byte); } } @@ -9075,7 +9070,7 @@ DEFUN ("find-coding-systems-region-internal", p++; else { - c = STRING_CHAR_ADVANCE (p); + c = string_char_advance (&p); if (!NILP (char_table_ref (work_table, c))) /* This character was already checked. Ignore it. */ continue; @@ -9208,7 +9203,7 @@ to the string and treated as in `substring'. */) p = GAP_END_ADDR; } - c = STRING_CHAR_ADVANCE (p); + c = string_char_advance (&p); if (! (ASCII_CHAR_P (c) && ascii_compatible) && ! char_charset (translate_char (translation_table, c), charset_list, NULL)) @@ -9277,32 +9272,35 @@ is nil. */) } else { - CHECK_FIXNUM_COERCE_MARKER (start); - CHECK_FIXNUM_COERCE_MARKER (end); - if (XFIXNUM (start) < BEG || XFIXNUM (end) > Z || XFIXNUM (start) > XFIXNUM (end)) + EMACS_INT s = fix_position (start); + EMACS_INT e = fix_position (end); + if (! (BEG <= s && s <= e && e <= Z)) args_out_of_range (start, end); if (NILP (BVAR (current_buffer, enable_multibyte_characters))) return Qnil; - start_byte = CHAR_TO_BYTE (XFIXNUM (start)); - end_byte = CHAR_TO_BYTE (XFIXNUM (end)); - if (XFIXNUM (end) - XFIXNUM (start) == end_byte - start_byte) + start_byte = CHAR_TO_BYTE (s); + end_byte = CHAR_TO_BYTE (e); + if (e - s == end_byte - start_byte) return Qnil; - if (XFIXNUM (start) < GPT && XFIXNUM (end) > GPT) + if (s < GPT && GPT < e) { - if ((GPT - XFIXNUM (start)) < (XFIXNUM (end) - GPT)) - move_gap_both (XFIXNUM (start), start_byte); + if (GPT - s < e - GPT) + move_gap_both (s, start_byte); else - move_gap_both (XFIXNUM (end), end_byte); + move_gap_both (e, end_byte); } - pos = XFIXNUM (start); + pos = s; } list = Qnil; for (tail = coding_system_list; CONSP (tail); tail = XCDR (tail)) { elt = XCAR (tail); - attrs = AREF (CODING_SYSTEM_SPEC (elt), 0); + Lisp_Object spec = CODING_SYSTEM_SPEC (elt); + if (!VECTORP (spec)) + xsignal1 (Qcoding_system_error, elt); + attrs = AREF (spec, 0); ASET (attrs, coding_attr_trans_tbl, get_translation_table (attrs, 1, NULL)); list = Fcons (list2 (elt, attrs), list); @@ -9323,7 +9321,7 @@ is nil. */) p++; else { - c = STRING_CHAR_ADVANCE (p); + c = string_char_advance (&p); charset_map_loaded = 0; for (tail = list; CONSP (tail); tail = XCDR (tail)) @@ -9471,6 +9469,17 @@ not fully specified.) */) return code_convert_region (start, end, coding_system, destination, 1, 0); } +/* Whether STRING only contains chars in the 0..127 range. */ +static bool +string_ascii_p (Lisp_Object string) +{ + ptrdiff_t nbytes = SBYTES (string); + for (ptrdiff_t i = 0; i < nbytes; i++) + if (SREF (string, i) > 127) + return false; + return true; +} + Lisp_Object code_convert_string (Lisp_Object string, Lisp_Object coding_system, Lisp_Object dst_object, bool encodep, bool nocopy, @@ -9485,7 +9494,7 @@ code_convert_string (Lisp_Object string, Lisp_Object coding_system, if (! norecord) Vlast_coding_system_used = Qno_conversion; if (NILP (dst_object)) - return (nocopy ? Fcopy_sequence (string) : string); + return nocopy ? string : Fcopy_sequence (string); } if (NILP (coding_system)) @@ -9502,7 +9511,28 @@ code_convert_string (Lisp_Object string, Lisp_Object coding_system, chars = SCHARS (string); bytes = SBYTES (string); - if (BUFFERP (dst_object)) + if (EQ (dst_object, Qt)) + { + /* Fast path for ASCII-only input and an ASCII-compatible coding: + act as identity if no EOL conversion is needed. */ + Lisp_Object attrs = CODING_ID_ATTRS (coding.id); + if (! NILP (CODING_ATTR_ASCII_COMPAT (attrs)) + && (STRING_MULTIBYTE (string) + ? (chars == bytes) : string_ascii_p (string)) + && (EQ (CODING_ID_EOL_TYPE (coding.id), Qunix) + || inhibit_eol_conversion + || ! memchr (SDATA (string), encodep ? '\n' : '\r', bytes))) + { + if (! norecord) + Vlast_coding_system_used = coding_system; + return (nocopy + ? string + : (encodep + ? make_unibyte_string (SSDATA (string), bytes) + : make_multibyte_string (SSDATA (string), bytes, bytes))); + } + } + else if (BUFFERP (dst_object)) { struct buffer *buf = XBUFFER (dst_object); ptrdiff_t buf_pt = BUF_PT (buf); @@ -9524,10 +9554,7 @@ code_convert_string (Lisp_Object string, Lisp_Object coding_system, /* Encode or decode STRING according to CODING_SYSTEM. - Do not set Vlast_coding_system_used. - - This function is called only from macros DECODE_FILE and - ENCODE_FILE, thus we ignore character composition. */ + Do not set Vlast_coding_system_used. */ Lisp_Object code_convert_string_norecord (Lisp_Object string, Lisp_Object coding_system, @@ -9696,7 +9723,7 @@ encode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, || (len == 2 ? ! CHAR_BYTE8_HEAD_P (c) : (EQ (handle_over_uni, Qt) || (len == 4 - && string_char (p, NULL, NULL) <= MAX_UNICODE_CHAR)))) + && STRING_CHAR (p) <= MAX_UNICODE_CHAR)))) { p += len; continue; @@ -9978,8 +10005,7 @@ decode_string_utf_8 (Lisp_Object string, const char *str, ptrdiff_t str_len, && (len == 3 || (UTF_8_EXTRA_OCTET_P (p[3]) && len == 4 - && (string_char (p, NULL, NULL) - <= MAX_UNICODE_CHAR)))))) + && STRING_CHAR (p) <= MAX_UNICODE_CHAR))))) { p += len; continue; @@ -10116,8 +10142,7 @@ decode_string_utf_8 (Lisp_Object string, const char *str, ptrdiff_t str_len, mlen++); if (mlen == len && (len <= 3 - || (len == 4 - && string_char (p, NULL, NULL) <= MAX_UNICODE_CHAR) + || (len == 4 && STRING_CHAR (p) <= MAX_UNICODE_CHAR) || EQ (handle_over_uni, Qt))) { p += len; @@ -10297,6 +10322,16 @@ DEFUN ("internal-decode-string-utf-8", Finternal_decode_string_utf_8, #endif /* ENABLE_UTF_8_CONVERTER_TEST */ +/* Encode or decode STRING using CODING_SYSTEM, with the possibility of + returning STRING itself if it equals the result. + Do not set Vlast_coding_system_used. */ +static Lisp_Object +convert_string_nocopy (Lisp_Object string, Lisp_Object coding_system, + bool encodep) +{ + return code_convert_string (string, coding_system, Qt, encodep, 1, 1); +} + /* Encode or decode a file name, to or from a unibyte string suitable for passing to C library functions. */ Lisp_Object @@ -10307,21 +10342,20 @@ decode_file_name (Lisp_Object fname) converts the file names either to UTF-16LE or to the system ANSI codepage internally, depending on the underlying OS; see w32.c. */ if (! NILP (Fcoding_system_p (Qutf_8))) - return code_convert_string_norecord (fname, Qutf_8, 0); + return convert_string_nocopy (fname, Qutf_8, 0); return fname; #else /* !WINDOWSNT */ if (! NILP (Vfile_name_coding_system)) - return code_convert_string_norecord (fname, Vfile_name_coding_system, 0); + return convert_string_nocopy (fname, Vfile_name_coding_system, 0); else if (! NILP (Vdefault_file_name_coding_system)) - return code_convert_string_norecord (fname, - Vdefault_file_name_coding_system, 0); + return convert_string_nocopy (fname, Vdefault_file_name_coding_system, 0); else return fname; #endif } -Lisp_Object -encode_file_name (Lisp_Object fname) +static Lisp_Object +encode_file_name_1 (Lisp_Object fname) { /* This is especially important during bootstrap and dumping, when file-name encoding is not yet known, and therefore any non-ASCII @@ -10334,19 +10368,31 @@ encode_file_name (Lisp_Object fname) converts the file names either to UTF-16LE or to the system ANSI codepage internally, depending on the underlying OS; see w32.c. */ if (! NILP (Fcoding_system_p (Qutf_8))) - return code_convert_string_norecord (fname, Qutf_8, 1); + return convert_string_nocopy (fname, Qutf_8, 1); return fname; #else /* !WINDOWSNT */ if (! NILP (Vfile_name_coding_system)) - return code_convert_string_norecord (fname, Vfile_name_coding_system, 1); + return convert_string_nocopy (fname, Vfile_name_coding_system, 1); else if (! NILP (Vdefault_file_name_coding_system)) - return code_convert_string_norecord (fname, - Vdefault_file_name_coding_system, 1); + return convert_string_nocopy (fname, Vdefault_file_name_coding_system, 1); else return fname; #endif } +Lisp_Object +encode_file_name (Lisp_Object fname) +{ + Lisp_Object encoded = encode_file_name_1 (fname); + /* No system accepts NUL bytes in filenames. Allowing them can + cause subtle bugs because the system would silently use a + different filename than expected. Perform this check after + encoding to not miss NUL bytes introduced through encoding. */ + CHECK_TYPE (memchr (SSDATA (encoded), '\0', SBYTES (encoded)) == NULL, + Qfilenamep, fname); + return encoded; +} + DEFUN ("decode-coding-string", Fdecode_coding_string, Sdecode_coding_string, 2, 4, 0, doc: /* Decode STRING which is encoded in CODING-SYSTEM, and return the result. @@ -10362,7 +10408,7 @@ representation of the decoded text. This function sets `last-coding-system-used' to the precise coding system used (which may be different from CODING-SYSTEM if CODING-SYSTEM is -not fully specified.) */) +not fully specified.) The function does not change the match data. */) (Lisp_Object string, Lisp_Object coding_system, Lisp_Object nocopy, Lisp_Object buffer) { return code_convert_string (string, coding_system, buffer, @@ -10382,7 +10428,7 @@ case, the return value is the length of the encoded text. This function sets `last-coding-system-used' to the precise coding system used (which may be different from CODING-SYSTEM if CODING-SYSTEM is -not fully specified.) */) +not fully specified.) The function does not change the match data. */) (Lisp_Object string, Lisp_Object coding_system, Lisp_Object nocopy, Lisp_Object buffer) { return code_convert_string (string, coding_system, buffer, @@ -10823,20 +10869,17 @@ HIGHESTP non-nil means just return the highest priority one. */) return Fnreverse (val); } -static const char *const suffixes[] = { "-unix", "-dos", "-mac" }; - static Lisp_Object make_subsidiaries (Lisp_Object base) { - Lisp_Object subsidiaries; + static char const suffixes[][8] = { "-unix", "-dos", "-mac" }; ptrdiff_t base_name_len = SBYTES (SYMBOL_NAME (base)); USE_SAFE_ALLOCA; char *buf = SAFE_ALLOCA (base_name_len + 6); - int i; memcpy (buf, SDATA (SYMBOL_NAME (base)), base_name_len); - subsidiaries = make_uninit_vector (3); - for (i = 0; i < 3; i++) + Lisp_Object subsidiaries = make_nil_vector (3); + for (int i = 0; i < 3; i++) { strcpy (buf + base_name_len, suffixes[i]); ASET (subsidiaries, i, intern (buf)); @@ -10865,7 +10908,10 @@ usage: (define-coding-system-internal ...) */) ASET (attrs, coding_attr_base_name, name); Lisp_Object val = args[coding_arg_mnemonic]; - if (! STRINGP (val)) + /* decode_mode_spec_coding assumes the mnemonic is a single character. */ + if (STRINGP (val)) + val = make_fixnum (STRING_CHAR (SDATA (val))); + else CHECK_CHARACTER (val); ASET (attrs, coding_attr_mnemonic, val); @@ -11061,10 +11107,8 @@ usage: (define-coding-system-internal ...) */) else { CHECK_CONS (val); - CHECK_RANGED_INTEGER (XCAR (val), 0, 255); - from = XFIXNUM (XCAR (val)); - CHECK_RANGED_INTEGER (XCDR (val), from, 255); - to = XFIXNUM (XCDR (val)); + from = check_integer_range (XCAR (val), 0, 255); + to = check_integer_range (XCDR (val), from, 255); } for (int i = from; i <= to; i++) SSET (valids, i, 1); @@ -11149,7 +11193,7 @@ usage: (define-coding-system-internal ...) */) val = XCAR (tail); CHECK_CONS (val); CHECK_CHARSET_GET_ID (XCAR (val), id); - CHECK_RANGED_INTEGER (XCDR (val), 0, 3); + check_integer_range (XCDR (val), 0, 3); XSETCAR (val, make_fixnum (id)); } @@ -11289,8 +11333,8 @@ usage: (define-coding-system-internal ...) */) { if (nargs < coding_arg_undecided_max) goto short_args; - ASET (attrs, coding_attr_undecided_inhibit_nul_byte_detection, - args[coding_arg_undecided_inhibit_nul_byte_detection]); + ASET (attrs, coding_attr_undecided_inhibit_null_byte_detection, + args[coding_arg_undecided_inhibit_null_byte_detection]); ASET (attrs, coding_attr_undecided_inhibit_iso_escape_detection, args[coding_arg_undecided_inhibit_iso_escape_detection]); ASET (attrs, coding_attr_undecided_prefer_utf_8, @@ -11380,7 +11424,10 @@ DEFUN ("coding-system-put", Fcoding_system_put, Scoding_system_put, attrs = AREF (spec, 0); if (EQ (prop, QCmnemonic)) { - if (! STRINGP (val)) + /* decode_mode_spec_coding assumes the mnemonic is a single character. */ + if (STRINGP (val)) + val = make_fixnum (STRING_CHAR (SDATA (val))); + else CHECK_CHARACTER (val); ASET (attrs, coding_attr_mnemonic, val); } @@ -11605,7 +11652,7 @@ syms_of_coding (void) staticpro (&Vcode_conversion_workbuf_name); Vcode_conversion_workbuf_name = build_pure_c_string (" *code-conversion-work*"); - reused_workbuf_in_use = 0; + reused_workbuf_in_use = false; PDUMPER_REMEMBER_SCALAR (reused_workbuf_in_use); DEFSYM (Qcharset, "charset"); @@ -11745,6 +11792,9 @@ syms_of_coding (void) DEFSYM (Qignored, "ignored"); + DEFSYM (Qutf_8_string_p, "utf-8-string-p"); + DEFSYM (Qfilenamep, "filenamep"); + defsubr (&Scoding_system_p); defsubr (&Sread_coding_system); defsubr (&Sread_non_nil_coding_system); @@ -11796,8 +11846,7 @@ Each element is one element list of coding system name. This variable is given to `completing-read' as COLLECTION argument. Do not alter the value of this variable manually. This variable should be -updated by the functions `make-coding-system' and -`define-coding-system-alias'. */); +updated by `define-coding-system-alias'. */); Vcoding_system_alist = Qnil; DEFVAR_LISP ("coding-category-list", Vcoding_category_list, @@ -12051,18 +12100,18 @@ to explicitly specify some coding system that doesn't use ISO-2022 escape sequence (e.g., `latin-1') on reading by \\[universal-coding-system-argument]. */); inhibit_iso_escape_detection = 0; - DEFVAR_BOOL ("inhibit-nul-byte-detection", - inhibit_nul_byte_detection, - doc: /* If non-nil, Emacs ignores NUL bytes on code detection. + DEFVAR_BOOL ("inhibit-null-byte-detection", + inhibit_null_byte_detection, + doc: /* If non-nil, Emacs ignores null bytes on code detection. By default, Emacs treats it as binary data, and does not attempt to decode it. The effect is as if you specified `no-conversion' for reading that text. -Set this to non-nil when a regular text happens to include NUL bytes. -Examples are Index nodes of Info files and NUL-byte delimited output -from GNU Find and GNU Grep. Emacs will then ignore the NUL bytes and +Set this to non-nil when a regular text happens to include null bytes. +Examples are Index nodes of Info files and null-byte delimited output +from GNU Find and GNU Grep. Emacs will then ignore the null bytes and decode text as usual. */); - inhibit_nul_byte_detection = 0; + inhibit_null_byte_detection = 0; DEFVAR_BOOL ("disable-ascii-optimization", disable_ascii_optimization, doc: /* If non-nil, Emacs does not optimize code decoder for ASCII files. @@ -12121,7 +12170,7 @@ internal character representation. */); "automatic conversion on decoding."); plist[15] = args[coding_arg_eol_type] = Qnil; args[coding_arg_plist] = CALLMANY (Flist, plist); - args[coding_arg_undecided_inhibit_nul_byte_detection] = make_fixnum (0); + args[coding_arg_undecided_inhibit_null_byte_detection] = make_fixnum (0); args[coding_arg_undecided_inhibit_iso_escape_detection] = make_fixnum (0); Fdefine_coding_system_internal (coding_arg_undecided_max, args); diff --git a/src/coding.h b/src/coding.h index 278eb8f6517..d06bed3f5d9 100644 --- a/src/coding.h +++ b/src/coding.h @@ -82,7 +82,7 @@ enum define_coding_ccl_arg_index enum define_coding_undecided_arg_index { - coding_arg_undecided_inhibit_nul_byte_detection = coding_arg_max, + coding_arg_undecided_inhibit_null_byte_detection = coding_arg_max, coding_arg_undecided_inhibit_iso_escape_detection, coding_arg_undecided_prefer_utf_8, coding_arg_undecided_max @@ -97,9 +97,6 @@ enum define_coding_undecided_arg_index extern Lisp_Object Vcoding_system_hash_table; -/* Name (or base name) of work buffer for code conversion. */ -extern Lisp_Object Vcode_conversion_workbuf_name; - /* Enumeration of index to an attribute vector of a coding system. */ enum coding_attr_index @@ -139,7 +136,7 @@ enum coding_attr_index coding_attr_emacs_mule_full, - coding_attr_undecided_inhibit_nul_byte_detection, + coding_attr_undecided_inhibit_null_byte_detection, coding_attr_undecided_inhibit_iso_escape_detection, coding_attr_undecided_prefer_utf_8, @@ -353,7 +350,7 @@ struct emacs_mule_spec struct undecided_spec { - /* Inhibit NUL byte detection. 1 means always inhibit, + /* Inhibit null byte detection. 1 means always inhibit, -1 means do not inhibit, 0 means rely on user variable. */ int inhibit_nbd; @@ -642,11 +639,11 @@ struct coding_system } while (false) /* Encode the file name NAME using the specified coding system - for file names, if any. */ + for file names, if any. May return NAME itself. */ #define ENCODE_FILE(NAME) encode_file_name (NAME) /* Decode the file name NAME using the specified coding system - for file names, if any. */ + for file names, if any. May return NAME itself. */ #define DECODE_FILE(NAME) decode_file_name (NAME) /* Encode the string STR using the specified coding system diff --git a/src/commands.h b/src/commands.h index a09858d050d..2205ebf7d39 100644 --- a/src/commands.h +++ b/src/commands.h @@ -23,14 +23,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #define Ctl(c) ((c)&037) -/* Define the names of keymaps, just so people can refer to them in - calls to initial_define_key. These should *not* be used after - initialization; use-global-map doesn't affect these; it sets - current_global_map instead. */ -extern Lisp_Object global_map; -extern Lisp_Object meta_map; -extern Lisp_Object control_x_map; - /* If not Qnil, this is a switch-frame event which we decided to put off until the end of a key sequence. This should be read as the next command input, after any Vunread_command_events. diff --git a/src/composite.c b/src/composite.c index cfe54b7e988..f1c011223b2 100644 --- a/src/composite.c +++ b/src/composite.c @@ -170,7 +170,6 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, ptrdiff_t hash_index; enum composition_method method; struct composition *cmp; - ptrdiff_t i; int ch; /* Maximum length of a string of glyphs. XftGlyphExtents limits @@ -224,15 +223,15 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, { key = make_uninit_vector (nchars); if (STRINGP (string)) - for (i = 0; i < nchars; i++) + for (ptrdiff_t i = 0; i < nchars; i++) { - FETCH_STRING_CHAR_ADVANCE (ch, string, charpos, bytepos); + ch = fetch_string_char_advance (string, &charpos, &bytepos); ASET (key, i, make_fixnum (ch)); } else - for (i = 0; i < nchars; i++) + for (ptrdiff_t i = 0; i < nchars; i++) { - FETCH_CHAR_ADVANCE (ch, charpos, bytepos); + ch = fetch_char_advance (&charpos, &bytepos); ASET (key, i, make_fixnum (ch)); } } @@ -273,7 +272,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, /* COMPONENTS is a glyph-string. */ ptrdiff_t len = ASIZE (key); - for (i = 1; i < len; i++) + for (ptrdiff_t i = 1; i < len; i++) if (! VECTORP (AREF (key, i))) goto invalid_composition; } @@ -286,7 +285,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, goto invalid_composition; /* All elements should be integers (character or encoded composition rule). */ - for (i = 0; i < len; i++) + for (ptrdiff_t i = 0; i < len; i++) { if (!FIXNUMP (key_contents[i])) goto invalid_composition; @@ -328,7 +327,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, { /* Relative composition. */ cmp->width = 0; - for (i = 0; i < glyph_len; i++) + for (ptrdiff_t i = 0; i < glyph_len; i++) { int this_width; ch = XFIXNUM (key_contents[i]); @@ -347,7 +346,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, ch = XFIXNUM (key_contents[0]); rightmost = ch != '\t' ? CHARACTER_WIDTH (ch) : 1; - for (i = 1; i < glyph_len; i += 2) + for (ptrdiff_t i = 1; i < glyph_len; i += 2) { int rule, gref, nref; int this_width; @@ -638,10 +637,8 @@ compose_text (ptrdiff_t start, ptrdiff_t end, Lisp_Object components, static Lisp_Object gstring_hash_table; -static Lisp_Object gstring_lookup_cache (Lisp_Object); - -static Lisp_Object -gstring_lookup_cache (Lisp_Object header) +Lisp_Object +composition_gstring_lookup_cache (Lisp_Object header) { struct Lisp_Hash_Table *h = XHASH_TABLE (gstring_hash_table); ptrdiff_t i = hash_lookup (h, header, NULL); @@ -653,7 +650,6 @@ Lisp_Object composition_gstring_put_cache (Lisp_Object gstring, ptrdiff_t len) { struct Lisp_Hash_Table *h = XHASH_TABLE (gstring_hash_table); - hash_rehash_if_needed (h); Lisp_Object header = LGSTRING_HEADER (gstring); Lisp_Object hash = h->test.hashfn (header, h); if (len < 0) @@ -681,6 +677,27 @@ composition_gstring_from_id (ptrdiff_t id) return HASH_VALUE (h, id); } +/* Remove from the composition hash table every lgstring that + references the given FONT_OBJECT. */ +void +composition_gstring_cache_clear_font (Lisp_Object font_object) +{ + struct Lisp_Hash_Table *h = XHASH_TABLE (gstring_hash_table); + + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) + { + Lisp_Object k = HASH_KEY (h, i); + + if (!EQ (k, Qunbound)) + { + Lisp_Object gstring = HASH_VALUE (h, i); + + if (EQ (LGSTRING_FONT (gstring), font_object)) + hash_remove_from_table (h, k); + } + } +} + DEFUN ("clear-composition-cache", Fclear_composition_cache, Sclear_composition_cache, 0, 0, 0, doc: /* Internal use only. @@ -800,12 +817,10 @@ fill_gstring_header (ptrdiff_t from, ptrdiff_t from_byte, ASET (header, 0, font_object); for (ptrdiff_t i = 0; i < len; i++) { - int c; - - if (NILP (string)) - FETCH_CHAR_ADVANCE_NO_CHECK (c, from, from_byte); - else - FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string, from, from_byte); + int c + = (NILP (string) + ? fetch_char_advance_no_check (&from, &from_byte) + : fetch_string_char_advance_no_check (string, &from, &from_byte)); ASET (header, i + 1, make_fixnum (c)); } return header; @@ -1012,10 +1027,9 @@ composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos, /* Forward search. */ while (charpos < endpos) { - if (STRINGP (string)) - FETCH_STRING_CHAR_ADVANCE (c, string, charpos, bytepos); - else - FETCH_CHAR_ADVANCE (c, charpos, bytepos); + c = (STRINGP (string) + ? fetch_string_char_advance (string, &charpos, &bytepos) + : fetch_char_advance (&charpos, &bytepos)); if (c == '\n') { cmp_it->ch = -2; @@ -1070,7 +1084,7 @@ composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos, p = BYTE_POS_ADDR (bytepos); else p = SDATA (string) + bytepos; - c = STRING_CHAR_AND_LENGTH (p, len); + c = string_char_and_length (p, &len); limit = bytepos + len; while (char_composable_p (c)) { @@ -1132,7 +1146,7 @@ composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos, } else { - DEC_BOTH (charpos, bytepos); + dec_both (&charpos, &bytepos); p = BYTE_POS_ADDR (bytepos); } c = STRING_CHAR (p); @@ -1145,7 +1159,7 @@ composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos, { while (charpos - 1 > endpos && ! char_composable_p (c)) { - DEC_BOTH (charpos, bytepos); + dec_both (&charpos, &bytepos); c = FETCH_MULTIBYTE_CHAR (bytepos); } } @@ -1303,7 +1317,7 @@ composition_reseat_it (struct composition_it *cmp_it, ptrdiff_t charpos, { charpos++; if (NILP (string)) - INC_POS (bytepos); + bytepos += next_char_len (bytepos); else bytepos += BYTES_BY_CHAR_HEAD (*(SDATA (string) + bytepos)); } @@ -1769,13 +1783,24 @@ should be ignored. */) CHECK_STRING (string); validate_subarray (string, from, to, SCHARS (string), &frompos, &topos); if (! STRING_MULTIBYTE (string)) - error ("Attempt to shape unibyte text"); + { + ptrdiff_t i; + + for (i = SBYTES (string) - 1; i >= 0; i--) + if (!ASCII_CHAR_P (SREF (string, i))) + error ("Attempt to shape unibyte text"); + /* STRING is a pure-ASCII string, so we can convert it (or, + rather, its copy) to multibyte and use that thereafter. */ + Lisp_Object string_copy = Fconcat (1, &string); + STRING_SET_MULTIBYTE (string_copy); + string = string_copy; + } frombyte = string_char_to_byte (string, frompos); } header = fill_gstring_header (frompos, frombyte, topos, font_object, string); - gstring = gstring_lookup_cache (header); + gstring = composition_gstring_lookup_cache (header); if (! NILP (gstring)) return gstring; @@ -1841,27 +1866,24 @@ See `find-composition' for more details. */) ptrdiff_t start, end, from, to; int id; - CHECK_FIXNUM_COERCE_MARKER (pos); + EMACS_INT fixed_pos = fix_position (pos); if (!NILP (limit)) - { - CHECK_FIXNUM_COERCE_MARKER (limit); - to = min (XFIXNUM (limit), ZV); - } + to = clip_to_bounds (PTRDIFF_MIN, fix_position (limit), ZV); else to = -1; if (!NILP (string)) { CHECK_STRING (string); - if (XFIXNUM (pos) < 0 || XFIXNUM (pos) > SCHARS (string)) + if (! (0 <= fixed_pos && fixed_pos <= SCHARS (string))) args_out_of_range (string, pos); } else { - if (XFIXNUM (pos) < BEGV || XFIXNUM (pos) > ZV) + if (! (BEGV <= fixed_pos && fixed_pos <= ZV)) args_out_of_range (Fcurrent_buffer (), pos); } - from = XFIXNUM (pos); + from = fixed_pos; if (!find_composition (from, to, &start, &end, &prop, string)) { @@ -1872,12 +1894,12 @@ See `find-composition' for more details. */) return list3 (make_fixnum (start), make_fixnum (end), gstring); return Qnil; } - if ((end <= XFIXNUM (pos) || start > XFIXNUM (pos))) + if (! (start <= fixed_pos && fixed_pos < end)) { ptrdiff_t s, e; if (find_automatic_composition (from, to, &s, &e, &gstring, string) - && (e <= XFIXNUM (pos) ? e > end : s < start)) + && (e <= fixed_pos ? e > end : s < start)) return list3 (make_fixnum (s), make_fixnum (e), gstring); } if (!composition_valid_p (start, end, prop)) @@ -1936,7 +1958,7 @@ syms_of_composite (void) staticpro (&gstring_hash_table); staticpro (&gstring_work_headers); - gstring_work_headers = make_uninit_vector (8); + gstring_work_headers = make_nil_vector (8); for (i = 0; i < 8; i++) ASET (gstring_work_headers, i, make_nil_vector (i + 2)); staticpro (&gstring_work); @@ -1996,7 +2018,9 @@ preceding and/or following characters, this char-table contains a function to call to compose that character. The element at index C in the table, if non-nil, is a list of -composition rules of this form: ([PATTERN PREV-CHARS FUNC] ...) +composition rules of the form ([PATTERN PREV-CHARS FUNC] ...); +the rules must be specified in the descending order of PREV-CHARS +values. PATTERN is a regular expression which C and the surrounding characters must match. diff --git a/src/composite.h b/src/composite.h index 1b346b4cdfe..c5d3c0faabb 100644 --- a/src/composite.h +++ b/src/composite.h @@ -125,10 +125,13 @@ composition_registered_p (Lisp_Object prop) COMPOSITION_DECODE_REFS (rule_code, gref, nref); \ } while (false) -/* Nonzero if the global reference point GREF and new reference point NREF are +/* True if the global reference point GREF and new reference point NREF are valid. */ -#define COMPOSITION_ENCODE_RULE_VALID(gref, nref) \ - (UNSIGNED_CMP (gref, <, 12) && UNSIGNED_CMP (nref, <, 12)) +INLINE bool +COMPOSITION_ENCODE_RULE_VALID (int gref, int nref) +{ + return 0 <= gref && gref < 12 && 0 <= nref && nref < 12; +} /* Return encoded composition rule for the pair of global reference point GREF and new reference point NREF. Arguments must be valid. */ @@ -327,6 +330,9 @@ extern int composition_update_it (struct composition_it *, ptrdiff_t, ptrdiff_t, Lisp_Object); extern ptrdiff_t composition_adjust_point (ptrdiff_t, ptrdiff_t); +extern Lisp_Object composition_gstring_lookup_cache (Lisp_Object); + +extern void composition_gstring_cache_clear_font (Lisp_Object); INLINE_HEADER_END diff --git a/src/conf_post.h b/src/conf_post.h index cef62e4cd06..176ab28b21a 100644 --- a/src/conf_post.h +++ b/src/conf_post.h @@ -30,13 +30,15 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #endif /* To help make dependencies clearer elsewhere, this file typically - does not #include other files. The exceptions are first stdbool.h + does not #include other files. The exceptions are stdbool.h because it is unlikely to interfere with configuration and bool is - such a core part of the C language, and second ms-w32.h (DOS_NT + such a core part of the C language, attribute.h because its + ATTRIBUTE_* macros are used here, and ms-w32.h (DOS_NT only) because it historically was included here and changing that would take some work. */ #include <stdbool.h> +#include <attribute.h> #if defined WINDOWSNT && !defined DEFER_MS_W32_H # include <ms-w32.h> @@ -65,30 +67,33 @@ typedef unsigned int bool_bf; typedef bool bool_bf; #endif -/* Simulate __has_attribute on compilers that lack it. It is used only - on arguments like alloc_size that are handled in this simulation. - __has_attribute should be used only in #if expressions, as Oracle +/* A substitute for __has_attribute on compilers that lack it. + It is used only on arguments like cleanup that are handled here. + This macro should be used only in #if expressions, as Oracle Studio 12.5's __has_attribute does not work in plain code. */ -#ifndef __has_attribute -# define __has_attribute(a) __has_attribute_##a -# define __has_attribute_alloc_size GNUC_PREREQ (4, 3, 0) -# define __has_attribute_cleanup GNUC_PREREQ (3, 4, 0) -# define __has_attribute_cold GNUC_PREREQ (4, 3, 0) -# define __has_attribute_externally_visible GNUC_PREREQ (4, 1, 0) -# define __has_attribute_no_address_safety_analysis false -# define __has_attribute_no_sanitize_address GNUC_PREREQ (4, 8, 0) -# define __has_attribute_no_sanitize_undefined GNUC_PREREQ (4, 9, 0) -# define __has_attribute_warn_unused_result GNUC_PREREQ (3, 4, 0) +#if (defined __has_attribute \ + && (!defined __clang_minor__ \ + || 3 < __clang_major__ + (5 <= __clang_minor__))) +# define HAS_ATTRIBUTE(a) __has_attribute (__##a##__) +#else +# define HAS_ATTRIBUTE(a) HAS_ATTR_##a +# define HAS_ATTR_cleanup GNUC_PREREQ (3, 4, 0) +# define HAS_ATTR_no_address_safety_analysis false +# define HAS_ATTR_no_sanitize false +# define HAS_ATTR_no_sanitize_address GNUC_PREREQ (4, 8, 0) +# define HAS_ATTR_no_sanitize_undefined GNUC_PREREQ (4, 9, 0) #endif -/* Simulate __has_feature on compilers that lack it. It is used only +/* A substitute for __has_feature on compilers that lack it. It is used only to define ADDRESS_SANITIZER below. */ -#ifndef __has_feature -# define __has_feature(a) false +#ifdef __has_feature +# define HAS_FEATURE(a) __has_feature (a) +#else +# define HAS_FEATURE(a) false #endif /* True if addresses are being sanitized. */ -#if defined __SANITIZE_ADDRESS__ || __has_feature (address_sanitizer) +#if defined __SANITIZE_ADDRESS__ || HAS_FEATURE (address_sanitizer) # define ADDRESS_SANITIZER true #else # define ADDRESS_SANITIZER false @@ -225,37 +230,8 @@ extern void _DebPrint (const char *fmt, ...); extern char *emacs_getenv_TZ (void); extern int emacs_setenv_TZ (char const *); -/* Avoid __attribute__ ((cold)) on MinGW; see thread starting at - <https://lists.gnu.org/r/emacs-devel/2019-04/msg01152.html>. */ -#if __has_attribute (cold) && !defined __MINGW32__ -# define ATTRIBUTE_COLD __attribute__ ((cold)) -#else -# define ATTRIBUTE_COLD -#endif - -#if __GNUC__ >= 3 /* On GCC 3.0 we might get a warning. */ -#define NO_INLINE __attribute__((noinline)) -#else -#define NO_INLINE -#endif - -#if __has_attribute (externally_visible) -#define EXTERNALLY_VISIBLE __attribute__((externally_visible)) -#else -#define EXTERNALLY_VISIBLE -#endif - -#if GNUC_PREREQ (2, 7, 0) -# define ATTRIBUTE_FORMAT(spec) __attribute__ ((__format__ spec)) -#else -# define ATTRIBUTE_FORMAT(spec) /* empty */ -#endif - -#if GNUC_PREREQ (7, 0, 0) -# define FALLTHROUGH __attribute__ ((__fallthrough__)) -#else -# define FALLTHROUGH ((void) 0) -#endif +#define NO_INLINE ATTRIBUTE_NOINLINE +#define EXTERNALLY_VISIBLE ATTRIBUTE_EXTERNALLY_VISIBLE #if GNUC_PREREQ (4, 4, 0) && defined __GLIBC_MINOR__ # define PRINTF_ARCHETYPE __gnu_printf__ @@ -287,15 +263,8 @@ extern int emacs_setenv_TZ (char const *); #define ATTRIBUTE_FORMAT_PRINTF(string_index, first_to_check) \ ATTRIBUTE_FORMAT ((PRINTF_ARCHETYPE, string_index, first_to_check)) -#define ARG_NONNULL _GL_ARG_NONNULL -#define ATTRIBUTE_CONST _GL_ATTRIBUTE_CONST -#define ATTRIBUTE_UNUSED _GL_UNUSED - -#if GNUC_PREREQ (3, 3, 0) && !defined __ICC -# define ATTRIBUTE_MAY_ALIAS __attribute__ ((__may_alias__)) -#else -# define ATTRIBUTE_MAY_ALIAS -#endif +#define ARG_NONNULL ATTRIBUTE_NONNULL +#define ATTRIBUTE_UNUSED MAYBE_UNUSED /* Declare NAME to be a pointer to an object of type TYPE, initialized to the address ADDR, which may be of a different type. Accesses @@ -306,19 +275,11 @@ extern int emacs_setenv_TZ (char const *); type ATTRIBUTE_MAY_ALIAS *name = (type *) (addr) #if 3 <= __GNUC__ -# define ATTRIBUTE_MALLOC __attribute__ ((__malloc__)) # define ATTRIBUTE_SECTION(name) __attribute__((section (name))) #else -# define ATTRIBUTE_MALLOC #define ATTRIBUTE_SECTION(name) #endif -#if __has_attribute (alloc_size) -# define ATTRIBUTE_ALLOC_SIZE(args) __attribute__ ((__alloc_size__ args)) -#else -# define ATTRIBUTE_ALLOC_SIZE(args) -#endif - #define ATTRIBUTE_MALLOC_SIZE(args) ATTRIBUTE_MALLOC ATTRIBUTE_ALLOC_SIZE (args) /* Work around GCC bug 59600: when a function is inlined, the inlined @@ -336,10 +297,10 @@ extern int emacs_setenv_TZ (char const *); /* Attribute of functions whose code should not have addresses sanitized. */ -#if __has_attribute (no_sanitize_address) +#if HAS_ATTRIBUTE (no_sanitize_address) # define ATTRIBUTE_NO_SANITIZE_ADDRESS \ __attribute__ ((no_sanitize_address)) ADDRESS_SANITIZER_WORKAROUND -#elif __has_attribute (no_address_safety_analysis) +#elif HAS_ATTRIBUTE (no_address_safety_analysis) # define ATTRIBUTE_NO_SANITIZE_ADDRESS \ __attribute__ ((no_address_safety_analysis)) ADDRESS_SANITIZER_WORKAROUND #else @@ -348,9 +309,9 @@ extern int emacs_setenv_TZ (char const *); /* Attribute of functions whose undefined behavior should not be sanitized. */ -#if __has_attribute (no_sanitize_undefined) +#if HAS_ATTRIBUTE (no_sanitize_undefined) # define ATTRIBUTE_NO_SANITIZE_UNDEFINED __attribute__ ((no_sanitize_undefined)) -#elif __has_attribute (no_sanitize) +#elif HAS_ATTRIBUTE (no_sanitize) # define ATTRIBUTE_NO_SANITIZE_UNDEFINED \ __attribute__ ((no_sanitize ("undefined"))) #else @@ -425,15 +386,13 @@ extern int emacs_setenv_TZ (char const *); #else -/* Use 'static' instead of 'extern inline' because 'static' typically - has better performance for Emacs. Do not use the 'inline' keyword, - as modern compilers inline automatically. ATTRIBUTE_UNUSED - pacifies gcc -Wunused-function. */ +/* Use 'static inline' instead of 'extern inline' because 'static inline' + has much better performance for Emacs when compiled with 'gcc -Og'. */ # ifndef INLINE # define INLINE EXTERN_INLINE # endif -# define EXTERN_INLINE static ATTRIBUTE_UNUSED +# define EXTERN_INLINE static inline # define INLINE_HEADER_BEGIN # define INLINE_HEADER_END diff --git a/src/data.c b/src/data.c index 2706a2474e6..38cde0ff8b2 100644 --- a/src/data.c +++ b/src/data.c @@ -143,15 +143,9 @@ wrong_length_argument (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3) } AVOID -wrong_type_argument (register Lisp_Object predicate, register Lisp_Object value) +wrong_type_argument (Lisp_Object predicate, Lisp_Object value) { - /* If VALUE is not even a valid Lisp object, we'd want to abort here - where we can get a backtrace showing where it came from. We used - to try and do that by checking the tagbits, but nowadays all - tagbits are potentially valid. */ - /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit) - * emacs_abort (); */ - + eassert (!TAGGEDP (value, Lisp_Type_Unused0)); xsignal2 (Qwrong_type_argument, predicate, value); } @@ -912,6 +906,15 @@ Value, if non-nil, is a list (interactive SPEC). */) if (PVSIZE (fun) > COMPILED_INTERACTIVE) return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE)); } +#ifdef HAVE_MODULES + else if (MODULE_FUNCTIONP (fun)) + { + Lisp_Object form + = module_function_interactive_form (XMODULE_FUNCTION (fun)); + if (! NILP (form)) + return form; + } +#endif else if (AUTOLOADP (fun)) return Finteractive_form (Fautoload_do_load (fun, cmd, Qnil)); else if (CONSP (fun)) @@ -1437,10 +1440,14 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, { int offset = XBUFFER_OBJFWD (innercontents)->offset; int idx = PER_BUFFER_IDX (offset); - if (idx > 0 - && bindflag == SET_INTERNAL_SET - && !let_shadows_buffer_binding_p (sym)) - SET_PER_BUFFER_VALUE_P (buf, idx, 1); + if (idx > 0 && bindflag == SET_INTERNAL_SET + && !PER_BUFFER_VALUE_P (buf, idx)) + { + if (let_shadows_buffer_binding_p (sym)) + set_default_internal (symbol, newval, bindflag); + else + SET_PER_BUFFER_VALUE_P (buf, idx, 1); + } } if (voide) @@ -1632,8 +1639,9 @@ default_value (Lisp_Object symbol) DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0, doc: /* Return t if SYMBOL has a non-void default value. -This is the value that is seen in buffers that do not have their own values -for this variable. */) +A variable may have a buffer-local or a `let'-bound local value. This +function says whether the variable has a non-void value outside of the +current context. Also see `default-value'. */) (Lisp_Object symbol) { register Lisp_Object value; @@ -1790,6 +1798,7 @@ make_blv (struct Lisp_Symbol *sym, bool forwarded, set_blv_defcell (blv, tem); set_blv_valcell (blv, tem); set_blv_found (blv, false); + __lsan_ignore_object (blv); return blv; } @@ -1810,7 +1819,9 @@ a variable local to the current buffer for one particular use, use while setting up a new major mode, unless they have a `permanent-local' property. -The function `default-value' gets the default value and `set-default' sets it. */) +The function `default-value' gets the default value and `set-default' sets it. + +See also `defvar-local'. */) (register Lisp_Object variable) { struct Lisp_Symbol *sym; @@ -2305,61 +2316,45 @@ bool-vector. IDX starts at 0. */) } else /* STRINGP */ { - int c; - CHECK_IMPURE (array, XSTRING (array)); if (idxval < 0 || idxval >= SCHARS (array)) args_out_of_range (array, idx); CHECK_CHARACTER (newelt); - c = XFIXNAT (newelt); + int c = XFIXNAT (newelt); + ptrdiff_t idxval_byte; + int prev_bytes; + unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1; if (STRING_MULTIBYTE (array)) { - ptrdiff_t idxval_byte, nbytes; - int prev_bytes, new_bytes; - unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1; - - nbytes = SBYTES (array); idxval_byte = string_char_to_byte (array, idxval); p1 = SDATA (array) + idxval_byte; prev_bytes = BYTES_BY_CHAR_HEAD (*p1); - new_bytes = CHAR_STRING (c, p0); - if (prev_bytes != new_bytes) - { - /* We must relocate the string data. */ - ptrdiff_t nchars = SCHARS (array); - USE_SAFE_ALLOCA; - unsigned char *str = SAFE_ALLOCA (nbytes); - - memcpy (str, SDATA (array), nbytes); - allocate_string_data (XSTRING (array), nchars, - nbytes + new_bytes - prev_bytes); - memcpy (SDATA (array), str, idxval_byte); - p1 = SDATA (array) + idxval_byte; - memcpy (p1 + new_bytes, str + idxval_byte + prev_bytes, - nbytes - (idxval_byte + prev_bytes)); - SAFE_FREE (); - clear_string_char_byte_cache (); - } - while (new_bytes--) - *p1++ = *p0++; } - else + else if (SINGLE_BYTE_CHAR_P (c)) { - if (! SINGLE_BYTE_CHAR_P (c)) - { - ptrdiff_t i; - - for (i = SBYTES (array) - 1; i >= 0; i--) - if (SREF (array, i) >= 0x80) - args_out_of_range (array, newelt); - /* ARRAY is an ASCII string. Convert it to a multibyte - string, and try `aset' again. */ - STRING_SET_MULTIBYTE (array); - return Faset (array, idx, newelt); - } SSET (array, idxval, c); + return newelt; } + else + { + for (ptrdiff_t i = SBYTES (array) - 1; i >= 0; i--) + if (!ASCII_CHAR_P (SREF (array, i))) + args_out_of_range (array, newelt); + /* ARRAY is an ASCII string. Convert it to a multibyte string. */ + STRING_SET_MULTIBYTE (array); + idxval_byte = idxval; + p1 = SDATA (array) + idxval_byte; + prev_bytes = 1; + } + + int new_bytes = CHAR_STRING (c, p0); + if (prev_bytes != new_bytes) + p1 = resize_string_data (array, idxval_byte, prev_bytes, new_bytes); + + do + *p1++ = *p0++; + while (--new_bytes != 0); } return newelt; @@ -2367,6 +2362,24 @@ bool-vector. IDX starts at 0. */) /* Arithmetic functions */ +static Lisp_Object +check_integer_coerce_marker (Lisp_Object x) +{ + if (MARKERP (x)) + return make_fixnum (marker_position (x)); + CHECK_TYPE (INTEGERP (x), Qinteger_or_marker_p, x); + return x; +} + +static Lisp_Object +check_number_coerce_marker (Lisp_Object x) +{ + if (MARKERP (x)) + return make_fixnum (marker_position (x)); + CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x); + return x; +} + Lisp_Object arithcompare (Lisp_Object num1, Lisp_Object num2, enum Arith_Comparison comparison) @@ -2375,8 +2388,8 @@ arithcompare (Lisp_Object num1, Lisp_Object num2, bool lt, eq = true, gt; bool test; - CHECK_NUMBER_COERCE_MARKER (num1); - CHECK_NUMBER_COERCE_MARKER (num2); + num1 = check_number_coerce_marker (num1); + num2 = check_number_coerce_marker (num2); /* If the comparison is mostly done by comparing two doubles, set LT, EQ, and GT to the <, ==, > results of that comparison, @@ -2778,9 +2791,7 @@ floatop_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, argnum++; if (argnum == nargs) return make_float (accum); - Lisp_Object val = args[argnum]; - CHECK_NUMBER_COERCE_MARKER (val); - next = XFLOATINT (val); + next = XFLOATINT (check_number_coerce_marker (args[argnum])); } } @@ -2842,8 +2853,7 @@ bignum_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, argnum++; if (argnum == nargs) return make_integer_mpz (); - val = args[argnum]; - CHECK_NUMBER_COERCE_MARKER (val); + val = check_number_coerce_marker (args[argnum]); if (FLOATP (val)) return float_arith_driver (code, nargs, args, argnum, mpz_get_d_rounded (*accum), val); @@ -2872,8 +2882,7 @@ arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, argnum++; if (argnum == nargs) return make_int (accum); - val = args[argnum]; - CHECK_NUMBER_COERCE_MARKER (val); + val = check_number_coerce_marker (args[argnum]); /* Set NEXT to the next value if it fits, else exit the loop. */ intmax_t next; @@ -2920,8 +2929,7 @@ usage: (+ &rest NUMBERS-OR-MARKERS) */) { if (nargs == 0) return make_fixnum (0); - Lisp_Object a = args[0]; - CHECK_NUMBER_COERCE_MARKER (a); + Lisp_Object a = check_number_coerce_marker (args[0]); return nargs == 1 ? a : arith_driver (Aadd, nargs, args, a); } @@ -2934,8 +2942,7 @@ usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */) { if (nargs == 0) return make_fixnum (0); - Lisp_Object a = args[0]; - CHECK_NUMBER_COERCE_MARKER (a); + Lisp_Object a = check_number_coerce_marker (args[0]); if (nargs == 1) { if (FIXNUMP (a)) @@ -2955,8 +2962,7 @@ usage: (* &rest NUMBERS-OR-MARKERS) */) { if (nargs == 0) return make_fixnum (1); - Lisp_Object a = args[0]; - CHECK_NUMBER_COERCE_MARKER (a); + Lisp_Object a = check_number_coerce_marker (args[0]); return nargs == 1 ? a : arith_driver (Amult, nargs, args, a); } @@ -2968,8 +2974,7 @@ The arguments must be numbers or markers. usage: (/ NUMBER &rest DIVISORS) */) (ptrdiff_t nargs, Lisp_Object *args) { - Lisp_Object a = args[0]; - CHECK_NUMBER_COERCE_MARKER (a); + Lisp_Object a = check_number_coerce_marker (args[0]); if (nargs == 1) { if (FIXNUMP (a)) @@ -3051,10 +3056,10 @@ integer_remainder (Lisp_Object num, Lisp_Object den, bool modulo) DEFUN ("%", Frem, Srem, 2, 2, 0, doc: /* Return remainder of X divided by Y. Both must be integers or markers. */) - (register Lisp_Object x, Lisp_Object y) + (Lisp_Object x, Lisp_Object y) { - CHECK_INTEGER_COERCE_MARKER (x); - CHECK_INTEGER_COERCE_MARKER (y); + x = check_integer_coerce_marker (x); + y = check_integer_coerce_marker (y); return integer_remainder (x, y, false); } @@ -3064,8 +3069,8 @@ The result falls between zero (inclusive) and Y (exclusive). Both X and Y must be numbers or markers. */) (Lisp_Object x, Lisp_Object y) { - CHECK_NUMBER_COERCE_MARKER (x); - CHECK_NUMBER_COERCE_MARKER (y); + x = check_number_coerce_marker (x); + y = check_number_coerce_marker (y); if (FLOATP (x) || FLOATP (y)) return fmod_float (x, y); return integer_remainder (x, y, true); @@ -3075,12 +3080,10 @@ static Lisp_Object minmax_driver (ptrdiff_t nargs, Lisp_Object *args, enum Arith_Comparison comparison) { - Lisp_Object accum = args[0]; - CHECK_NUMBER_COERCE_MARKER (accum); + Lisp_Object accum = check_number_coerce_marker (args[0]); for (ptrdiff_t argnum = 1; argnum < nargs; argnum++) { - Lisp_Object val = args[argnum]; - CHECK_NUMBER_COERCE_MARKER (val); + Lisp_Object val = check_number_coerce_marker (args[argnum]); if (!NILP (arithcompare (val, accum, comparison))) accum = val; else if (FLOATP (val) && isnan (XFLOAT_DATA (val))) @@ -3115,8 +3118,7 @@ usage: (logand &rest INTS-OR-MARKERS) */) { if (nargs == 0) return make_fixnum (-1); - Lisp_Object a = args[0]; - CHECK_INTEGER_COERCE_MARKER (a); + Lisp_Object a = check_integer_coerce_marker (args[0]); return nargs == 1 ? a : arith_driver (Alogand, nargs, args, a); } @@ -3128,8 +3130,7 @@ usage: (logior &rest INTS-OR-MARKERS) */) { if (nargs == 0) return make_fixnum (0); - Lisp_Object a = args[0]; - CHECK_INTEGER_COERCE_MARKER (a); + Lisp_Object a = check_integer_coerce_marker (args[0]); return nargs == 1 ? a : arith_driver (Alogior, nargs, args, a); } @@ -3141,8 +3142,7 @@ usage: (logxor &rest INTS-OR-MARKERS) */) { if (nargs == 0) return make_fixnum (0); - Lisp_Object a = args[0]; - CHECK_INTEGER_COERCE_MARKER (a); + Lisp_Object a = check_integer_coerce_marker (args[0]); return nargs == 1 ? a : arith_driver (Alogxor, nargs, args, a); } @@ -3261,9 +3261,9 @@ expt_integer (Lisp_Object x, Lisp_Object y) DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0, doc: /* Return NUMBER plus one. NUMBER may be a number or a marker. Markers are converted to integers. */) - (register Lisp_Object number) + (Lisp_Object number) { - CHECK_NUMBER_COERCE_MARKER (number); + number = check_number_coerce_marker (number); if (FIXNUMP (number)) return make_int (XFIXNUM (number) + 1); @@ -3276,9 +3276,9 @@ Markers are converted to integers. */) DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0, doc: /* Return NUMBER minus one. NUMBER may be a number or a marker. Markers are converted to integers. */) - (register Lisp_Object number) + (Lisp_Object number) { - CHECK_NUMBER_COERCE_MARKER (number); + number = check_number_coerce_marker (number); if (FIXNUMP (number)) return make_int (XFIXNUM (number) - 1); @@ -3322,27 +3322,14 @@ bool_vector_spare_mask (EMACS_INT nr_bits) return (((bits_word) 1) << (nr_bits % BITS_PER_BITS_WORD)) - 1; } -/* Info about unsigned long long, falling back on unsigned long - if unsigned long long is not available. */ - -#if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_WIDTH -enum { ULL_WIDTH = ULLONG_WIDTH }; -# define ULL_MAX ULLONG_MAX -#else -enum { ULL_WIDTH = ULONG_WIDTH }; -# define ULL_MAX ULONG_MAX -# define count_one_bits_ll count_one_bits_l -# define count_trailing_zeros_ll count_trailing_zeros_l -#endif - /* Shift VAL right by the width of an unsigned long long. - ULL_WIDTH must be less than BITS_PER_BITS_WORD. */ + ULLONG_WIDTH must be less than BITS_PER_BITS_WORD. */ static bits_word shift_right_ull (bits_word w) { /* Pacify bogus GCC warning about shift count exceeding type width. */ - int shift = ULL_WIDTH - BITS_PER_BITS_WORD < 0 ? ULL_WIDTH : 0; + int shift = ULLONG_WIDTH - BITS_PER_BITS_WORD < 0 ? ULLONG_WIDTH : 0; return w >> shift; } @@ -3359,7 +3346,7 @@ count_one_bits_word (bits_word w) { int i = 0, count = 0; while (count += count_one_bits_ll (w), - (i += ULL_WIDTH) < BITS_PER_BITS_WORD) + (i += ULLONG_WIDTH) < BITS_PER_BITS_WORD) w = shift_right_ull (w); return count; } @@ -3490,7 +3477,7 @@ count_trailing_zero_bits (bits_word val) return count_trailing_zeros (val); if (BITS_WORD_MAX == ULONG_MAX) return count_trailing_zeros_l (val); - if (BITS_WORD_MAX == ULL_MAX) + if (BITS_WORD_MAX == ULLONG_MAX) return count_trailing_zeros_ll (val); /* The rest of this code is for the unlikely platform where bits_word differs @@ -3504,18 +3491,18 @@ count_trailing_zero_bits (bits_word val) { int count; for (count = 0; - count < BITS_PER_BITS_WORD - ULL_WIDTH; - count += ULL_WIDTH) + count < BITS_PER_BITS_WORD - ULLONG_WIDTH; + count += ULLONG_WIDTH) { - if (val & ULL_MAX) + if (val & ULLONG_MAX) return count + count_trailing_zeros_ll (val); val = shift_right_ull (val); } - if (BITS_PER_BITS_WORD % ULL_WIDTH != 0 + if (BITS_PER_BITS_WORD % ULLONG_WIDTH != 0 && BITS_WORD_MAX == (bits_word) -1) val |= (bits_word) 1 << pre_value (ULONG_MAX < BITS_WORD_MAX, - BITS_PER_BITS_WORD % ULL_WIDTH); + BITS_PER_BITS_WORD % ULLONG_WIDTH); return count + count_trailing_zeros_ll (val); } } @@ -3528,10 +3515,8 @@ bits_word_to_host_endian (bits_word val) #else if (BITS_WORD_MAX >> 31 == 1) return bswap_32 (val); -# if HAVE_UNSIGNED_LONG_LONG if (BITS_WORD_MAX >> 31 >> 31 >> 1 == 1) return bswap_64 (val); -# endif { int i; bits_word r = 0; @@ -3777,6 +3762,7 @@ syms_of_data (void) DEFSYM (Qbuffer_read_only, "buffer-read-only"); DEFSYM (Qtext_read_only, "text-read-only"); DEFSYM (Qmark_inactive, "mark-inactive"); + DEFSYM (Qinhibited_interaction, "inhibited-interaction"); DEFSYM (Qlistp, "listp"); DEFSYM (Qconsp, "consp"); @@ -3861,6 +3847,8 @@ syms_of_data (void) PUT_ERROR (Qbuffer_read_only, error_tail, "Buffer is read-only"); PUT_ERROR (Qtext_read_only, pure_cons (Qbuffer_read_only, error_tail), "Text is read-only"); + PUT_ERROR (Qinhibited_interaction, error_tail, + "User interaction while inhibited"); DEFSYM (Qrange_error, "range-error"); DEFSYM (Qdomain_error, "domain-error"); diff --git a/src/dbusbind.c b/src/dbusbind.c index a666bcc2959..c005474d440 100644 --- a/src/dbusbind.c +++ b/src/dbusbind.c @@ -44,7 +44,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ /* Alist of D-Bus buses we are polling for messages. The key is the symbol or string of the bus, and the value is the - connection address. */ + connection address. For every bus, just one connection is counted. + If there shall be a second connection to the same bus, a different + symbol or string for the bus must be chosen. On Lisp level, a bus + stands for the associated connection. */ static Lisp_Object xd_registered_buses; /* Whether we are reading a D-Bus event. */ @@ -192,9 +195,39 @@ xd_symbol_to_dbus_type (Lisp_Object object) : DBUS_TYPE_INVALID); } +/* Determine the Lisp symbol of DBusType. */ +static Lisp_Object +xd_dbus_type_to_symbol (int type) +{ + return + (type == DBUS_TYPE_BYTE) ? QCbyte + : (type == DBUS_TYPE_BOOLEAN) ? QCboolean + : (type == DBUS_TYPE_INT16) ? QCint16 + : (type == DBUS_TYPE_UINT16) ? QCuint16 + : (type == DBUS_TYPE_INT32) ? QCint32 + : (type == DBUS_TYPE_UINT32) ? QCuint32 + : (type == DBUS_TYPE_INT64) ? QCint64 + : (type == DBUS_TYPE_UINT64) ? QCuint64 + : (type == DBUS_TYPE_DOUBLE) ? QCdouble + : (type == DBUS_TYPE_STRING) ? QCstring + : (type == DBUS_TYPE_OBJECT_PATH) ? QCobject_path + : (type == DBUS_TYPE_SIGNATURE) ? QCsignature +#ifdef DBUS_TYPE_UNIX_FD + : (type == DBUS_TYPE_UNIX_FD) ? QCunix_fd +#endif + : (type == DBUS_TYPE_ARRAY) ? QCarray + : (type == DBUS_TYPE_VARIANT) ? QCvariant + : (type == DBUS_TYPE_STRUCT) ? QCstruct + : (type == DBUS_TYPE_DICT_ENTRY) ? QCdict_entry + : Qnil; +} + +#define XD_KEYWORDP(object) !NILP (Fkeywordp (object)) + /* Check whether a Lisp symbol is a predefined D-Bus type symbol. */ #define XD_DBUS_TYPE_P(object) \ - (SYMBOLP (object) && ((xd_symbol_to_dbus_type (object) != DBUS_TYPE_INVALID))) + XD_KEYWORDP (object) && \ + ((xd_symbol_to_dbus_type (object) != DBUS_TYPE_INVALID)) /* Determine the DBusType of a given Lisp OBJECT. It is used to convert Lisp objects, being arguments of `dbus-call-method' or @@ -265,10 +298,13 @@ XD_OBJECT_TO_STRING (Lisp_Object object) else \ { \ CHECK_SYMBOL (bus); \ - if (!(EQ (bus, QCsystem) || EQ (bus, QCsession))) \ + if (!(EQ (bus, QCsystem) || EQ (bus, QCsession) \ + || EQ (bus, QCsystem_private) \ + || EQ (bus, QCsession_private))) \ XD_SIGNAL2 (build_string ("Wrong bus name"), bus); \ /* We do not want to have an autolaunch for the session bus. */ \ - if (EQ (bus, QCsession) && session_bus_address == NULL) \ + if ((EQ (bus, QCsession) || EQ (bus, QCsession_private)) \ + && session_bus_address == NULL) \ XD_SIGNAL2 (build_string ("No connection to bus"), bus); \ } \ } while (0) @@ -360,7 +396,8 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) break; case DBUS_TYPE_BOOLEAN: - if (!EQ (object, Qt) && !NILP (object)) + /* There must be an argument. */ + if (EQ (QCboolean, object)) wrong_type_argument (intern ("booleanp"), object); sprintf (signature, "%c", dtype); break; @@ -385,7 +422,12 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) case DBUS_TYPE_STRING: case DBUS_TYPE_OBJECT_PATH: case DBUS_TYPE_SIGNATURE: - CHECK_STRING (object); + /* We dont check the syntax of signature. This will be done by + libdbus. */ + if (dtype == DBUS_TYPE_OBJECT_PATH) + XD_DBUS_VALIDATE_PATH (object) + else + CHECK_STRING (object); sprintf (signature, "%c", dtype); break; @@ -420,12 +462,18 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) { Lisp_Object elt1 = XD_NEXT_VALUE (elt); if (CONSP (elt1) && STRINGP (XCAR (elt1)) && NILP (XCDR (elt1))) - subsig = SSDATA (XCAR (elt1)); + { + subsig = SSDATA (XCAR (elt1)); + elt = Qnil; + } } while (!NILP (elt)) { - if (subtype != XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt))) + char x[DBUS_MAXIMUM_SIGNATURE_LENGTH]; + subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt)); + xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt))); + if (strcmp (subsig, x) != 0) wrong_type_argument (intern ("D-Bus"), CAR_SAFE (elt)); elt = CDR_SAFE (XD_NEXT_VALUE (elt)); } @@ -440,6 +488,7 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) CHECK_CONS (object); elt = XD_NEXT_VALUE (elt); + CHECK_CONS (elt); subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt)); xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt))); @@ -451,11 +500,12 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) break; case DBUS_TYPE_STRUCT: - /* A struct list might contain any number of elements with - different types. No further check needed. */ + /* A struct list might contain any (but zero) number of elements + with different types. No further check needed. */ CHECK_CONS (object); elt = XD_NEXT_VALUE (elt); + CHECK_CONS (elt); /* Compose the signature from the elements. It is enclosed by parentheses. */ @@ -486,6 +536,7 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) /* First element. */ elt = XD_NEXT_VALUE (elt); + CHECK_CONS (elt); subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt)); xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt))); xd_signature_cat (signature, x); @@ -495,6 +546,7 @@ xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object) /* Second element. */ elt = CDR_SAFE (XD_NEXT_VALUE (elt)); + CHECK_CONS (elt); subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt)); xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt))); xd_signature_cat (signature, x); @@ -595,6 +647,9 @@ xd_append_arg (int dtype, Lisp_Object object, DBusMessageIter *iter) } case DBUS_TYPE_BOOLEAN: + /* There must be an argument. */ + if (EQ (QCboolean, object)) + wrong_type_argument (intern ("booleanp"), object); { dbus_bool_t val = (NILP (object)) ? FALSE : TRUE; XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true"); @@ -693,7 +748,12 @@ xd_append_arg (int dtype, Lisp_Object object, DBusMessageIter *iter) case DBUS_TYPE_STRING: case DBUS_TYPE_OBJECT_PATH: case DBUS_TYPE_SIGNATURE: - CHECK_STRING (object); + /* We dont check the syntax of signature. This will be done + by libdbus. */ + if (dtype == DBUS_TYPE_OBJECT_PATH) + XD_DBUS_VALIDATE_PATH (object) + else + CHECK_STRING (object); { /* We need to send a valid UTF-8 string. We could encode `object' but by not encoding it, we guarantee it's valid utf-8, even if @@ -816,7 +876,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); val = val & 0xFF; XD_DEBUG_MESSAGE ("%c %u", dtype, val); - return make_fixnum (val); + return list2 (xd_dbus_type_to_symbol (dtype), make_fixnum (val)); } case DBUS_TYPE_BOOLEAN: @@ -824,7 +884,8 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_bool_t val; dbus_message_iter_get_basic (iter, &val); XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true"); - return (val == FALSE) ? Qnil : Qt; + return list2 (xd_dbus_type_to_symbol (dtype), + (val == FALSE) ? Qnil : Qt); } case DBUS_TYPE_INT16: @@ -834,7 +895,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); pval = val; XD_DEBUG_MESSAGE ("%c %d", dtype, pval); - return make_fixnum (val); + return list2 (xd_dbus_type_to_symbol (dtype), make_fixnum (val)); } case DBUS_TYPE_UINT16: @@ -844,7 +905,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); pval = val; XD_DEBUG_MESSAGE ("%c %d", dtype, pval); - return make_fixnum (val); + return list2 (xd_dbus_type_to_symbol (dtype), make_fixnum (val)); } case DBUS_TYPE_INT32: @@ -854,7 +915,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); pval = val; XD_DEBUG_MESSAGE ("%c %d", dtype, pval); - return INT_TO_INTEGER (val); + return list2 (xd_dbus_type_to_symbol (dtype), INT_TO_INTEGER (val)); } case DBUS_TYPE_UINT32: @@ -867,7 +928,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); pval = val; XD_DEBUG_MESSAGE ("%c %u", dtype, pval); - return INT_TO_INTEGER (val); + return list2 (xd_dbus_type_to_symbol (dtype), INT_TO_INTEGER (val)); } case DBUS_TYPE_INT64: @@ -876,7 +937,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); intmax_t pval = val; XD_DEBUG_MESSAGE ("%c %"PRIdMAX, dtype, pval); - return INT_TO_INTEGER (val); + return list2 (xd_dbus_type_to_symbol (dtype), INT_TO_INTEGER (val)); } case DBUS_TYPE_UINT64: @@ -885,7 +946,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_get_basic (iter, &val); uintmax_t pval = val; XD_DEBUG_MESSAGE ("%c %"PRIuMAX, dtype, pval); - return INT_TO_INTEGER (val); + return list2 (xd_dbus_type_to_symbol (dtype), INT_TO_INTEGER (val)); } case DBUS_TYPE_DOUBLE: @@ -893,7 +954,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) double val; dbus_message_iter_get_basic (iter, &val); XD_DEBUG_MESSAGE ("%c %f", dtype, val); - return make_float (val); + return list2 (xd_dbus_type_to_symbol (dtype), make_float (val)); } case DBUS_TYPE_STRING: @@ -903,7 +964,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) char *val; dbus_message_iter_get_basic (iter, &val); XD_DEBUG_MESSAGE ("%c %s", dtype, val); - return build_string (val); + return list2 (xd_dbus_type_to_symbol (dtype), build_string (val)); } case DBUS_TYPE_ARRAY: @@ -923,7 +984,7 @@ xd_retrieve_arg (int dtype, DBusMessageIter *iter) dbus_message_iter_next (&subiter); } XD_DEBUG_MESSAGE ("%c %s", dtype, XD_OBJECT_TO_STRING (result)); - return Fnreverse (result); + return Fcons (xd_dbus_type_to_symbol (dtype), Fnreverse (result)); } default: @@ -953,8 +1014,9 @@ xd_lisp_dbus_to_dbus (Lisp_Object bus) return xmint_pointer (bus); } -/* Return D-Bus connection address. BUS is either a Lisp symbol, - :system or :session, or a string denoting the bus address. */ +/* Return D-Bus connection address. + BUS is either a Lisp symbol, :system, :session, :system-private or + :session-private, or a string denoting the bus address. */ static DBusConnection * xd_get_connection_address (Lisp_Object bus) { @@ -1016,7 +1078,8 @@ xd_add_watch (DBusWatch *watch, void *data) } /* Stop monitoring WATCH for possible I/O. - DATA is the used bus, either a string or QCsystem or QCsession. */ + DATA is the used bus, either a string or QCsystem, QCsession, + QCsystem_private or QCsession_private. */ static void xd_remove_watch (DBusWatch *watch, void *data) { @@ -1031,7 +1094,7 @@ xd_remove_watch (DBusWatch *watch, void *data) /* Unset session environment. */ #if 0 /* This is buggy, since unsetenv is not thread-safe. */ - if (XSYMBOL (QCsession) == data) + if (XSYMBOL (QCsession) == data) || (XSYMBOL (QCsession_private) == data) { XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS"); unsetenv ("DBUS_SESSION_BUS_ADDRESS"); @@ -1105,6 +1168,11 @@ can be a string denoting the address of the corresponding bus. For the system and session buses, this function is called when loading `dbus.el', there is no need to call it again. +A special case is BUS being the symbol `:system-private' or +`:session-private'. These symbols still denote the system or session +bus, but using a private connection. They should not be used outside +dbus.el. + The function returns a number, which counts the connections this Emacs session has established to the BUS under the same unique name (see `dbus-get-unique-name'). It depends on the libraries Emacs is linked @@ -1127,6 +1195,10 @@ this connection to those buses. */) ptrdiff_t refcount; /* Check parameter. */ + if (!NILP (private)) + bus = EQ (bus, QCsystem) + ? QCsystem_private + : EQ (bus, QCsession) ? QCsession_private : bus; XD_DBUS_VALIDATE_BUS_ADDRESS (bus); /* Close bus if it is already open. */ @@ -1154,8 +1226,9 @@ this connection to those buses. */) else { - DBusBusType bustype = (EQ (bus, QCsystem) - ? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION); + DBusBusType bustype + = EQ (bus, QCsystem) || EQ (bus, QCsystem_private) + ? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION; if (NILP (private)) connection = dbus_bus_get (bustype, &derror); else @@ -1169,9 +1242,9 @@ this connection to those buses. */) XD_SIGNAL2 (build_string ("No connection to bus"), bus); /* If it is not the system or session bus, we must register - ourselves. Otherwise, we have called dbus_bus_get, which has - configured us to exit if the connection closes - we undo this - setting. */ + ourselves. Otherwise, we have called dbus_bus_get{_private}, + which has configured us to exit if the connection closes - we + undo this setting. */ if (STRINGP (bus)) dbus_bus_register (connection, &derror); else @@ -1186,7 +1259,7 @@ this connection to those buses. */) xd_add_watch, xd_remove_watch, xd_toggle_watch, - SYMBOLP (bus) + XD_KEYWORDP (bus) ? (void *) XSYMBOL (bus) : (void *) XSTRING (bus), NULL)) @@ -1200,6 +1273,9 @@ this connection to those buses. */) dbus_error_free (&derror); } + XD_DEBUG_MESSAGE ("Registered buses: %s", + XD_OBJECT_TO_STRING (xd_registered_buses)); + /* Return reference counter. */ refcount = xd_get_connection_references (connection); XD_DEBUG_MESSAGE ("Bus %s, Reference counter %"pD"d", @@ -1252,7 +1328,11 @@ The following usages are expected: `dbus-method-error-internal': (dbus-message-internal - dbus-message-type-error BUS SERVICE SERIAL &rest ARGS) + dbus-message-type-error BUS SERVICE SERIAL ERROR-NAME &rest ARGS) + +`dbus-check-arguments': (does not send a message) + (dbus-message-internal + dbus-message-type-invalid BUS SERVICE &rest ARGS) usage: (dbus-message-internal &rest REST) */) (ptrdiff_t nargs, Lisp_Object *args) @@ -1261,6 +1341,7 @@ usage: (dbus-message-internal &rest REST) */) Lisp_Object path = Qnil; Lisp_Object interface = Qnil; Lisp_Object member = Qnil; + Lisp_Object error_name = Qnil; Lisp_Object result; DBusConnection *connection; DBusMessage *dmessage; @@ -1270,7 +1351,7 @@ usage: (dbus-message-internal &rest REST) */) dbus_uint32_t serial = 0; unsigned int ui_serial; int timeout = -1; - ptrdiff_t count; + ptrdiff_t count, count0; char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH]; /* Initialize parameters. */ @@ -1280,7 +1361,7 @@ usage: (dbus-message-internal &rest REST) */) handler = Qnil; CHECK_FIXNAT (message_type); - if (! (DBUS_MESSAGE_TYPE_INVALID < XFIXNAT (message_type) + if (! (DBUS_MESSAGE_TYPE_INVALID <= XFIXNAT (message_type) && XFIXNAT (message_type) < DBUS_NUM_MESSAGE_TYPES)) XD_SIGNAL2 (build_string ("Invalid message type"), message_type); mtype = XFIXNAT (message_type); @@ -1295,11 +1376,16 @@ usage: (dbus-message-internal &rest REST) */) handler = args[6]; count = (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL) ? 7 : 6; } - else /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */ + else if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN) + || (mtype == DBUS_MESSAGE_TYPE_ERROR)) { serial = xd_extract_unsigned (args[3], TYPE_MAXIMUM (dbus_uint32_t)); - count = 4; + if (mtype == DBUS_MESSAGE_TYPE_ERROR) + error_name = args[4]; + count = (mtype == DBUS_MESSAGE_TYPE_ERROR) ? 5 : 4; } + else /* DBUS_MESSAGE_TYPE_INVALID */ + count = 3; /* Check parameters. */ XD_DBUS_VALIDATE_BUS_ADDRESS (bus); @@ -1341,24 +1427,41 @@ usage: (dbus-message-internal &rest REST) */) XD_OBJECT_TO_STRING (interface), XD_OBJECT_TO_STRING (member)); break; - default: /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */ + case DBUS_MESSAGE_TYPE_METHOD_RETURN: ui_serial = serial; XD_DEBUG_MESSAGE ("%s %s %s %u", XD_MESSAGE_TYPE_TO_STRING (mtype), XD_OBJECT_TO_STRING (bus), XD_OBJECT_TO_STRING (service), ui_serial); + break; + case DBUS_MESSAGE_TYPE_ERROR: + ui_serial = serial; + XD_DEBUG_MESSAGE ("%s %s %s %u %s", + XD_MESSAGE_TYPE_TO_STRING (mtype), + XD_OBJECT_TO_STRING (bus), + XD_OBJECT_TO_STRING (service), + ui_serial, + XD_OBJECT_TO_STRING (error_name)); + break; + default: /* DBUS_MESSAGE_TYPE_INVALID */ + XD_DEBUG_MESSAGE ("%s %s %s", + XD_MESSAGE_TYPE_TO_STRING (mtype), + XD_OBJECT_TO_STRING (bus), + XD_OBJECT_TO_STRING (service)); } /* Retrieve bus address. */ connection = xd_get_connection_address (bus); - /* Create the D-Bus message. */ - dmessage = dbus_message_new (mtype); + /* Create the D-Bus message. Since DBUS_MESSAGE_TYPE_INVALID is not + a valid message type, we mockup it with DBUS_MESSAGE_TYPE_SIGNAL. */ + dmessage = dbus_message_new + ((mtype == DBUS_MESSAGE_TYPE_INVALID) ? DBUS_MESSAGE_TYPE_SIGNAL : mtype); if (dmessage == NULL) XD_SIGNAL1 (build_string ("Unable to create a new message")); - if (STRINGP (service)) + if ((STRINGP (service)) && (mtype != DBUS_MESSAGE_TYPE_INVALID)) { if (mtype != DBUS_MESSAGE_TYPE_SIGNAL) /* Set destination. */ @@ -1400,13 +1503,14 @@ usage: (dbus-message-internal &rest REST) */) XD_SIGNAL1 (build_string ("Unable to set the message parameter")); } - else /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */ + else if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN) + || (mtype == DBUS_MESSAGE_TYPE_ERROR)) { if (!dbus_message_set_reply_serial (dmessage, serial)) XD_SIGNAL1 (build_string ("Unable to create a return message")); if ((mtype == DBUS_MESSAGE_TYPE_ERROR) - && (!dbus_message_set_error_name (dmessage, DBUS_ERROR_FAILED))) + && (!dbus_message_set_error_name (dmessage, SSDATA (error_name)))) XD_SIGNAL1 (build_string ("Unable to create an error message")); } @@ -1422,6 +1526,7 @@ usage: (dbus-message-internal &rest REST) */) dbus_message_iter_init_append (dmessage, &iter); /* Append parameters to the message. */ + count0 = count - 1; for (; count < nargs; ++count) { dtype = XD_OBJECT_TO_DBUS_TYPE (args[count]); @@ -1429,15 +1534,17 @@ usage: (dbus-message-internal &rest REST) */) { XD_DEBUG_VALID_LISP_OBJECT_P (args[count]); XD_DEBUG_VALID_LISP_OBJECT_P (args[count+1]); - XD_DEBUG_MESSAGE ("Parameter%"pD"d %s %s", count - 4, + XD_DEBUG_MESSAGE ("Parameter%"pD"d: %s Parameter%"pD"d: %s", + count - count0, XD_OBJECT_TO_STRING (args[count]), + count + 1 - count0, XD_OBJECT_TO_STRING (args[count+1])); ++count; } else { XD_DEBUG_VALID_LISP_OBJECT_P (args[count]); - XD_DEBUG_MESSAGE ("Parameter%"pD"d %s", count - 4, + XD_DEBUG_MESSAGE ("Parameter%"pD"d: %s", count - count0, XD_OBJECT_TO_STRING (args[count])); } @@ -1448,7 +1555,10 @@ usage: (dbus-message-internal &rest REST) */) xd_append_arg (dtype, args[count], &iter); } - if (!NILP (handler)) + if (mtype == DBUS_MESSAGE_TYPE_INVALID) + result = Qt; + + else if (!NILP (handler)) { /* Send the message. The message is just added to the outgoing message queue. */ @@ -1473,7 +1583,8 @@ usage: (dbus-message-internal &rest REST) */) result = Qnil; } - XD_DEBUG_MESSAGE ("Message sent: %s", XD_OBJECT_TO_STRING (result)); + if (mtype != DBUS_MESSAGE_TYPE_INVALID) + XD_DEBUG_MESSAGE ("Message sent: %s", XD_OBJECT_TO_STRING (result)); /* Cleanup. */ dbus_message_unref (dmessage); @@ -1483,8 +1594,8 @@ usage: (dbus-message-internal &rest REST) */) } /* Read one queued incoming message of the D-Bus BUS. - BUS is either a Lisp symbol, :system or :session, or a string denoting - the bus address. */ + BUS is either a Lisp symbol, :system, :session, :system-private or + :session-private, or a string denoting the bus address. */ static void xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) { @@ -1496,7 +1607,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) int mtype; dbus_uint32_t serial; unsigned int ui_serial; - const char *uname, *path, *interface, *member; + const char *uname, *destination, *path, *interface, *member, *error_name; dmessage = dbus_connection_pop_message (connection); @@ -1521,7 +1632,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) } /* Read message type, message serial, unique name, object path, - interface and member from the message. */ + interface, member and error name from the message. */ mtype = dbus_message_get_type (dmessage); ui_serial = serial = ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN) @@ -1529,13 +1640,16 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) ? dbus_message_get_reply_serial (dmessage) : dbus_message_get_serial (dmessage); uname = dbus_message_get_sender (dmessage); + destination = dbus_message_get_destination (dmessage); path = dbus_message_get_path (dmessage); interface = dbus_message_get_interface (dmessage); member = dbus_message_get_member (dmessage); + error_name = dbus_message_get_error_name (dmessage); - XD_DEBUG_MESSAGE ("Event received: %s %u %s %s %s %s %s", + XD_DEBUG_MESSAGE ("Event received: %s %u %s %s %s %s %s %s", XD_MESSAGE_TYPE_TO_STRING (mtype), - ui_serial, uname, path, interface, member, + ui_serial, uname, destination, path, interface, + mtype == DBUS_MESSAGE_TYPE_ERROR ? error_name : member, XD_OBJECT_TO_STRING (args)); if (mtype == DBUS_MESSAGE_TYPE_INVALID) @@ -1550,7 +1664,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) /* There shall be exactly one entry. Construct an event. */ if (NILP (value)) - goto cleanup; + goto monitor; /* Remove the entry. */ Fremhash (key, Vdbus_registered_objects_table); @@ -1559,6 +1673,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) EVENT_INIT (event); event.kind = DBUS_EVENT; event.frame_or_window = Qnil; + /* Handler. */ event.arg = Fcons (value, args); } @@ -1567,7 +1682,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) /* Vdbus_registered_objects_table requires non-nil interface and member. */ if ((interface == NULL) || (member == NULL)) - goto cleanup; + goto monitor; /* Search for a registered function of the message. */ key = list4 (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL ? QCmethod : QCsignal, @@ -1592,6 +1707,7 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) EVENT_INIT (event); event.kind = DBUS_EVENT; event.frame_or_window = Qnil; + /* Handler. */ event.arg = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))), args); break; @@ -1600,16 +1716,22 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) } if (NILP (value)) - goto cleanup; + goto monitor; } - /* Add type, serial, uname, path, interface and member to the event. */ - event.arg = Fcons ((member == NULL ? Qnil : build_string (member)), - event.arg); + /* Add type, serial, uname, destination, path, interface and member + or error_name to the event. */ + event.arg + = Fcons (mtype == DBUS_MESSAGE_TYPE_ERROR + ? error_name == NULL ? Qnil : build_string (error_name) + : member == NULL ? Qnil : build_string (member), + event.arg); event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)), event.arg); event.arg = Fcons ((path == NULL ? Qnil : build_string (path)), event.arg); + event.arg = Fcons ((destination == NULL ? Qnil : build_string (destination)), + event.arg); event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)), event.arg); event.arg = Fcons (INT_TO_INTEGER (serial), event.arg); @@ -1623,14 +1745,58 @@ xd_read_message_1 (DBusConnection *connection, Lisp_Object bus) XD_DEBUG_MESSAGE ("Event stored: %s", XD_OBJECT_TO_STRING (event.arg)); + /* Monitor. */ + monitor: + /* Search for a registered function of the message. */ + key = list2 (QCmonitor, bus); + value = Fgethash (key, Vdbus_registered_objects_table, Qnil); + + /* There shall be exactly one entry. Construct an event. */ + if (NILP (value)) + goto cleanup; + + /* Construct an event. */ + EVENT_INIT (event); + event.kind = DBUS_EVENT; + event.frame_or_window = Qnil; + + /* Add type, serial, uname, destination, path, interface, member + or error_name and handler to the event. */ + event.arg + = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (CAR_SAFE (value))))), + args); + event.arg + = Fcons (mtype == DBUS_MESSAGE_TYPE_ERROR + ? error_name == NULL ? Qnil : build_string (error_name) + : member == NULL ? Qnil : build_string (member), + event.arg); + event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)), + event.arg); + event.arg = Fcons ((path == NULL ? Qnil : build_string (path)), + event.arg); + event.arg = Fcons ((destination == NULL ? Qnil : build_string (destination)), + event.arg); + event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)), + event.arg); + event.arg = Fcons (INT_TO_INTEGER (serial), event.arg); + event.arg = Fcons (make_fixnum (mtype), event.arg); + + /* Add the bus symbol to the event. */ + event.arg = Fcons (bus, event.arg); + + /* Store it into the input event queue. */ + kbd_buffer_store_event (&event); + + XD_DEBUG_MESSAGE ("Monitor event stored: %s", XD_OBJECT_TO_STRING (event.arg)); + /* Cleanup. */ cleanup: dbus_message_unref (dmessage); } /* Read queued incoming messages of the D-Bus BUS. - BUS is either a Lisp symbol, :system or :session, or a string denoting - the bus address. */ + BUS is either a Lisp symbol, :system, :session, :system-private or + :session-private, or a string denoting the bus address. */ static Lisp_Object xd_read_message (Lisp_Object bus) { @@ -1659,7 +1825,7 @@ xd_read_queued_messages (int fd, void *data) while (!NILP (busp)) { key = CAR_SAFE (CAR_SAFE (busp)); - if ((SYMBOLP (key) && XSYMBOL (key) == data) + if ((XD_KEYWORDP (key) && XSYMBOL (key) == data) || (STRINGP (key) && XSTRING (key) == data)) bus = key; busp = CDR_SAFE (busp); @@ -1707,6 +1873,8 @@ syms_of_dbusbind (void) /* Lisp symbols of the system and session buses. */ DEFSYM (QCsystem, ":system"); DEFSYM (QCsession, ":session"); + DEFSYM (QCsystem_private, ":system-private"); + DEFSYM (QCsession_private, ":session-private"); /* Lisp symbol for method call timeout. */ DEFSYM (QCtimeout, ":timeout"); @@ -1732,10 +1900,12 @@ syms_of_dbusbind (void) DEFSYM (QCstruct, ":struct"); DEFSYM (QCdict_entry, ":dict-entry"); - /* Lisp symbols of objects in `dbus-registered-objects-table'. */ + /* Lisp symbols of objects in `dbus-registered-objects-table'. + `:property', which does exist there as well, is not declared here. */ DEFSYM (QCserial, ":serial"); DEFSYM (QCmethod, ":method"); DEFSYM (QCsignal, ":signal"); + DEFSYM (QCmonitor, ":monitor"); DEFVAR_LISP ("dbus-compiled-version", Vdbus_compiled_version, @@ -1792,29 +1962,33 @@ syms_of_dbusbind (void) doc: /* Hash table of registered functions for D-Bus. There are two different uses of the hash table: for accessing -registered interfaces properties, targeted by signals or method calls, -and for calling handlers in case of non-blocking method call returns. +registered interfaces properties, targeted by signals, method calls or +monitors, and for calling handlers in case of non-blocking method call +returns. In the first case, the key in the hash table is the list (TYPE BUS -INTERFACE MEMBER). TYPE is one of the Lisp symbols `:method', -`:signal' or `:property'. BUS is either a Lisp symbol, `:system' or -`:session', or a string denoting the bus address. INTERFACE is a -string which denotes a D-Bus interface, and MEMBER, also a string, is -either a method, a signal or a property INTERFACE is offering. All -arguments but BUS must not be nil. +[INTERFACE MEMBER]). TYPE is one of the Lisp symbols `:method', +`:signal', `:property' or `:monitor'. BUS is either a Lisp symbol, +`:system', `:session', `:system-private' or `:session-private', or a +string denoting the bus address. INTERFACE is a string which denotes +a D-Bus interface, and MEMBER, also a string, is either a method, a +signal or a property INTERFACE is offering. All arguments can be nil. The value in the hash table is a list of quadruple lists ((UNAME SERVICE PATH OBJECT [RULE]) ...). SERVICE is the service name as registered, UNAME is the corresponding unique name. In case of -registered methods and properties, UNAME is nil. PATH is the object -path of the sending object. All of them can be nil, which means a -wildcard then. OBJECT is either the handler to be called when a D-Bus -message, which matches the key criteria, arrives (TYPE `:method' and -`:signal'), or a cons cell containing the value of the property (TYPE -`:property'). - -For entries of type `:signal', there is also a fifth element RULE, -which keeps the match string the signal is registered with. +registered methods, properties and monitors, UNAME is nil. PATH is +the object path of the sending object. All of them can be nil, which +means a wildcard then. + +OBJECT is either the handler to be called when a D-Bus message, which +matches the key criteria, arrives (TYPE `:method', `:signal' and +`:monitor'), or a list (ACCESS EMITS-SIGNAL VALUE) for TYPE +`:property'. + +For entries of type `:signal' or `:monitor', there is also a fifth +element RULE, which keeps the match string the signal or monitor is +registered with. In the second case, the key in the hash table is the list (:serial BUS SERIAL). BUS is either a Lisp symbol, `:system' or `:session', or a diff --git a/src/deps.mk b/src/deps.mk index f242c1649ce..eda2ed63382 100644 --- a/src/deps.mk +++ b/src/deps.mk @@ -239,9 +239,6 @@ xfont.o: dispextern.h xterm.h frame.h blockinput.h character.h charset.h \ xftfont.o: xftfont.c dispextern.h xterm.h frame.h blockinput.h character.h \ charset.h font.h lisp.h globals.h $(config_h) atimer.h systime.h \ fontset.h ccl.h ftfont.h composite.h -ftxfont.o: ftxfont.c dispextern.h xterm.h frame.h blockinput.h character.h \ - charset.h font.h lisp.h globals.h $(config_h) atimer.h systime.h \ - fontset.h ccl.h menu.o: menu.c lisp.h keyboard.h keymap.h frame.h termhooks.h blockinput.h \ dispextern.h $(srcdir)/../lwlib/lwlib.h xterm.h gtkutil.h menu.h \ lisp.h globals.h $(config_h) systime.h coding.h composite.h window.h \ diff --git a/src/dired.c b/src/dired.c index dbf93a91831..ebcf77bc263 100644 --- a/src/dired.c +++ b/src/dired.c @@ -165,8 +165,16 @@ read_dirent (DIR *dir, Lisp_Object dirname) Lisp_Object directory_files_internal (Lisp_Object directory, Lisp_Object full, Lisp_Object match, Lisp_Object nosort, bool attrs, - Lisp_Object id_format) + Lisp_Object id_format, Lisp_Object return_count) { + EMACS_INT ind = 0, last = MOST_POSITIVE_FIXNUM; + + if (!NILP (return_count)) + { + CHECK_FIXNAT (return_count); + last = XFIXNAT (return_count); + } + if (!NILP (match)) CHECK_STRING (match); @@ -267,6 +275,10 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full, else finalname = name; + if (ind == last) + break; + ind ++; + list = Fcons (attrs ? Fcons (finalname, fileattrs) : finalname, list); } @@ -288,17 +300,20 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full, } -DEFUN ("directory-files", Fdirectory_files, Sdirectory_files, 1, 4, 0, +DEFUN ("directory-files", Fdirectory_files, Sdirectory_files, 1, 5, 0, doc: /* Return a list of names of files in DIRECTORY. -There are three optional arguments: +There are four optional arguments: If FULL is non-nil, return absolute file names. Otherwise return names that are relative to the specified directory. -If MATCH is non-nil, mention only file names that match the regexp MATCH. +If MATCH is non-nil, mention only file names whose non-directory part + matches the regexp MATCH. If NOSORT is non-nil, the list is not sorted--its order is unpredictable. Otherwise, the list returned is sorted with `string-lessp'. - NOSORT is useful if you plan to sort the result yourself. */) + NOSORT is useful if you plan to sort the result yourself. +If COUNT is non-nil and a natural number, the function will return + COUNT number of file names (if so many are present). */) (Lisp_Object directory, Lisp_Object full, Lisp_Object match, - Lisp_Object nosort) + Lisp_Object nosort, Lisp_Object count) { directory = Fexpand_file_name (directory, Qnil); @@ -306,14 +321,15 @@ If NOSORT is non-nil, the list is not sorted--its order is unpredictable. call the corresponding file name handler. */ Lisp_Object handler = Ffind_file_name_handler (directory, Qdirectory_files); if (!NILP (handler)) - return call5 (handler, Qdirectory_files, directory, - full, match, nosort); + return call6 (handler, Qdirectory_files, directory, + full, match, nosort, count); - return directory_files_internal (directory, full, match, nosort, false, Qnil); + return directory_files_internal (directory, full, match, nosort, + false, Qnil, count); } DEFUN ("directory-files-and-attributes", Fdirectory_files_and_attributes, - Sdirectory_files_and_attributes, 1, 5, 0, + Sdirectory_files_and_attributes, 1, 6, 0, doc: /* Return a list of names of files and their attributes in DIRECTORY. Value is a list of the form: @@ -322,18 +338,21 @@ Value is a list of the form: where each FILEn-ATTRS is the attributes of FILEn as returned by `file-attributes'. -This function accepts four optional arguments: +This function accepts five optional arguments: If FULL is non-nil, return absolute file names. Otherwise return names that are relative to the specified directory. -If MATCH is non-nil, mention only file names that match the regexp MATCH. +If MATCH is non-nil, mention only file names whose non-directory part + matches the regexp MATCH. If NOSORT is non-nil, the list is not sorted--its order is unpredictable. NOSORT is useful if you plan to sort the result yourself. ID-FORMAT specifies the preferred format of attributes uid and gid, see -`file-attributes' for further documentation. + `file-attributes' for further documentation. +If COUNT is non-nil and a natural number, the function will return + COUNT number of file names (if so many are present). On MS-Windows, performance depends on `w32-get-true-file-attributes', which see. */) (Lisp_Object directory, Lisp_Object full, Lisp_Object match, - Lisp_Object nosort, Lisp_Object id_format) + Lisp_Object nosort, Lisp_Object id_format, Lisp_Object count) { directory = Fexpand_file_name (directory, Qnil); @@ -342,11 +361,11 @@ which see. */) Lisp_Object handler = Ffind_file_name_handler (directory, Qdirectory_files_and_attributes); if (!NILP (handler)) - return call6 (handler, Qdirectory_files_and_attributes, - directory, full, match, nosort, id_format); + return call7 (handler, Qdirectory_files_and_attributes, + directory, full, match, nosort, id_format, count); return directory_files_internal (directory, full, match, nosort, - true, id_format); + true, id_format, count); } @@ -929,7 +948,7 @@ file_attributes (int fd, char const *name, struct stat s; /* An array to hold the mode string generated by filemodestring, - including its terminating space and NUL byte. */ + including its terminating space and null byte. */ char modes[sizeof "-rwxr-xr-x "]; char *uname = NULL, *gname = NULL; @@ -937,7 +956,7 @@ file_attributes (int fd, char const *name, int err = EINVAL; #if defined O_PATH && !defined HAVE_CYGWIN_O_PATH_BUG - int namefd = openat (fd, name, O_PATH | O_CLOEXEC | O_NOFOLLOW); + int namefd = emacs_openat (fd, name, O_PATH | O_CLOEXEC | O_NOFOLLOW, 0); if (namefd < 0) err = errno; else @@ -970,7 +989,7 @@ file_attributes (int fd, char const *name, information to be accurate. */ w32_stat_get_owner_group = 1; #endif - err = fstatat (fd, name, &s, AT_SYMLINK_NOFOLLOW) == 0 ? 0 : errno; + err = emacs_fstatat (fd, name, &s, AT_SYMLINK_NOFOLLOW) == 0 ? 0 : errno; #ifdef WINDOWSNT w32_stat_get_owner_group = 0; #endif diff --git a/src/dispextern.h b/src/dispextern.h index f772590c872..f4e872644db 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -102,7 +102,7 @@ typedef XImage *Emacs_Pix_Context; #endif #ifdef USE_CAIRO -/* Mininal version of XImage. */ +/* Minimal version of XImage. */ typedef struct { int width, height; /* size of image */ @@ -234,7 +234,7 @@ struct text_pos { \ ++(POS).charpos; \ if (MULTIBYTE_P) \ - INC_POS ((POS).bytepos); \ + (POS).bytepos += next_char_len ((POS).bytepos); \ else \ ++(POS).bytepos; \ } \ @@ -247,7 +247,7 @@ struct text_pos { \ --(POS).charpos; \ if (MULTIBYTE_P) \ - DEC_POS ((POS).bytepos); \ + (POS).bytepos -= prev_char_len ((POS).bytepos); \ else \ --(POS).bytepos; \ } \ @@ -369,7 +369,7 @@ enum glyph_type /* Glyph describes a character. */ CHAR_GLYPH, - /* Glyph describes a static composition. */ + /* Glyph describes a static or automatic composition. */ COMPOSITE_GLYPH, /* Glyph describes a glyphless character. */ @@ -1693,12 +1693,17 @@ struct face int fontset; /* Non-zero means characters in this face have a box of that - thickness around them. If this value is negative, its absolute - value indicates the thickness, and the horizontal (top and - bottom) borders of box are drawn inside of the character glyphs' - area. The vertical (left and right) borders of the box are drawn - in the same way as when this value is positive. */ - int box_line_width; + thickness around them. Vertical (left and right) and horizontal + (top and bottom) borders size can be set separatedly using an + associated list of two ints in the form + (vertical_size . horizontal_size). In case one of the value is + negative, its absolute value indicates the thickness, and the + borders of box are drawn inside of the character glyphs' area + potentially over the glyph itself but the glyph drawing size is + not increase. If a (signed) int N is use instead of a list, it + is the same as setting ( abs(N) . N ) values. */ + int box_vertical_line_width; + int box_horizontal_line_width; /* Type of box drawn. A value of FACE_NO_BOX means no box is drawn around text in this face. A value of FACE_SIMPLE_BOX means a box @@ -1739,6 +1744,7 @@ struct face bool_bf tty_italic_p : 1; bool_bf tty_underline_p : 1; bool_bf tty_reverse_p : 1; + bool_bf tty_strike_through_p : 1; /* True means that colors of this face may not be freed because they have been copied bitwise from a base face (see @@ -1820,6 +1826,7 @@ enum face_id WINDOW_DIVIDER_FIRST_PIXEL_FACE_ID, WINDOW_DIVIDER_LAST_PIXEL_FACE_ID, INTERNAL_BORDER_FACE_ID, + CHILD_FRAME_BORDER_FACE_ID, TAB_BAR_FACE_ID, TAB_LINE_FACE_ID, BASIC_FACE_ID_SENTINEL @@ -1850,20 +1857,6 @@ struct face_cache bool_bf menu_face_changed_p : 1; }; -/* Return a non-null pointer to the cached face with ID on frame F. */ - -#define FACE_FROM_ID(F, ID) \ - (eassert (UNSIGNED_CMP (ID, <, FRAME_FACE_CACHE (F)->used)), \ - FRAME_FACE_CACHE (F)->faces_by_id[ID]) - -/* Return a pointer to the face with ID on frame F, or null if such a - face doesn't exist. */ - -#define FACE_FROM_ID_OR_NULL(F, ID) \ - (UNSIGNED_CMP (ID, <, FRAME_FACE_CACHE (F)->used) \ - ? FRAME_FACE_CACHE (F)->faces_by_id[ID] \ - : NULL) - #define FACE_EXTENSIBLE_P(F) \ (!NILP (F->lface[LFACE_EXTEND_INDEX])) @@ -2004,7 +1997,7 @@ struct bidi_string_data { Lisp_Object lstring; /* Lisp string to reorder, or nil */ const unsigned char *s; /* string data, or NULL if reordering buffer */ ptrdiff_t schars; /* the number of characters in the string, - excluding the terminating NUL */ + excluding the terminating null */ ptrdiff_t bufpos; /* buffer position of lstring, or 0 if N/A */ bool_bf from_disp_str : 1; /* True means the string comes from a display property */ @@ -2782,7 +2775,8 @@ struct it else \ produce_glyphs ((IT)); \ if ((IT)->glyph_row != NULL) \ - inhibit_free_realized_faces = true; \ + inhibit_free_realized_faces =true; \ + reset_box_start_end_flags ((IT)); \ } while (false) /* Bit-flags indicating what operation move_it_to should perform. */ @@ -3068,9 +3062,9 @@ struct image if necessary. */ unsigned long background; - /* Foreground and background colors of the frame on which the image + /* Foreground and background colors of the face on which the image is created. */ - unsigned long frame_foreground, frame_background; + unsigned long face_foreground, face_background; /* True if this image has a `transparent' background -- that is, is uses an image mask. The accessor macro for this is @@ -3161,21 +3155,6 @@ struct image_cache ptrdiff_t refcount; }; - -/* A non-null pointer to the image with id ID on frame F. */ - -#define IMAGE_FROM_ID(F, ID) \ - (eassert (UNSIGNED_CMP (ID, <, FRAME_IMAGE_CACHE (F)->used)), \ - FRAME_IMAGE_CACHE (F)->images[ID]) - -/* Value is a pointer to the image with id ID on frame F, or null if - no image with that id exists. */ - -#define IMAGE_OPT_FROM_ID(F, ID) \ - (UNSIGNED_CMP (ID, <, FRAME_IMAGE_CACHE (F)->used) \ - ? FRAME_IMAGE_CACHE (F)->images[ID] \ - : NULL) - /* Size of bucket vector of image caches. Should be prime. */ #define IMAGE_CACHE_BUCKETS_SIZE 1001 @@ -3317,6 +3296,7 @@ enum tool_bar_item_image #define TTY_CAP_BOLD 0x04 #define TTY_CAP_DIM 0x08 #define TTY_CAP_ITALIC 0x10 +#define TTY_CAP_STRIKE_THROUGH 0x20 /*********************************************************************** @@ -3502,7 +3482,7 @@ void clear_image_caches (Lisp_Object); void mark_image_cache (struct image_cache *); bool valid_image_p (Lisp_Object); void prepare_image_for_display (struct frame *, struct image *); -ptrdiff_t lookup_image (struct frame *, Lisp_Object); +ptrdiff_t lookup_image (struct frame *, Lisp_Object, int); #if defined HAVE_X_WINDOWS || defined USE_CAIRO || defined HAVE_NS #define RGB_PIXEL_COLOR unsigned long @@ -3541,6 +3521,8 @@ void update_face_from_frame_parameter (struct frame *, Lisp_Object, Lisp_Object); extern bool tty_defined_color (struct frame *, const char *, Emacs_Color *, bool, bool); +bool parse_color_spec (const char *, + unsigned short *, unsigned short *, unsigned short *); Lisp_Object tty_color_name (struct frame *, int); void clear_face_cache (bool); @@ -3629,6 +3611,7 @@ extern Lisp_Object marginal_area_string (struct window *, enum window_part, extern void redraw_frame (struct frame *); extern bool update_frame (struct frame *, bool, bool); extern void update_frame_with_menu (struct frame *, int, int); +extern int update_mouse_position (struct frame *, int, int); extern void bitch_at_user (void); extern void adjust_frame_glyphs (struct frame *); void free_glyphs (struct frame *); diff --git a/src/dispnew.c b/src/dispnew.c index 991a20b7383..e603c671363 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -25,7 +25,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <unistd.h> #include "lisp.h" -#include "ptr-bounds.h" #include "termchar.h" /* cm.h must come after dispextern.h on Windows. */ #include "dispextern.h" @@ -881,7 +880,7 @@ clear_glyph_row (struct glyph_row *row) enum { off = offsetof (struct glyph_row, used) }; /* Zero everything except pointers in `glyphs'. */ - memset (row->used, 0, sizeof *row - off); + memset ((char *) row + off, 0, sizeof *row - off); } @@ -1831,7 +1830,7 @@ adjust_frame_glyphs (struct frame *f) /* Don't forget the buffer for decode_mode_spec. */ adjust_decode_mode_spec_buffer (f); - f->glyphs_initialized_p = 1; + f->glyphs_initialized_p = true; unblock_input (); } @@ -2252,7 +2251,7 @@ free_glyphs (struct frame *f) /* Block interrupt input so that we don't get surprised by an X event while we're in an inconsistent state. */ block_input (); - f->glyphs_initialized_p = 0; + f->glyphs_initialized_p = false; /* Release window sub-matrices. */ if (!NILP (f->root_window)) @@ -3241,9 +3240,16 @@ update_frame (struct frame *f, bool force_p, bool inhibit_hairy_id_p) build_frame_matrix (f); /* Update the display. */ - update_begin (f); - paused_p = update_frame_1 (f, force_p, inhibit_hairy_id_p, 1, false); - update_end (f); + if (FRAME_INITIAL_P (f)) + /* No actual display to update so the "update" is a nop and + obviously isn't interrupted by pending input. */ + paused_p = false; + else + { + update_begin (f); + paused_p = update_frame_1 (f, force_p, inhibit_hairy_id_p, 1, false); + update_end (f); + } if (FRAME_TERMCAP_P (f) || FRAME_MSDOS_P (f)) { @@ -3321,6 +3327,53 @@ update_frame_with_menu (struct frame *f, int row, int col) display_completed = !paused_p; } +/* Update the mouse position for a frame F. This handles both + updating the display for mouse-face propreties and updating the + help echo text. + + Returns the number of events generated. */ +int +update_mouse_position (struct frame *f, int x, int y) +{ + previous_help_echo_string = help_echo_string; + help_echo_string = Qnil; + + note_mouse_highlight (f, x, y); + + /* If the contents of the global variable help_echo_string + has changed, generate a HELP_EVENT. */ + if (!NILP (help_echo_string) + || !NILP (previous_help_echo_string)) + { + Lisp_Object frame; + XSETFRAME (frame, f); + + gen_help_event (help_echo_string, frame, help_echo_window, + help_echo_object, help_echo_pos); + return 1; + } + + return 0; +} + +DEFUN ("display--update-for-mouse-movement", Fdisplay__update_for_mouse_movement, + Sdisplay__update_for_mouse_movement, 2, 2, 0, + doc: /* Handle mouse movement detected by Lisp code. + +This function should be called when Lisp code detects the mouse has +moved, even if `track-mouse' is nil. This handles updates that do not +rely on input events such as updating display for mouse-face +properties or updating the help echo text. */) + (Lisp_Object mouse_x, Lisp_Object mouse_y) +{ + CHECK_FIXNUM (mouse_x); + CHECK_FIXNUM (mouse_y); + + update_mouse_position (SELECTED_FRAME (), XFIXNUM (mouse_x), + XFIXNUM (mouse_y)); + return Qnil; +} + /************************************************************************ Window-based updates @@ -4895,12 +4948,6 @@ scrolling (struct frame *frame) unsigned *new_hash = old_hash + height; int *draw_cost = (int *) (new_hash + height); int *old_draw_cost = draw_cost + height; - old_hash = ptr_bounds_clip (old_hash, height * sizeof *old_hash); - new_hash = ptr_bounds_clip (new_hash, height * sizeof *new_hash); - draw_cost = ptr_bounds_clip (draw_cost, height * sizeof *draw_cost); - old_draw_cost = ptr_bounds_clip (old_draw_cost, - height * sizeof *old_draw_cost); - eassert (current_matrix); /* Compute hash codes of all the lines. Also calculate number of @@ -6002,7 +6049,14 @@ additional wait period, in milliseconds; this is for backwards compatibility. READING is true if reading input. If DISPLAY_OPTION is >0 display process output while waiting. If DISPLAY_OPTION is >1 perform an initial redisplay before waiting. -*/ + + Returns a boolean Qt if we waited the full time and returns Qnil if the + wait was interrupted by incoming process output or keyboard events. + + FIXME: When `wait_reading_process_output` returns early because of + process output, instead of returning nil we should loop and wait some + more (i.e. until either there's pending input events or the timeout + expired). */ Lisp_Object sit_for (Lisp_Object timeout, bool reading, int display_option) @@ -6010,6 +6064,8 @@ sit_for (Lisp_Object timeout, bool reading, int display_option) intmax_t sec; int nsec; bool do_display = display_option > 0; + bool curbuf_eq_winbuf + = (current_buffer == XBUFFER (XWINDOW (selected_window)->contents)); swallow_events (do_display); @@ -6061,10 +6117,18 @@ sit_for (Lisp_Object timeout, bool reading, int display_option) gobble_input (); #endif - wait_reading_process_output (sec, nsec, reading ? -1 : 1, do_display, - Qnil, NULL, 0); + int nbytes + = wait_reading_process_output (sec, nsec, reading ? -1 : 1, do_display, + Qnil, NULL, 0); + + if (reading && curbuf_eq_winbuf) + /* Timers and process filters/sentinels may have changed the selected + window (e.g. in response to a connection from emacsclient), in which + case we should follow it (unless we weren't in the selected-window's + buffer to start with). */ + set_buffer_internal (XBUFFER (XWINDOW (selected_window)->contents)); - return detect_input_pending () ? Qnil : Qt; + return (nbytes > 0 || detect_input_pending ()) ? Qnil : Qt; } @@ -6498,6 +6562,7 @@ syms_of_display (void) { defsubr (&Sredraw_frame); defsubr (&Sredraw_display); + defsubr (&Sdisplay__update_for_mouse_movement); defsubr (&Sframe_or_buffer_changed_p); defsubr (&Sopen_termscript); defsubr (&Sding); diff --git a/src/doc.c b/src/doc.c index 960900bdc0f..1307aa5ee92 100644 --- a/src/doc.c +++ b/src/doc.c @@ -82,10 +82,7 @@ Lisp_Object get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) { char *from, *to, *name, *p, *p1; - int fd; - int offset; - EMACS_INT position; - Lisp_Object file, tem, pos; + Lisp_Object file, pos; ptrdiff_t count = SPECPDL_INDEX (); USE_SAFE_ALLOCA; @@ -102,7 +99,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) else return Qnil; - position = eabs (XFIXNUM (pos)); + EMACS_INT position = eabs (XFIXNUM (pos)); if (!STRINGP (Vdoc_directory)) return Qnil; @@ -113,7 +110,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) /* Put the file name in NAME as a C string. If it is relative, combine it with Vdoc_directory. */ - tem = Ffile_name_absolute_p (file); + Lisp_Object tem = Ffile_name_absolute_p (file); file = ENCODE_FILE (file); Lisp_Object docdir = NILP (tem) ? ENCODE_FILE (Vdoc_directory) : empty_unibyte_string; @@ -123,7 +120,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) name = SAFE_ALLOCA (docdir_sizemax + SBYTES (file)); lispstpcpy (lispstpcpy (name, docdir), file); - fd = emacs_open (name, O_RDONLY, 0); + int fd = emacs_open (name, O_RDONLY, 0); if (fd < 0) { if (will_dump_p ()) @@ -150,7 +147,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) /* Seek only to beginning of disk block. */ /* Make sure we read at least 1024 bytes before `position' so we can check the leading text for consistency. */ - offset = min (position, max (1024, position % (8 * 1024))); + int offset = min (position, max (1024, position % (8 * 1024))); if (TYPE_MAXIMUM (off_t) < position || lseek (fd, position - offset, 0) < 0) error ("Position %"pI"d out of range in doc string file \"%s\"", @@ -164,7 +161,6 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) { ptrdiff_t space_left = (get_doc_string_buffer_size - 1 - (p - get_doc_string_buffer)); - int nread; /* Allocate or grow the buffer if we need to. */ if (space_left <= 0) @@ -182,7 +178,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) If we read the same block last time, maybe skip this? */ if (space_left > 1024 * 8) space_left = 1024 * 8; - nread = emacs_read_quit (fd, p, space_left); + int nread = emacs_read_quit (fd, p, space_left); if (nread < 0) report_file_error ("Read error on documentation file", file); p[nread] = 0; @@ -233,17 +229,15 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) } /* Scan the text and perform quoting with ^A (char code 1). - ^A^A becomes ^A, ^A0 becomes a NUL char, and ^A_ becomes a ^_. */ + ^A^A becomes ^A, ^A0 becomes a null char, and ^A_ becomes a ^_. */ from = get_doc_string_buffer + offset; to = get_doc_string_buffer + offset; while (from != p) { if (*from == 1) { - int c; - from++; - c = *from++; + int c = *from++; if (c == 1) *to++ = c; else if (c == '0') @@ -313,10 +307,8 @@ Unless a non-nil second argument RAW is given, the string is passed through `substitute-command-keys'. */) (Lisp_Object function, Lisp_Object raw) { - Lisp_Object fun; - Lisp_Object funcar; Lisp_Object doc; - bool try_reload = 1; + bool try_reload = true; documentation: @@ -330,7 +322,7 @@ string is passed through `substitute-command-keys'. */) raw); } - fun = Findirect_function (function, Qnil); + Lisp_Object fun = Findirect_function (function, Qnil); if (NILP (fun)) xsignal1 (Qvoid_function, function); if (CONSP (fun) && EQ (XCAR (fun), Qmacro)) @@ -362,7 +354,7 @@ string is passed through `substitute-command-keys'. */) } else if (CONSP (fun)) { - funcar = XCAR (fun); + Lisp_Object funcar = XCAR (fun); if (!SYMBOLP (funcar)) xsignal1 (Qinvalid_function, fun); else if (EQ (funcar, Qkeymap)) @@ -406,7 +398,7 @@ string is passed through `substitute-command-keys'. */) try_reload = reread_doc_file (Fcar_safe (doc)); if (try_reload) { - try_reload = 0; + try_reload = false; goto documentation; } } @@ -415,7 +407,7 @@ string is passed through `substitute-command-keys'. */) } if (NILP (raw)) - doc = Fsubstitute_command_keys (doc); + doc = call1 (Qsubstitute_command_keys, doc); return doc; } @@ -430,7 +422,7 @@ This differs from `get' in that it can refer to strings stored in the aren't strings. */) (Lisp_Object symbol, Lisp_Object prop, Lisp_Object raw) { - bool try_reload = 1; + bool try_reload = true; Lisp_Object tem; documentation_property: @@ -462,7 +454,7 @@ aren't strings. */) try_reload = reread_doc_file (Fcar_safe (doc)); if (try_reload) { - try_reload = 0; + try_reload = false; goto documentation_property; } } @@ -472,7 +464,7 @@ aren't strings. */) tem = Feval (tem, Qnil); if (NILP (raw) && STRINGP (tem)) - tem = Fsubstitute_command_keys (tem); + tem = call1 (Qsubstitute_command_keys, tem); return tem; } @@ -492,9 +484,7 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) fun = XCDR (fun); if (CONSP (fun)) { - Lisp_Object tem; - - tem = XCAR (fun); + Lisp_Object tem = XCAR (fun); if (EQ (tem, Qlambda) || EQ (tem, Qautoload) || (EQ (tem, Qclosure) && (fun = XCDR (fun), 1))) { @@ -682,329 +672,36 @@ default_to_grave_quoting_style (void) && EQ (AREF (dv, 0), make_fixnum ('`'))); } -/* Return the current effective text quoting style. */ -enum text_quoting_style -text_quoting_style (void) +DEFUN ("text-quoting-style", Ftext_quoting_style, + Stext_quoting_style, 0, 0, 0, + doc: /* Return the current effective text quoting style. +See variable `text-quoting-style'. */) + (void) { + /* Use grave accent and apostrophe `like this'. */ if (NILP (Vtext_quoting_style) ? default_to_grave_quoting_style () : EQ (Vtext_quoting_style, Qgrave)) - return GRAVE_QUOTING_STYLE; - else if (EQ (Vtext_quoting_style, Qstraight)) - return STRAIGHT_QUOTING_STYLE; - else - return CURVE_QUOTING_STYLE; -} - -DEFUN ("substitute-command-keys", Fsubstitute_command_keys, - Ssubstitute_command_keys, 1, 1, 0, - doc: /* Substitute key descriptions for command names in STRING. -Each substring of the form \\=\\[COMMAND] is replaced by either a -keystroke sequence that invokes COMMAND, or "M-x COMMAND" if COMMAND -is not on any keys. - -Each substring of the form \\=\\{MAPVAR} is replaced by a summary of -the value of MAPVAR as a keymap. This summary is similar to the one -produced by `describe-bindings'. The summary ends in two newlines -\(used by the helper function `help-make-xrefs' to find the end of the -summary). - -Each substring of the form \\=\\<MAPVAR> specifies the use of MAPVAR -as the keymap for future \\=\\[COMMAND] substrings. - -Each grave accent \\=` is replaced by left quote, and each apostrophe \\=' -is replaced by right quote. Left and right quote characters are -specified by `text-quoting-style'. - -\\=\\= quotes the following character and is discarded; thus, \\=\\=\\=\\= puts \\=\\= -into the output, \\=\\=\\=\\[ puts \\=\\[ into the output, and \\=\\=\\=` puts \\=` into the -output. - -Return the original STRING if no substitutions are made. -Otherwise, return a new string (without any text properties). */) - (Lisp_Object string) -{ - char *buf; - bool changed = false; - bool nonquotes_changed = false; - unsigned char *strp; - char *bufp; - ptrdiff_t idx; - ptrdiff_t bsize; - Lisp_Object tem; - Lisp_Object keymap; - unsigned char const *start; - ptrdiff_t length, length_byte; - Lisp_Object name; - ptrdiff_t nchars; - - if (NILP (string)) - return Qnil; - - /* If STRING contains non-ASCII unibyte data, process its - properly-encoded multibyte equivalent instead. This simplifies - the implementation and is OK since substitute-command-keys is - intended for use only on text strings. Keep STRING around, since - it will be returned if no changes occur. */ - Lisp_Object str = Fstring_make_multibyte (string); - - enum text_quoting_style quoting_style = text_quoting_style (); - - nchars = 0; - - /* KEYMAP is either nil (which means search all the active keymaps) - or a specified local map (which means search just that and the - global map). If non-nil, it might come from Voverriding_local_map, - or from a \\<mapname> construct in STRING itself.. */ - keymap = Voverriding_local_map; - - ptrdiff_t strbytes = SBYTES (str); - bsize = strbytes; - - /* Fixed-size stack buffer. */ - char sbuf[MAX_ALLOCA]; - - /* Heap-allocated buffer, if any. */ - char *abuf; - - /* Extra room for expansion due to replacing ‘\[]’ with ‘M-x ’. */ - enum { EXTRA_ROOM = sizeof "M-x " - sizeof "\\[]" }; - - ptrdiff_t count = SPECPDL_INDEX (); - - if (bsize <= sizeof sbuf - EXTRA_ROOM) - { - abuf = NULL; - buf = sbuf; - bsize = sizeof sbuf; - } - else - { - buf = abuf = xpalloc (NULL, &bsize, EXTRA_ROOM, STRING_BYTES_BOUND, 1); - record_unwind_protect_ptr (xfree, abuf); - } - bufp = buf; - - strp = SDATA (str); - while (strp < SDATA (str) + strbytes) - { - unsigned char *close_bracket; - - if (strp[0] == '\\' && strp[1] == '=' - && strp + 2 < SDATA (str) + strbytes) - { - /* \= quotes the next character; - thus, to put in \[ without its special meaning, use \=\[. */ - changed = nonquotes_changed = true; - strp += 2; - /* Fall through to copy one char. */ - } - else if (strp[0] == '\\' && strp[1] == '[' - && (close_bracket - = memchr (strp + 2, ']', - SDATA (str) + strbytes - (strp + 2)))) - { - bool follow_remap = 1; - - start = strp + 2; - length_byte = close_bracket - start; - idx = close_bracket + 1 - SDATA (str); + return Qgrave; - name = Fintern (make_string ((char *) start, length_byte), Qnil); - - do_remap: - tem = Fwhere_is_internal (name, keymap, Qt, Qnil, Qnil); - - if (VECTORP (tem) && ASIZE (tem) > 1 - && EQ (AREF (tem, 0), Qremap) && SYMBOLP (AREF (tem, 1)) - && follow_remap) - { - name = AREF (tem, 1); - follow_remap = 0; - goto do_remap; - } - - /* Fwhere_is_internal can GC, so take relocation of string - contents into account. */ - strp = SDATA (str) + idx; - start = strp - length_byte - 1; - - if (NILP (tem)) /* but not on any keys */ - { - memcpy (bufp, "M-x ", 4); - bufp += 4; - nchars += 4; - length = multibyte_chars_in_text (start, length_byte); - goto subst; - } - else - { /* function is on a key */ - tem = Fkey_description (tem, Qnil); - goto subst_string; - } - } - /* \{foo} is replaced with a summary of the keymap (symbol-value foo). - \<foo> just sets the keymap used for \[cmd]. */ - else if (strp[0] == '\\' && (strp[1] == '{' || strp[1] == '<') - && (close_bracket - = memchr (strp + 2, strp[1] == '{' ? '}' : '>', - SDATA (str) + strbytes - (strp + 2)))) - { - { - bool generate_summary = strp[1] == '{'; - /* This is for computing the SHADOWS arg for describe_map_tree. */ - Lisp_Object active_maps = Fcurrent_active_maps (Qnil, Qnil); - ptrdiff_t count = SPECPDL_INDEX (); - - start = strp + 2; - length_byte = close_bracket - start; - idx = close_bracket + 1 - SDATA (str); - - /* Get the value of the keymap in TEM, or nil if undefined. - Do this while still in the user's current buffer - in case it is a local variable. */ - name = Fintern (make_string ((char *) start, length_byte), Qnil); - tem = Fboundp (name); - if (! NILP (tem)) - { - tem = Fsymbol_value (name); - if (! NILP (tem)) - tem = get_keymap (tem, 0, 1); - } - - /* Now switch to a temp buffer. */ - struct buffer *oldbuf = current_buffer; - set_buffer_internal (XBUFFER (Vprin1_to_string_buffer)); - /* This is for an unusual case where some after-change - function uses 'format' or 'prin1' or something else that - will thrash Vprin1_to_string_buffer we are using. */ - specbind (Qinhibit_modification_hooks, Qt); - - if (NILP (tem)) - { - name = Fsymbol_name (name); - AUTO_STRING (msg_prefix, "\nUses keymap `"); - insert1 (Fsubstitute_command_keys (msg_prefix)); - insert_from_string (name, 0, 0, - SCHARS (name), - SBYTES (name), 1); - AUTO_STRING (msg_suffix, "', which is not currently defined.\n"); - insert1 (Fsubstitute_command_keys (msg_suffix)); - if (!generate_summary) - keymap = Qnil; - } - else if (!generate_summary) - keymap = tem; - else - { - /* Get the list of active keymaps that precede this one. - If this one's not active, get nil. */ - Lisp_Object earlier_maps - = Fcdr (Fmemq (tem, Freverse (active_maps))); - describe_map_tree (tem, 1, Fnreverse (earlier_maps), - Qnil, 0, 1, 0, 0, 1); - } - tem = Fbuffer_string (); - Ferase_buffer (); - set_buffer_internal (oldbuf); - unbind_to (count, Qnil); - } - - subst_string: - /* Convert non-ASCII unibyte data to properly-encoded multibyte, - for the same reason STRING was converted to STR. */ - tem = Fstring_make_multibyte (tem); - start = SDATA (tem); - length = SCHARS (tem); - length_byte = SBYTES (tem); - subst: - nonquotes_changed = true; - subst_quote: - changed = true; - { - ptrdiff_t offset = bufp - buf; - ptrdiff_t avail = bsize - offset; - ptrdiff_t need = strbytes - idx; - if (INT_ADD_WRAPV (need, length_byte + EXTRA_ROOM, &need)) - string_overflow (); - if (avail < need) - { - abuf = xpalloc (abuf, &bsize, need - avail, - STRING_BYTES_BOUND, 1); - if (buf == sbuf) - { - record_unwind_protect_ptr (xfree, abuf); - memcpy (abuf, sbuf, offset); - } - else - set_unwind_protect_ptr (count, xfree, abuf); - buf = abuf; - bufp = buf + offset; - } - memcpy (bufp, start, length_byte); - bufp += length_byte; - nchars += length; - - /* Some of the previous code can GC, so take relocation of - string contents into account. */ - strp = SDATA (str) + idx; - - continue; - } - } - else if ((strp[0] == '`' || strp[0] == '\'') - && quoting_style == CURVE_QUOTING_STYLE) - { - start = (unsigned char const *) (strp[0] == '`' ? uLSQM : uRSQM); - length = 1; - length_byte = sizeof uLSQM - 1; - idx = strp - SDATA (str) + 1; - goto subst_quote; - } - else if (strp[0] == '`' && quoting_style == STRAIGHT_QUOTING_STYLE) - { - *bufp++ = '\''; - strp++; - nchars++; - changed = true; - continue; - } - - /* Copy one char. */ - do - *bufp++ = *strp++; - while (! CHAR_HEAD_P (*strp)); - nchars++; - } + /* Use apostrophes 'like this'. */ + else if (EQ (Vtext_quoting_style, Qstraight)) + return Qstraight; - if (changed) /* don't bother if nothing substituted */ - { - tem = make_string_from_bytes (buf, nchars, bufp - buf); - if (!nonquotes_changed) - { - /* Nothing has changed other than quoting, so copy the string’s - text properties. FIXME: Text properties should survive other - changes too; see bug#17052. */ - INTERVAL interval_copy = copy_intervals (string_intervals (string), - 0, SCHARS (string)); - if (interval_copy) - { - set_interval_object (interval_copy, tem); - set_string_intervals (tem, interval_copy); - } - } - } + /* Use curved single quotes ‘like this’. */ else - tem = string; - return unbind_to (count, tem); + return Qcurve; } + void syms_of_doc (void) { + DEFSYM (Qsubstitute_command_keys, "substitute-command-keys"); DEFSYM (Qfunction_documentation, "function-documentation"); DEFSYM (Qgrave, "grave"); DEFSYM (Qstraight, "straight"); + DEFSYM (Qcurve, "curve"); DEFVAR_LISP ("internal-doc-file-name", Vdoc_file_name, doc: /* Name of file containing documentation strings of built-in symbols. */); @@ -1036,5 +733,5 @@ otherwise. */); defsubr (&Sdocumentation); defsubr (&Sdocumentation_property); defsubr (&Ssnarf_documentation); - defsubr (&Ssubstitute_command_keys); + defsubr (&Stext_quoting_style); } diff --git a/src/doprnt.c b/src/doprnt.c index 7c5c43e6298..b6b5978c891 100644 --- a/src/doprnt.c +++ b/src/doprnt.c @@ -28,6 +28,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ . For %s and %c, when field width is specified (e.g., %25s), it accounts for the display width of each character, according to char-width-table. That is, it does not assume that each character takes one column on display. + Nor does it assume that each character is a single byte. . If the size of the buffer is not enough to produce the formatted string in its entirety, it makes sure that truncation does not chop the last @@ -35,19 +36,21 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ sequence. . It accepts a pointer to the end of the format string, so the format string - could include embedded NUL characters. + could include embedded null characters. . It signals an error if the length of the formatted string is about to overflow ptrdiff_t or size_t, to avoid producing strings longer than what Emacs can handle. OTOH, this function supports only a small subset of the standard C formatted - output facilities. E.g., %u and %ll are not supported, and precision is - ignored %s and %c conversions. (See below for the detailed documentation of - what is supported.) However, this is okay, as this function is supposed to - be called from `error' and similar functions, and thus does not need to - support features beyond those in `Fformat_message', which is used - by `error' on the Lisp level. */ + output facilities. E.g., %u is not supported, precision is ignored + in %s and %c conversions, and %lld does not necessarily work and + code should use something like %"pM"d with intmax_t instead. + (See below for the detailed documentation of what is supported.) + However, this is okay, as this function is supposed to be called + from 'error' and similar C functions, and thus does not need to + support all the features of 'Fformat_message', which is used by the + Lisp 'error' function. */ /* In the FORMAT argument this function supports ` and ' as directives that output left and right quotes as per ‘text-quoting style’. It @@ -61,19 +64,20 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ %e means print a `double' argument in exponential notation. %f means print a `double' argument in decimal-point notation. %g means print a `double' argument in exponential notation - or in decimal-point notation, whichever uses fewer characters. + or in decimal-point notation, depending on the value; + this is often (though not always) the shorter of the two notations. %c means print a `signed int' argument as a single character. %% means produce a literal % character. - A %-sequence may contain optional flag, width, and precision specifiers, and - a length modifier, as follows: + A %-sequence other than %% may contain optional flags, width, precision, + and length, as follows: %<flags><width><precision><length>character where flags is [+ -0], width is [0-9]+, precision is .[0-9]+, and length is empty or l or the value of the pD or pI or PRIdMAX (sans "d") macros. - Also, %% in a format stands for a single % in the output. A % that - does not introduce a valid %-sequence causes undefined behavior. + A % that does not introduce a valid %-sequence causes undefined behavior. + Bytes in FORMAT other than % are copied through as-is. The + flag character inserts a + before any positive number, while a space inserts a space before any positive number; these flags only affect %d, %o, @@ -99,7 +103,9 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ For %e, %f, and %g sequences, the number after the "." in the precision specifier says how many decimal places to show; if zero, the decimal point - itself is omitted. For %s and %S, the precision specifier is ignored. */ + itself is omitted. For %d, %o, and %x sequences, the precision specifies + the minimum number of digits to appear. Precision specifiers are + not supported for other %-sequences. */ #include <config.h> #include <stdio.h> @@ -115,7 +121,50 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ another macro. */ #include "character.h" +/* Enough to handle floating point formats with large numbers. */ +enum { SIZE_BOUND_EXTRA = DBL_MAX_10_EXP + 50 }; + +/* Parse FMT as an unsigned decimal integer, putting its value into *VALUE. + Return the address of the first byte after the integer. + If FMT is not an integer, return FMT and store zero into *VALUE. */ +static char const * +parse_format_integer (char const *fmt, int *value) +{ + int n = 0; + bool overflow = false; + for (; '0' <= *fmt && *fmt <= '9'; fmt++) + { + overflow |= INT_MULTIPLY_WRAPV (n, 10, &n); + overflow |= INT_ADD_WRAPV (n, *fmt - '0', &n); + } + if (overflow || min (PTRDIFF_MAX, SIZE_MAX) - SIZE_BOUND_EXTRA < n) + error ("Format width or precision too large"); + *value = n; + return fmt; +} + +/* Like doprnt, except FORMAT_END must be non-null. + Although this function is never exercised in current Emacs, + it is retained in case some future Emacs version + contains doprnt callers that need such formats. + Having a separate function helps GCC optimize doprnt better. */ +static ptrdiff_t +doprnt_non_null_end (char *buffer, ptrdiff_t bufsize, char const *format, + char const *format_end, va_list ap) +{ + USE_SAFE_ALLOCA; + ptrdiff_t fmtlen = format_end - format; + char *fmt = SAFE_ALLOCA (fmtlen + 1); + memcpy (fmt, format, fmtlen); + fmt[fmtlen] = 0; + ptrdiff_t nbytes = doprnt (buffer, bufsize, fmt, NULL, ap); + SAFE_FREE (); + return nbytes; +} + /* Generate output from a format-spec FORMAT, + terminated at either the first NUL or (if FORMAT_END is non-null + and there are no NUL bytes between FORMAT and FORMAT_END) terminated at position FORMAT_END. (*FORMAT_END is not part of the format, but must exist and be readable.) Output goes in BUFFER, which has room for BUFSIZE chars. @@ -123,20 +172,26 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ to fit and return BUFSIZE - 1; if this truncates a multibyte sequence, store '\0' into the sequence's first byte. Returns the number of bytes stored into BUFFER, excluding - the terminating NUL byte. Output is always NUL-terminated. + the terminating null byte. Output is always null-terminated. String arguments are passed as C strings. - Integers are passed as C integers. */ + Integers are passed as C integers. + + FIXME: If FORMAT_END is not at a character boundary + doprnt_non_null_end will cut the string in the middle of the + character and the returned string will have an incomplete character + sequence at the end. We may prefer to cut at a character + boundary. */ ptrdiff_t doprnt (char *buffer, ptrdiff_t bufsize, const char *format, const char *format_end, va_list ap) { + if (format_end) + return doprnt_non_null_end (buffer, bufsize, format, format_end, ap); + const char *fmt = format; /* Pointer into format string. */ char *bufptr = buffer; /* Pointer into output buffer. */ - /* Enough to handle floating point formats with large numbers. */ - enum { SIZE_BOUND_EXTRA = DBL_MAX_10_EXP + 50 }; - /* Use this for sprintf unless we need something really big. */ char tembuf[SIZE_BOUND_EXTRA + 50]; @@ -149,104 +204,92 @@ doprnt (char *buffer, ptrdiff_t bufsize, const char *format, /* Buffer we have got with malloc. */ char *big_buffer = NULL; - enum text_quoting_style quoting_style = text_quoting_style (); - ptrdiff_t tem = -1; - char *string; - char fixed_buffer[20]; /* Default buffer for small formatting. */ - char *fmtcpy; - int minlen; - char charbuf[MAX_MULTIBYTE_LENGTH + 1]; /* Used for %c. */ - USE_SAFE_ALLOCA; - - if (format_end == 0) - format_end = format + strlen (format); - - fmtcpy = (format_end - format < sizeof (fixed_buffer) - 1 - ? fixed_buffer - : SAFE_ALLOCA (format_end - format + 1)); + Lisp_Object quoting_style = Ftext_quoting_style (); bufsize--; /* Loop until end of format string or buffer full. */ - while (fmt < format_end && bufsize > 0) + while (*fmt && bufsize > 0) { char const *fmt0 = fmt; char fmtchar = *fmt++; if (fmtchar == '%') { - ptrdiff_t size_bound = 0; ptrdiff_t width; /* Columns occupied by STRING on display. */ enum { pDlen = sizeof pD - 1, pIlen = sizeof pI - 1, - pMlen = sizeof PRIdMAX - 2 + pMlen = sizeof PRIdMAX - 2, + maxmlen = max (max (1, pDlen), max (pIlen, pMlen)) }; enum { no_modifier, long_modifier, pD_modifier, pI_modifier, pM_modifier } length_modifier = no_modifier; static char const modifier_len[] = { 0, 1, pDlen, pIlen, pMlen }; - int maxmlen = max (max (1, pDlen), max (pIlen, pMlen)); int mlen; + char charbuf[MAX_MULTIBYTE_LENGTH + 1]; /* Used for %c. */ - /* Copy this one %-spec into fmtcpy. */ - string = fmtcpy; + /* Width and precision specified by this %-sequence. */ + int wid = 0, prec = -1; + + /* FMTSTAR will be a "%*.*X"-like version of this %-sequence. + Start by putting '%' into FMTSTAR. */ + char fmtstar[sizeof "%-+ 0*.*d" + maxmlen]; + char *string = fmtstar; *string++ = '%'; - while (fmt < format_end) + + /* Copy at most one instance of each flag into FMTSTAR. */ + bool minusflag = false, plusflag = false, zeroflag = false, + spaceflag = false; + for (;; fmt++) { - *string++ = *fmt; - if ('0' <= *fmt && *fmt <= '9') + *string = *fmt; + switch (*fmt) { - /* Get an idea of how much space we might need. - This might be a field width or a precision; e.g. - %1.1000f and %1000.1f both might need 1000+ bytes. - Parse the width or precision, checking for overflow. */ - int n = *fmt - '0'; - bool overflow = false; - while (fmt + 1 < format_end - && '0' <= fmt[1] && fmt[1] <= '9') - { - overflow |= INT_MULTIPLY_WRAPV (n, 10, &n); - overflow |= INT_ADD_WRAPV (n, fmt[1] - '0', &n); - *string++ = *++fmt; - } - - if (overflow - || min (PTRDIFF_MAX, SIZE_MAX) - SIZE_BOUND_EXTRA < n) - error ("Format width or precision too large"); - if (size_bound < n) - size_bound = n; + case '-': string += !minusflag; minusflag = true; continue; + case '+': string += !plusflag; plusflag = true; continue; + case ' ': string += !spaceflag; spaceflag = true; continue; + case '0': string += !zeroflag; zeroflag = true; continue; } - else if (! (*fmt == '-' || *fmt == ' ' || *fmt == '.' - || *fmt == '+')) - break; - fmt++; + break; } + /* Parse width and precision, putting "*.*" into FMTSTAR. */ + if ('1' <= *fmt && *fmt <= '9') + fmt = parse_format_integer (fmt, &wid); + if (*fmt == '.') + fmt = parse_format_integer (fmt + 1, &prec); + *string++ = '*'; + *string++ = '.'; + *string++ = '*'; + /* Check for the length modifiers in textual length order, so that longer modifiers override shorter ones. */ for (mlen = 1; mlen <= maxmlen; mlen++) { - if (format_end - fmt < mlen) - break; if (mlen == 1 && *fmt == 'l') length_modifier = long_modifier; - if (mlen == pDlen && memcmp (fmt, pD, pDlen) == 0) + if (mlen == pDlen && strncmp (fmt, pD, pDlen) == 0) length_modifier = pD_modifier; - if (mlen == pIlen && memcmp (fmt, pI, pIlen) == 0) + if (mlen == pIlen && strncmp (fmt, pI, pIlen) == 0) length_modifier = pI_modifier; - if (mlen == pMlen && memcmp (fmt, PRIdMAX, pMlen) == 0) + if (mlen == pMlen && strncmp (fmt, PRIdMAX, pMlen) == 0) length_modifier = pM_modifier; } + /* Copy optional length modifier and conversion specifier + character into FMTSTAR, and append a NUL. */ mlen = modifier_len[length_modifier]; - memcpy (string, fmt + 1, mlen); - string += mlen; + string = mempcpy (string, fmt, mlen + 1); fmt += mlen; *string = 0; - /* Make the size bound large enough to handle floating point formats + /* An idea of how much space we might need. + This might be a field width or a precision; e.g. + %1.1000f and %1000.1f both might need 1000+ bytes. + Make it large enough to handle floating point formats with large numbers. */ - size_bound += SIZE_BOUND_EXTRA; + ptrdiff_t size_bound = max (wid, prec) + SIZE_BOUND_EXTRA; /* Make sure we have that much. */ if (size_bound > size_allocated) @@ -257,48 +300,49 @@ doprnt (char *buffer, ptrdiff_t bufsize, const char *format, sprintf_buffer = big_buffer; size_allocated = size_bound; } - minlen = 0; + int minlen = 0; + ptrdiff_t tem; switch (*fmt++) { default: - error ("Invalid format operation %s", fmtcpy); + error ("Invalid format operation %s", fmt0); -/* case 'b': */ - case 'l': case 'd': switch (length_modifier) { case no_modifier: { int v = va_arg (ap, int); - tem = sprintf (sprintf_buffer, fmtcpy, v); + tem = sprintf (sprintf_buffer, fmtstar, wid, prec, v); } break; case long_modifier: { long v = va_arg (ap, long); - tem = sprintf (sprintf_buffer, fmtcpy, v); + tem = sprintf (sprintf_buffer, fmtstar, wid, prec, v); } break; case pD_modifier: signed_pD_modifier: { ptrdiff_t v = va_arg (ap, ptrdiff_t); - tem = sprintf (sprintf_buffer, fmtcpy, v); + tem = sprintf (sprintf_buffer, fmtstar, wid, prec, v); } break; case pI_modifier: { EMACS_INT v = va_arg (ap, EMACS_INT); - tem = sprintf (sprintf_buffer, fmtcpy, v); + tem = sprintf (sprintf_buffer, fmtstar, wid, prec, v); } break; case pM_modifier: { intmax_t v = va_arg (ap, intmax_t); - tem = sprintf (sprintf_buffer, fmtcpy, v); + tem = sprintf (sprintf_buffer, fmtstar, wid, prec, v); } break; + default: + eassume (false); } /* Now copy into final output, truncating as necessary. */ string = sprintf_buffer; @@ -311,13 +355,13 @@ doprnt (char *buffer, ptrdiff_t bufsize, const char *format, case no_modifier: { unsigned v = va_arg (ap, unsigned); - tem = sprintf (sprintf_buffer, fmtcpy, v); + tem = sprintf (sprintf_buffer, fmtstar, wid, prec, v); } break; case long_modifier: { unsigned long v = va_arg (ap, unsigned long); - tem = sprintf (sprintf_buffer, fmtcpy, v); + tem = sprintf (sprintf_buffer, fmtstar, wid, prec, v); } break; case pD_modifier: @@ -325,15 +369,17 @@ doprnt (char *buffer, ptrdiff_t bufsize, const char *format, case pI_modifier: { EMACS_UINT v = va_arg (ap, EMACS_UINT); - tem = sprintf (sprintf_buffer, fmtcpy, v); + tem = sprintf (sprintf_buffer, fmtstar, wid, prec, v); } break; case pM_modifier: { uintmax_t v = va_arg (ap, uintmax_t); - tem = sprintf (sprintf_buffer, fmtcpy, v); + tem = sprintf (sprintf_buffer, fmtstar, wid, prec, v); } break; + default: + eassume (false); } /* Now copy into final output, truncating as necessary. */ string = sprintf_buffer; @@ -344,18 +390,15 @@ doprnt (char *buffer, ptrdiff_t bufsize, const char *format, case 'g': { double d = va_arg (ap, double); - tem = sprintf (sprintf_buffer, fmtcpy, d); + tem = sprintf (sprintf_buffer, fmtstar, wid, prec, d); /* Now copy into final output, truncating as necessary. */ string = sprintf_buffer; goto doit; } case 'S': - string[-1] = 's'; - FALLTHROUGH; case 's': - if (fmtcpy[1] != 's') - minlen = atoi (&fmtcpy[1]); + minlen = minusflag ? -wid : wid; string = va_arg (ap, char *); tem = strnlen (string, STRING_BYTES_BOUND + 1); if (tem == STRING_BYTES_BOUND + 1) @@ -432,32 +475,41 @@ doprnt (char *buffer, ptrdiff_t bufsize, const char *format, string = charbuf; string[tem] = 0; width = strwidth (string, tem); - if (fmtcpy[1] != 'c') - minlen = atoi (&fmtcpy[1]); + minlen = minusflag ? -wid : wid; goto doit1; } case '%': /* Treat this '%' as normal. */ - fmt0 = fmt - 1; break; } } char const *src; ptrdiff_t srclen; - if (quoting_style == CURVE_QUOTING_STYLE && fmtchar == '`') + if (EQ (quoting_style, Qcurve) && fmtchar == '`') src = uLSQM, srclen = sizeof uLSQM - 1; - else if (quoting_style == CURVE_QUOTING_STYLE && fmtchar == '\'') + else if (EQ (quoting_style, Qcurve) && fmtchar == '\'') src = uRSQM, srclen = sizeof uRSQM - 1; - else if (quoting_style == STRAIGHT_QUOTING_STYLE && fmtchar == '`') - src = "'", srclen = 1; - else + else if (! LEADING_CODE_P (fmtchar)) { - while (fmt < format_end && !CHAR_HEAD_P (*fmt)) - fmt++; - src = fmt0, srclen = fmt - fmt0; + if (EQ (quoting_style, Qstraight) && fmtchar == '`') + fmtchar = '\''; + + *bufptr++ = fmtchar; + continue; } + else + { + int charlen = BYTES_BY_CHAR_HEAD (fmtchar); + src = fmt0; + + /* If the format string ends in the middle of a multibyte + character we don't want to skip over the NUL byte. */ + for (srclen = 1 ; *(src + srclen) != 0 && srclen < charlen ; srclen++); + + fmt = src + srclen; + } if (bufsize < srclen) { @@ -479,8 +531,6 @@ doprnt (char *buffer, ptrdiff_t bufsize, const char *format, xfree (big_buffer); *bufptr = 0; /* Make sure our string ends with a '\0' */ - - SAFE_FREE (); return bufptr - buffer; } diff --git a/src/editfns.c b/src/editfns.c index 255537cdc6d..991f79abac7 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -46,13 +46,15 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "composite.h" #include "intervals.h" -#include "ptr-bounds.h" #include "systime.h" #include "character.h" #include "buffer.h" #include "window.h" #include "blockinput.h" +#ifdef WINDOWSNT +# include "w32common.h" +#endif static void update_buffer_properties (ptrdiff_t, ptrdiff_t); static Lisp_Object styled_format (ptrdiff_t, Lisp_Object *, bool); @@ -122,12 +124,14 @@ init_editfns (void) else if (NILP (Vuser_full_name)) Vuser_full_name = build_string ("unknown"); -#ifdef HAVE_SYS_UTSNAME_H +#if defined HAVE_SYS_UTSNAME_H { struct utsname uts; uname (&uts); Voperating_system_release = build_string (uts.release); } +#elif defined WINDOWSNT + Voperating_system_release = build_string (w32_version_string ()); #else Voperating_system_release = Qnil; #endif @@ -162,20 +166,14 @@ DEFUN ("byte-to-string", Fbyte_to_string, Sbyte_to_string, 1, 1, 0, DEFUN ("string-to-char", Fstring_to_char, Sstring_to_char, 1, 1, 0, doc: /* Return the first character in STRING. */) - (register Lisp_Object string) + (Lisp_Object string) { - register Lisp_Object val; CHECK_STRING (string); - if (SCHARS (string)) - { - if (STRING_MULTIBYTE (string)) - XSETFASTINT (val, STRING_CHAR (SDATA (string))); - else - XSETFASTINT (val, SREF (string, 0)); - } - else - XSETFASTINT (val, 0); - return val; + + /* This returns zero if STRING is empty. */ + return make_fixnum (STRING_MULTIBYTE (string) + ? STRING_CHAR (SDATA (string)) + : SREF (string, 0)); } DEFUN ("point", Fpoint, Spoint, 0, 0, 0, @@ -195,11 +193,16 @@ DEFUN ("point-marker", Fpoint_marker, Spoint_marker, 0, 0, 0, return build_marker (current_buffer, PT, PT_BYTE); } -DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 1, "NGoto char: ", +DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 1, + "(goto-char--read-natnum-interactive \"Go to char: \")", doc: /* Set point to POSITION, a number or marker. Beginning of buffer is position (point-min), end is (point-max). -The return value is POSITION. */) +The return value is POSITION. + +If called interactively, a numeric prefix argument specifies +POSITION; without a numeric prefix argument, read POSITION from the +minibuffer. The default value is the number at point (if any). */) (register Lisp_Object position) { if (MARKERP (position)) @@ -714,7 +717,8 @@ If the scan reaches the end of the buffer, return that position. This function ignores text display directionality; it returns the position of the first character in logical order, i.e. the smallest -character position on the line. +character position on the logical line. See `vertical-motion' for +movement by screen lines. This function constrains the returned position to the current field unless that position would be on a different line from the original, @@ -725,18 +729,23 @@ boundaries, bind `inhibit-field-text-motion' to t. This function does not move point. */) (Lisp_Object n) { - ptrdiff_t charpos, bytepos; + ptrdiff_t charpos, bytepos, count; if (NILP (n)) - XSETFASTINT (n, 1); + count = 0; + else if (FIXNUMP (n)) + count = clip_to_bounds (-BUF_BYTES_MAX, XFIXNUM (n) - 1, BUF_BYTES_MAX); else - CHECK_FIXNUM (n); + { + CHECK_INTEGER (n); + count = NILP (Fnatnump (n)) ? -BUF_BYTES_MAX : BUF_BYTES_MAX; + } - scan_newline_from_point (XFIXNUM (n) - 1, &charpos, &bytepos); + scan_newline_from_point (count, &charpos, &bytepos); /* Return END constrained to the current input field. */ return Fconstrain_to_field (make_fixnum (charpos), make_fixnum (PT), - XFIXNUM (n) != 1 ? Qt : Qnil, + count != 0 ? Qt : Qnil, Qt, Qnil); } @@ -763,11 +772,14 @@ This function does not move point. */) ptrdiff_t orig = PT; if (NILP (n)) - XSETFASTINT (n, 1); + clipped_n = 1; + else if (FIXNUMP (n)) + clipped_n = clip_to_bounds (-BUF_BYTES_MAX, XFIXNUM (n), BUF_BYTES_MAX); else - CHECK_FIXNUM (n); - - clipped_n = clip_to_bounds (PTRDIFF_MIN + 1, XFIXNUM (n), PTRDIFF_MAX); + { + CHECK_INTEGER (n); + clipped_n = NILP (Fnatnump (n)) ? -BUF_BYTES_MAX : BUF_BYTES_MAX; + } end_pos = find_before_next_newline (orig, 0, clipped_n - (clipped_n <= 0), NULL); @@ -940,10 +952,10 @@ DEFUN ("position-bytes", Fposition_bytes, Sposition_bytes, 1, 1, 0, If POSITION is out of range, the value is nil. */) (Lisp_Object position) { - CHECK_FIXNUM_COERCE_MARKER (position); - if (XFIXNUM (position) < BEG || XFIXNUM (position) > Z) + EMACS_INT pos = fix_position (position); + if (! (BEG <= pos && pos <= Z)) return Qnil; - return make_fixnum (CHAR_TO_BYTE (XFIXNUM (position))); + return make_fixnum (CHAR_TO_BYTE (pos)); } DEFUN ("byte-to-position", Fbyte_to_position, Sbyte_to_position, 1, 1, 0, @@ -991,7 +1003,7 @@ At the beginning of the buffer or accessible region, return 0. */) else if (!NILP (BVAR (current_buffer, enable_multibyte_characters))) { ptrdiff_t pos = PT_BYTE; - DEC_POS (pos); + pos -= prev_char_len (pos); XSETFASTINT (temp, FETCH_CHAR (pos)); } else @@ -1060,11 +1072,11 @@ If POS is out of range, the value is nil. */) } else { - CHECK_FIXNUM_COERCE_MARKER (pos); - if (XFIXNUM (pos) < BEGV || XFIXNUM (pos) >= ZV) + EMACS_INT p = fix_position (pos); + if (! (BEGV <= p && p < ZV)) return Qnil; - pos_byte = CHAR_TO_BYTE (XFIXNUM (pos)); + pos_byte = CHAR_TO_BYTE (p); } return make_fixnum (FETCH_CHAR (pos_byte)); @@ -1094,17 +1106,17 @@ If POS is out of range, the value is nil. */) } else { - CHECK_FIXNUM_COERCE_MARKER (pos); + EMACS_INT p = fix_position (pos); - if (XFIXNUM (pos) <= BEGV || XFIXNUM (pos) > ZV) + if (! (BEGV < p && p <= ZV)) return Qnil; - pos_byte = CHAR_TO_BYTE (XFIXNUM (pos)); + pos_byte = CHAR_TO_BYTE (p); } if (!NILP (BVAR (current_buffer, enable_multibyte_characters))) { - DEC_POS (pos_byte); + pos_byte -= prev_char_len (pos_byte); XSETFASTINT (val, FETCH_CHAR (pos_byte)); } else @@ -1262,14 +1274,17 @@ name, or nil if there is no such user. */) if (q) { Lisp_Object login = Fuser_login_name (INT_TO_INTEGER (pw->pw_uid)); - USE_SAFE_ALLOCA; - char *r = SAFE_ALLOCA (strlen (p) + SBYTES (login) + 1); - memcpy (r, p, q - p); - char *s = lispstpcpy (&r[q - p], login); - r[q - p] = upcase ((unsigned char) r[q - p]); - strcpy (s, q + 1); - full = build_string (r); - SAFE_FREE (); + if (!NILP (login)) + { + USE_SAFE_ALLOCA; + char *r = SAFE_ALLOCA (strlen (p) + SBYTES (login) + 1); + memcpy (r, p, q - p); + char *s = lispstpcpy (&r[q - p], login); + r[q - p] = upcase ((unsigned char) r[q - p]); + strcpy (s, q + 1); + full = build_string (r); + SAFE_FREE (); + } } #endif /* AMPERSAND_FULL_NAME */ @@ -1538,7 +1553,7 @@ from adjoining text, if those properties are sticky. */) make_uninit_string, which can cause the buffer arena to be compacted. make_string has no way of knowing that the data has been moved, and thus copies the wrong data into the string. This - doesn't effect most of the other users of make_string, so it should + doesn't affect most of the other users of make_string, so it should be left as is. But we should use this function when conjuring buffer substrings. */ @@ -1715,21 +1730,8 @@ using `string-make-multibyte' or `string-make-unibyte', which see. */) if (!BUFFER_LIVE_P (bp)) error ("Selecting deleted buffer"); - if (NILP (start)) - b = BUF_BEGV (bp); - else - { - CHECK_FIXNUM_COERCE_MARKER (start); - b = XFIXNUM (start); - } - if (NILP (end)) - e = BUF_ZV (bp); - else - { - CHECK_FIXNUM_COERCE_MARKER (end); - e = XFIXNUM (end); - } - + b = !NILP (start) ? fix_position (start) : BUF_BEGV (bp); + e = !NILP (end) ? fix_position (end) : BUF_ZV (bp); if (b > e) temp = b, b = e, e = temp; @@ -1783,21 +1785,8 @@ determines whether case is significant or ignored. */) error ("Selecting deleted buffer"); } - if (NILP (start1)) - begp1 = BUF_BEGV (bp1); - else - { - CHECK_FIXNUM_COERCE_MARKER (start1); - begp1 = XFIXNUM (start1); - } - if (NILP (end1)) - endp1 = BUF_ZV (bp1); - else - { - CHECK_FIXNUM_COERCE_MARKER (end1); - endp1 = XFIXNUM (end1); - } - + begp1 = !NILP (start1) ? fix_position (start1) : BUF_BEGV (bp1); + endp1 = !NILP (end1) ? fix_position (end1) : BUF_ZV (bp1); if (begp1 > endp1) temp = begp1, begp1 = endp1, endp1 = temp; @@ -1821,21 +1810,8 @@ determines whether case is significant or ignored. */) error ("Selecting deleted buffer"); } - if (NILP (start2)) - begp2 = BUF_BEGV (bp2); - else - { - CHECK_FIXNUM_COERCE_MARKER (start2); - begp2 = XFIXNUM (start2); - } - if (NILP (end2)) - endp2 = BUF_ZV (bp2); - else - { - CHECK_FIXNUM_COERCE_MARKER (end2); - endp2 = XFIXNUM (end2); - } - + begp2 = !NILP (start2) ? fix_position (start2) : BUF_BEGV (bp2); + endp2 = !NILP (end2) ? fix_position (end2) : BUF_ZV (bp2); if (begp2 > endp2) temp = begp2, begp2 = endp2, endp2 = temp; @@ -1858,26 +1834,24 @@ determines whether case is significant or ignored. */) if (! NILP (BVAR (bp1, enable_multibyte_characters))) { c1 = BUF_FETCH_MULTIBYTE_CHAR (bp1, i1_byte); - BUF_INC_POS (bp1, i1_byte); + i1_byte += buf_next_char_len (bp1, i1_byte); i1++; } else { - c1 = BUF_FETCH_BYTE (bp1, i1); - MAKE_CHAR_MULTIBYTE (c1); + c1 = make_char_multibyte (BUF_FETCH_BYTE (bp1, i1)); i1++; } if (! NILP (BVAR (bp2, enable_multibyte_characters))) { c2 = BUF_FETCH_MULTIBYTE_CHAR (bp2, i2_byte); - BUF_INC_POS (bp2, i2_byte); + i2_byte += buf_next_char_len (bp2, i2_byte); i2++; } else { - c2 = BUF_FETCH_BYTE (bp2, i2); - MAKE_CHAR_MULTIBYTE (c2); + c2 = make_char_multibyte (BUF_FETCH_BYTE (bp2, i2)); i2++; } @@ -1936,8 +1910,8 @@ determines whether case is significant or ignored. */) sys_jmp_buf jmp; \ unsigned short quitcounter; -#define NOTE_DELETE(ctx, xoff) set_bit ((ctx)->deletions, (xoff)) -#define NOTE_INSERT(ctx, yoff) set_bit ((ctx)->insertions, (yoff)) +#define NOTE_DELETE(ctx, xoff) set_bit ((ctx)->deletions, xoff) +#define NOTE_INSERT(ctx, yoff) set_bit ((ctx)->insertions, yoff) #define EARLY_ABORT(ctx) compareseq_early_abort (ctx) struct context; @@ -1990,6 +1964,28 @@ nil. */) if (a == b) error ("Cannot replace a buffer with itself"); + ptrdiff_t too_expensive; + if (NILP (max_costs)) + too_expensive = 1000000; + else if (FIXNUMP (max_costs)) + too_expensive = clip_to_bounds (0, XFIXNUM (max_costs), PTRDIFF_MAX); + else + { + CHECK_INTEGER (max_costs); + too_expensive = NILP (Fnatnump (max_costs)) ? 0 : PTRDIFF_MAX; + } + + struct timespec time_limit = make_timespec (0, -1); + if (!NILP (max_secs)) + { + struct timespec + tlim = timespec_add (current_timespec (), + lisp_time_argument (max_secs)), + tmax = make_timespec (TYPE_MAXIMUM (time_t), TIMESPEC_HZ - 1); + if (timespec_cmp (tlim, tmax) < 0) + time_limit = tlim; + } + ptrdiff_t min_a = BEGV; ptrdiff_t min_b = BUF_BEGV (b); ptrdiff_t size_a = ZV - min_a; @@ -2019,36 +2015,24 @@ nil. */) ptrdiff_t count = SPECPDL_INDEX (); - /* FIXME: It is not documented how to initialize the contents of the - context structure. This code cargo-cults from the existing - caller in src/analyze.c of GNU Diffutils, which appears to - work. */ ptrdiff_t diags = size_a + size_b + 3; + ptrdiff_t del_bytes = size_a / CHAR_BIT + 1; + ptrdiff_t ins_bytes = size_b / CHAR_BIT + 1; ptrdiff_t *buffer; + ptrdiff_t bytes_needed; + if (INT_MULTIPLY_WRAPV (diags, 2 * sizeof *buffer, &bytes_needed) + || INT_ADD_WRAPV (del_bytes + ins_bytes, bytes_needed, &bytes_needed)) + memory_full (SIZE_MAX); USE_SAFE_ALLOCA; - SAFE_NALLOCA (buffer, 2, diags); - - if (NILP (max_costs)) - XSETFASTINT (max_costs, 1000000); - else - CHECK_FIXNUM (max_costs); + buffer = SAFE_ALLOCA (bytes_needed); + unsigned char *deletions_insertions = memset (buffer + 2 * diags, 0, + del_bytes + ins_bytes); - struct timespec time_limit = make_timespec (0, -1); - if (!NILP (max_secs)) - { - struct timespec - tlim = timespec_add (current_timespec (), - lisp_time_argument (max_secs)), - tmax = make_timespec (TYPE_MAXIMUM (time_t), TIMESPEC_HZ - 1); - if (timespec_cmp (tlim, tmax) < 0) - time_limit = tlim; - } - - /* Micro-optimization: Casting to size_t generates much better - code. */ - ptrdiff_t del_bytes = (size_t) size_a / CHAR_BIT + 1; - ptrdiff_t ins_bytes = (size_t) size_b / CHAR_BIT + 1; + /* FIXME: It is not documented how to initialize the contents of the + context structure. This code cargo-cults from the existing + caller in src/analyze.c of GNU Diffutils, which appears to + work. */ struct context ctx = { .buffer_a = a, .buffer_b = b, @@ -2056,16 +2040,14 @@ nil. */) .beg_b = min_b, .a_unibyte = BUF_ZV (a) == BUF_ZV_BYTE (a), .b_unibyte = BUF_ZV (b) == BUF_ZV_BYTE (b), - .deletions = SAFE_ALLOCA (del_bytes), - .insertions = SAFE_ALLOCA (ins_bytes), + .deletions = deletions_insertions, + .insertions = deletions_insertions + del_bytes, .fdiag = buffer + size_b + 1, .bdiag = buffer + diags + size_b + 1, .heuristic = true, - .too_expensive = XFIXNUM (max_costs), + .too_expensive = too_expensive, .time_limit = time_limit, }; - memclear (ctx.deletions, del_bytes); - memclear (ctx.insertions, ins_bytes); /* compareseq requires indices to be zero-based. We add BEGV back later. */ @@ -2110,8 +2092,8 @@ nil. */) /* Check whether there is a change (insertion or deletion) before the current position. */ - if ((i > 0 && bit_is_set (ctx.deletions, i - 1)) || - (j > 0 && bit_is_set (ctx.insertions, j - 1))) + if ((i > 0 && bit_is_set (ctx.deletions, i - 1)) + || (j > 0 && bit_is_set (ctx.insertions, j - 1))) { ptrdiff_t end_a = min_a + i; ptrdiff_t end_b = min_b + j; @@ -2160,21 +2142,15 @@ nil. */) static void set_bit (unsigned char *a, ptrdiff_t i) { - eassert (i >= 0); - /* Micro-optimization: Casting to size_t generates much better - code. */ - size_t j = i; - a[j / CHAR_BIT] |= (1 << (j % CHAR_BIT)); + eassume (0 <= i); + a[i / CHAR_BIT] |= (1 << (i % CHAR_BIT)); } static bool bit_is_set (const unsigned char *a, ptrdiff_t i) { - eassert (i >= 0); - /* Micro-optimization: Casting to size_t generates much better - code. */ - size_t j = i; - return a[j / CHAR_BIT] & (1 << (j % CHAR_BIT)); + eassume (0 <= i); + return a[i / CHAR_BIT] & (1 << (i % CHAR_BIT)); } /* Return true if the characters at position POS_A of buffer @@ -2338,7 +2314,7 @@ Both characters must have the same length of multi-byte form. */) } p = BYTE_POS_ADDR (pos_byte); if (multibyte_p) - INC_POS (pos_byte_next); + pos_byte_next += next_char_len (pos_byte_next); else ++pos_byte_next; if (pos_byte_next - pos_byte == len @@ -2399,7 +2375,7 @@ Both characters must have the same length of multi-byte form. */) decrease it now. */ pos--; else - INC_POS (pos_byte_next); + pos_byte_next += next_char_len (pos_byte_next); if (! NILP (noundo)) bset_undo_list (current_buffer, tem); @@ -2476,7 +2452,7 @@ check_translation (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t end, memcpy (bufalloc, buf, sizeof initial_buf); buf = bufalloc; } - buf[buf_used++] = STRING_CHAR_AND_LENGTH (p, len1); + buf[buf_used++] = string_char_and_length (p, &len1); pos_byte += len1; } if (XFIXNUM (AREF (elt, i)) != buf[i]) @@ -2535,13 +2511,13 @@ It returns the number of characters changed. */) int len, oc; if (multibyte) - oc = STRING_CHAR_AND_LENGTH (p, len); + oc = string_char_and_length (p, &len); else oc = *p, len = 1; if (oc < translatable_chars) { int nc; /* New character. */ - int str_len; + int str_len UNINIT; Lisp_Object val; if (STRINGP (table)) @@ -2552,7 +2528,7 @@ It returns the number of characters changed. */) if (string_multibyte) { str = tt + string_char_to_byte (table, oc); - nc = STRING_CHAR_AND_LENGTH (str, str_len); + nc = string_char_and_length (str, &str_len); } else { @@ -2695,29 +2671,27 @@ See also `save-restriction'. When calling from Lisp, pass two arguments START and END: positions (integers or markers) bounding the text that should remain visible. */) - (register Lisp_Object start, Lisp_Object end) + (Lisp_Object start, Lisp_Object end) { - CHECK_FIXNUM_COERCE_MARKER (start); - CHECK_FIXNUM_COERCE_MARKER (end); + EMACS_INT s = fix_position (start), e = fix_position (end); - if (XFIXNUM (start) > XFIXNUM (end)) + if (e < s) { - Lisp_Object tem; - tem = start; start = end; end = tem; + EMACS_INT tem = s; s = e; e = tem; } - if (!(BEG <= XFIXNUM (start) && XFIXNUM (start) <= XFIXNUM (end) && XFIXNUM (end) <= Z)) + if (!(BEG <= s && s <= e && e <= Z)) args_out_of_range (start, end); - if (BEGV != XFIXNAT (start) || ZV != XFIXNAT (end)) + if (BEGV != s || ZV != e) current_buffer->clip_changed = 1; - SET_BUF_BEGV (current_buffer, XFIXNAT (start)); - SET_BUF_ZV (current_buffer, XFIXNAT (end)); - if (PT < XFIXNAT (start)) - SET_PT (XFIXNAT (start)); - if (PT > XFIXNAT (end)) - SET_PT (XFIXNAT (end)); + SET_BUF_BEGV (current_buffer, s); + SET_BUF_ZV (current_buffer, e); + if (PT < s) + SET_PT (s); + if (e < PT) + SET_PT (e); /* Changing the buffer bounds invalidates any recorded current column. */ invalidate_current_column (); return Qnil; @@ -3112,7 +3086,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) : FLT_RADIX == 16 ? 4 : -1)), - /* Maximum number of bytes (including terminating NUL) generated + /* Maximum number of bytes (including terminating null) generated by any format, if precision is no more than USEFUL_PRECISION_MAX. On all practical hosts, %Lf is the worst case. */ SPRINTF_BUFSIZE = (sizeof "-." + (LDBL_MAX_10_EXP + 1) @@ -3160,6 +3134,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) char *format_start = SSDATA (args[0]); bool multibyte_format = STRING_MULTIBYTE (args[0]); ptrdiff_t formatlen = SBYTES (args[0]); + bool fmt_props = string_intervals (args[0]); /* Upper bound on number of format specs. Each uses at least 2 chars. */ ptrdiff_t nspec_bound = SCHARS (args[0]) >> 1; @@ -3175,8 +3150,6 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) string was not copied into the output. It is 2 if byte I was not the first byte of its character. */ char *discarded = (char *) &info[nspec_bound]; - info = ptr_bounds_clip (info, info_size); - discarded = ptr_bounds_clip (discarded, formatlen); memset (discarded, 0, formatlen); /* Try to determine whether the result should be multibyte. @@ -3192,7 +3165,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) if (STRINGP (args[i]) && STRING_MULTIBYTE (args[i])) multibyte = true; - int quoting_style = message ? text_quoting_style () : -1; + Lisp_Object quoting_style = message ? Ftext_quoting_style () : Qnil; ptrdiff_t ispec; ptrdiff_t nspec = 0; @@ -3434,13 +3407,20 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) convbytes += padding; if (convbytes <= buf + bufsize - p) { + /* If the format spec has properties, we should account + for the padding on the left in the info[] array. */ + if (fmt_props) + spec->start = nchars; if (! minus_flag) { memset (p, ' ', padding); p += padding; nchars += padding; } - spec->start = nchars; + /* If the properties will come from the argument, we + don't extend them to the left due to padding. */ + if (!fmt_props) + spec->start = nchars; if (p > buf && multibyte @@ -3812,7 +3792,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) unsigned char str[MAX_MULTIBYTE_LENGTH]; if ((format_char == '`' || format_char == '\'') - && quoting_style == CURVE_QUOTING_STYLE) + && EQ (quoting_style, Qcurve)) { if (! multibyte) { @@ -3823,7 +3803,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) convbytes = 3; new_result = true; } - else if (format_char == '`' && quoting_style == STRAIGHT_QUOTING_STYLE) + else if (format_char == '`' && EQ (quoting_style, Qstraight)) { convsrc = "'"; new_result = true; @@ -4512,7 +4492,9 @@ functions if all the text being accessed has this property. */); doc: /* The user's name, based upon the real uid only. */); DEFVAR_LISP ("operating-system-release", Voperating_system_release, - doc: /* The release of the operating system Emacs is running on. */); + doc: /* The kernel version of the operating system on which Emacs is running. +The value is a string. It can also be nil if Emacs doesn't +know how to get the kernel version on the underlying OS. */); DEFVAR_BOOL ("binary-as-unsigned", binary_as_unsigned, diff --git a/src/emacs-module.c b/src/emacs-module.c index 37f1084d88b..894dffcf21e 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -41,7 +41,7 @@ rules: module-env-VER.h. Add functions solely at the end of the fragment file for the next (not yet released) major version of Emacs. For example, if the current Emacs release is 26.2, add functions only to - emacs-env-27.h. + module-env-27.h. - emacs-module.h should only depend on standard C headers. In particular, don't include config.h or lisp.h from emacs-module.h. @@ -55,7 +55,7 @@ rules: To add a new module function, proceed as follows: -1. Add a new function pointer field at the end of the emacs-env-*.h +1. Add a new function pointer field at the end of the module-env-*.h file for the next major version of Emacs. 2. Run config.status or configure to regenerate emacs-module.h. @@ -89,6 +89,7 @@ To add a new module function, proceed as follows: #include "dynlib.h" #include "coding.h" #include "keyboard.h" +#include "process.h" #include "syssignal.h" #include "sysstdio.h" #include "thread.h" @@ -123,12 +124,6 @@ To add a new module function, proceed as follows: /* Function prototype for the module init function. */ typedef int (*emacs_init_function) (struct emacs_runtime *); -/* Function prototype for module user-pointer finalizers. These - should not throw C++ exceptions, so emacs-module.h declares the - corresponding interfaces with EMACS_NOEXCEPT. There is only C code - in this module, though, so this constraint is not enforced here. */ -typedef void (*emacs_finalizer_function) (void *); - /* Memory management. */ @@ -195,7 +190,7 @@ struct emacs_runtime_private /* Forward declarations. */ static Lisp_Object value_to_lisp (emacs_value); -static emacs_value allocate_emacs_value (emacs_env *, struct emacs_value_storage *, Lisp_Object); +static emacs_value allocate_emacs_value (emacs_env *, Lisp_Object); static emacs_value lisp_to_value (emacs_env *, Lisp_Object); static enum emacs_funcall_exit module_non_local_exit_check (emacs_env *); static void module_assert_thread (void); @@ -205,8 +200,6 @@ static AVOID module_abort (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2); static emacs_env *initialize_environment (emacs_env *, struct emacs_env_private *); static void finalize_environment (emacs_env *); -static void finalize_environment_unwind (void *); -static void finalize_runtime_unwind (void *); static void module_handle_nonlocal_exit (emacs_env *, enum nonlocal_exit, Lisp_Object); static void module_non_local_exit_signal_1 (emacs_env *, @@ -220,6 +213,25 @@ static bool value_storage_contains_p (const struct emacs_value_storage *, static bool module_assertions = false; + +/* Small helper functions. */ + +/* Interprets the string at STR with length LEN as UTF-8 string. + Signals an error if it's not a valid UTF-8 string. */ + +static Lisp_Object +module_decode_utf_8 (const char *str, ptrdiff_t len) +{ + /* We set HANDLE-8-BIT and HANDLE-OVER-UNI to nil to signal an error + if the argument is not a valid UTF-8 string. While it isn't + documented how make_string and make_function behave in this case, + signaling an error is the most defensive and obvious reaction. */ + Lisp_Object s = decode_string_utf_8 (Qnil, str, len, Qnil, false, Qnil, Qnil); + CHECK_TYPE (!NILP (s), Qutf_8_string_p, make_string_from_utf8 (str, len)); + return s; +} + + /* Convenience macros for non-local exit handling. */ /* FIXME: The following implementation for non-local exit handling @@ -235,7 +247,7 @@ static bool module_assertions = false; of `internal_condition_case' etc., and to avoid worrying about passing information to the handler functions. */ -#if !__has_attribute (cleanup) +#if !HAS_ATTRIBUTE (cleanup) #error "__attribute__ ((cleanup)) not supported by this compiler; try GCC" #endif @@ -334,6 +346,12 @@ static bool module_assertions = false; MODULE_HANDLE_NONLOCAL_EXIT (error_retval) static void +CHECK_MODULE_FUNCTION (Lisp_Object obj) +{ + CHECK_TYPE (MODULE_FUNCTIONP (obj), Qmodule_function_p, obj); +} + +static void CHECK_USER_PTR (Lisp_Object obj) { CHECK_TYPE (USER_PTRP (obj), Quser_ptrp, obj); @@ -344,11 +362,11 @@ CHECK_USER_PTR (Lisp_Object obj) the Emacs main thread. */ static emacs_env * -module_get_environment (struct emacs_runtime *ert) +module_get_environment (struct emacs_runtime *runtime) { module_assert_thread (); - module_assert_runtime (ert); - return ert->private_members->env; + module_assert_runtime (runtime); + return runtime->private_members->env; } /* To make global refs (GC-protected global values) keep a hash that @@ -404,11 +422,11 @@ module_global_reference_p (emacs_value v, ptrdiff_t *n) } static emacs_value -module_make_global_ref (emacs_env *env, emacs_value ref) +module_make_global_ref (emacs_env *env, emacs_value value) { MODULE_FUNCTION_BEGIN (NULL); struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash); - Lisp_Object new_obj = value_to_lisp (ref), hashcode; + Lisp_Object new_obj = value_to_lisp (value), hashcode; ptrdiff_t i = hash_lookup (h, new_obj, &hashcode); /* Note: This approach requires the garbage collector to never move @@ -438,20 +456,20 @@ module_make_global_ref (emacs_env *env, emacs_value ref) } static void -module_free_global_ref (emacs_env *env, emacs_value ref) +module_free_global_ref (emacs_env *env, emacs_value global_value) { /* TODO: This probably never signals. */ /* FIXME: Wait a minute. Shouldn't this function report an error if the hash lookup fails? */ MODULE_FUNCTION_BEGIN (); struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash); - Lisp_Object obj = value_to_lisp (ref); + Lisp_Object obj = value_to_lisp (global_value); ptrdiff_t i = hash_lookup (h, obj, NULL); if (module_assertions) { ptrdiff_t n = 0; - if (! module_global_reference_p (ref, &n)) + if (! module_global_reference_p (global_value, &n)) module_abort ("Global value was not found in list of %"pD"d globals", n); } @@ -483,14 +501,15 @@ module_non_local_exit_clear (emacs_env *env) } static enum emacs_funcall_exit -module_non_local_exit_get (emacs_env *env, emacs_value *sym, emacs_value *data) +module_non_local_exit_get (emacs_env *env, + emacs_value *symbol, emacs_value *data) { module_assert_thread (); module_assert_env (env); struct emacs_env_private *p = env->private_members; if (p->pending_non_local_exit != emacs_funcall_exit_return) { - *sym = &p->non_local_exit_symbol; + *symbol = &p->non_local_exit_symbol; *data = &p->non_local_exit_data; } return p->pending_non_local_exit; @@ -498,12 +517,13 @@ module_non_local_exit_get (emacs_env *env, emacs_value *sym, emacs_value *data) /* Like for `signal', DATA must be a list. */ static void -module_non_local_exit_signal (emacs_env *env, emacs_value sym, emacs_value data) +module_non_local_exit_signal (emacs_env *env, + emacs_value symbol, emacs_value data) { module_assert_thread (); module_assert_env (env); if (module_non_local_exit_check (env) == emacs_funcall_exit_return) - module_non_local_exit_signal_1 (env, value_to_lisp (sym), + module_non_local_exit_signal_1 (env, value_to_lisp (symbol), value_to_lisp (data)); } @@ -517,10 +537,6 @@ module_non_local_exit_throw (emacs_env *env, emacs_value tag, emacs_value value) value_to_lisp (value)); } -/* Function prototype for the module Lisp functions. */ -typedef emacs_value (*emacs_subr) (emacs_env *, ptrdiff_t, - emacs_value [], void *); - /* Module function. */ /* A function environment is an auxiliary structure returned by @@ -533,19 +549,20 @@ struct Lisp_Module_Function union vectorlike_header header; /* Fields traced by GC; these must come first. */ - Lisp_Object documentation; + Lisp_Object documentation, interactive_form; /* Fields ignored by GC. */ ptrdiff_t min_arity, max_arity; - emacs_subr subr; + emacs_function subr; void *data; + emacs_finalizer finalizer; } GCALIGNED_STRUCT; static struct Lisp_Module_Function * allocate_module_function (void) { return ALLOCATE_PSEUDOVECTOR (struct Lisp_Module_Function, - documentation, PVEC_MODULE_FUNCTION); + interactive_form, PVEC_MODULE_FUNCTION); } #define XSET_MODULE_FUNCTION(var, ptr) \ @@ -556,8 +573,7 @@ allocate_module_function (void) static emacs_value module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity, - emacs_subr subr, const char *documentation, - void *data) + emacs_function func, const char *docstring, void *data) { MODULE_FUNCTION_BEGIN (NULL); @@ -571,11 +587,13 @@ module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity, struct Lisp_Module_Function *function = allocate_module_function (); function->min_arity = min_arity; function->max_arity = max_arity; - function->subr = subr; + function->subr = func; function->data = data; + function->finalizer = NULL; - if (documentation) - function->documentation = build_string_from_utf8 (documentation); + if (docstring) + function->documentation + = module_decode_utf_8 (docstring, strlen (docstring)); Lisp_Object result; XSET_MODULE_FUNCTION (result, function); @@ -584,9 +602,53 @@ module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity, return lisp_to_value (env, result); } +static emacs_finalizer +module_get_function_finalizer (emacs_env *env, emacs_value arg) +{ + MODULE_FUNCTION_BEGIN (NULL); + Lisp_Object lisp = value_to_lisp (arg); + CHECK_MODULE_FUNCTION (lisp); + return XMODULE_FUNCTION (lisp)->finalizer; +} + +static void +module_set_function_finalizer (emacs_env *env, emacs_value arg, + emacs_finalizer fin) +{ + MODULE_FUNCTION_BEGIN (); + Lisp_Object lisp = value_to_lisp (arg); + CHECK_MODULE_FUNCTION (lisp); + XMODULE_FUNCTION (lisp)->finalizer = fin; +} + +void +module_finalize_function (const struct Lisp_Module_Function *func) +{ + if (func->finalizer != NULL) + func->finalizer (func->data); +} + +static void +module_make_interactive (emacs_env *env, emacs_value function, emacs_value spec) +{ + MODULE_FUNCTION_BEGIN (); + Lisp_Object lisp_fun = value_to_lisp (function); + CHECK_MODULE_FUNCTION (lisp_fun); + Lisp_Object lisp_spec = value_to_lisp (spec); + /* Normalize (interactive nil) to (interactive). */ + XMODULE_FUNCTION (lisp_fun)->interactive_form + = NILP (lisp_spec) ? list1 (Qinteractive) : list2 (Qinteractive, lisp_spec); +} + +Lisp_Object +module_function_interactive_form (const struct Lisp_Module_Function *fun) +{ + return fun->interactive_form; +} + static emacs_value -module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs, - emacs_value args[]) +module_funcall (emacs_env *env, emacs_value func, ptrdiff_t nargs, + emacs_value *args) { MODULE_FUNCTION_BEGIN (NULL); @@ -598,7 +660,7 @@ module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs, if (INT_ADD_WRAPV (nargs, 1, &nargs1)) overflow_error (); SAFE_ALLOCA_LISP (newargs, nargs1); - newargs[0] = value_to_lisp (fun); + newargs[0] = value_to_lisp (func); for (ptrdiff_t i = 0; i < nargs; i++) newargs[1 + i] = value_to_lisp (args[i]); emacs_value result = lisp_to_value (env, Ffuncall (nargs1, newargs)); @@ -614,17 +676,17 @@ module_intern (emacs_env *env, const char *name) } static emacs_value -module_type_of (emacs_env *env, emacs_value value) +module_type_of (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN (NULL); - return lisp_to_value (env, Ftype_of (value_to_lisp (value))); + return lisp_to_value (env, Ftype_of (value_to_lisp (arg))); } static bool -module_is_not_nil (emacs_env *env, emacs_value value) +module_is_not_nil (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN_NO_CATCH (false); - return ! NILP (value_to_lisp (value)); + return ! NILP (value_to_lisp (arg)); } static bool @@ -635,14 +697,14 @@ module_eq (emacs_env *env, emacs_value a, emacs_value b) } static intmax_t -module_extract_integer (emacs_env *env, emacs_value n) +module_extract_integer (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN (0); - Lisp_Object l = value_to_lisp (n); - CHECK_INTEGER (l); + Lisp_Object lisp = value_to_lisp (arg); + CHECK_INTEGER (lisp); intmax_t i; - if (! integer_to_intmax (l, &i)) - xsignal1 (Qoverflow_error, l); + if (! integer_to_intmax (lisp, &i)) + xsignal1 (Qoverflow_error, lisp); return i; } @@ -654,10 +716,10 @@ module_make_integer (emacs_env *env, intmax_t n) } static double -module_extract_float (emacs_env *env, emacs_value f) +module_extract_float (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN (0); - Lisp_Object lisp = value_to_lisp (f); + Lisp_Object lisp = value_to_lisp (arg); CHECK_TYPE (FLOATP (lisp), Qfloatp, lisp); return XFLOAT_DATA (lisp); } @@ -670,8 +732,8 @@ module_make_float (emacs_env *env, double d) } static bool -module_copy_string_contents (emacs_env *env, emacs_value value, char *buffer, - ptrdiff_t *length) +module_copy_string_contents (emacs_env *env, emacs_value value, char *buf, + ptrdiff_t *len) { MODULE_FUNCTION_BEGIN (false); Lisp_Object lisp_str = value_to_lisp (value); @@ -695,77 +757,89 @@ module_copy_string_contents (emacs_env *env, emacs_value value, char *buffer, ptrdiff_t raw_size = SBYTES (lisp_str_utf8); ptrdiff_t required_buf_size = raw_size + 1; - if (buffer == NULL) + if (buf == NULL) { - *length = required_buf_size; + *len = required_buf_size; return true; } - if (*length < required_buf_size) + if (*len < required_buf_size) { - ptrdiff_t actual = *length; - *length = required_buf_size; + ptrdiff_t actual = *len; + *len = required_buf_size; args_out_of_range_3 (INT_TO_INTEGER (actual), INT_TO_INTEGER (required_buf_size), INT_TO_INTEGER (PTRDIFF_MAX)); } - *length = required_buf_size; - memcpy (buffer, SDATA (lisp_str_utf8), raw_size + 1); + *len = required_buf_size; + memcpy (buf, SDATA (lisp_str_utf8), raw_size + 1); return true; } static emacs_value -module_make_string (emacs_env *env, const char *str, ptrdiff_t length) +module_make_string (emacs_env *env, const char *str, ptrdiff_t len) +{ + MODULE_FUNCTION_BEGIN (NULL); + if (! (0 <= len && len <= STRING_BYTES_BOUND)) + overflow_error (); + Lisp_Object lstr + = len == 0 ? empty_multibyte_string : module_decode_utf_8 (str, len); + return lisp_to_value (env, lstr); +} + +static emacs_value +module_make_unibyte_string (emacs_env *env, const char *str, ptrdiff_t length) { MODULE_FUNCTION_BEGIN (NULL); if (! (0 <= length && length <= STRING_BYTES_BOUND)) overflow_error (); - Lisp_Object lstr = make_string_from_utf8 (str, length); + Lisp_Object lstr + = length == 0 ? empty_unibyte_string : make_unibyte_string (str, length); return lisp_to_value (env, lstr); } static emacs_value -module_make_user_ptr (emacs_env *env, emacs_finalizer_function fin, void *ptr) +module_make_user_ptr (emacs_env *env, emacs_finalizer fin, void *ptr) { MODULE_FUNCTION_BEGIN (NULL); return lisp_to_value (env, make_user_ptr (fin, ptr)); } static void * -module_get_user_ptr (emacs_env *env, emacs_value uptr) +module_get_user_ptr (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN (NULL); - Lisp_Object lisp = value_to_lisp (uptr); + Lisp_Object lisp = value_to_lisp (arg); CHECK_USER_PTR (lisp); return XUSER_PTR (lisp)->p; } static void -module_set_user_ptr (emacs_env *env, emacs_value uptr, void *ptr) +module_set_user_ptr (emacs_env *env, emacs_value arg, void *ptr) { MODULE_FUNCTION_BEGIN (); - Lisp_Object lisp = value_to_lisp (uptr); + Lisp_Object lisp = value_to_lisp (arg); CHECK_USER_PTR (lisp); XUSER_PTR (lisp)->p = ptr; } -static emacs_finalizer_function -module_get_user_finalizer (emacs_env *env, emacs_value uptr) +static emacs_finalizer +module_get_user_finalizer (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN (NULL); - Lisp_Object lisp = value_to_lisp (uptr); + Lisp_Object lisp = value_to_lisp (arg); CHECK_USER_PTR (lisp); return XUSER_PTR (lisp)->finalizer; } static void -module_set_user_finalizer (emacs_env *env, emacs_value uptr, - emacs_finalizer_function fin) +module_set_user_finalizer (emacs_env *env, emacs_value arg, + emacs_finalizer fin) { MODULE_FUNCTION_BEGIN (); - Lisp_Object lisp = value_to_lisp (uptr); + Lisp_Object lisp = value_to_lisp (arg); CHECK_USER_PTR (lisp); XUSER_PTR (lisp)->finalizer = fin; } @@ -780,30 +854,31 @@ check_vec_index (Lisp_Object lvec, ptrdiff_t i) } static void -module_vec_set (emacs_env *env, emacs_value vec, ptrdiff_t i, emacs_value val) +module_vec_set (emacs_env *env, emacs_value vector, ptrdiff_t index, + emacs_value value) { MODULE_FUNCTION_BEGIN (); - Lisp_Object lvec = value_to_lisp (vec); - check_vec_index (lvec, i); - ASET (lvec, i, value_to_lisp (val)); + Lisp_Object lisp = value_to_lisp (vector); + check_vec_index (lisp, index); + ASET (lisp, index, value_to_lisp (value)); } static emacs_value -module_vec_get (emacs_env *env, emacs_value vec, ptrdiff_t i) +module_vec_get (emacs_env *env, emacs_value vector, ptrdiff_t index) { MODULE_FUNCTION_BEGIN (NULL); - Lisp_Object lvec = value_to_lisp (vec); - check_vec_index (lvec, i); - return lisp_to_value (env, AREF (lvec, i)); + Lisp_Object lisp = value_to_lisp (vector); + check_vec_index (lisp, index); + return lisp_to_value (env, AREF (lisp, index)); } static ptrdiff_t -module_vec_size (emacs_env *env, emacs_value vec) +module_vec_size (emacs_env *env, emacs_value vector) { MODULE_FUNCTION_BEGIN (0); - Lisp_Object lvec = value_to_lisp (vec); - CHECK_VECTOR (lvec); - return ASIZE (lvec); + Lisp_Object lisp = value_to_lisp (vector); + CHECK_VECTOR (lisp); + return ASIZE (lisp); } /* This function should return true if and only if maybe_quit would @@ -824,10 +899,10 @@ module_process_input (emacs_env *env) } static struct timespec -module_extract_time (emacs_env *env, emacs_value value) +module_extract_time (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN ((struct timespec) {0}); - return lisp_time_argument (value_to_lisp (value)); + return lisp_time_argument (value_to_lisp (arg)); } static emacs_value @@ -984,6 +1059,13 @@ module_make_big_integer (emacs_env *env, int sign, return lisp_to_value (env, make_integer_mpz ()); } +static int +module_open_channel (emacs_env *env, emacs_value pipe_process) +{ + MODULE_FUNCTION_BEGIN (-1); + return open_channel_for_module (value_to_lisp (pipe_process)); +} + /* Subroutines. */ @@ -1005,10 +1087,6 @@ module_signal_or_throw (struct emacs_env_private *env) } } -/* Live runtime and environment objects, for assertions. */ -static Lisp_Object Vmodule_runtimes; -static Lisp_Object Vmodule_environments; - DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, doc: /* Load module FILE. */) (Lisp_Object file) @@ -1041,14 +1119,21 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, for two different runtime objects are guaranteed to be distinct, which we can use for checking the liveness of runtime pointers. */ - struct emacs_runtime *rt = module_assertions ? xmalloc (sizeof *rt) : &rt_pub; + struct emacs_runtime *rt; + if (module_assertions) + { + rt = xmalloc (sizeof *rt); + __lsan_ignore_object (rt); + } + else + rt = &rt_pub; rt->size = sizeof *rt; rt->private_members = &rt_priv; rt->get_environment = module_get_environment; - Vmodule_runtimes = Fcons (make_mint_ptr (rt), Vmodule_runtimes); ptrdiff_t count = SPECPDL_INDEX (); - record_unwind_protect_ptr (finalize_runtime_unwind, rt); + record_unwind_protect_module (SPECPDL_MODULE_RUNTIME, rt); + record_unwind_protect_module (SPECPDL_MODULE_ENVIRONMENT, rt_priv.env); int r = module_init (rt); @@ -1076,7 +1161,7 @@ funcall_module (Lisp_Object function, ptrdiff_t nargs, Lisp_Object *arglist) struct emacs_env_private priv; emacs_env *env = initialize_environment (&pub, &priv); ptrdiff_t count = SPECPDL_INDEX (); - record_unwind_protect_ptr (finalize_environment_unwind, env); + record_unwind_protect_module (SPECPDL_MODULE_ENVIRONMENT, env); USE_SAFE_ALLOCA; emacs_value *args = nargs > 0 ? SAFE_ALLOCA (nargs * sizeof *args) : NULL; @@ -1125,6 +1210,12 @@ module_function_address (const struct Lisp_Module_Function *function) return (module_funcptr) function->subr; } +void * +module_function_data (const struct Lisp_Module_Function *function) +{ + return function->data; +} + /* Helper functions. */ @@ -1141,17 +1232,18 @@ module_assert_thread (void) } static void -module_assert_runtime (struct emacs_runtime *ert) +module_assert_runtime (struct emacs_runtime *runtime) { if (! module_assertions) return; ptrdiff_t count = 0; - for (Lisp_Object tail = Vmodule_runtimes; CONSP (tail); tail = XCDR (tail)) - { - if (xmint_pointer (XCAR (tail)) == ert) - return; - ++count; - } + for (const union specbinding *pdl = specpdl; pdl != specpdl_ptr; ++pdl) + if (pdl->kind == SPECPDL_MODULE_RUNTIME) + { + if (pdl->unwind_ptr.arg == runtime) + return; + ++count; + } module_abort ("Runtime pointer not found in list of %"pD"d runtimes", count); } @@ -1162,13 +1254,13 @@ module_assert_env (emacs_env *env) if (! module_assertions) return; ptrdiff_t count = 0; - for (Lisp_Object tail = Vmodule_environments; CONSP (tail); - tail = XCDR (tail)) - { - if (xmint_pointer (XCAR (tail)) == env) - return; - ++count; - } + for (const union specbinding *pdl = specpdl; pdl != specpdl_ptr; ++pdl) + if (pdl->kind == SPECPDL_MODULE_ENVIRONMENT) + { + if (pdl->unwind_ptr.arg == env) + return; + ++count; + } module_abort ("Environment pointer not found in list of %"pD"d environments", count); } @@ -1226,22 +1318,22 @@ value_to_lisp (emacs_value v) environments. */ ptrdiff_t num_environments = 0; ptrdiff_t num_values = 0; - for (Lisp_Object environments = Vmodule_environments; - CONSP (environments); environments = XCDR (environments)) - { - emacs_env *env = xmint_pointer (XCAR (environments)); - struct emacs_env_private *priv = env->private_members; - /* The value might be one of the nonlocal exit values. Note - that we don't check whether a nonlocal exit is currently - pending, because the module might have cleared the flag - in the meantime. */ - if (&priv->non_local_exit_symbol == v - || &priv->non_local_exit_data == v) - goto ok; - if (value_storage_contains_p (&priv->storage, v, &num_values)) - goto ok; - ++num_environments; - } + for (const union specbinding *pdl = specpdl; pdl != specpdl_ptr; ++pdl) + if (pdl->kind == SPECPDL_MODULE_ENVIRONMENT) + { + const emacs_env *env = pdl->unwind_ptr.arg; + struct emacs_env_private *priv = env->private_members; + /* The value might be one of the nonlocal exit values. Note + that we don't check whether a nonlocal exit is currently + pending, because the module might have cleared the flag + in the meantime. */ + if (&priv->non_local_exit_symbol == v + || &priv->non_local_exit_data == v) + goto ok; + if (value_storage_contains_p (&priv->storage, v, &num_values)) + goto ok; + ++num_environments; + } /* Also check global values. */ if (module_global_reference_p (v, &num_values)) goto ok; @@ -1261,7 +1353,7 @@ lisp_to_value (emacs_env *env, Lisp_Object o) struct emacs_env_private *p = env->private_members; if (p->pending_non_local_exit != emacs_funcall_exit_return) return NULL; - return allocate_emacs_value (env, &p->storage, o); + return allocate_emacs_value (env, o); } /* Must be called for each frame before it can be used for allocation. */ @@ -1298,9 +1390,9 @@ finalize_storage (struct emacs_value_storage *storage) /* Allocate a new value from STORAGE and stores OBJ in it. Return NULL if allocation fails and use ENV for non local exit reporting. */ static emacs_value -allocate_emacs_value (emacs_env *env, struct emacs_value_storage *storage, - Lisp_Object obj) +allocate_emacs_value (emacs_env *env, Lisp_Object obj) { + struct emacs_value_storage *storage = &env->private_members->storage; eassert (storage->current); eassert (storage->current->offset < value_frame_size); eassert (! storage->current->next); @@ -1324,18 +1416,14 @@ allocate_emacs_value (emacs_env *env, struct emacs_value_storage *storage, /* Mark all objects allocated from local environments so that they don't get garbage-collected. */ void -mark_modules (void) +mark_module_environment (void *ptr) { - for (Lisp_Object tem = Vmodule_environments; CONSP (tem); tem = XCDR (tem)) - { - emacs_env *env = xmint_pointer (XCAR (tem)); - struct emacs_env_private *priv = env->private_members; - for (struct emacs_value_frame *frame = &priv->storage.initial; - frame != NULL; - frame = frame->next) - for (int i = 0; i < frame->offset; ++i) - mark_object (frame->objects[i].v); - } + emacs_env *env = ptr; + struct emacs_env_private *priv = env->private_members; + for (struct emacs_value_frame *frame = &priv->storage.initial; frame != NULL; + frame = frame->next) + for (int i = 0; i < frame->offset; ++i) + mark_object (frame->objects[i].v); } @@ -1351,7 +1439,10 @@ static emacs_env * initialize_environment (emacs_env *env, struct emacs_env_private *priv) { if (module_assertions) + { env = xmalloc (sizeof *env); + __lsan_ignore_object (env); + } priv->pending_non_local_exit = emacs_funcall_exit_return; initialize_storage (&priv->storage); @@ -1376,6 +1467,7 @@ initialize_environment (emacs_env *env, struct emacs_env_private *priv) env->make_float = module_make_float; env->copy_string_contents = module_copy_string_contents; env->make_string = module_make_string; + env->make_unibyte_string = module_make_unibyte_string; env->make_user_ptr = module_make_user_ptr; env->get_user_ptr = module_get_user_ptr; env->set_user_ptr = module_set_user_ptr; @@ -1390,7 +1482,10 @@ initialize_environment (emacs_env *env, struct emacs_env_private *priv) env->make_time = module_make_time; env->extract_big_integer = module_extract_big_integer; env->make_big_integer = module_make_big_integer; - Vmodule_environments = Fcons (make_mint_ptr (env), Vmodule_environments); + env->get_function_finalizer = module_get_function_finalizer; + env->set_function_finalizer = module_set_function_finalizer; + env->open_channel = module_open_channel; + env->make_interactive = module_make_interactive; return env; } @@ -1400,23 +1495,19 @@ static void finalize_environment (emacs_env *env) { finalize_storage (&env->private_members->storage); - eassert (xmint_pointer (XCAR (Vmodule_environments)) == env); - Vmodule_environments = XCDR (Vmodule_environments); } -static void +void finalize_environment_unwind (void *env) { finalize_environment (env); } -static void +void finalize_runtime_unwind (void *raw_ert) { - struct emacs_runtime *ert = raw_ert; - eassert (xmint_pointer (XCAR (Vmodule_runtimes)) == ert); - Vmodule_runtimes = XCDR (Vmodule_runtimes); - finalize_environment (ert->private_members->env); + /* No further cleanup is required, as the initial environment is + unwound separately. See the logic in Fmodule_load. */ } @@ -1505,12 +1596,6 @@ syms_of_module (void) DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD, Qnil, false); - staticpro (&Vmodule_runtimes); - Vmodule_runtimes = Qnil; - - staticpro (&Vmodule_environments); - Vmodule_environments = Qnil; - DEFSYM (Qmodule_load_failed, "module-load-failed"); Fput (Qmodule_load_failed, Qerror_conditions, pure_list (Qmodule_load_failed, Qerror)); diff --git a/src/emacs-module.h.in b/src/emacs-module.h.in index 4e73e2009cb..fe52587c1a5 100644 --- a/src/emacs-module.h.in +++ b/src/emacs-module.h.in @@ -42,10 +42,22 @@ information how to write modules and use this header file. # define EMACS_NOEXCEPT #endif -#ifdef __has_attribute -#if __has_attribute(__nonnull__) -# define EMACS_ATTRIBUTE_NONNULL(...) __attribute__((__nonnull__(__VA_ARGS__))) +#if defined __cplusplus && __cplusplus >= 201703L +# define EMACS_NOEXCEPT_TYPEDEF noexcept +#else +# define EMACS_NOEXCEPT_TYPEDEF #endif + +#if 3 < __GNUC__ + (3 <= __GNUC_MINOR__) +# define EMACS_ATTRIBUTE_NONNULL(...) \ + __attribute__ ((__nonnull__ (__VA_ARGS__))) +#elif (defined __has_attribute \ + && (!defined __clang_minor__ \ + || 3 < __clang_major__ + (5 <= __clang_minor__))) +# if __has_attribute (__nonnull__) +# define EMACS_ATTRIBUTE_NONNULL(...) \ + __attribute__ ((__nonnull__ (__VA_ARGS__))) +# endif #endif #ifndef EMACS_ATTRIBUTE_NONNULL # define EMACS_ATTRIBUTE_NONNULL(...) @@ -56,7 +68,7 @@ extern "C" { #endif /* Current environment. */ -typedef struct emacs_env_27 emacs_env; +typedef struct emacs_env_@emacs_major_version@ emacs_env; /* Opaque pointer representing an Emacs Lisp value. BEWARE: Do not assume NULL is a valid value! */ @@ -74,10 +86,25 @@ struct emacs_runtime struct emacs_runtime_private *private_members; /* Return an environment pointer. */ - emacs_env *(*get_environment) (struct emacs_runtime *ert) - EMACS_ATTRIBUTE_NONNULL(1); + emacs_env *(*get_environment) (struct emacs_runtime *runtime) + EMACS_ATTRIBUTE_NONNULL (1); }; +/* Type aliases for function pointer types used in the module API. + Note that we don't use these aliases directly in the API to be able + to mark the function arguments as 'noexcept' before C++20. + However, users can use them if they want. */ + +/* Function prototype for the module Lisp functions. These must not + throw C++ exceptions. */ +typedef emacs_value (*emacs_function) (emacs_env *env, ptrdiff_t nargs, + emacs_value *args, + void *data) + EMACS_NOEXCEPT_TYPEDEF EMACS_ATTRIBUTE_NONNULL (1); + +/* Function prototype for module user-pointer and function finalizers. + These must not throw C++ exceptions. */ +typedef void (*emacs_finalizer) (void *data) EMACS_NOEXCEPT_TYPEDEF; /* Possible Emacs function call outcomes. */ enum emacs_funcall_exit @@ -131,10 +158,21 @@ struct emacs_env_27 @module_env_snippet_27@ }; +struct emacs_env_28 +{ +@module_env_snippet_25@ + +@module_env_snippet_26@ + +@module_env_snippet_27@ + +@module_env_snippet_28@ +}; + /* Every module should define a function as follows. */ -extern int emacs_module_init (struct emacs_runtime *ert) +extern int emacs_module_init (struct emacs_runtime *runtime) EMACS_NOEXCEPT - EMACS_ATTRIBUTE_NONNULL(1); + EMACS_ATTRIBUTE_NONNULL (1); #ifdef __cplusplus } diff --git a/src/emacs.c b/src/emacs.c index 67220ebb769..fd08667f3fd 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -83,7 +83,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "charset.h" #include "composite.h" #include "dispextern.h" -#include "ptr-bounds.h" #include "regex-emacs.h" #include "sheap.h" #include "syntax.h" @@ -388,7 +387,14 @@ terminate_due_to_signal (int sig, int backtrace_limit) totally_unblock_input (); if (sig == SIGTERM || sig == SIGHUP || sig == SIGINT) - Fkill_emacs (make_fixnum (sig)); + { + /* Avoid abort in shut_down_emacs if we were interrupted + by SIGINT in noninteractive usage, as in that case we + don't care about the message stack. */ + if (sig == SIGINT && noninteractive) + clear_message_stack (); + Fkill_emacs (make_fixnum (sig)); + } shut_down_emacs (sig, Qnil); emacs_backtrace (backtrace_limit); @@ -939,7 +945,6 @@ main (int argc, char **argv) for pointers. */ void *stack_bottom_variable; - bool do_initial_setlocale; bool no_loadup = false; char *junk = 0; char *dname_arg = 0; @@ -1244,19 +1249,21 @@ main (int argc, char **argv) set_binary_mode (STDOUT_FILENO, O_BINARY); #endif /* MSDOS */ - /* Skip initial setlocale if LC_ALL is "C", as it's not needed in that case. - The build procedure uses this while dumping, to ensure that the - dumped Emacs does not have its system locale tables initialized, - as that might cause screwups when the dumped Emacs starts up. */ - { - char *lc_all = getenv ("LC_ALL"); - do_initial_setlocale = ! lc_all || strcmp (lc_all, "C"); - } - - /* Set locale now, so that initial error messages are localized properly. - fixup_locale must wait until later, since it builds strings. */ - if (do_initial_setlocale) - setlocale (LC_ALL, ""); + /* Set locale, so that initial error messages are localized properly. + However, skip this if LC_ALL is "C", as it's not needed in that case. + Skipping helps if dumping with unexec, to ensure that the dumped + Emacs does not have its system locale tables initialized, as that + might cause screwups when the dumped Emacs starts up. */ + char *lc_all = getenv ("LC_ALL"); + if (! (lc_all && strcmp (lc_all, "C") == 0)) + { + #ifdef HAVE_NS + ns_pool = ns_alloc_autorelease_pool (); + ns_init_locale (); + #endif + setlocale (LC_ALL, ""); + fixup_locale (); + } text_quoting_flag = using_utf8 (); inhibit_window_system = 0; @@ -1269,12 +1276,12 @@ main (int argc, char **argv) { emacs_close (STDIN_FILENO); emacs_close (STDOUT_FILENO); - int result = emacs_open (term, O_RDWR, 0); + int result = emacs_open_noquit (term, O_RDWR, 0); if (result != STDIN_FILENO || (fcntl (STDIN_FILENO, F_DUPFD_CLOEXEC, STDOUT_FILENO) != STDOUT_FILENO)) { - char *errstring = strerror (errno); + const char *errstring = strerror (errno); fprintf (stderr, "%s: %s: %s\n", argv[0], term, errstring); exit (EXIT_FAILURE); } @@ -1537,6 +1544,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem if (!initialized) { init_alloc_once (); + init_pdumper_once (); init_obarray_once (); init_eval_once (); init_charset_once (); @@ -1585,14 +1593,6 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem init_alloc (); init_bignum (); init_threads (); - - if (do_initial_setlocale) - { - fixup_locale (); - Vsystem_messages_locale = Vprevious_system_messages_locale; - Vsystem_time_locale = Vprevious_system_time_locale; - } - init_eval (); init_atimer (); running_asynch_code = 0; @@ -1629,12 +1629,6 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem #endif #ifdef HAVE_NS - ns_pool = ns_alloc_autorelease_pool (); -#ifdef NS_IMPL_GNUSTEP - /* GNUstep stupidly resets our locale settings after we made them. */ - fixup_locale (); -#endif - if (!noninteractive) { #ifdef NS_IMPL_COCOA @@ -1748,11 +1742,6 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem globals_of_gfilenotify (); #endif -#ifdef HAVE_NS - /* Initialize the locale from user defaults. */ - ns_init_locale (); -#endif - /* Initialize and GC-protect Vinitial_environment and Vprocess_environment before set_initial_environment fills them in. */ @@ -1883,7 +1872,6 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem syms_of_xfns (); syms_of_xmenu (); syms_of_fontset (); - syms_of_xwidget (); syms_of_xsettings (); #ifdef HAVE_X_SM syms_of_xsmfns (); @@ -1960,6 +1948,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem #endif /* HAVE_W32NOTIFY */ #endif /* WINDOWSNT */ + syms_of_xwidget (); syms_of_threads (); syms_of_profiler (); syms_of_pdumper (); @@ -1968,12 +1957,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem syms_of_json (); #endif - keys_of_casefiddle (); - keys_of_cmds (); - keys_of_buffer (); keys_of_keyboard (); - keys_of_keymap (); - keys_of_window (); } else { @@ -1995,7 +1979,6 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem /* This calls putenv and so must precede init_process_emacs. */ init_timefns (); - /* This sets Voperating_system_release, which init_process_emacs uses. */ init_editfns (); /* These two call putenv. */ @@ -2381,10 +2364,13 @@ all of which are called before Emacs is actually killed. */ /* Fsignal calls emacs_abort () if it sees that waiting_for_input is set. */ waiting_for_input = 0; - if (noninteractive) - safe_run_hooks (Qkill_emacs_hook); - else - run_hook (Qkill_emacs_hook); + if (!NILP (find_symbol_value (Qkill_emacs_hook))) + { + if (noninteractive) + safe_run_hooks (Qkill_emacs_hook); + else + call1 (Qrun_hook_query_error_with_timeout, Qkill_emacs_hook); + } #ifdef HAVE_X_WINDOWS /* Transfer any clipboards we own to the clipboard manager. */ @@ -2635,25 +2621,25 @@ synchronize_locale (int category, Lisp_Object *plocale, Lisp_Object desired_loca if (! EQ (*plocale, desired_locale)) { *plocale = desired_locale; -#ifdef WINDOWSNT + char const *locale_string + = STRINGP (desired_locale) ? SSDATA (desired_locale) : ""; +# ifdef WINDOWSNT /* Changing categories like LC_TIME usually requires specifying an encoding suitable for the new locale, but MS-Windows's 'setlocale' will only switch the encoding when LC_ALL is specified. So we ignore CATEGORY, use LC_ALL instead, and then restore LC_NUMERIC to "C", so reading and printing numbers is unaffected. */ - setlocale (LC_ALL, (STRINGP (desired_locale) - ? SSDATA (desired_locale) - : "")); + setlocale (LC_ALL, locale_string); fixup_locale (); -#else /* !WINDOWSNT */ - setlocale (category, (STRINGP (desired_locale) - ? SSDATA (desired_locale) - : "")); -#endif /* !WINDOWSNT */ +# else /* !WINDOWSNT */ + setlocale (category, locale_string); +# endif /* !WINDOWSNT */ } } +static Lisp_Object Vprevious_system_time_locale; + /* Set system time locale to match Vsystem_time_locale, if possible. */ void synchronize_system_time_locale (void) @@ -2662,15 +2648,19 @@ synchronize_system_time_locale (void) Vsystem_time_locale); } +# ifdef LC_MESSAGES +static Lisp_Object Vprevious_system_messages_locale; +# endif + /* Set system messages locale to match Vsystem_messages_locale, if possible. */ void synchronize_system_messages_locale (void) { -#ifdef LC_MESSAGES +# ifdef LC_MESSAGES synchronize_locale (LC_MESSAGES, &Vprevious_system_messages_locale, Vsystem_messages_locale); -#endif +# endif } #endif /* HAVE_SETLOCALE */ @@ -2754,7 +2744,7 @@ decode_env_path (const char *evarname, const char *defalt, bool empty) } } else if (cnv_result != 0 && d > path_utf8) - d[-1] = '\0'; /* remove last semi-colon and NUL-terminate PATH */ + d[-1] = '\0'; /* remove last semi-colon and null-terminate PATH */ } while (q); path_copy = path_utf8; #else /* MSDOS */ @@ -2861,7 +2851,7 @@ from the parent process and its tty file descriptors. */) int nfd; /* Get rid of stdin, stdout and stderr. */ - nfd = emacs_open ("/dev/null", O_RDWR, 0); + nfd = emacs_open_noquit ("/dev/null", O_RDWR, 0); err |= nfd < 0; err |= dup2 (nfd, STDIN_FILENO) < 0; err |= dup2 (nfd, STDOUT_FILENO) < 0; @@ -2902,6 +2892,8 @@ syms_of_emacs (void) DEFSYM (Qrisky_local_variable, "risky-local-variable"); DEFSYM (Qkill_emacs, "kill-emacs"); DEFSYM (Qkill_emacs_hook, "kill-emacs-hook"); + DEFSYM (Qrun_hook_query_error_with_timeout, + "run-hook-query-error-with-timeout"); #ifdef HAVE_UNEXEC defsubr (&Sdump_emacs); @@ -2992,19 +2984,16 @@ build directory. */); DEFVAR_LISP ("system-messages-locale", Vsystem_messages_locale, doc: /* System locale for messages. */); Vsystem_messages_locale = Qnil; - - DEFVAR_LISP ("previous-system-messages-locale", - Vprevious_system_messages_locale, - doc: /* Most recently used system locale for messages. */); +#ifdef LC_MESSAGES Vprevious_system_messages_locale = Qnil; + staticpro (&Vprevious_system_messages_locale); +#endif DEFVAR_LISP ("system-time-locale", Vsystem_time_locale, doc: /* System locale for time. */); Vsystem_time_locale = Qnil; - - DEFVAR_LISP ("previous-system-time-locale", Vprevious_system_time_locale, - doc: /* Most recently used system locale for time. */); Vprevious_system_time_locale = Qnil; + staticpro (&Vprevious_system_time_locale); DEFVAR_LISP ("before-init-time", Vbefore_init_time, doc: /* Value of `current-time' before Emacs begins initialization. */); diff --git a/src/eval.c b/src/eval.c index c86e84636db..3aff3b56d52 100644 --- a/src/eval.c +++ b/src/eval.c @@ -544,7 +544,10 @@ usage: (quote ARG) */) DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0, doc: /* Like `quote', but preferred for objects which are functions. In byte compilation, `function' causes its argument to be handled by -the byte compiler. `quote' cannot do that. +the byte compiler. Similarly, when expanding macros and expressions, +ARG can be examined and possibly expanded. If `quote' is used +instead, this doesn't happen. + usage: (function ARG) */) (Lisp_Object args) { @@ -678,6 +681,10 @@ default_toplevel_binding (Lisp_Object symbol) case SPECPDL_UNWIND_EXCURSION: case SPECPDL_UNWIND_VOID: case SPECPDL_BACKTRACE: +#ifdef HAVE_MODULES + case SPECPDL_MODULE_RUNTIME: + case SPECPDL_MODULE_ENVIRONMENT: +#endif case SPECPDL_LET_LOCAL: break; @@ -688,6 +695,49 @@ default_toplevel_binding (Lisp_Object symbol) return binding; } +/* Look for a lexical-binding of SYMBOL somewhere up the stack. + This will only find bindings created with interpreted code, since once + compiled names of lexical variables are basically gone anyway. */ +static bool +lexbound_p (Lisp_Object symbol) +{ + union specbinding *pdl = specpdl_ptr; + while (pdl > specpdl) + { + switch ((--pdl)->kind) + { + case SPECPDL_LET_DEFAULT: + case SPECPDL_LET: + if (EQ (specpdl_symbol (pdl), Qinternal_interpreter_environment)) + { + Lisp_Object env = specpdl_old_value (pdl); + if (CONSP (env) && !NILP (Fassq (symbol, env))) + return true; + } + break; + + case SPECPDL_UNWIND: + case SPECPDL_UNWIND_ARRAY: + case SPECPDL_UNWIND_PTR: + case SPECPDL_UNWIND_INT: + case SPECPDL_UNWIND_INTMAX: + case SPECPDL_UNWIND_EXCURSION: + case SPECPDL_UNWIND_VOID: + case SPECPDL_BACKTRACE: +#ifdef HAVE_MODULES + case SPECPDL_MODULE_RUNTIME: + case SPECPDL_MODULE_ENVIRONMENT: +#endif + case SPECPDL_LET_LOCAL: + break; + + default: + emacs_abort (); + } + } + return false; +} + DEFUN ("default-toplevel-value", Fdefault_toplevel_value, Sdefault_toplevel_value, 1, 1, 0, doc: /* Return SYMBOL's toplevel default value. "Toplevel" means outside of any let binding. */) @@ -723,6 +773,15 @@ This is like `defvar' and `defconst' but without affecting the variable's value. */) (Lisp_Object symbol, Lisp_Object doc) { + if (!XSYMBOL (symbol)->u.s.declared_special + && lexbound_p (symbol)) + /* This test tries to catch the situation where we do + (let ((<foo-var> ...)) ...(<foo-function> ...)....) + and where the `foo` package only gets loaded when <foo-function> + is called, so the outer `let` incorrectly made the binding lexical + because the <foo-var> wasn't yet declared as dynamic at that point. */ + error ("Defining as dynamic an already lexical var"); + XSYMBOL (symbol)->u.s.declared_special = true; if (!NILP (doc)) { @@ -759,6 +818,8 @@ The optional argument DOCSTRING is a documentation string for the variable. To define a user option, use `defcustom' instead of `defvar'. + +To define a buffer-local variable, use `defvar-local'. usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) (Lisp_Object args) { @@ -1108,9 +1169,18 @@ Lisp_Object internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object arg) { + /* MINIBUFFER_QUIT_LEVEL is to handle quitting from nested minibuffers by + throwing t to tag `exit'. + Value -1 means there is no (throw 'exit t) in progress; + 0 means the `throw' wasn't done from an active minibuffer; + N > 0 means the `throw' was done from the minibuffer at level N. */ + static EMACS_INT minibuffer_quit_level = -1; /* This structure is made part of the chain `catchlist'. */ struct handler *c = push_handler (tag, CATCHER); + if (EQ (tag, Qexit)) + minibuffer_quit_level = -1; + /* Call FUNC. */ if (! sys_setjmp (c->jmp)) { @@ -1124,6 +1194,23 @@ internal_catch (Lisp_Object tag, Lisp_Object val = handlerlist->val; clobbered_eassert (handlerlist == c); handlerlist = handlerlist->next; + if (EQ (tag, Qexit) && EQ (val, Qt)) + /* If we've thrown t to tag `exit' from within a minibuffer, we + exit all minibuffers more deeply nested than the current + one. */ + { + EMACS_INT mini_depth = this_minibuffer_depth (Qnil); + if (mini_depth && mini_depth != minibuffer_quit_level) + { + if (minibuffer_quit_level == -1) + minibuffer_quit_level = mini_depth; + if (minibuffer_quit_level + && (minibuf_level > minibuffer_quit_level)) + Fthrow (Qexit, Qt); + } + else + minibuffer_quit_level = -1; + } return val; } } @@ -1650,6 +1737,7 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit) break; } + bool debugger_called = false; if (/* Don't run the debugger for a memory-full error. (There is no room in memory to do that!) */ !NILP (error_symbol) @@ -1663,7 +1751,7 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit) if requested". */ || EQ (h->tag_or_ch, Qerror))) { - bool debugger_called + debugger_called = maybe_call_debugger (conditions, error_symbol, data); /* We can't return values to code which signaled an error, but we can continue code which has signaled a quit. */ @@ -1671,6 +1759,23 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit) return Qnil; } + /* If we're in batch mode, print a backtrace unconditionally to help + with debugging. Make sure to use `debug' unconditionally to not + interfere with ERT or other packages that install custom + debuggers. Don't try to call the debugger while dumping or + bootstrapping, it wouldn't work anyway. */ + if (!debugger_called && !NILP (error_symbol) + && (NILP (clause) || EQ (h->tag_or_ch, Qerror)) + && noninteractive && backtrace_on_error_noninteractive + && !will_dump_p () && !will_bootstrap_p () + && NILP (Vinhibit_debugger)) + { + ptrdiff_t count = SPECPDL_INDEX (); + specbind (Vdebugger, Qdebug); + call_debugger (list2 (Qerror, Fcons (error_symbol, data))); + unbind_to (count, Qnil); + } + if (!NILP (clause)) { Lisp_Object unwind_data @@ -1948,6 +2053,15 @@ then strings and vectors are not accepted. */) else if (COMPILEDP (fun)) return (PVSIZE (fun) > COMPILED_INTERACTIVE ? Qt : if_prop); +#ifdef HAVE_MODULES + /* Module functions are interactive if their `interactive_form' + field is non-nil. */ + else if (MODULE_FUNCTIONP (fun)) + return NILP (module_function_interactive_form (XMODULE_FUNCTION (fun))) + ? if_prop + : Qt; +#endif + /* Strings and vectors are keyboard macros. */ if (STRINGP (fun) || VECTORP (fun)) return (NILP (for_call_interactively) ? Qt : Qnil); @@ -2362,6 +2476,8 @@ eval_sub (Lisp_Object form) DEFUN ("apply", Fapply, Sapply, 1, MANY, 0, doc: /* Call FUNCTION with our remaining args, using our last arg as list of args. Then return the value FUNCTION returns. +With a single argument, call the argument's first element using the +other elements as args. Thus, (apply \\='+ 1 2 \\='(3 4)) returns 10. usage: (apply FUNCTION &rest ARGUMENTS) */) (ptrdiff_t nargs, Lisp_Object *args) @@ -2375,7 +2491,7 @@ usage: (apply FUNCTION &rest ARGUMENTS) */) ptrdiff_t numargs = list_length (spread_arg); if (numargs == 0) - return Ffuncall (nargs - 1, args); + return Ffuncall (max (1, nargs - 1), args); else if (numargs == 1) { args [nargs - 1] = XCAR (spread_arg); @@ -2905,6 +3021,21 @@ funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args) } } +/* Call the compiled Lisp function FUN. If we have not yet read FUN's + bytecode string and constants vector, fetch them from the file first. */ + +static Lisp_Object +fetch_and_exec_byte_code (Lisp_Object fun, Lisp_Object syms_left, + ptrdiff_t nargs, Lisp_Object *args) +{ + if (CONSP (AREF (fun, COMPILED_BYTECODE))) + Ffetch_bytecode (fun); + return exec_byte_code (AREF (fun, COMPILED_BYTECODE), + AREF (fun, COMPILED_CONSTANTS), + AREF (fun, COMPILED_STACK_DEPTH), + syms_left, nargs, args); +} + static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args, ptrdiff_t count) { @@ -2969,9 +3100,6 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, } else if (COMPILEDP (fun)) { - ptrdiff_t size = PVSIZE (fun); - if (size <= COMPILED_STACK_DEPTH) - xsignal1 (Qinvalid_function, fun); syms_left = AREF (fun, COMPILED_ARGLIST); if (FIXNUMP (syms_left)) /* A byte-code object with an integer args template means we @@ -2983,15 +3111,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, argument-binding code below instead (as do all interpreted functions, even lexically bound ones). */ { - /* If we have not actually read the bytecode string - and constants vector yet, fetch them from the file. */ - if (CONSP (AREF (fun, COMPILED_BYTECODE))) - Ffetch_bytecode (fun); - return exec_byte_code (AREF (fun, COMPILED_BYTECODE), - AREF (fun, COMPILED_CONSTANTS), - AREF (fun, COMPILED_STACK_DEPTH), - syms_left, - nargs, arg_vector); + return fetch_and_exec_byte_code (fun, syms_left, nargs, arg_vector); } lexenv = Qnil; } @@ -3060,16 +3180,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, if (CONSP (fun)) val = Fprogn (XCDR (XCDR (fun))); else - { - /* If we have not actually read the bytecode string - and constants vector yet, fetch them from the file. */ - if (CONSP (AREF (fun, COMPILED_BYTECODE))) - Ffetch_bytecode (fun); - val = exec_byte_code (AREF (fun, COMPILED_BYTECODE), - AREF (fun, COMPILED_CONSTANTS), - AREF (fun, COMPILED_STACK_DEPTH), - Qnil, 0, 0); - } + val = fetch_and_exec_byte_code (fun, Qnil, 0, NULL); return unbind_to (count, val); } @@ -3154,9 +3265,6 @@ lambda_arity (Lisp_Object fun) } else if (COMPILEDP (fun)) { - ptrdiff_t size = PVSIZE (fun); - if (size <= COMPILED_STACK_DEPTH) - xsignal1 (Qinvalid_function, fun); syms_left = AREF (fun, COMPILED_ARGLIST); if (FIXNUMP (syms_left)) return get_byte_code_arity (syms_left); @@ -3199,13 +3307,11 @@ DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode, if (COMPILEDP (object)) { - ptrdiff_t size = PVSIZE (object); - if (size <= COMPILED_STACK_DEPTH) - xsignal1 (Qinvalid_function, object); if (CONSP (AREF (object, COMPILED_BYTECODE))) { tem = read_doc_string (AREF (object, COMPILED_BYTECODE)); - if (!CONSP (tem)) + if (! (CONSP (tem) && STRINGP (XCAR (tem)) + && VECTORP (XCDR (tem)))) { tem = AREF (object, COMPILED_BYTECODE); if (CONSP (tem) && STRINGP (XCAR (tem))) @@ -3213,7 +3319,19 @@ DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode, else error ("Invalid byte code"); } - ASET (object, COMPILED_BYTECODE, XCAR (tem)); + + Lisp_Object bytecode = XCAR (tem); + if (STRING_MULTIBYTE (bytecode)) + { + /* BYTECODE must have been produced by Emacs 20.2 or earlier + because it produced a raw 8-bit string for byte-code and now + such a byte-code string is loaded as multibyte with raw 8-bit + characters converted to multibyte form. Convert them back to + the original unibyte form. */ + bytecode = Fstring_as_unibyte (bytecode); + } + + ASET (object, COMPILED_BYTECODE, bytecode); ASET (object, COMPILED_CONSTANTS, XCDR (tem)); } } @@ -3416,6 +3534,15 @@ record_unwind_protect_void (void (*function) (void)) } void +record_unwind_protect_module (enum specbind_tag kind, void *ptr) +{ + specpdl_ptr->kind = kind; + specpdl_ptr->unwind_ptr.func = NULL; + specpdl_ptr->unwind_ptr.arg = ptr; + grow_specpdl (); +} + +void rebind_for_thread_switch (void) { union specbinding *bind; @@ -3465,6 +3592,14 @@ do_one_unbind (union specbinding *this_binding, bool unwinding, break; case SPECPDL_BACKTRACE: break; +#ifdef HAVE_MODULES + case SPECPDL_MODULE_RUNTIME: + finalize_runtime_unwind (this_binding->unwind_ptr.arg); + break; + case SPECPDL_MODULE_ENVIRONMENT: + finalize_environment_unwind (this_binding->unwind_ptr.arg); + break; +#endif case SPECPDL_LET: { /* If variable has a trivial value (no forwarding), and isn't trapped, we can just set it. */ @@ -3795,6 +3930,10 @@ backtrace_eval_unrewind (int distance) case SPECPDL_UNWIND_INTMAX: case SPECPDL_UNWIND_VOID: case SPECPDL_BACKTRACE: +#ifdef HAVE_MODULES + case SPECPDL_MODULE_RUNTIME: + case SPECPDL_MODULE_ENVIRONMENT: +#endif break; case SPECPDL_LET: { /* If variable has a trivial value (no forwarding), we can @@ -3930,6 +4069,10 @@ NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. case SPECPDL_UNWIND_EXCURSION: case SPECPDL_UNWIND_VOID: case SPECPDL_BACKTRACE: +#ifdef HAVE_MODULES + case SPECPDL_MODULE_RUNTIME: + case SPECPDL_MODULE_ENVIRONMENT: +#endif break; default: @@ -3958,7 +4101,7 @@ mark_specpdl (union specbinding *first, union specbinding *ptr) break; case SPECPDL_UNWIND_ARRAY: - mark_maybe_objects (pdl->unwind_array.array, pdl->unwind_array.nelts); + mark_objects (pdl->unwind_array.array, pdl->unwind_array.nelts); break; case SPECPDL_UNWIND_EXCURSION: @@ -3972,11 +4115,18 @@ mark_specpdl (union specbinding *first, union specbinding *ptr) mark_object (backtrace_function (pdl)); if (nargs == UNEVALLED) nargs = 1; - while (nargs--) - mark_object (backtrace_args (pdl)[nargs]); + mark_objects (backtrace_args (pdl), nargs); } break; +#ifdef HAVE_MODULES + case SPECPDL_MODULE_RUNTIME: + break; + case SPECPDL_MODULE_ENVIRONMENT: + mark_module_environment (pdl->unwind_ptr.arg); + break; +#endif + case SPECPDL_LET_DEFAULT: case SPECPDL_LET_LOCAL: mark_object (specpdl_where (pdl)); @@ -4147,6 +4297,14 @@ Note that `debug-on-error', `debug-on-quit' and friends still determine whether to handle the particular condition. */); Vdebug_on_signal = Qnil; + DEFVAR_BOOL ("backtrace-on-error-noninteractive", + backtrace_on_error_noninteractive, + doc: /* Non-nil means print backtrace on error in batch mode. +If this is nil, errors in batch mode will just print the error +message upon encountering an unhandled error, without showing +the Lisp backtrace. */); + backtrace_on_error_noninteractive = true; + /* The value of num_nonmacro_input_events as of the last time we started to enter the debugger. If we decide to enter the debugger again when this is still equal to num_nonmacro_input_events, then we diff --git a/src/fileio.c b/src/fileio.c index eab268f8444..741e297d29c 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -96,7 +96,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <acl.h> #include <allocator.h> #include <careadlinkat.h> -#include <dosname.h> +#include <filename.h> #include <fsusage.h> #include <stat-time.h> #include <tempname.h> @@ -947,6 +947,22 @@ the root directory. */) ) { default_directory = Fexpand_file_name (default_directory, Qnil); + + /* The above expansion might have produced a remote file name, + so give the handlers one last chance to DTRT. This can + happen when both NAME and DEFAULT-DIRECTORY arguments are + relative file names, and the buffer's default-directory is + remote. */ + handler = Ffind_file_name_handler (default_directory, + Qexpand_file_name); + if (!NILP (handler)) + { + handled_name = call3 (handler, Qexpand_file_name, + name, default_directory); + if (STRINGP (handled_name)) + return handled_name; + error ("Invalid handler in `file-name-handler-alist'"); + } } } multibyte = STRING_MULTIBYTE (name); @@ -1694,7 +1710,7 @@ See also the function `substitute-in-file-name'.") #endif /* Put into BUF the concatenation of DIR and FILE, with an intervening - directory separator if needed. Return a pointer to the NUL byte + directory separator if needed. Return a pointer to the null byte at the end of the concatenated string. */ char * splice_dir_file (char *buf, char const *dir, char const *file) @@ -1952,7 +1968,10 @@ barf_or_query_if_file_exists (Lisp_Object absname, bool known_to_exist, encoded_filename = ENCODE_FILE (absname); - if (! known_to_exist && lstat (SSDATA (encoded_filename), &statbuf) == 0) + if (! known_to_exist + && (emacs_fstatat (AT_FDCWD, SSDATA (encoded_filename), + &statbuf, AT_SYMLINK_NOFOLLOW) + == 0)) { if (S_ISDIR (statbuf.st_mode)) xsignal2 (Qfile_error, @@ -2028,7 +2047,7 @@ permissions. */) ptrdiff_t count = SPECPDL_INDEX (); Lisp_Object encoded_file, encoded_newname; #if HAVE_LIBSELINUX - security_context_t con; + char *con; int conlength = 0; #endif #ifdef WINDOWSNT @@ -2074,7 +2093,7 @@ permissions. */) report_file_error ("Copying permissions from", file); case -3: xsignal2 (Qfile_date_error, - build_string ("Resetting file times"), newname); + build_string ("Cannot set file date"), newname); case -4: report_file_error ("Copying permissions to", newname); } @@ -2250,9 +2269,8 @@ permissions. */) if (!NILP (keep_time)) { - struct timespec atime = get_stat_atime (&st); - struct timespec mtime = get_stat_mtime (&st); - if (set_file_times (ofd, SSDATA (encoded_newname), atime, mtime) != 0) + struct timespec ts[] = { get_stat_atime (&st), get_stat_mtime (&st) }; + if (futimens (ofd, ts) != 0) xsignal2 (Qfile_date_error, build_string ("Cannot set file date"), newname); } @@ -2555,7 +2573,9 @@ This is what happens in interactive use with M-x. */) bool dirp = !NILP (Fdirectory_name_p (file)); if (!dirp) { - if (lstat (SSDATA (encoded_file), &file_st) != 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (encoded_file), + &file_st, AT_SYMLINK_NOFOLLOW) + != 0) report_file_error ("Renaming", list2 (file, newname)); dirp = S_ISDIR (file_st.st_mode) != 0; } @@ -2899,6 +2919,11 @@ DEFUN ("file-directory-p", Ffile_directory_p, Sfile_directory_p, 1, 1, 0, doc: /* Return t if FILENAME names an existing directory. Return nil if FILENAME does not name a directory, or if there was trouble determining whether FILENAME is a directory. + +As a special case, this function will also return t if FILENAME is the +empty string (\"\"). This quirk is due to Emacs interpreting the +empty string (in some cases) as the current directory. + Symbolic links to directories count as directories. See `file-symlink-p' to distinguish symlinks. */) (Lisp_Object filename) @@ -2928,7 +2953,8 @@ file_directory_p (Lisp_Object file) #else # ifdef O_PATH /* Use O_PATH if available, as it avoids races and EOVERFLOW issues. */ - int fd = openat (AT_FDCWD, SSDATA (file), O_PATH | O_CLOEXEC | O_DIRECTORY); + int fd = emacs_openat (AT_FDCWD, SSDATA (file), + O_PATH | O_CLOEXEC | O_DIRECTORY, 0); if (0 <= fd) { emacs_close (fd); @@ -2939,9 +2965,9 @@ file_directory_p (Lisp_Object file) /* O_PATH is defined but evidently this Linux kernel predates 2.6.39. Fall back on generic POSIX code. */ # endif - /* Use file_accessible_directory_p, as it avoids stat EOVERFLOW + /* Use file_accessible_directory_p, as it avoids fstatat EOVERFLOW problems and could be cheaper. However, if it fails because FILE - is inaccessible, fall back on stat; if the latter fails with + is inaccessible, fall back on fstatat; if the latter fails with EOVERFLOW then FILE must have been a directory unless a race condition occurred (a problem hard to work around portably). */ if (file_accessible_directory_p (file)) @@ -2949,7 +2975,7 @@ file_directory_p (Lisp_Object file) if (errno != EACCES) return false; struct stat st; - if (stat (SSDATA (file), &st) != 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (file), &st, 0) != 0) return errno == EOVERFLOW; if (S_ISDIR (st.st_mode)) return true; @@ -3024,7 +3050,6 @@ file_accessible_directory_p (Lisp_Object file) ptrdiff_t len = SBYTES (file); char const *dir; bool ok; - int saved_errno; USE_SAFE_ALLOCA; /* Normally a file "FOO" is an accessible directory if "FOO/." exists. @@ -3049,9 +3074,7 @@ file_accessible_directory_p (Lisp_Object file) } ok = file_access_p (dir, F_OK); - saved_errno = errno; SAFE_FREE (); - errno = saved_errno; return ok; #endif /* !DOS_NT */ } @@ -3080,7 +3103,7 @@ See `file-symlink-p' to distinguish symlinks. */) Vw32_get_true_file_attributes = Qt; #endif - int stat_result = stat (SSDATA (absname), &st); + int stat_result = emacs_fstatat (AT_FDCWD, SSDATA (absname), &st, 0); #ifdef WINDOWSNT Vw32_get_true_file_attributes = true_attributes; @@ -3113,7 +3136,7 @@ or if SELinux is disabled, or if Emacs lacks SELinux support. */) #if HAVE_LIBSELINUX if (is_selinux_enabled ()) { - security_context_t con; + char *con; int conlength = lgetfilecon (SSDATA (ENCODE_FILE (absname)), &con); if (conlength > 0) { @@ -3158,7 +3181,7 @@ or if Emacs was not compiled with SELinux support. */) Lisp_Object role = CAR_SAFE (CDR_SAFE (context)); Lisp_Object type = CAR_SAFE (CDR_SAFE (CDR_SAFE (context))); Lisp_Object range = CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (context)))); - security_context_t con; + char *con; bool fail; int conlength; context_t parsed_con; @@ -3326,50 +3349,60 @@ support. */) return Qnil; } -DEFUN ("file-modes", Ffile_modes, Sfile_modes, 1, 1, 0, +static int +symlink_nofollow_flag (Lisp_Object flag) +{ + /* For now, treat all non-nil FLAGs like 'nofollow'. */ + return !NILP (flag) ? AT_SYMLINK_NOFOLLOW : 0; +} + +DEFUN ("file-modes", Ffile_modes, Sfile_modes, 1, 2, 0, doc: /* Return mode bits of file named FILENAME, as an integer. -Return nil if FILENAME does not exist. */) - (Lisp_Object filename) +Return nil if FILENAME does not exist. If optional FLAG is `nofollow', +do not follow FILENAME if it is a symbolic link. */) + (Lisp_Object filename, Lisp_Object flag) { struct stat st; + int nofollow = symlink_nofollow_flag (flag); Lisp_Object absname = expand_and_dir_to_file (filename); /* If the file name has special constructs in it, call the corresponding file name handler. */ Lisp_Object handler = Ffind_file_name_handler (absname, Qfile_modes); if (!NILP (handler)) - return call2 (handler, Qfile_modes, absname); + return call3 (handler, Qfile_modes, absname, flag); - if (stat (SSDATA (ENCODE_FILE (absname)), &st) != 0) + char *fname = SSDATA (ENCODE_FILE (absname)); + if (emacs_fstatat (AT_FDCWD, fname, &st, nofollow) != 0) return file_attribute_errno (absname, errno); return make_fixnum (st.st_mode & 07777); } -DEFUN ("set-file-modes", Fset_file_modes, Sset_file_modes, 2, 2, +DEFUN ("set-file-modes", Fset_file_modes, Sset_file_modes, 2, 3, "(let ((file (read-file-name \"File: \"))) \ (list file (read-file-modes nil file)))", doc: /* Set mode bits of file named FILENAME to MODE (an integer). -Only the 12 low bits of MODE are used. +Only the 12 low bits of MODE are used. If optional FLAG is `nofollow', +do not follow FILENAME if it is a symbolic link. Interactively, mode bits are read by `read-file-modes', which accepts symbolic notation, like the `chmod' command from GNU Coreutils. */) - (Lisp_Object filename, Lisp_Object mode) + (Lisp_Object filename, Lisp_Object mode, Lisp_Object flag) { - Lisp_Object absname, encoded_absname; - Lisp_Object handler; - - absname = Fexpand_file_name (filename, BVAR (current_buffer, directory)); CHECK_FIXNUM (mode); + int nofollow = symlink_nofollow_flag (flag); + Lisp_Object absname = Fexpand_file_name (filename, + BVAR (current_buffer, directory)); /* If the file name has special constructs in it, call the corresponding file name handler. */ - handler = Ffind_file_name_handler (absname, Qset_file_modes); + Lisp_Object handler = Ffind_file_name_handler (absname, Qset_file_modes); if (!NILP (handler)) - return call3 (handler, Qset_file_modes, absname, mode); - - encoded_absname = ENCODE_FILE (absname); + return call4 (handler, Qset_file_modes, absname, mode, flag); - if (chmod (SSDATA (encoded_absname), XFIXNUM (mode) & 07777) < 0) + char *fname = SSDATA (ENCODE_FILE (absname)); + mode_t imode = XFIXNUM (mode) & 07777; + if (fchmodat (AT_FDCWD, fname, imode, nofollow) != 0) report_file_error ("Doing chmod", absname); return Qnil; @@ -3414,39 +3447,41 @@ The value is an integer. */) } -DEFUN ("set-file-times", Fset_file_times, Sset_file_times, 1, 2, 0, +DEFUN ("set-file-times", Fset_file_times, Sset_file_times, 1, 3, 0, doc: /* Set times of file FILENAME to TIMESTAMP. -Set both access and modification times. -Return t on success, else nil. -Use the current time if TIMESTAMP is nil. TIMESTAMP is in the format of -`current-time'. */) - (Lisp_Object filename, Lisp_Object timestamp) +If optional FLAG is `nofollow', do not follow FILENAME if it is a +symbolic link. Set both access and modification times. Return t on +success, else nil. Use the current time if TIMESTAMP is nil. +TIMESTAMP is in the format of `current-time'. */) + (Lisp_Object filename, Lisp_Object timestamp, Lisp_Object flag) { - Lisp_Object absname, encoded_absname; - Lisp_Object handler; - struct timespec t = lisp_time_argument (timestamp); + int nofollow = symlink_nofollow_flag (flag); - absname = Fexpand_file_name (filename, BVAR (current_buffer, directory)); + struct timespec ts[2]; + if (!NILP (timestamp)) + ts[0] = ts[1] = lisp_time_argument (timestamp); + else + ts[0].tv_nsec = ts[1].tv_nsec = UTIME_NOW; /* If the file name has special constructs in it, call the corresponding file name handler. */ - handler = Ffind_file_name_handler (absname, Qset_file_times); + Lisp_Object + absname = Fexpand_file_name (filename, BVAR (current_buffer, directory)), + handler = Ffind_file_name_handler (absname, Qset_file_times); if (!NILP (handler)) - return call3 (handler, Qset_file_times, absname, timestamp); + return call4 (handler, Qset_file_times, absname, timestamp, flag); - encoded_absname = ENCODE_FILE (absname); + Lisp_Object encoded_absname = ENCODE_FILE (absname); - { - if (set_file_times (-1, SSDATA (encoded_absname), t, t) != 0) - { + if (utimensat (AT_FDCWD, SSDATA (encoded_absname), ts, nofollow) != 0) + { #ifdef MSDOS - /* Setting times on a directory always fails. */ - if (file_directory_p (encoded_absname)) - return Qnil; + /* Setting times on a directory always fails. */ + if (file_directory_p (encoded_absname)) + return Qnil; #endif - report_file_error ("Setting file times", absname); - } - } + report_file_error ("Setting file times", absname); + } return Qt; } @@ -3486,7 +3521,7 @@ otherwise, if FILE2 does not exist, the answer is t. */) return call3 (handler, Qfile_newer_than_file_p, absname1, absname2); int err1; - if (stat (SSDATA (ENCODE_FILE (absname1)), &st1) == 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (ENCODE_FILE (absname1)), &st1, 0) == 0) err1 = 0; else { @@ -3494,7 +3529,7 @@ otherwise, if FILE2 does not exist, the answer is t. */) if (err1 != EOVERFLOW) return file_attribute_errno (absname1, err1); } - if (stat (SSDATA (ENCODE_FILE (absname2)), &st2) != 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (ENCODE_FILE (absname2)), &st2, 0) != 0) { file_attribute_errno (absname2, errno); return Qt; @@ -3719,9 +3754,10 @@ characters in the buffer. If VISIT is non-nil, BEG and END must be nil. If optional fifth argument REPLACE is non-nil, replace the current buffer contents (in the accessible portion) with the file contents. This is better than simply deleting and inserting the whole thing -because (1) it preserves some marker positions and (2) it puts less data -in the undo list. When REPLACE is non-nil, the second return value is -the number of characters that replace previous buffer contents. +because (1) it preserves some marker positions (in unchanged portions +at the start and end of the buffer) and (2) it puts less data in the +undo list. When REPLACE is non-nil, the second return value is the +number of characters that replace previous buffer contents. This function does code conversion according to the value of `coding-system-for-read' or `file-coding-system-alist', and sets the @@ -3880,7 +3916,7 @@ by calling `format-decode', which see. */) if (end_offset < 0) buffer_overflow (); - /* The file size returned from stat may be zero, but data + /* The file size returned from fstat may be zero, but data may be readable nonetheless, for example when this is a file in the /proc filesystem. */ if (end_offset == 0) @@ -3965,7 +4001,7 @@ by calling `format-decode', which see. */) record_unwind_current_buffer (); - workbuf = Fget_buffer_create (name); + workbuf = Fget_buffer_create (name, Qt); buf = XBUFFER (workbuf); delete_all_overlays (buf); @@ -5625,7 +5661,7 @@ See Info node `(elisp)Modification Time' for more details. */) filename = ENCODE_FILE (BVAR (b, filename)); - mtime = (stat (SSDATA (filename), &st) == 0 + mtime = (emacs_fstatat (AT_FDCWD, SSDATA (filename), &st, 0) == 0 ? get_stat_mtime (&st) : time_error_value (errno)); if (timespec_cmp (mtime, b->modtime) == 0 @@ -5665,8 +5701,8 @@ in `current-time' or an integer flag as returned by `visited-file-modtime'. */) struct timespec mtime; if (FIXNUMP (time_flag)) { - CHECK_RANGED_INTEGER (time_flag, -1, 0); - mtime = make_timespec (0, UNKNOWN_MODTIME_NSECS - XFIXNUM (time_flag)); + int flag = check_integer_range (time_flag, -1, 0); + mtime = make_timespec (0, UNKNOWN_MODTIME_NSECS - flag); } else mtime = lisp_time_argument (time_flag); @@ -5689,7 +5725,8 @@ in `current-time' or an integer flag as returned by `visited-file-modtime'. */) /* The handler can find the file name the same way we did. */ return call2 (handler, Qset_visited_file_modtime, Qnil); - if (stat (SSDATA (ENCODE_FILE (filename)), &st) == 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (ENCODE_FILE (filename)), &st, 0) + == 0) { current_buffer->modtime = get_stat_mtime (&st); current_buffer->modtime_size = st.st_size; @@ -5712,7 +5749,7 @@ auto_save_error (Lisp_Object error_val) Lisp_Object msg = CALLN (Fformat, format, BVAR (current_buffer, name), Ferror_message_string (error_val)); call3 (intern ("display-warning"), - intern ("auto-save"), msg, intern ("error")); + intern ("auto-save"), msg, intern (":error")); return Qnil; } @@ -5728,12 +5765,14 @@ auto_save_1 (void) /* Get visited file's mode to become the auto save file's mode. */ if (! NILP (BVAR (current_buffer, filename))) { - if (stat (SSDATA (BVAR (current_buffer, filename)), &st) >= 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (BVAR (current_buffer, filename)), + &st, 0) + == 0) /* But make sure we can overwrite it later! */ auto_save_mode_bits = (st.st_mode | 0600) & 0777; - else if (modes = Ffile_modes (BVAR (current_buffer, filename)), + else if (modes = Ffile_modes (BVAR (current_buffer, filename), Qnil), FIXNUMP (modes)) - /* Remote files don't cooperate with stat. */ + /* Remote files don't cooperate with fstatat. */ auto_save_mode_bits = (XFIXNUM (modes) | 0600) & 0777; } @@ -6217,6 +6256,7 @@ syms_of_fileio (void) DEFSYM (Qfile_date_error, "file-date-error"); DEFSYM (Qfile_missing, "file-missing"); DEFSYM (Qfile_notify_error, "file-notify-error"); + DEFSYM (Qremote_file_error, "remote-file-error"); DEFSYM (Qexcl, "excl"); DEFVAR_LISP ("file-name-coding-system", Vfile_name_coding_system, @@ -6278,6 +6318,11 @@ behaves as if file names were encoded in `utf-8'. */); Fput (Qfile_notify_error, Qerror_message, build_pure_c_string ("File notification error")); + Fput (Qremote_file_error, Qerror_conditions, + Fpurecopy (list3 (Qremote_file_error, Qfile_error, Qerror))); + Fput (Qremote_file_error, Qerror_message, + build_pure_c_string ("Remote file error")); + DEFVAR_LISP ("file-name-handler-alist", Vfile_name_handler_alist, doc: /* Alist of elements (REGEXP . HANDLER) for file names handled specially. If a file name matches REGEXP, all I/O on that file is done by calling diff --git a/src/filelock.c b/src/filelock.c index f7f536022c6..35baa0c6668 100644 --- a/src/filelock.c +++ b/src/filelock.c @@ -296,7 +296,7 @@ typedef struct /* Write the name of the lock file for FNAME into LOCKNAME. Length will be that of FNAME plus two more for the leading ".#", plus one - for the NUL. */ + for the null. */ #define MAKE_LOCK_NAME(lockname, fname) \ (lockname = SAFE_ALLOCA (SBYTES (fname) + 2 + 1), \ fill_in_lock_file_name (lockname, fname)) @@ -347,7 +347,8 @@ rename_lock_file (char const *old, char const *new, bool force) potential race condition since some other process may create NEW immediately after the existence check, but it's the best we can portably do here. */ - if (lstat (new, &st) == 0 || errno == EOVERFLOW) + if (emacs_fstatat (AT_FDCWD, new, &st, AT_SYMLINK_NOFOLLOW) == 0 + || errno == EOVERFLOW) { errno = EEXIST; return -1; @@ -660,7 +661,7 @@ void lock_file (Lisp_Object fn) { Lisp_Object orig_fn, encoded_fn; - char *lfname; + char *lfname = NULL; lock_info_type lock_info; USE_SAFE_ALLOCA; @@ -679,28 +680,22 @@ lock_file (Lisp_Object fn) dostounix_filename (SSDATA (fn)); #endif encoded_fn = ENCODE_FILE (fn); + if (create_lockfiles) + /* Create the name of the lock-file for file fn */ + MAKE_LOCK_NAME (lfname, encoded_fn); /* See if this file is visited and has changed on disk since it was visited. */ - { - register Lisp_Object subject_buf; - - subject_buf = get_truename_buffer (orig_fn); - - if (!NILP (subject_buf) - && NILP (Fverify_visited_file_modtime (subject_buf)) - && !NILP (Ffile_exists_p (fn))) - call1 (intern ("userlock--ask-user-about-supersession-threat"), fn); - - } + Lisp_Object subject_buf = get_truename_buffer (orig_fn); + if (!NILP (subject_buf) + && NILP (Fverify_visited_file_modtime (subject_buf)) + && !NILP (Ffile_exists_p (fn)) + && !(lfname && current_lock_owner (NULL, lfname) == -2)) + call1 (intern ("userlock--ask-user-about-supersession-threat"), fn); /* Don't do locking if the user has opted out. */ - if (create_lockfiles) + if (lfname) { - - /* Create the name of the lock-file for file fn */ - MAKE_LOCK_NAME (lfname, encoded_fn); - /* Try to lock the lock. FIXME: This ignores errors when lock_if_free returns a positive errno value. */ if (lock_if_free (&lock_info, lfname) < 0) @@ -859,7 +854,7 @@ syms_of_filelock (void) The name of the (per-buffer) lockfile is constructed by prepending a '.#' to the name of the file being locked. See also `lock-buffer' and Info node `(emacs)Interlocking'. */); - create_lockfiles = 1; + create_lockfiles = true; defsubr (&Sunlock_buffer); defsubr (&Slock_buffer); diff --git a/src/fns.c b/src/fns.c index 0bd6f8b6e5b..bd4afa0c4e9 100644 --- a/src/fns.c +++ b/src/fns.c @@ -21,6 +21,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <config.h> #include <stdlib.h> +#include <sys/random.h> #include <unistd.h> #include <filevercmp.h> #include <intprops.h> @@ -38,15 +39,12 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "puresize.h" #include "gnutls.h" -#if defined WINDOWSNT && defined HAVE_GNUTLS3 -# define gnutls_rnd w32_gnutls_rnd -#endif - static void sort_vector_copy (Lisp_Object, ptrdiff_t, Lisp_Object *restrict, Lisp_Object *restrict); enum equal_kind { EQUAL_NO_QUIT, EQUAL_PLAIN, EQUAL_INCLUDING_PROPERTIES }; static bool internal_equal (Lisp_Object, Lisp_Object, enum equal_kind, int, Lisp_Object); +static EMACS_UINT sxhash_obj (Lisp_Object, int); DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0, doc: /* Return the ARGUMENT unchanged. */ @@ -107,9 +105,14 @@ list_length (Lisp_Object list) DEFUN ("length", Flength, Slength, 1, 1, 0, doc: /* Return the length of vector, list or string SEQUENCE. A byte-code function object is also allowed. + If the string contains multibyte characters, this is not necessarily the number of bytes in the string; it is the number of characters. -To get the number of bytes, use `string-bytes'. */) +To get the number of bytes, use `string-bytes'. + +If the length of a list is being computed to compare to a (small) +number, the `length<', `length>' and `length=' functions may be more +efficient. */) (Lisp_Object sequence) { EMACS_INT val; @@ -147,6 +150,75 @@ least the number of distinct elements. */) return make_fixnum (len); } +static inline +EMACS_INT length_internal (Lisp_Object sequence, int len) +{ + /* If LENGTH is short (arbitrarily chosen cut-off point), use a + fast loop that doesn't care about whether SEQUENCE is + circular or not. */ + if (len < 0xffff) + while (CONSP (sequence)) + { + if (--len <= 0) + return -1; + sequence = XCDR (sequence); + } + /* Signal an error on circular lists. */ + else + FOR_EACH_TAIL (sequence) + if (--len <= 0) + return -1; + return len; +} + +DEFUN ("length<", Flength_less, Slength_less, 2, 2, 0, + doc: /* Return non-nil if SEQUENCE is shorter than LENGTH. +See `length' for allowed values of SEQUENCE and how elements are +counted. */) + (Lisp_Object sequence, Lisp_Object length) +{ + CHECK_FIXNUM (length); + EMACS_INT len = XFIXNUM (length); + + if (CONSP (sequence)) + return length_internal (sequence, len) == -1? Qnil: Qt; + else + return XFIXNUM (Flength (sequence)) < len? Qt: Qnil; +} + +DEFUN ("length>", Flength_greater, Slength_greater, 2, 2, 0, + doc: /* Return non-nil if SEQUENCE is longer than LENGTH. +See `length' for allowed values of SEQUENCE and how elements are +counted. */) + (Lisp_Object sequence, Lisp_Object length) +{ + CHECK_FIXNUM (length); + EMACS_INT len = XFIXNUM (length); + + if (CONSP (sequence)) + return length_internal (sequence, len + 1) == -1? Qt: Qnil; + else + return XFIXNUM (Flength (sequence)) > len? Qt: Qnil; +} + +DEFUN ("length=", Flength_equal, Slength_equal, 2, 2, 0, + doc: /* Return non-nil if SEQUENCE has length equal to LENGTH. +See `length' for allowed values of SEQUENCE and how elements are +counted. */) + (Lisp_Object sequence, Lisp_Object length) +{ + CHECK_FIXNUM (length); + EMACS_INT len = XFIXNUM (length); + + if (len < 0) + return Qnil; + + if (CONSP (sequence)) + return length_internal (sequence, len + 1) == 1? Qt: Qnil; + else + return XFIXNUM (Flength (sequence)) == len? Qt: Qnil; +} + DEFUN ("proper-list-p", Fproper_list_p, Sproper_list_p, 1, 1, 0, doc: /* Return OBJECT's length if it is a proper list, nil otherwise. A proper list is neither circular nor dotted (i.e., its last cdr is nil). */ @@ -225,12 +297,12 @@ Letter-case is significant, but text properties are ignored. */) for (x = 1; x <= len2; x++) { column[0] = x; - FETCH_STRING_CHAR_ADVANCE (c2, string2, i2, i2_byte); + c2 = fetch_string_char_advance (string2, &i2, &i2_byte); i1 = i1_byte = 0; for (y = 1, lastdiag = x - 1; y <= len1; y++) { olddiag = column[y]; - FETCH_STRING_CHAR_ADVANCE (c1, string1, i1, i1_byte); + c1 = fetch_string_char_advance (string1, &i1, &i1_byte); column[y] = min (min (column[y] + 1, column[y-1] + 1), lastdiag + (c1 == c2 ? 0 : 1)); lastdiag = olddiag; @@ -311,10 +383,8 @@ If string STR1 is greater, the value is a positive number N; { /* When we find a mismatch, we must compare the characters, not just the bytes. */ - int c1, c2; - - FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1, str1, i1, i1_byte); - FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2, str2, i2, i2_byte); + int c1 = fetch_string_char_as_multibyte_advance (str1, &i1, &i1_byte); + int c2 = fetch_string_char_as_multibyte_advance (str2, &i2, &i2_byte); if (c1 == c2) continue; @@ -349,11 +419,8 @@ DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0, doc: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order. Case is significant. Symbols are also allowed; their print names are used instead. */) - (register Lisp_Object string1, Lisp_Object string2) + (Lisp_Object string1, Lisp_Object string2) { - register ptrdiff_t end; - register ptrdiff_t i1, i1_byte, i2, i2_byte; - if (SYMBOLP (string1)) string1 = SYMBOL_NAME (string1); if (SYMBOLP (string2)) @@ -361,21 +428,15 @@ Symbols are also allowed; their print names are used instead. */) CHECK_STRING (string1); CHECK_STRING (string2); - i1 = i1_byte = i2 = i2_byte = 0; - - end = SCHARS (string1); - if (end > SCHARS (string2)) - end = SCHARS (string2); + ptrdiff_t i1 = 0, i1_byte = 0, i2 = 0, i2_byte = 0; + ptrdiff_t end = min (SCHARS (string1), SCHARS (string2)); while (i1 < end) { /* When we find a mismatch, we must compare the characters, not just the bytes. */ - int c1, c2; - - FETCH_STRING_CHAR_ADVANCE (c1, string1, i1, i1_byte); - FETCH_STRING_CHAR_ADVANCE (c2, string2, i2, i2_byte); - + int c1 = fetch_string_char_advance (string1, &i1, &i1_byte); + int c2 = fetch_string_char_advance (string2, &i2, &i2_byte); if (c1 != c2) return c1 < c2 ? Qt : Qnil; } @@ -419,7 +480,7 @@ string_version_cmp (Lisp_Object string1, Lisp_Object string2) while ((cmp = filevercmp (p1, p2)) == 0) { - /* If the strings are identical through their first NUL bytes, + /* If the strings are identical through their first null bytes, skip past identical prefixes and try again. */ ptrdiff_t size = strlen (p1) + 1; eassert (size == strlen (p2) + 1); @@ -766,8 +827,8 @@ concat (ptrdiff_t nargs, Lisp_Object *args, { Lisp_Object thislen; ptrdiff_t thisleni = 0; - register ptrdiff_t thisindex = 0; - register ptrdiff_t thisindex_byte = 0; + ptrdiff_t thisindex = 0; + ptrdiff_t thisindex_byte = 0; this = args[argnum]; if (!CONSP (this)) @@ -820,9 +881,8 @@ concat (ptrdiff_t nargs, Lisp_Object *args, { int c; if (STRING_MULTIBYTE (this)) - FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this, - thisindex, - thisindex_byte); + c = fetch_string_char_advance_no_check (this, &thisindex, + &thisindex_byte); else { c = SREF (this, thisindex); thisindex++; @@ -1544,11 +1604,21 @@ same_float (Lisp_Object x, Lisp_Object y) return !neql; } +/* True if X can be compared using `eq'. + This predicate is approximative, for maximum speed. */ +static bool +eq_comparable_value (Lisp_Object x) +{ + return SYMBOLP (x) || FIXNUMP (x); +} + DEFUN ("member", Fmember, Smember, 2, 2, 0, doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'. The value is actually the tail of LIST whose car is ELT. */) (Lisp_Object elt, Lisp_Object list) { + if (eq_comparable_value (elt)) + return Fmemq (elt, list); Lisp_Object tail = list; FOR_EACH_TAIL (tail) if (! NILP (Fequal (elt, XCAR (tail)))) @@ -1636,6 +1706,8 @@ The value is actually the first element of ALIST whose car equals KEY. Equality is defined by TESTFN if non-nil or by `equal' if nil. */) (Lisp_Object key, Lisp_Object alist, Lisp_Object testfn) { + if (eq_comparable_value (key) && NILP (testfn)) + return Fassq (key, alist); Lisp_Object tail = alist; FOR_EACH_TAIL (tail) { @@ -1686,6 +1758,8 @@ DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0, The value is actually the first element of ALIST whose cdr equals KEY. */) (Lisp_Object key, Lisp_Object alist) { + if (eq_comparable_value (key)) + return Frassq (key, alist); Lisp_Object tail = alist; FOR_EACH_TAIL (tail) { @@ -1747,25 +1821,27 @@ changing the value of a sequence `foo'. */) { if (VECTORP (seq)) { - ptrdiff_t i, n; - - for (i = n = 0; i < ASIZE (seq); ++i) - if (NILP (Fequal (AREF (seq, i), elt))) - ++n; + ptrdiff_t n = 0; + ptrdiff_t size = ASIZE (seq); + USE_SAFE_ALLOCA; + Lisp_Object *kept = SAFE_ALLOCA (size * sizeof *kept); - if (n != ASIZE (seq)) + for (ptrdiff_t i = 0; i < size; i++) { - struct Lisp_Vector *p = allocate_vector (n); + kept[n] = AREF (seq, i); + n += NILP (Fequal (AREF (seq, i), elt)); + } - for (i = n = 0; i < ASIZE (seq); ++i) - if (NILP (Fequal (AREF (seq, i), elt))) - p->contents[n++] = AREF (seq, i); + if (n != size) + seq = Fvector (n, kept); - XSETVECTOR (seq, p); - } + SAFE_FREE (); } else if (STRINGP (seq)) { + if (!CHARACTERP (elt)) + return seq; + ptrdiff_t i, ibyte, nchars, nbytes, cbytes; int c; @@ -1784,7 +1860,7 @@ changing the value of a sequence `foo'. */) cbytes = 1; } - if (!FIXNUMP (elt) || c != XFIXNUM (elt)) + if (c != XFIXNUM (elt)) { ++nchars; nbytes += cbytes; @@ -1814,7 +1890,7 @@ changing the value of a sequence `foo'. */) cbytes = 1; } - if (!FIXNUMP (elt) || c != XFIXNUM (elt)) + if (c != XFIXNUM (elt)) { unsigned char *from = SDATA (seq) + ibyte; unsigned char *to = SDATA (tem) + nbytes; @@ -1960,9 +2036,7 @@ See also the function `nreverse', which is used more often. */) p = SDATA (seq), q = SDATA (new) + bytes; while (q > SDATA (new)) { - int ch, len; - - ch = STRING_CHAR_AND_LENGTH (p, len); + int len, ch = string_char_and_length (p, &len); p += len, q -= len; CHAR_STRING (ch, q); } @@ -2295,6 +2369,7 @@ The PLIST is modified by side effects. */) DEFUN ("eql", Feql, Seql, 2, 2, 0, doc: /* Return t if the two args are `eq' or are indistinguishable numbers. +Integers with the same value are `eql'. Floating-point values with the same sign, exponent and fraction are `eql'. This differs from numeric comparison: (eql 0.0 -0.0) returns nil and \(eql 0.0e+NaN 0.0e+NaN) returns t, whereas `=' does the opposite. */) @@ -2433,6 +2508,9 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, same size. */ if (ASIZE (o2) != size) return false; + + /* Compare bignums, overlays, markers, and boolvectors + specially, by comparing their values. */ if (BIGNUMP (o1)) return mpz_cmp (*xbignum_val (o1), *xbignum_val (o2)) == 0; if (OVERLAYP (o1)) @@ -2453,21 +2531,12 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, && (XMARKER (o1)->buffer == 0 || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos)); } - /* Boolvectors are compared much like strings. */ if (BOOL_VECTOR_P (o1)) { EMACS_INT size = bool_vector_size (o1); - if (size != bool_vector_size (o2)) - return false; - if (memcmp (bool_vector_data (o1), bool_vector_data (o2), - bool_vector_bytes (size))) - return false; - return true; - } - if (WINDOW_CONFIGURATIONP (o1)) - { - eassert (equal_kind != EQUAL_NO_QUIT); - return compare_window_configurations (o1, o2, false); + return (size == bool_vector_size (o2) + && !memcmp (bool_vector_data (o1), bool_vector_data (o2), + bool_vector_bytes (size))); } /* Aside from them, only true vectors, char-tables, compiled @@ -2493,16 +2562,11 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, break; case Lisp_String: - if (SCHARS (o1) != SCHARS (o2)) - return false; - if (SBYTES (o1) != SBYTES (o2)) - return false; - if (memcmp (SDATA (o1), SDATA (o2), SBYTES (o1))) - return false; - if (equal_kind == EQUAL_INCLUDING_PROPERTIES - && !compare_string_intervals (o1, o2)) - return false; - return true; + return (SCHARS (o1) == SCHARS (o2) + && SBYTES (o1) == SBYTES (o2) + && !memcmp (SDATA (o1), SDATA (o2), SBYTES (o1)) + && (equal_kind != EQUAL_INCLUDING_PROPERTIES + || compare_string_intervals (o1, o2))); default: break; @@ -2532,26 +2596,36 @@ ARRAY is a vector, string, char-table, or bool-vector. */) } else if (STRINGP (array)) { - register unsigned char *p = SDATA (array); - int charval; + unsigned char *p = SDATA (array); CHECK_CHARACTER (item); - charval = XFIXNAT (item); + int charval = XFIXNAT (item); size = SCHARS (array); - if (STRING_MULTIBYTE (array)) + if (size != 0) { + CHECK_IMPURE (array, XSTRING (array)); unsigned char str[MAX_MULTIBYTE_LENGTH]; - int len = CHAR_STRING (charval, str); - ptrdiff_t size_byte = SBYTES (array); - ptrdiff_t product; + int len; + if (STRING_MULTIBYTE (array)) + len = CHAR_STRING (charval, str); + else + { + str[0] = charval; + len = 1; + } - if (INT_MULTIPLY_WRAPV (size, len, &product) || product != size_byte) - error ("Attempt to change byte length of a string"); - for (idx = 0; idx < size_byte; idx++) - *p++ = str[idx % len]; + ptrdiff_t size_byte = SBYTES (array); + if (len == 1 && size == size_byte) + memset (p, str[0], size); + else + { + ptrdiff_t product; + if (INT_MULTIPLY_WRAPV (size, len, &product) + || product != size_byte) + error ("Attempt to change byte length of a string"); + for (idx = 0; idx < size_byte; idx++) + *p++ = str[idx % len]; + } } - else - for (idx = 0; idx < size; idx++) - p[idx] = charval; } else if (BOOL_VECTOR_P (array)) return bool_vector_fill (array, item); @@ -2566,12 +2640,15 @@ DEFUN ("clear-string", Fclear_string, Sclear_string, This makes STRING unibyte and may change its length. */) (Lisp_Object string) { - ptrdiff_t len; CHECK_STRING (string); - len = SBYTES (string); - memset (SDATA (string), 0, len); - STRING_SET_CHARS (string, len); - STRING_SET_UNIBYTE (string); + ptrdiff_t len = SBYTES (string); + if (len != 0 || STRING_MULTIBYTE (string)) + { + CHECK_IMPURE (string, XSTRING (string)); + memset (SDATA (string), 0, len); + STRING_SET_CHARS (string, len); + STRING_SET_UNIBYTE (string); + } return Qnil; } @@ -2624,51 +2701,45 @@ usage: (nconc &rest LISTS) */) static EMACS_INT mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) { - Lisp_Object tail, dummy; - EMACS_INT i; - if (VECTORP (seq) || COMPILEDP (seq)) { - for (i = 0; i < leni; i++) + for (ptrdiff_t i = 0; i < leni; i++) { - dummy = call1 (fn, AREF (seq, i)); + Lisp_Object dummy = call1 (fn, AREF (seq, i)); if (vals) vals[i] = dummy; } } else if (BOOL_VECTOR_P (seq)) { - for (i = 0; i < leni; i++) + for (EMACS_INT i = 0; i < leni; i++) { - dummy = call1 (fn, bool_vector_ref (seq, i)); + Lisp_Object dummy = call1 (fn, bool_vector_ref (seq, i)); if (vals) vals[i] = dummy; } } else if (STRINGP (seq)) { - ptrdiff_t i_byte; + ptrdiff_t i_byte = 0; - for (i = 0, i_byte = 0; i < leni;) + for (ptrdiff_t i = 0; i < leni;) { - int c; ptrdiff_t i_before = i; - - FETCH_STRING_CHAR_ADVANCE (c, seq, i, i_byte); - XSETFASTINT (dummy, c); - dummy = call1 (fn, dummy); + int c = fetch_string_char_advance (seq, &i, &i_byte); + Lisp_Object dummy = call1 (fn, make_fixnum (c)); if (vals) vals[i_before] = dummy; } } else /* Must be a list, since Flength did not get an error */ { - tail = seq; - for (i = 0; i < leni; i++) + Lisp_Object tail = seq; + for (ptrdiff_t i = 0; i < leni; i++) { if (! CONSP (tail)) return i; - dummy = call1 (fn, XCAR (tail)); + Lisp_Object dummy = call1 (fn, XCAR (tail)); if (vals) vals[i] = dummy; tail = XCDR (tail); @@ -2853,7 +2924,7 @@ advisable. */) while (loads-- > 0) { Lisp_Object load = (NILP (use_floats) - ? make_fixnum (100.0 * load_ave[loads]) + ? double_to_integer (100.0 * load_ave[loads]) : make_float (load_ave[loads])); ret = Fcons (load, ret); } @@ -3461,7 +3532,7 @@ base64_encode_1 (const char *from, char *to, ptrdiff_t length, { if (multibyte) { - c = STRING_CHAR_AND_LENGTH ((unsigned char *) from + i, bytes); + c = string_char_and_length ((unsigned char *) from + i, &bytes); if (CHAR_BYTE8_P (c)) c = CHAR_TO_BYTE8 (c); else if (c >= 256) @@ -3504,7 +3575,7 @@ base64_encode_1 (const char *from, char *to, ptrdiff_t length, if (multibyte) { - c = STRING_CHAR_AND_LENGTH ((unsigned char *) from + i, bytes); + c = string_char_and_length ((unsigned char *) from + i, &bytes); if (CHAR_BYTE8_P (c)) c = CHAR_TO_BYTE8 (c); else if (c >= 256) @@ -3529,7 +3600,7 @@ base64_encode_1 (const char *from, char *to, ptrdiff_t length, if (multibyte) { - c = STRING_CHAR_AND_LENGTH ((unsigned char *) from + i, bytes); + c = string_char_and_length ((unsigned char *) from + i, &bytes); if (CHAR_BYTE8_P (c)) c = CHAR_TO_BYTE8 (c); else if (c >= 256) @@ -3710,7 +3781,7 @@ base64_decode_1 (const char *from, char *to, ptrdiff_t length, c = value >> 16 & 0xff; if (c & multibyte_bit) - e += BYTE8_STRING (c, e); + e += BYTE8_STRING (c, (unsigned char *) e); else *e++ = c; nchars++; @@ -3752,7 +3823,7 @@ base64_decode_1 (const char *from, char *to, ptrdiff_t length, c = value >> 8 & 0xff; if (c & multibyte_bit) - e += BYTE8_STRING (c, e); + e += BYTE8_STRING (c, (unsigned char *) e); else *e++ = c; nchars++; @@ -3782,7 +3853,7 @@ base64_decode_1 (const char *from, char *to, ptrdiff_t length, c = value & 0xff; if (c & multibyte_bit) - e += BYTE8_STRING (c, e); + e += BYTE8_STRING (c, (unsigned char *) e); else *e++ = c; nchars++; @@ -4022,7 +4093,7 @@ hashfn_eq (Lisp_Object key, struct Lisp_Hash_Table *h) Lisp_Object hashfn_equal (Lisp_Object key, struct Lisp_Hash_Table *h) { - return make_ufixnum (sxhash (key, 0)); + return make_ufixnum (sxhash (key)); } /* Ignore HT and return a hash code for KEY which uses 'eql' to compare keys. @@ -4042,7 +4113,7 @@ hashfn_user_defined (Lisp_Object key, struct Lisp_Hash_Table *h) { Lisp_Object args[] = { h->test.user_hash_function, key }; Lisp_Object hash = hash_table_user_defined_call (ARRAYELTS (args), args, h); - return FIXNUMP (hash) ? hash : make_ufixnum (sxhash (hash, 0)); + return FIXNUMP (hash) ? hash : make_ufixnum (sxhash (hash)); } struct hash_table_test const @@ -4254,50 +4325,31 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h) /* Recompute the hashes (and hence also the "next" pointers). Normally there's never a need to recompute hashes. - This is done only on first-access to a hash-table loaded from - the "pdump", because the object's addresses may have changed, thus - affecting their hash. */ + This is done only on first access to a hash-table loaded from + the "pdump", because the objects' addresses may have changed, thus + affecting their hashes. */ void -hash_table_rehash (struct Lisp_Hash_Table *h) +hash_table_rehash (Lisp_Object hash) { - ptrdiff_t size = HASH_TABLE_SIZE (h); - - /* These structures may have been purecopied and shared - (bug#36447). */ - Lisp_Object hash = make_nil_vector (size); - h->next = Fcopy_sequence (h->next); - h->index = Fcopy_sequence (h->index); + struct Lisp_Hash_Table *h = XHASH_TABLE (hash); + ptrdiff_t i, count = h->count; /* Recompute the actual hash codes for each entry in the table. Order is still invalid. */ - for (ptrdiff_t i = 0; i < size; ++i) + for (i = 0; i < count; i++) { Lisp_Object key = HASH_KEY (h, i); - if (!EQ (key, Qunbound)) - ASET (hash, i, h->test.hashfn (key, h)); + Lisp_Object hash_code = h->test.hashfn (key, h); + ptrdiff_t start_of_bucket = XUFIXNUM (hash_code) % ASIZE (h->index); + set_hash_hash_slot (h, i, hash_code); + set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket)); + set_hash_index_slot (h, start_of_bucket, i); + eassert (HASH_NEXT (h, i) != i); /* Stop loops. */ } - /* Reset the index so that any slot we don't fill below is marked - invalid. */ - Ffillarray (h->index, make_fixnum (-1)); - - /* Rebuild the collision chains. */ - for (ptrdiff_t i = 0; i < size; ++i) - if (!NILP (AREF (hash, i))) - { - EMACS_UINT hash_code = XUFIXNUM (AREF (hash, i)); - ptrdiff_t start_of_bucket = hash_code % ASIZE (h->index); - set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket)); - set_hash_index_slot (h, start_of_bucket, i); - eassert (HASH_NEXT (h, i) != i); /* Stop loops. */ - } - - /* Finally, mark the hash table as having a valid hash order. - Do this last so that if we're interrupted, we retry on next - access. */ - eassert (hash_rehash_needed_p (h)); - h->hash = hash; - eassert (!hash_rehash_needed_p (h)); + ptrdiff_t size = ASIZE (h->next); + for (; i + 1 < size; i++) + set_hash_next_slot (h, i, i + 1); } /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH @@ -4309,8 +4361,6 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object *hash) { ptrdiff_t start_of_bucket, i; - hash_rehash_if_needed (h); - Lisp_Object hash_code = h->test.hashfn (key, h); if (hash) *hash = hash_code; @@ -4345,8 +4395,6 @@ hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value, { ptrdiff_t start_of_bucket, i; - hash_rehash_if_needed (h); - /* Increment count after resizing because resizing may fail. */ maybe_resize_hash_table (h); h->count++; @@ -4379,8 +4427,6 @@ hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key) ptrdiff_t start_of_bucket = XUFIXNUM (hash_code) % ASIZE (h->index); ptrdiff_t prev = -1; - hash_rehash_if_needed (h); - for (ptrdiff_t i = HASH_INDEX (h, start_of_bucket); 0 <= i; i = HASH_NEXT (h, i)) @@ -4421,8 +4467,7 @@ hash_clear (struct Lisp_Hash_Table *h) if (h->count > 0) { ptrdiff_t size = HASH_TABLE_SIZE (h); - if (!hash_rehash_needed_p (h)) - memclear (XVECTOR (h->hash)->contents, size * word_size); + memclear (xvector_contents (h->hash), size * word_size); for (ptrdiff_t i = 0; i < size; i++) { set_hash_next_slot (h, i, i < size - 1 ? i + 1 : -1); @@ -4458,9 +4503,7 @@ sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p) for (ptrdiff_t bucket = 0; bucket < n; ++bucket) { /* Follow collision chain, removing entries that don't survive - this garbage collection. It's okay if hash_rehash_needed_p - (h) is true, since we're operating entirely on the cached - hash values. */ + this garbage collection. */ ptrdiff_t prev = -1; ptrdiff_t next; for (ptrdiff_t i = HASH_INDEX (h, bucket); 0 <= i; i = next) @@ -4505,7 +4548,7 @@ sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p) set_hash_hash_slot (h, i, Qnil); eassert (h->count != 0); - h->count += h->count > 0 ? -1 : 1; + h->count--; } else { @@ -4556,14 +4599,28 @@ sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p) EMACS_UINT hash_string (char const *ptr, ptrdiff_t len) { - char const *p = ptr; - char const *end = p + len; - unsigned char c; - EMACS_UINT hash = 0; + char const *p = ptr; + char const *end = ptr + len; + EMACS_UINT hash = len; + /* At most 8 steps. We could reuse SXHASH_MAX_LEN, of course, + * but dividing by 8 is cheaper. */ + ptrdiff_t step = sizeof hash + ((end - p) >> 3); - while (p != end) + while (p + sizeof hash <= end) + { + EMACS_UINT c; + /* We presume that the compiler will replace this `memcpy` with + a single load/move instruction when applicable. */ + memcpy (&c, p, sizeof hash); + p += step; + hash = sxhash_combine (hash, c); + } + /* A few last bytes may remain (smaller than an EMACS_UINT). */ + /* FIXME: We could do this without a loop, but it'd require + endian-dependent code :-( */ + while (p < end) { - c = *p++; + unsigned char c = *p++; hash = sxhash_combine (hash, c); } @@ -4606,13 +4663,13 @@ sxhash_list (Lisp_Object list, int depth) CONSP (list) && i < SXHASH_MAX_LEN; list = XCDR (list), ++i) { - EMACS_UINT hash2 = sxhash (XCAR (list), depth + 1); + EMACS_UINT hash2 = sxhash_obj (XCAR (list), depth + 1); hash = sxhash_combine (hash, hash2); } if (!NILP (list)) { - EMACS_UINT hash2 = sxhash (list, depth + 1); + EMACS_UINT hash2 = sxhash_obj (list, depth + 1); hash = sxhash_combine (hash, hash2); } @@ -4632,7 +4689,7 @@ sxhash_vector (Lisp_Object vec, int depth) n = min (SXHASH_MAX_LEN, hash & PSEUDOVECTOR_FLAG ? PVSIZE (vec) : hash); for (i = 0; i < n; ++i) { - EMACS_UINT hash2 = sxhash (AREF (vec, i), depth + 1); + EMACS_UINT hash2 = sxhash_obj (AREF (vec, i), depth + 1); hash = sxhash_combine (hash, hash2); } @@ -4675,58 +4732,78 @@ sxhash_bignum (Lisp_Object bignum) structure. Value is an unsigned integer clipped to INTMASK. */ EMACS_UINT -sxhash (Lisp_Object obj, int depth) +sxhash (Lisp_Object obj) { - EMACS_UINT hash; + return sxhash_obj (obj, 0); +} +static EMACS_UINT +sxhash_obj (Lisp_Object obj, int depth) +{ if (depth > SXHASH_MAX_DEPTH) return 0; switch (XTYPE (obj)) { case_Lisp_Int: - hash = XUFIXNUM (obj); - break; + return XUFIXNUM (obj); case Lisp_Symbol: - hash = XHASH (obj); - break; + return XHASH (obj); case Lisp_String: - hash = sxhash_string (SSDATA (obj), SBYTES (obj)); - break; + return sxhash_string (SSDATA (obj), SBYTES (obj)); - /* This can be everything from a vector to an overlay. */ case Lisp_Vectorlike: - if (BIGNUMP (obj)) - hash = sxhash_bignum (obj); - else if (VECTORP (obj) || RECORDP (obj)) - /* According to the CL HyperSpec, two arrays are equal only if - they are `eq', except for strings and bit-vectors. In - Emacs, this works differently. We have to compare element - by element. Same for records. */ - hash = sxhash_vector (obj, depth); - else if (BOOL_VECTOR_P (obj)) - hash = sxhash_bool_vector (obj); - else - /* Others are `equal' if they are `eq', so let's take their - address as hash. */ - hash = XHASH (obj); - break; + { + enum pvec_type pvec_type = PSEUDOVECTOR_TYPE (XVECTOR (obj)); + if (! (PVEC_NORMAL_VECTOR < pvec_type && pvec_type < PVEC_COMPILED)) + { + /* According to the CL HyperSpec, two arrays are equal only if + they are 'eq', except for strings and bit-vectors. In + Emacs, this works differently. We have to compare element + by element. Same for pseudovectors that internal_equal + examines the Lisp contents of. */ + return (SUB_CHAR_TABLE_P (obj) + /* 'sxhash_vector' can't be applies to a sub-char-table and + it's probably not worth looking into them anyway! */ + ? 42 + : sxhash_vector (obj, depth)); + } + else if (pvec_type == PVEC_BIGNUM) + return sxhash_bignum (obj); + else if (pvec_type == PVEC_MARKER) + { + ptrdiff_t bytepos + = XMARKER (obj)->buffer ? XMARKER (obj)->bytepos : 0; + EMACS_UINT hash + = sxhash_combine ((intptr_t) XMARKER (obj)->buffer, bytepos); + return SXHASH_REDUCE (hash); + } + else if (pvec_type == PVEC_BOOL_VECTOR) + return sxhash_bool_vector (obj); + else if (pvec_type == PVEC_OVERLAY) + { + EMACS_UINT hash = sxhash_obj (OVERLAY_START (obj), depth); + hash = sxhash_combine (hash, sxhash_obj (OVERLAY_END (obj), depth)); + hash = sxhash_combine (hash, sxhash_obj (XOVERLAY (obj)->plist, depth)); + return SXHASH_REDUCE (hash); + } + else + /* Others are 'equal' if they are 'eq', so take their + address as hash. */ + return XHASH (obj); + } case Lisp_Cons: - hash = sxhash_list (obj, depth); - break; + return sxhash_list (obj, depth); case Lisp_Float: - hash = sxhash_float (XFLOAT_DATA (obj)); - break; + return sxhash_float (XFLOAT_DATA (obj)); default: emacs_abort (); } - - return hash; } @@ -4909,7 +4986,6 @@ DEFUN ("hash-table-count", Fhash_table_count, Shash_table_count, 1, 1, 0, (Lisp_Object table) { struct Lisp_Hash_Table *h = check_hash_table (table); - eassert (h->count >= 0); return make_fixnum (h->count); } @@ -5177,22 +5253,8 @@ extract_data_from_object (Lisp_Object spec, struct buffer *bp = XBUFFER (object); set_buffer_internal (bp); - if (NILP (start)) - b = BEGV; - else - { - CHECK_FIXNUM_COERCE_MARKER (start); - b = XFIXNUM (start); - } - - if (NILP (end)) - e = ZV; - else - { - CHECK_FIXNUM_COERCE_MARKER (end); - e = XFIXNUM (end); - } - + b = !NILP (start) ? fix_position (start) : BEGV; + e = !NILP (end) ? fix_position (end) : ZV; if (b > e) { EMACS_INT temp = b; @@ -5278,7 +5340,6 @@ extract_data_from_object (Lisp_Object spec, } else if (EQ (object, Qiv_auto)) { -#ifdef HAVE_GNUTLS3 /* Format: (iv-auto REQUIRED-LENGTH). */ if (! FIXNATP (start)) @@ -5287,14 +5348,19 @@ extract_data_from_object (Lisp_Object spec, { EMACS_INT start_hold = XFIXNAT (start); object = make_uninit_string (start_hold); - gnutls_rnd (GNUTLS_RND_NONCE, SSDATA (object), start_hold); + char *lim = SSDATA (object) + start_hold; + for (char *p = SSDATA (object); p < lim; p++) + { + ssize_t gotten = getrandom (p, lim - p, 0); + if (0 <= gotten) + p += gotten; + else if (errno != EINTR) + report_file_error ("Getting random data", Qnil); + } *start_byte = 0; *end_byte = start_hold; } -#else - error ("GnuTLS is not available, so `iv-auto' can't be used"); -#endif } if (!STRINGP (object)) @@ -5440,7 +5506,8 @@ disregarding any coding systems. If nil, use the current buffer. This function is useful for comparing two buffers running in the same Emacs, but is not guaranteed to return the same hash between different -Emacs versions. +Emacs versions. It should be somewhat more efficient on larger +buffers than `secure-hash' is, and should not allocate more memory. It should not be used for anything security-related. See `secure-hash' for these applications. */ ) @@ -5477,6 +5544,220 @@ It should not be used for anything security-related. See return make_digest_string (digest, SHA1_DIGEST_SIZE); } +DEFUN ("buffer-line-statistics", Fbuffer_line_statistics, + Sbuffer_line_statistics, 0, 1, 0, + doc: /* Return data about lines in BUFFER. +The data is returned as a list, and the first element is the number of +lines in the buffer, the second is the length of the longest line, and +the third is the mean line length. The lengths returned are in bytes, not +characters. */ ) + (Lisp_Object buffer_or_name) +{ + Lisp_Object buffer; + ptrdiff_t lines = 0, longest = 0; + double mean = 0; + struct buffer *b; + + if (NILP (buffer_or_name)) + buffer = Fcurrent_buffer (); + else + buffer = Fget_buffer (buffer_or_name); + if (NILP (buffer)) + nsberror (buffer_or_name); + + b = XBUFFER (buffer); + + unsigned char *start = BUF_BEG_ADDR (b); + ptrdiff_t area = BUF_GPT_BYTE (b) - BUF_BEG_BYTE (b), pre_gap = 0; + + /* Process the first part of the buffer. */ + while (area > 0) + { + unsigned char *n = memchr (start, '\n', area); + + if (n) + { + ptrdiff_t this_line = n - start; + if (this_line > longest) + longest = this_line; + lines++; + /* Blame Knuth. */ + mean = mean + (this_line - mean) / lines; + area = area - this_line - 1; + start += this_line + 1; + } + else + { + /* Didn't have a newline here, so save the rest for the + post-gap calculation. */ + pre_gap = area; + area = 0; + } + } + + /* If the gap is before the end of the buffer, process the last half + of the buffer. */ + if (BUF_GPT_BYTE (b) < BUF_Z_BYTE (b)) + { + start = BUF_GAP_END_ADDR (b); + area = BUF_Z_ADDR (b) - BUF_GAP_END_ADDR (b); + + while (area > 0) + { + unsigned char *n = memchr (start, '\n', area); + ptrdiff_t this_line = n? n - start + pre_gap: area + pre_gap; + + if (this_line > longest) + longest = this_line; + lines++; + /* Blame Knuth again. */ + mean = mean + (this_line - mean) / lines; + area = area - this_line - 1; + start += this_line + 1; + pre_gap = 0; + } + } + else if (pre_gap > 0) + { + if (pre_gap > longest) + longest = pre_gap; + lines++; + mean = mean + (pre_gap - mean) / lines; + } + + return list3 (make_int (lines), make_int (longest), make_float (mean)); +} + +static bool +string_ascii_p (Lisp_Object string) +{ + ptrdiff_t nbytes = SBYTES (string); + for (ptrdiff_t i = 0; i < nbytes; i++) + if (SREF (string, i) > 127) + return false; + return true; +} + +DEFUN ("string-search", Fstring_search, Sstring_search, 2, 3, 0, + doc: /* Search for the string NEEDLE in the string HAYSTACK. +The return value is the position of the first occurrence of NEEDLE in +HAYSTACK, or nil if no match was found. + +The optional START-POS argument says where to start searching in +HAYSTACK and defaults to zero (start at the beginning). +It must be between zero and the length of HAYSTACK, inclusive. + +Case is always significant and text properties are ignored. */) + (register Lisp_Object needle, Lisp_Object haystack, Lisp_Object start_pos) +{ + ptrdiff_t start_byte = 0, haybytes; + char *res, *haystart; + EMACS_INT start = 0; + + CHECK_STRING (needle); + CHECK_STRING (haystack); + + if (!NILP (start_pos)) + { + CHECK_FIXNUM (start_pos); + start = XFIXNUM (start_pos); + if (start < 0 || start > SCHARS (haystack)) + xsignal1 (Qargs_out_of_range, start_pos); + start_byte = string_char_to_byte (haystack, start); + } + + /* If NEEDLE is longer than (the remaining length of) haystack, then + we can't have a match, and return early. */ + if (SCHARS (needle) > SCHARS (haystack) - start) + return Qnil; + + haystart = SSDATA (haystack) + start_byte; + haybytes = SBYTES (haystack) - start_byte; + + /* We can do a direct byte-string search if both strings have the + same multibyteness, or if the needle consists of ASCII characters only. */ + if (STRING_MULTIBYTE (haystack) + ? (STRING_MULTIBYTE (needle) + || SCHARS (haystack) == SBYTES (haystack) || string_ascii_p (needle)) + : (!STRING_MULTIBYTE (needle) + || SCHARS (needle) == SBYTES (needle))) + { + if (STRING_MULTIBYTE (haystack) && STRING_MULTIBYTE (needle) + && SCHARS (haystack) == SBYTES (haystack) + && SCHARS (needle) != SBYTES (needle)) + /* Multibyte non-ASCII needle, multibyte ASCII haystack: impossible. */ + return Qnil; + else + res = memmem (haystart, haybytes, + SSDATA (needle), SBYTES (needle)); + } + else if (STRING_MULTIBYTE (haystack)) /* unibyte non-ASCII needle */ + { + Lisp_Object multi_needle = string_to_multibyte (needle); + res = memmem (haystart, haybytes, + SSDATA (multi_needle), SBYTES (multi_needle)); + } + else /* unibyte haystack, multibyte non-ASCII needle */ + { + /* The only possible way we can find the multibyte needle in the + unibyte stack (since we know that the needle is non-ASCII) is + if they contain "raw bytes" (and no other non-ASCII chars.) */ + ptrdiff_t nbytes = SBYTES (needle); + for (ptrdiff_t i = 0; i < nbytes; i++) + { + int c = SREF (needle, i); + if (CHAR_BYTE8_HEAD_P (c)) + i++; /* Skip raw byte. */ + else if (!ASCII_CHAR_P (c)) + return Qnil; /* Found a char that can't be in the haystack. */ + } + + /* "Raw bytes" (aka eighth-bit) are represented differently in + multibyte and unibyte strings. */ + Lisp_Object uni_needle = Fstring_to_unibyte (needle); + res = memmem (haystart, haybytes, + SSDATA (uni_needle), SBYTES (uni_needle)); + } + + if (! res) + return Qnil; + + return make_int (string_byte_to_char (haystack, res - SSDATA (haystack))); +} + +static void +collect_interval (INTERVAL interval, Lisp_Object collector) +{ + nconc2 (collector, + list1(list3 (make_fixnum (interval->position), + make_fixnum (interval->position + LENGTH (interval)), + interval->plist))); +} + +DEFUN ("object-intervals", Fobject_intervals, Sobject_intervals, 1, 1, 0, + doc: /* Return a copy of the text properties of OBJECT. +OBJECT must be a buffer or a string. + +Altering this copy does not change the layout of the text properties +in OBJECT. */) + (register Lisp_Object object) +{ + Lisp_Object collector = Fcons (Qnil, Qnil); + INTERVAL intervals; + + if (STRINGP (object)) + intervals = string_intervals (object); + else if (BUFFERP (object)) + intervals = buffer_intervals (XBUFFER (object)); + else + wrong_type_argument (Qbuffer_or_string_p, object); + + if (! intervals) + return Qnil; + + traverse_intervals (intervals, 0, collect_interval, collector); + return CDR (collector); +} void @@ -5517,6 +5798,8 @@ syms_of_fns (void) defsubr (&Sremhash); defsubr (&Smaphash); defsubr (&Sdefine_hash_table_test); + defsubr (&Sstring_search); + defsubr (&Sobject_intervals); /* Crypto and hashing stuff. */ DEFSYM (Qiv_auto, "iv-auto"); @@ -5592,6 +5875,9 @@ this variable. */); defsubr (&Srandom); defsubr (&Slength); defsubr (&Ssafe_length); + defsubr (&Slength_less); + defsubr (&Slength_greater); + defsubr (&Slength_equal); defsubr (&Sproper_list_p); defsubr (&Sstring_bytes); defsubr (&Sstring_distance); @@ -5665,4 +5951,5 @@ this variable. */); defsubr (&Ssecure_hash); defsubr (&Sbuffer_hash); defsubr (&Slocale_info); + defsubr (&Sbuffer_line_statistics); } diff --git a/src/font.c b/src/font.c index b6a778eaa04..a59ebe216b8 100644 --- a/src/font.c +++ b/src/font.c @@ -188,6 +188,9 @@ font_make_object (int size, Lisp_Object entity, int pixelsize) FONT_OBJECT_MAX, PVEC_FONT); int i; + /* Poison the max_width, so we can detect when it hasn't been set. */ + eassert (font->max_width = 1024 * 1024 * 1024); + /* GC can happen before the driver is set up, so avoid dangling pointer here (Bug#17771). */ font->driver = NULL; @@ -1011,7 +1014,7 @@ font_expand_wildcards (Lisp_Object *field, int n) } -/* Parse NAME (NUL terminated) as XLFD and store information in FONT +/* Parse NAME (null terminated) as XLFD and store information in FONT (font-spec or font-entity). Size property of FONT is set as follows: specified XLFD fields FONT property @@ -1355,7 +1358,7 @@ font_unparse_xlfd (Lisp_Object font, int pixel_size, char *name, int nbytes) return len < nbytes ? len : -1; } -/* Parse NAME (NUL terminated) and store information in FONT +/* Parse NAME (null terminated) and store information in FONT (font-spec or font-entity). NAME is supplied in either the Fontconfig or GTK font name format. If NAME is successfully parsed, return 0. Otherwise return -1. @@ -1727,7 +1730,7 @@ font_unparse_fcname (Lisp_Object font, int pixel_size, char *name, int nbytes) #endif -/* Parse NAME (NUL terminated) and store information in FONT +/* Parse NAME (null terminated) and store information in FONT (font-spec or font-entity). If NAME is successfully parsed, return 0. Otherwise return -1. */ @@ -2642,6 +2645,11 @@ font_clear_cache (struct frame *f, Lisp_Object cache, if (! NILP (AREF (val, FONT_TYPE_INDEX))) { eassert (font && driver == font->driver); + /* We are going to close the font, so make + sure we don't have any lgstrings lying + around in lgstring cache that reference + the font. */ + composition_gstring_cache_clear_font (val); driver->close_font (font); } } @@ -2810,7 +2818,13 @@ font_list_entities (struct frame *f, Lisp_Object spec) || ! NILP (Vface_ignored_fonts))) val = font_delete_unmatched (val, need_filtering ? spec : Qnil, size); if (ASIZE (val) > 0) - list = Fcons (val, list); + { + list = Fcons (val, list); + /* Querying further backends can be very slow, so we only do + it if the user has explicitly requested it (Bug#43177). */ + if (query_all_font_backends == false) + break; + } } list = Fnreverse (list); @@ -3856,13 +3870,10 @@ font_range (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t *limit, while (pos < *limit) { - Lisp_Object category; - - if (NILP (string)) - FETCH_CHAR_ADVANCE_NO_CHECK (c, pos, pos_byte); - else - FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string, pos, pos_byte); - category = CHAR_TABLE_REF (Vunicode_category_table, c); + c = (NILP (string) + ? fetch_char_advance_no_check (&pos, &pos_byte) + : fetch_string_char_advance_no_check (string, &pos, &pos_byte)); + Lisp_Object category = CHAR_TABLE_REF (Vunicode_category_table, c); if (FIXNUMP (category) && (XFIXNUM (category) == UNICODE_CATEGORY_Cf || CHAR_VARIATION_SELECTOR_P (c))) @@ -4472,6 +4483,10 @@ GSTRING. */) signal_error ("Invalid glyph-string: ", gstring); if (! NILP (LGSTRING_ID (gstring))) return gstring; + Lisp_Object cached_gstring = + composition_gstring_lookup_cache (LGSTRING_HEADER (gstring)); + if (! NILP (cached_gstring)) + return cached_gstring; font_object = LGSTRING_FONT (gstring); CHECK_FONT_OBJECT (font_object); font = XFONT_OBJECT (font_object); @@ -4623,10 +4638,10 @@ DEFUN ("internal-char-font", Finternal_char_font, Sinternal_char_font, 1, 2, 0, Lisp_Object window; struct window *w; - CHECK_FIXNUM_COERCE_MARKER (position); - if (! (BEGV <= XFIXNUM (position) && XFIXNUM (position) < ZV)) + EMACS_INT fixed_pos = fix_position (position); + if (! (BEGV <= fixed_pos && fixed_pos < ZV)) args_out_of_range_3 (position, make_fixnum (BEGV), make_fixnum (ZV)); - pos = XFIXNUM (position); + pos = fixed_pos; pos_byte = CHAR_TO_BYTE (pos); if (NILP (ch)) c = FETCH_CHAR (pos_byte); @@ -4867,21 +4882,18 @@ If the font is not OpenType font, CAPABILITY is nil. */) (Lisp_Object font_object) { struct font *font = CHECK_FONT_GET_OBJECT (font_object); - Lisp_Object val = make_uninit_vector (9); - - ASET (val, 0, AREF (font_object, FONT_NAME_INDEX)); - ASET (val, 1, AREF (font_object, FONT_FILE_INDEX)); - ASET (val, 2, make_fixnum (font->pixel_size)); - ASET (val, 3, make_fixnum (font->max_width)); - ASET (val, 4, make_fixnum (font->ascent)); - ASET (val, 5, make_fixnum (font->descent)); - ASET (val, 6, make_fixnum (font->space_width)); - ASET (val, 7, make_fixnum (font->average_width)); - if (font->driver->otf_capability) - ASET (val, 8, Fcons (Qopentype, font->driver->otf_capability (font))); - else - ASET (val, 8, Qnil); - return val; + return CALLN (Fvector, + AREF (font_object, FONT_NAME_INDEX), + AREF (font_object, FONT_FILE_INDEX), + make_fixnum (font->pixel_size), + make_fixnum (font->max_width), + make_fixnum (font->ascent), + make_fixnum (font->descent), + make_fixnum (font->space_width), + make_fixnum (font->average_width), + (font->driver->otf_capability + ? Fcons (Qopentype, font->driver->otf_capability (font)) + : Qnil)); } DEFUN ("font-get-glyphs", Ffont_get_glyphs, Sfont_get_glyphs, 3, 4, 0, @@ -4908,8 +4920,8 @@ the corresponding element is nil. */) Lisp_Object object) { struct font *font = CHECK_FONT_GET_OBJECT (font_object); - ptrdiff_t i, len; - Lisp_Object *chars, vec; + ptrdiff_t len; + Lisp_Object *chars; USE_SAFE_ALLOCA; if (NILP (object)) @@ -4923,10 +4935,9 @@ the corresponding element is nil. */) SAFE_ALLOCA_LISP (chars, len); charpos = XFIXNAT (from); bytepos = CHAR_TO_BYTE (charpos); - for (i = 0; charpos < XFIXNAT (to); i++) + for (ptrdiff_t i = 0; charpos < XFIXNAT (to); i++) { - int c; - FETCH_CHAR_ADVANCE (c, charpos, bytepos); + int c = fetch_char_advance (&charpos, &bytepos); chars[i] = make_fixnum (c); } } @@ -4946,18 +4957,18 @@ the corresponding element is nil. */) int c; /* Skip IFROM characters from the beginning. */ - for (i = 0; i < ifrom; i++) - c = STRING_CHAR_ADVANCE (p); + for (ptrdiff_t i = 0; i < ifrom; i++) + p += BYTES_BY_CHAR_HEAD (*p); /* Now fetch an interesting characters. */ - for (i = 0; i < len; i++) - { - c = STRING_CHAR_ADVANCE (p); - chars[i] = make_fixnum (c); - } + for (ptrdiff_t i = 0; i < len; i++) + { + c = string_char_advance (&p); + chars[i] = make_fixnum (c); + } } else - for (i = 0; i < len; i++) + for (ptrdiff_t i = 0; i < len; i++) chars[i] = make_fixnum (p[ifrom + i]); } else if (VECTORP (object)) @@ -4968,7 +4979,7 @@ the corresponding element is nil. */) if (ifrom == ito) return Qnil; len = ito - ifrom; - for (i = 0; i < len; i++) + for (ptrdiff_t i = 0; i < len; i++) { Lisp_Object elt = AREF (object, ifrom + i); CHECK_CHARACTER (elt); @@ -4978,8 +4989,8 @@ the corresponding element is nil. */) else wrong_type_argument (Qarrayp, object); - vec = make_uninit_vector (len); - for (i = 0; i < len; i++) + Lisp_Object vec = make_nil_vector (len); + for (ptrdiff_t i = 0; i < len; i++) { Lisp_Object g; int c = XFIXNAT (chars[i]); @@ -5030,24 +5041,26 @@ character at index specified by POSITION. */) (Lisp_Object position, Lisp_Object window, Lisp_Object string) { struct window *w = decode_live_window (window); + EMACS_INT pos; if (NILP (string)) { if (XBUFFER (w->contents) != current_buffer) error ("Specified window is not displaying the current buffer"); - CHECK_FIXNUM_COERCE_MARKER (position); - if (! (BEGV <= XFIXNUM (position) && XFIXNUM (position) < ZV)) + pos = fix_position (position); + if (! (BEGV <= pos && pos < ZV)) args_out_of_range_3 (position, make_fixnum (BEGV), make_fixnum (ZV)); } else { CHECK_FIXNUM (position); CHECK_STRING (string); - if (! (0 <= XFIXNUM (position) && XFIXNUM (position) < SCHARS (string))) + pos = XFIXNUM (position); + if (! (0 <= pos && pos < SCHARS (string))) args_out_of_range (string, position); } - return font_at (-1, XFIXNUM (position), NULL, w, string); + return font_at (-1, pos, NULL, w, string); } #if 0 @@ -5187,24 +5200,26 @@ If the named font cannot be opened and loaded, return nil. */) return Qnil; font = XFONT_OBJECT (font_object); - info = make_uninit_vector (14); - ASET (info, 0, AREF (font_object, FONT_NAME_INDEX)); - ASET (info, 1, AREF (font_object, FONT_FULLNAME_INDEX)); - ASET (info, 2, make_fixnum (font->pixel_size)); - ASET (info, 3, make_fixnum (font->height)); - ASET (info, 4, make_fixnum (font->baseline_offset)); - ASET (info, 5, make_fixnum (font->relative_compose)); - ASET (info, 6, make_fixnum (font->default_ascent)); - ASET (info, 7, make_fixnum (font->max_width)); - ASET (info, 8, make_fixnum (font->ascent)); - ASET (info, 9, make_fixnum (font->descent)); - ASET (info, 10, make_fixnum (font->space_width)); - ASET (info, 11, make_fixnum (font->average_width)); - ASET (info, 12, AREF (font_object, FONT_FILE_INDEX)); - if (font->driver->otf_capability) - ASET (info, 13, Fcons (Qopentype, font->driver->otf_capability (font))); - else - ASET (info, 13, Qnil); + /* Sanity check to make sure we have initialized max_width. */ + eassert (XFONT_OBJECT (font_object)->max_width < 1024 * 1024 * 1024); + + info = CALLN (Fvector, + AREF (font_object, FONT_NAME_INDEX), + AREF (font_object, FONT_FULLNAME_INDEX), + make_fixnum (font->pixel_size), + make_fixnum (font->height), + make_fixnum (font->baseline_offset), + make_fixnum (font->relative_compose), + make_fixnum (font->default_ascent), + make_fixnum (font->max_width), + make_fixnum (font->ascent), + make_fixnum (font->descent), + make_fixnum (font->space_width), + make_fixnum (font->average_width), + AREF (font_object, FONT_FILE_INDEX), + (font->driver->otf_capability + ? Fcons (Qopentype, font->driver->otf_capability (font)) + : Qnil)); #if 0 /* As font_object is still in FONT_OBJLIST of the entity, we can't @@ -5222,7 +5237,7 @@ If the named font cannot be opened and loaded, return nil. */) static Lisp_Object build_style_table (const struct table_entry *entry, int nelement) { - Lisp_Object table = make_uninit_vector (nelement); + Lisp_Object table = make_nil_vector (nelement); for (int i = 0; i < nelement; i++) { int j; @@ -5513,10 +5528,8 @@ This variable cannot be set; trying to do so will signal an error. */); make_symbol_constant (intern_c_string ("font-width-table")); staticpro (&font_style_table); - font_style_table = make_uninit_vector (3); - ASET (font_style_table, 0, Vfont_weight_table); - ASET (font_style_table, 1, Vfont_slant_table); - ASET (font_style_table, 2, Vfont_width_table); + font_style_table = CALLN (Fvector, Vfont_weight_table, Vfont_slant_table, + Vfont_width_table); DEFVAR_LISP ("font-log", Vfont_log, doc: /* A list that logs font-related actions and results, for debugging. @@ -5546,11 +5559,18 @@ footprint in sessions that use lots of different fonts. */); #endif DEFVAR_BOOL ("xft-ignore-color-fonts", - Vxft_ignore_color_fonts, + xft_ignore_color_fonts, doc: /* Non-nil means don't query fontconfig for color fonts, since they often cause Xft crashes. Only has an effect in Xft builds. */); - Vxft_ignore_color_fonts = 1; + xft_ignore_color_fonts = true; + + DEFVAR_BOOL ("query-all-font-backends", query_all_font_backends, + doc: /* +If non-nil, attempt to query all available font backends. +By default Emacs will stop searching for a matching font at the first +match. */); + query_all_font_backends = false; #ifdef HAVE_WINDOW_SYSTEM #ifdef HAVE_FREETYPE @@ -5560,7 +5580,6 @@ cause Xft crashes. Only has an effect in Xft builds. */); #ifdef USE_CAIRO syms_of_ftcrfont (); #else - syms_of_ftxfont (); #ifdef HAVE_XFT syms_of_xftfont (); #endif /* HAVE_XFT */ diff --git a/src/font.h b/src/font.h index 93dc85b3ee1..d3e15306427 100644 --- a/src/font.h +++ b/src/font.h @@ -69,8 +69,8 @@ INLINE_HEADER_BEGIN enum font_property_index { - /* FONT-TYPE is a symbol indicating a font backend; currently `x', - `xft', and `ftx' are available on X, `uniscribe' and `gdi' on + /* FONT-TYPE is a symbol indicating a font backend; currently `x' + and `xft' are available on X, `uniscribe' and `gdi' on Windows, and `ns' under Cocoa / GNUstep. */ FONT_TYPE_INDEX, @@ -938,7 +938,6 @@ extern void syms_of_ftfont (void); extern struct font_driver const xfont_driver; extern Lisp_Object xfont_get_cache (struct frame *); extern void syms_of_xfont (void); -extern void syms_of_ftxfont (void); #ifdef HAVE_XFT extern struct font_driver const xftfont_driver; #ifdef HAVE_HARFBUZZ @@ -946,7 +945,6 @@ extern struct font_driver xfthbfont_driver; #endif /* HAVE_HARFBUZZ */ #endif #if defined HAVE_FREETYPE || defined HAVE_XFT -extern struct font_driver const ftxfont_driver; extern void syms_of_xftfont (void); #endif #ifdef HAVE_BDFFONT diff --git a/src/fontset.c b/src/fontset.c index 9c706a1846d..332be6c39d1 100644 --- a/src/fontset.c +++ b/src/fontset.c @@ -252,14 +252,13 @@ set_fontset_fallback (Lisp_Object fontset, Lisp_Object fallback) #define BASE_FONTSET_P(fontset) (NILP (FONTSET_BASE (fontset))) -/* Macros for FONT-DEF and RFONT-DEF of fontset. */ -#define FONT_DEF_NEW(font_def, font_spec, encoding, repertory) \ - do { \ - (font_def) = make_uninit_vector (3); \ - ASET ((font_def), 0, font_spec); \ - ASET ((font_def), 1, encoding); \ - ASET ((font_def), 2, repertory); \ - } while (0) +/* Definitions for FONT-DEF and RFONT-DEF of fontset. */ +static Lisp_Object +font_def_new (Lisp_Object font_spec, Lisp_Object encoding, + Lisp_Object repertory) +{ + return CALLN (Fvector, font_spec, encoding, repertory); +} #define FONT_DEF_SPEC(font_def) AREF (font_def, 0) #define FONT_DEF_ENCODING(font_def) AREF (font_def, 1) @@ -1547,7 +1546,7 @@ appended. By default, FONT-SPEC overrides the previous settings. */) repertory = CHARSET_SYMBOL_ID (repertory); } } - FONT_DEF_NEW (font_def, font_spec, encoding, repertory); + font_def = font_def_new (font_spec, encoding, repertory); } else font_def = Qnil; @@ -1619,14 +1618,8 @@ appended. By default, FONT-SPEC overrides the previous settings. */) if (charset) { - Lisp_Object arg; - - arg = make_uninit_vector (5); - ASET (arg, 0, fontset); - ASET (arg, 1, font_def); - ASET (arg, 2, add); - ASET (arg, 3, ascii_changed ? Qt : Qnil); - ASET (arg, 4, range_list); + Lisp_Object arg = CALLN (Fvector, fontset, font_def, add, + ascii_changed ? Qt : Qnil, range_list); map_charset_chars (set_fontset_font, Qnil, arg, charset, CHARSET_MIN_CODE (charset), diff --git a/src/frame.c b/src/frame.c index 289abe2f79a..a2167ce1e49 100644 --- a/src/frame.c +++ b/src/frame.c @@ -35,7 +35,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "buffer.h" /* These help us bind and responding to switch-frame events. */ #include "keyboard.h" -#include "ptr-bounds.h" #include "frame.h" #include "blockinput.h" #include "termchar.h" @@ -904,7 +903,7 @@ make_frame (bool mini_p) f->last_tool_bar_item = -1; #endif #ifdef NS_IMPL_COCOA - f->ns_appearance = ns_appearance_aqua; + f->ns_appearance = ns_appearance_system_default; f->ns_transparent_titlebar = false; #endif #endif @@ -932,18 +931,18 @@ make_frame (bool mini_p) wset_frame (rw, frame); - /* 10 is arbitrary, + /* 80/25 is arbitrary, just so that there is "something there." Correct size will be set up later with adjust_frame_size. */ - SET_FRAME_COLS (f, 10); - SET_FRAME_LINES (f, 10); + SET_FRAME_COLS (f, 80); + SET_FRAME_LINES (f, 25); SET_FRAME_WIDTH (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f)); SET_FRAME_HEIGHT (f, FRAME_LINES (f) * FRAME_LINE_HEIGHT (f)); - rw->total_cols = 10; + rw->total_cols = FRAME_COLS (f); rw->pixel_width = rw->total_cols * FRAME_COLUMN_WIDTH (f); - rw->total_lines = mini_p ? 9 : 10; + rw->total_lines = FRAME_LINES (f) - (mini_p ? 1 : 0); rw->pixel_height = rw->total_lines * FRAME_LINE_HEIGHT (f); if (mini_p) @@ -1102,7 +1101,7 @@ make_initial_frame (void) terminal = init_initial_terminal (); - f = make_frame (1); + f = make_frame (true); XSETFRAME (frame, f); Vframe_list = Fcons (frame, Vframe_list); @@ -1487,6 +1486,7 @@ do_switch_frame (Lisp_Object frame, int track, int for_deletion, Lisp_Object nor #endif internal_last_event_frame = Qnil; + move_minibuffer_onto_frame (); return frame; } @@ -2439,6 +2439,12 @@ passing the normal return value to that function as an argument, and returns whatever that function returns. */) (void) { + return mouse_position (true); +} + +Lisp_Object +mouse_position (bool call_mouse_position_function) +{ struct frame *f; Lisp_Object lispy_dummy; Lisp_Object x, y, retval; @@ -2467,7 +2473,7 @@ and returns whatever that function returns. */) } XSETFRAME (lispy_dummy, f); retval = Fcons (lispy_dummy, Fcons (x, y)); - if (!NILP (Vmouse_position_function)) + if (call_mouse_position_function && !NILP (Vmouse_position_function)) retval = call1 (Vmouse_position_function, retval); return retval; } @@ -2562,30 +2568,34 @@ before calling this function on it, like this. (Lisp_Object frame, Lisp_Object x, Lisp_Object y) { CHECK_LIVE_FRAME (frame); - CHECK_TYPE_RANGED_INTEGER (int, x); - CHECK_TYPE_RANGED_INTEGER (int, y); + int xval = check_integer_range (x, INT_MIN, INT_MAX); + int yval = check_integer_range (y, INT_MIN, INT_MAX); /* I think this should be done with a hook. */ -#ifdef HAVE_WINDOW_SYSTEM if (FRAME_WINDOW_P (XFRAME (frame))) - /* Warping the mouse will cause enternotify and focus events. */ - frame_set_mouse_position (XFRAME (frame), XFIXNUM (x), XFIXNUM (y)); -#else -#if defined (MSDOS) - if (FRAME_MSDOS_P (XFRAME (frame))) + { +#ifdef HAVE_WINDOW_SYSTEM + /* Warping the mouse will cause enternotify and focus events. */ + frame_set_mouse_position (XFRAME (frame), xval, yval); +#endif /* HAVE_WINDOW_SYSTEM */ + } +#ifdef MSDOS + else if (FRAME_MSDOS_P (XFRAME (frame))) { Fselect_frame (frame, Qnil); - mouse_moveto (XFIXNUM (x), XFIXNUM (y)); + mouse_moveto (xval, yval); } -#else -#ifdef HAVE_GPM +#endif /* MSDOS */ + else { Fselect_frame (frame, Qnil); - term_mouse_moveto (XFIXNUM (x), XFIXNUM (y)); +#ifdef HAVE_GPM + term_mouse_moveto (xval, yval); +#else + (void) xval; + (void) yval; +#endif /* HAVE_GPM */ } -#endif -#endif -#endif return Qnil; } @@ -2603,30 +2613,35 @@ before calling this function on it, like this. (Lisp_Object frame, Lisp_Object x, Lisp_Object y) { CHECK_LIVE_FRAME (frame); - CHECK_TYPE_RANGED_INTEGER (int, x); - CHECK_TYPE_RANGED_INTEGER (int, y); + int xval = check_integer_range (x, INT_MIN, INT_MAX); + int yval = check_integer_range (y, INT_MIN, INT_MAX); /* I think this should be done with a hook. */ -#ifdef HAVE_WINDOW_SYSTEM if (FRAME_WINDOW_P (XFRAME (frame))) - /* Warping the mouse will cause enternotify and focus events. */ - frame_set_mouse_pixel_position (XFRAME (frame), XFIXNUM (x), XFIXNUM (y)); -#else -#if defined (MSDOS) - if (FRAME_MSDOS_P (XFRAME (frame))) + { + /* Warping the mouse will cause enternotify and focus events. */ +#ifdef HAVE_WINDOW_SYSTEM + frame_set_mouse_pixel_position (XFRAME (frame), xval, yval); +#endif /* HAVE_WINDOW_SYSTEM */ + } +#ifdef MSDOS + else if (FRAME_MSDOS_P (XFRAME (frame))) { Fselect_frame (frame, Qnil); - mouse_moveto (XFIXNUM (x), XFIXNUM (y)); + mouse_moveto (xval, yval); } -#else -#ifdef HAVE_GPM +#endif /* MSDOS */ + else { Fselect_frame (frame, Qnil); - term_mouse_moveto (XFIXNUM (x), XFIXNUM (y)); +#ifdef HAVE_GPM + term_mouse_moveto (xval, yval); +#else + (void) xval; + (void) yval; +#endif /* HAVE_GPM */ + } -#endif -#endif -#endif return Qnil; } @@ -3528,6 +3543,13 @@ DEFUN ("frame-fringe-width", Ffringe_width, Sfringe_width, 0, 1, 0, return make_fixnum (FRAME_TOTAL_FRINGE_WIDTH (decode_any_frame (frame))); } +DEFUN ("frame-child-frame-border-width", Fframe_child_frame_border_width, Sframe_child_frame_border_width, 0, 1, 0, + doc: /* Return width of FRAME's child-frame border in pixels. */) + (Lisp_Object frame) +{ + return make_fixnum (FRAME_CHILD_FRAME_BORDER_WIDTH (decode_any_frame (frame))); +} + DEFUN ("frame-internal-border-width", Fframe_internal_border_width, Sframe_internal_border_width, 0, 1, 0, doc: /* Return width of FRAME's internal border in pixels. */) (Lisp_Object frame) @@ -3549,6 +3571,21 @@ DEFUN ("frame-bottom-divider-width", Fbottom_divider_width, Sbottom_divider_widt return make_fixnum (FRAME_BOTTOM_DIVIDER_WIDTH (decode_any_frame (frame))); } +static int +check_frame_pixels (Lisp_Object size, Lisp_Object pixelwise, int item_size) +{ + CHECK_INTEGER (size); + if (!NILP (pixelwise)) + item_size = 1; + intmax_t sz; + int pixel_size; /* size * item_size */ + if (! integer_to_intmax (size, &sz) + || INT_MULTIPLY_WRAPV (sz, item_size, &pixel_size)) + args_out_of_range_3 (size, make_int (INT_MIN / item_size), + make_int (INT_MAX / item_size)); + return pixel_size; +} + DEFUN ("set-frame-height", Fset_frame_height, Sset_frame_height, 2, 4, "(list (selected-frame) (prefix-numeric-value current-prefix-arg))", doc: /* Set text height of frame FRAME to HEIGHT lines. @@ -3562,19 +3599,15 @@ window managers may refuse to honor a HEIGHT that is not an integer multiple of the default frame font height. When called interactively, HEIGHT is the numeric prefix and the -currently selected frame will be set to this height. */) +currently selected frame will be set to this height. + +If FRAME is nil, it defaults to the selected frame. */) (Lisp_Object frame, Lisp_Object height, Lisp_Object pretend, Lisp_Object pixelwise) { struct frame *f = decode_live_frame (frame); - int pixel_height; - - CHECK_TYPE_RANGED_INTEGER (int, height); - - pixel_height = (!NILP (pixelwise) - ? XFIXNUM (height) - : XFIXNUM (height) * FRAME_LINE_HEIGHT (f)); + int pixel_height = check_frame_pixels (height, pixelwise, + FRAME_LINE_HEIGHT (f)); adjust_frame_size (f, -1, pixel_height, 1, !NILP (pretend), Qheight); - return Qnil; } @@ -3591,19 +3624,15 @@ window managers may refuse to honor a WIDTH that is not an integer multiple of the default frame font width. When called interactively, WIDTH is the numeric prefix and the -currently selected frame will be set to this width. */) +currently selected frame will be set to this width. + +If FRAME is nil, it defaults to the selected frame. */) (Lisp_Object frame, Lisp_Object width, Lisp_Object pretend, Lisp_Object pixelwise) { struct frame *f = decode_live_frame (frame); - int pixel_width; - - CHECK_TYPE_RANGED_INTEGER (int, width); - - pixel_width = (!NILP (pixelwise) - ? XFIXNUM (width) - : XFIXNUM (width) * FRAME_COLUMN_WIDTH (f)); + int pixel_width = check_frame_pixels (width, pixelwise, + FRAME_COLUMN_WIDTH (f)); adjust_frame_size (f, pixel_width, -1, 1, !NILP (pretend), Qwidth); - return Qnil; } @@ -3613,23 +3642,17 @@ Optional argument PIXELWISE non-nil means to measure in pixels. Note: When `frame-resize-pixelwise' is nil, some window managers may refuse to honor a WIDTH that is not an integer multiple of the default frame font width or a HEIGHT that is not an integer multiple of the default frame -font height. */) +font height. + +If FRAME is nil, it defaults to the selected frame. */) (Lisp_Object frame, Lisp_Object width, Lisp_Object height, Lisp_Object pixelwise) { struct frame *f = decode_live_frame (frame); - int pixel_width, pixel_height; - - CHECK_TYPE_RANGED_INTEGER (int, width); - CHECK_TYPE_RANGED_INTEGER (int, height); - - pixel_width = (!NILP (pixelwise) - ? XFIXNUM (width) - : XFIXNUM (width) * FRAME_COLUMN_WIDTH (f)); - pixel_height = (!NILP (pixelwise) - ? XFIXNUM (height) - : XFIXNUM (height) * FRAME_LINE_HEIGHT (f)); + int pixel_width = check_frame_pixels (width, pixelwise, + FRAME_COLUMN_WIDTH (f)); + int pixel_height = check_frame_pixels (height, pixelwise, + FRAME_LINE_HEIGHT (f)); adjust_frame_size (f, pixel_width, pixel_height, 1, 0, Qsize); - return Qnil; } @@ -3639,7 +3662,11 @@ DEFUN ("frame-position", Fframe_position, FRAME must be a live frame and defaults to the selected one. The return value is a cons (x, y) of the coordinates of the top left corner of FRAME's outer frame, in pixels relative to an origin (0, 0) of FRAME's -display. */) +display. + +Note that the values returned are not guaranteed to be accurate: The +values depend on the underlying window system, and some systems add a +constant offset to the values. */) (Lisp_Object frame) { register struct frame *f = decode_live_frame (frame); @@ -3659,18 +3686,17 @@ bottom edge of FRAME's display. */) (Lisp_Object frame, Lisp_Object x, Lisp_Object y) { struct frame *f = decode_live_frame (frame); - - CHECK_TYPE_RANGED_INTEGER (int, x); - CHECK_TYPE_RANGED_INTEGER (int, y); + int xval = check_integer_range (x, INT_MIN, INT_MAX); + int yval = check_integer_range (y, INT_MIN, INT_MAX); if (FRAME_WINDOW_P (f)) { #ifdef HAVE_WINDOW_SYSTEM if (FRAME_TERMINAL (f)->set_frame_offset_hook) - FRAME_TERMINAL (f)->set_frame_offset_hook (f, - XFIXNUM (x), - XFIXNUM (y), - 1); + FRAME_TERMINAL (f)->set_frame_offset_hook (f, xval, yval, 1); +#else + (void) xval; + (void) yval; #endif } @@ -3740,6 +3766,7 @@ static const struct frame_parm_table frame_parms[] = {"foreground-color", -1}, {"icon-name", SYMBOL_INDEX (Qicon_name)}, {"icon-type", SYMBOL_INDEX (Qicon_type)}, + {"child-frame-border-width", SYMBOL_INDEX (Qchild_frame_border_width)}, {"internal-border-width", SYMBOL_INDEX (Qinternal_border_width)}, {"right-divider-width", SYMBOL_INDEX (Qright_divider_width)}, {"bottom-divider-width", SYMBOL_INDEX (Qbottom_divider_width)}, @@ -4283,6 +4310,8 @@ gui_report_frame_params (struct frame *f, Lisp_Object *alistptr) store_in_alist (alistptr, Qborder_width, make_fixnum (f->border_width)); + store_in_alist (alistptr, Qchild_frame_border_width, + make_fixnum (FRAME_CHILD_FRAME_BORDER_WIDTH (f))); store_in_alist (alistptr, Qinternal_border_width, make_fixnum (FRAME_INTERNAL_BORDER_WIDTH (f))); store_in_alist (alistptr, Qright_divider_width, @@ -4645,23 +4674,22 @@ gui_set_right_fringe (struct frame *f, Lisp_Object new_value, Lisp_Object old_va void gui_set_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { - CHECK_TYPE_RANGED_INTEGER (int, arg); + int border_width = check_integer_range (arg, INT_MIN, INT_MAX); - if (XFIXNUM (arg) == f->border_width) + if (border_width == f->border_width) return; if (FRAME_NATIVE_WINDOW (f) != 0) error ("Cannot change the border width of a frame"); - f->border_width = XFIXNUM (arg); + f->border_width = border_width; } void gui_set_right_divider_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { int old = FRAME_RIGHT_DIVIDER_WIDTH (f); - CHECK_TYPE_RANGED_INTEGER (int, arg); - int new = max (0, XFIXNUM (arg)); + int new = check_int_nonnegative (arg); if (new != old) { f->right_divider_width = new; @@ -4675,8 +4703,7 @@ void gui_set_bottom_divider_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { int old = FRAME_BOTTOM_DIVIDER_WIDTH (f); - CHECK_TYPE_RANGED_INTEGER (int, arg); - int new = max (0, XFIXNUM (arg)); + int new = check_int_nonnegative (arg); if (new != old) { f->bottom_divider_width = new; @@ -5034,8 +5061,6 @@ gui_display_get_resource (Display_Info *dpyinfo, Lisp_Object attribute, USE_SAFE_ALLOCA; char *name_key = SAFE_ALLOCA (name_keysize + class_keysize); char *class_key = name_key + name_keysize; - name_key = ptr_bounds_clip (name_key, name_keysize); - class_key = ptr_bounds_clip (class_key, class_keysize); /* Start with emacs.FRAMENAME for the name (the specific one) and with `Emacs' for the class key (the general one). */ @@ -5106,9 +5131,6 @@ x_get_resource_string (const char *attribute, const char *class) ptrdiff_t class_keysize = sizeof (EMACS_CLASS) - 1 + strlen (class) + 2; char *name_key = SAFE_ALLOCA (name_keysize + class_keysize); char *class_key = name_key + name_keysize; - name_key = ptr_bounds_clip (name_key, name_keysize); - class_key = ptr_bounds_clip (class_key, class_keysize); - esprintf (name_key, "%s.%s", SSDATA (Vinvocation_name), attribute); sprintf (class_key, "%s.%s", EMACS_CLASS, class); @@ -5655,8 +5677,7 @@ gui_figure_window_size (struct frame *f, Lisp_Object parms, bool tabbar_p, f->top_pos = 0; else { - CHECK_TYPE_RANGED_INTEGER (int, top); - f->top_pos = XFIXNUM (top); + f->top_pos = check_integer_range (top, INT_MIN, INT_MAX); if (f->top_pos < 0) window_prompting |= YNegative; } @@ -5686,8 +5707,7 @@ gui_figure_window_size (struct frame *f, Lisp_Object parms, bool tabbar_p, f->left_pos = 0; else { - CHECK_TYPE_RANGED_INTEGER (int, left); - f->left_pos = XFIXNUM (left); + f->left_pos = check_integer_range (left, INT_MIN, INT_MAX); if (f->left_pos < 0) window_prompting |= XNegative; } @@ -5989,6 +6009,7 @@ syms_of_frame (void) DEFSYM (Qhorizontal_scroll_bars, "horizontal-scroll-bars"); DEFSYM (Qicon_name, "icon-name"); DEFSYM (Qicon_type, "icon-type"); + DEFSYM (Qchild_frame_border_width, "child-frame-border-width"); DEFSYM (Qinternal_border_width, "internal-border-width"); DEFSYM (Qleft_fringe, "left-fringe"); DEFSYM (Qline_spacing, "line-spacing"); @@ -6413,6 +6434,7 @@ iconify the top level frame instead. */); defsubr (&Sscroll_bar_width); defsubr (&Sscroll_bar_height); defsubr (&Sfringe_width); + defsubr (&Sframe_child_frame_border_width); defsubr (&Sframe_internal_border_width); defsubr (&Sright_divider_width); defsubr (&Sbottom_divider_width); diff --git a/src/frame.h b/src/frame.h index bfe04b276af..21148fe94c9 100644 --- a/src/frame.h +++ b/src/frame.h @@ -69,8 +69,9 @@ enum internal_border_part #ifdef NS_IMPL_COCOA enum ns_appearance_type { - ns_appearance_aqua, - ns_appearance_vibrant_dark + ns_appearance_system_default, + ns_appearance_aqua, + ns_appearance_vibrant_dark }; #endif #endif /* HAVE_WINDOW_SYSTEM */ @@ -533,6 +534,10 @@ struct frame /* Border width of the frame window as known by the (X) window system. */ int border_width; + /* Width of child frames' internal border. Acts as + internal_border_width for child frames. */ + int child_frame_border_width; + /* Width of the internal border. This is a line of background color just inside the window's border. When the frame is selected, a highlighting is displayed inside the internal border. */ @@ -1360,6 +1365,7 @@ extern bool frame_inhibit_resize (struct frame *, bool, Lisp_Object); extern void adjust_frame_size (struct frame *, int, int, int, bool, Lisp_Object); extern void frame_size_history_add (struct frame *f, Lisp_Object fun_symbol, int width, int height, Lisp_Object rest); +extern Lisp_Object mouse_position (bool); extern Lisp_Object Vframe_list; @@ -1430,11 +1436,27 @@ FRAME_TOTAL_FRINGE_WIDTH (struct frame *f) return FRAME_LEFT_FRINGE_WIDTH (f) + FRAME_RIGHT_FRINGE_WIDTH (f); } -/* Pixel-width of internal border lines. */ +INLINE int +FRAME_CHILD_FRAME_BORDER_WIDTH (struct frame *f) +{ + return frame_dimension (f->child_frame_border_width); +} + +/* Pixel-width of internal border. Uses child_frame_border_width for + child frames if possible, and falls back on internal_border_width + otherwise. */ INLINE int FRAME_INTERNAL_BORDER_WIDTH (struct frame *f) { +#ifdef HAVE_WINDOW_SYSTEM + return FRAME_PARENT_FRAME(f) + ? (f->child_frame_border_width + ? FRAME_CHILD_FRAME_BORDER_WIDTH(f) + : frame_dimension (f->internal_border_width)) + : frame_dimension (f->internal_border_width); +#else return frame_dimension (f->internal_border_width); +#endif } /* Pixel-size of window divider lines. */ @@ -1449,6 +1471,49 @@ FRAME_BOTTOM_DIVIDER_WIDTH (struct frame *f) { return frame_dimension (f->bottom_divider_width); } + +/* Return a non-null pointer to the cached face with ID on frame F. */ + +INLINE struct face * +FACE_FROM_ID (struct frame *f, int id) +{ + eassert (0 <= id && id < FRAME_FACE_CACHE (f)->used); + return FRAME_FACE_CACHE (f)->faces_by_id[id]; +} + +/* Return a pointer to the face with ID on frame F, or null if such a + face doesn't exist. */ + +INLINE struct face * +FACE_FROM_ID_OR_NULL (struct frame *f, int id) +{ + int used = FRAME_FACE_CACHE (f)->used; + eassume (0 <= used); + return 0 <= id && id < used ? FRAME_FACE_CACHE (f)->faces_by_id[id] : NULL; +} + +#ifdef HAVE_WINDOW_SYSTEM + +/* A non-null pointer to the image with id ID on frame F. */ + +INLINE struct image * +IMAGE_FROM_ID (struct frame *f, int id) +{ + eassert (0 <= id && id < FRAME_IMAGE_CACHE (f)->used); + return FRAME_IMAGE_CACHE (f)->images[id]; +} + +/* Value is a pointer to the image with id ID on frame F, or null if + no image with that id exists. */ + +INLINE struct image * +IMAGE_OPT_FROM_ID (struct frame *f, int id) +{ + int used = FRAME_IMAGE_CACHE (f)->used; + eassume (0 <= used); + return 0 <= id && id < used ? FRAME_IMAGE_CACHE (f)->images[id] : NULL; +} +#endif /*********************************************************************** Conversion between canonical units and pixels @@ -1642,7 +1707,7 @@ extern Lisp_Object gui_display_get_resource (Display_Info *, Lisp_Object component, Lisp_Object subclass); -extern void set_frame_menubar (struct frame *f, bool first_time, bool deep_p); +extern void set_frame_menubar (struct frame *f, bool deep_p); extern void frame_set_mouse_pixel_position (struct frame *f, int pix_x, int pix_y); extern void free_frame_menubar (struct frame *); extern bool frame_ancestor_p (struct frame *af, struct frame *df); diff --git a/src/fringe.c b/src/fringe.c index 2f0d360567b..65c9a84ac99 100644 --- a/src/fringe.c +++ b/src/fringe.c @@ -23,7 +23,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "lisp.h" #include "frame.h" -#include "ptr-bounds.h" #include "window.h" #include "dispextern.h" #include "buffer.h" @@ -101,7 +100,7 @@ struct fringe_bitmap ...xx... */ static unsigned short question_mark_bits[] = { - 0x3c, 0x7e, 0x7e, 0x0c, 0x18, 0x18, 0x00, 0x18, 0x18}; + 0x3c, 0x7e, 0xc3, 0xc3, 0x0c, 0x18, 0x18, 0x00, 0x18, 0x18}; /* An exclamation mark. */ /* @@ -117,7 +116,7 @@ static unsigned short question_mark_bits[] = { ...XX... */ static unsigned short exclamation_mark_bits[] = { - 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x00, 0x18}; + 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x00, 0x18, 0x18}; /* An arrow like this: `<-'. */ /* @@ -1607,9 +1606,7 @@ If BITMAP already exists, the existing definition is replaced. */) fb.dynamic = true; xfb = xmalloc (sizeof fb + fb.height * BYTES_PER_BITMAP_ROW); - fb.bits = b = ((unsigned short *) - ptr_bounds_clip (xfb + 1, fb.height * BYTES_PER_BITMAP_ROW)); - xfb = ptr_bounds_clip (xfb, sizeof *xfb); + fb.bits = b = (unsigned short *) (xfb + 1); j = 0; while (j < fb.height) @@ -1675,10 +1672,10 @@ Return nil if POS is not visible in WINDOW. */) if (!NILP (pos)) { - CHECK_FIXNUM_COERCE_MARKER (pos); - if (! (BEGV <= XFIXNUM (pos) && XFIXNUM (pos) <= ZV)) + EMACS_INT p = fix_position (pos); + if (! (BEGV <= p && p <= ZV)) args_out_of_range (window, pos); - textpos = XFIXNUM (pos); + textpos = p; } else if (w == XWINDOW (selected_window)) textpos = PT; @@ -1736,11 +1733,7 @@ If nil, also continue lines which are exactly as wide as the window. */); void mark_fringe_data (void) { - int i; - - for (i = 0; i < max_fringe_bitmaps; i++) - if (!NILP (fringe_faces[i])) - mark_object (fringe_faces[i]); + mark_objects (fringe_faces, max_fringe_bitmaps); } /* Initialize this module when Emacs starts. */ diff --git a/src/ftcrfont.c b/src/ftcrfont.c index ddd3cc9be64..db417b3e77d 100644 --- a/src/ftcrfont.c +++ b/src/ftcrfont.c @@ -84,7 +84,12 @@ ftcrfont_glyph_extents (struct font *font, cache->lbearing = floor (extents.x_bearing); cache->rbearing = ceil (extents.width + extents.x_bearing); cache->width = lround (extents.x_advance); - cache->ascent = ceil (- extents.y_bearing); + /* The subtraction of a small number is to avoid rounding up due + to floating-point inaccuracies with some fonts, which then + could cause unpleasant effects while scrolling (see bug + #44284), since we then think that a glyph row's ascent is too + small to accommodate a glyph with a higher phys_ascent. */ + cache->ascent = ceil (- extents.y_bearing - 1.0 / 256); cache->descent = ceil (extents.height + extents.y_bearing); } @@ -200,7 +205,8 @@ ftcrfont_open (struct frame *f, Lisp_Object entity, int pixel_size) block_input (); cairo_glyph_t stack_glyph; - font->min_width = font->average_width = font->space_width = 0; + font->min_width = font->max_width = 0; + font->average_width = font->space_width = 0; for (char c = 32; c < 127; c++) { cairo_glyph_t *glyphs = &stack_glyph; @@ -224,6 +230,8 @@ ftcrfont_open (struct frame *f, Lisp_Object entity, int pixel_size) && (! font->min_width || font->min_width > this_width)) font->min_width = this_width; + if (this_width > font->max_width) + font->max_width = this_width; if (c == 32) font->space_width = this_width; font->average_width += this_width; @@ -278,6 +286,7 @@ ftcrfont_open (struct frame *f, Lisp_Object entity, int pixel_size) font->relative_compose = 0; font->default_ascent = 0; font->vertical_centering = false; + eassert (font->max_width < 512 * 1024 * 1024); return font_object; } @@ -340,14 +349,13 @@ ftcrfont_encode_char (struct font *font, int c) struct font_info *ftcrfont_info = (struct font_info *) font; unsigned code = FONT_INVALID_CODE; unsigned char utf8[MAX_MULTIBYTE_LENGTH]; - unsigned char *p = utf8; + int utf8len = CHAR_STRING (c, utf8); cairo_glyph_t stack_glyph; cairo_glyph_t *glyphs = &stack_glyph; int num_glyphs = 1; - CHAR_STRING_ADVANCE (c, p); if (cairo_scaled_font_text_to_glyphs (ftcrfont_info->cr_scaled_font, 0, 0, - (char *) utf8, p - utf8, + (char *) utf8, utf8len, &glyphs, &num_glyphs, NULL, NULL, NULL) == CAIRO_STATUS_SUCCESS) diff --git a/src/ftfont.c b/src/ftfont.c index 77ceebde41c..0603dd9ce68 100644 --- a/src/ftfont.c +++ b/src/ftfont.c @@ -346,18 +346,15 @@ struct ftfont_cache_data static Lisp_Object ftfont_lookup_cache (Lisp_Object key, enum ftfont_cache_for cache_for) { - Lisp_Object cache, val, entity; + Lisp_Object cache, val; struct ftfont_cache_data *cache_data; if (FONT_ENTITY_P (key)) { - entity = key; - val = assq_no_quit (QCfont_entity, AREF (entity, FONT_EXTRA_INDEX)); + val = assq_no_quit (QCfont_entity, AREF (key, FONT_EXTRA_INDEX)); eassert (CONSP (val)); key = XCDR (val); } - else - entity = Qnil; if (NILP (ft_face_cache)) cache = Qnil; @@ -771,7 +768,7 @@ ftfont_spec_pattern (Lisp_Object spec, char *otlayout, struct OpenTypeSpec **ots #if defined HAVE_XFT && defined FC_COLOR /* We really don't like color fonts, they cause Xft crashes. See Bug#30874. */ - if (Vxft_ignore_color_fonts + if (xft_ignore_color_fonts && ! FcPatternAddBool (pattern, FC_COLOR, FcFalse)) goto err; #endif @@ -914,7 +911,7 @@ ftfont_list (struct frame *f, Lisp_Object spec) returns them even when it shouldn't really do so, so we need to manually skip them here (Bug#37786). */ FcBool b; - if (Vxft_ignore_color_fonts + if (xft_ignore_color_fonts && FcPatternGetBool (fontset->fonts[i], FC_COLOR, 0, &b) == FcResultMatch && b != FcFalse) continue; @@ -2829,14 +2826,10 @@ ftfont_shape_by_flt (Lisp_Object lgstring, struct font *font, LGLYPH_SET_ASCENT (lglyph, g->g.ascent >> 6); LGLYPH_SET_DESCENT (lglyph, g->g.descent >> 6); if (g->g.adjusted) - { - Lisp_Object vec = make_uninit_vector (3); - - ASET (vec, 0, make_fixnum (g->g.xoff >> 6)); - ASET (vec, 1, make_fixnum (g->g.yoff >> 6)); - ASET (vec, 2, make_fixnum (g->g.xadv >> 6)); - LGLYPH_SET_ADJUSTMENT (lglyph, vec); - } + LGLYPH_SET_ADJUSTMENT (lglyph, CALLN (Fvector, + make_fixnum (g->g.xoff >> 6), + make_fixnum (g->g.yoff >> 6), + make_fixnum (g->g.xadv >> 6))); } return make_fixnum (i); } diff --git a/src/ftxfont.c b/src/ftxfont.c deleted file mode 100644 index 2a991c715dc..00000000000 --- a/src/ftxfont.c +++ /dev/null @@ -1,371 +0,0 @@ -/* ftxfont.c -- FreeType font driver on X (without using XFT). - Copyright (C) 2006-2021 Free Software Foundation, Inc. - Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 - National Institute of Advanced Industrial Science and Technology (AIST) - Registration Number H13PRO009 - -This file is part of GNU Emacs. - -GNU Emacs is free software: you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation, either version 3 of the License, or (at -your option) any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ - -#include <config.h> -#include <X11/Xlib.h> - -#include "lisp.h" -#include "xterm.h" -#include "frame.h" -#include "blockinput.h" -#include "font.h" -#include "pdumper.h" - -/* FTX font driver. */ - -struct ftxfont_frame_data -{ - /* Background and foreground colors. */ - XColor colors[2]; - /* GCs interpolating the above colors. gcs[0] is for a color - closest to BACKGROUND, and gcs[5] is for a color closest to - FOREGROUND. */ - GC gcs[6]; - struct ftxfont_frame_data *next; -}; - - -/* Return an array of 6 GCs for antialiasing. */ - -static GC * -ftxfont_get_gcs (struct frame *f, unsigned long foreground, unsigned long background) -{ - XColor color; - XGCValues xgcv; - int i; - struct ftxfont_frame_data *data = font_get_frame_data (f, Qftx); - struct ftxfont_frame_data *prev = NULL, *this = NULL, *new; - - if (data) - { - for (this = data; this; prev = this, this = this->next) - { - if (this->colors[0].pixel < background) - continue; - if (this->colors[0].pixel > background) - break; - if (this->colors[1].pixel < foreground) - continue; - if (this->colors[1].pixel > foreground) - break; - return this->gcs; - } - } - - new = xmalloc (sizeof *new); - new->next = this; - if (prev) - prev->next = new; - font_put_frame_data (f, Qftx, new); - - new->colors[0].pixel = background; - new->colors[1].pixel = foreground; - - block_input (); - XQueryColors (FRAME_X_DISPLAY (f), FRAME_X_COLORMAP (f), new->colors, 2); - for (i = 1; i < 7; i++) - { - /* Interpolate colors linearly. Any better algorithm? */ - color.red - = (new->colors[1].red * i + new->colors[0].red * (8 - i)) / 8; - color.green - = (new->colors[1].green * i + new->colors[0].green * (8 - i)) / 8; - color.blue - = (new->colors[1].blue * i + new->colors[0].blue * (8 - i)) / 8; - if (! x_alloc_nearest_color (f, FRAME_X_COLORMAP (f), &color)) - break; - xgcv.foreground = color.pixel; - new->gcs[i - 1] = XCreateGC (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), - GCForeground, &xgcv); - } - unblock_input (); - - if (i < 7) - { - block_input (); - for (i--; i >= 0; i--) - XFreeGC (FRAME_X_DISPLAY (f), new->gcs[i]); - unblock_input (); - if (prev) - prev->next = new->next; - else if (data) - font_put_frame_data (f, Qftx, new->next); - xfree (new); - return NULL; - } - return new->gcs; -} - -static int -ftxfont_draw_bitmap (struct frame *f, GC gc_fore, GC *gcs, struct font *font, - unsigned int code, int x, int y, XPoint *p, int size, - int *n, bool flush) -{ - struct font_bitmap bitmap; - unsigned char *b; - int i, j; - - if (ftfont_get_bitmap (font, code, &bitmap, size > 0x100 ? 1 : 8) < 0) - return 0; - if (size > 0x100) - { - for (i = 0, b = bitmap.buffer; i < bitmap.rows; - i++, b += bitmap.pitch) - { - for (j = 0; j < bitmap.width; j++) - if (b[j / 8] & (1 << (7 - (j % 8)))) - { - p[n[0]].x = x + bitmap.left + j; - p[n[0]].y = y - bitmap.top + i; - if (++n[0] == size) - { - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), - gc_fore, p, size, CoordModeOrigin); - n[0] = 0; - } - } - } - if (flush && n[0] > 0) - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), - gc_fore, p, n[0], CoordModeOrigin); - } - else - { - for (i = 0, b = bitmap.buffer; i < bitmap.rows; - i++, b += bitmap.pitch) - { - for (j = 0; j < bitmap.width; j++) - { - int idx = (bitmap.bits_per_pixel == 1 - ? ((b[j / 8] & (1 << (7 - (j % 8)))) ? 6 : -1) - : (b[j] >> 5) - 1); - - if (idx >= 0) - { - XPoint *pp = p + size * idx; - - pp[n[idx]].x = x + bitmap.left + j; - pp[n[idx]].y = y - bitmap.top + i; - if (++(n[idx]) == size) - { - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), - idx == 6 ? gc_fore : gcs[idx], pp, size, - CoordModeOrigin); - n[idx] = 0; - } - } - } - } - if (flush) - { - for (i = 0; i < 6; i++) - if (n[i] > 0) - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), - gcs[i], p + 0x100 * i, n[i], CoordModeOrigin); - if (n[6] > 0) - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), - gc_fore, p + 0x600, n[6], CoordModeOrigin); - } - } - - /* There is no ftfont_free_bitmap, so do not try to free BITMAP. */ - - return bitmap.advance; -} - -static void -ftxfont_draw_background (struct frame *f, struct font *font, GC gc, int x, int y, - int width) -{ - XGCValues xgcv; - - XGetGCValues (FRAME_X_DISPLAY (f), gc, - GCForeground | GCBackground, &xgcv); - XSetForeground (FRAME_X_DISPLAY (f), gc, xgcv.background); - XFillRectangle (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), gc, - x, y - FONT_BASE (font), width, FONT_HEIGHT (font)); - XSetForeground (FRAME_X_DISPLAY (f), gc, xgcv.foreground); -} - -static Lisp_Object -ftxfont_list (struct frame *f, Lisp_Object spec) -{ - return ftfont_list2 (f, spec, Qftx); -} - -static Lisp_Object -ftxfont_match (struct frame *f, Lisp_Object spec) -{ - return ftfont_match2 (f, spec, Qftx); -} - -static Lisp_Object -ftxfont_open (struct frame *f, Lisp_Object entity, int pixel_size) -{ - Lisp_Object font_object = ftfont_open (f, entity, pixel_size); - if (NILP (font_object)) - return Qnil; - struct font *font = XFONT_OBJECT (font_object); - font->driver = &ftxfont_driver; - return font_object; -} - -static void -ftxfont_close (struct font *font) -{ - ftfont_close (font); -} - -static int -ftxfont_draw (struct glyph_string *s, int from, int to, int x, int y, - bool with_background) -{ - struct frame *f = s->f; - struct face *face = s->face; - struct font *font = s->font; - XPoint p[0x700]; - int n[7]; - unsigned *code = s->char2b + from; - int len = to - from; - int i; - GC *gcs; - int xadvance; - - n[0] = n[1] = n[2] = n[3] = n[4] = n[5] = n[6] = 0; - - block_input (); - if (with_background) - ftxfont_draw_background (f, font, s->gc, x, y, s->width); - - if (face->gc == s->gc) - { - gcs = ftxfont_get_gcs (f, face->foreground, face->background); - } - else - { - XGCValues xgcv; - unsigned long mask = GCForeground | GCBackground; - - XGetGCValues (FRAME_X_DISPLAY (f), s->gc, mask, &xgcv); - gcs = ftxfont_get_gcs (f, xgcv.foreground, xgcv.background); - } - - if (gcs) - { - if (s->num_clips) - for (i = 0; i < 6; i++) - XSetClipRectangles (FRAME_X_DISPLAY (f), gcs[i], 0, 0, - s->clip, s->num_clips, Unsorted); - - for (i = 0; i < len; i++) - { - xadvance = ftxfont_draw_bitmap (f, s->gc, gcs, font, code[i], x, y, - p, 0x100, n, i + 1 == len); - x += (s->padding_p ? 1 : xadvance); - } - if (s->num_clips) - for (i = 0; i < 6; i++) - XSetClipMask (FRAME_X_DISPLAY (f), gcs[i], None); - } - else - { - /* We can't draw with antialiasing. - s->gc should already have a proper clipping setting. */ - for (i = 0; i < len; i++) - { - xadvance = ftxfont_draw_bitmap (f, s->gc, NULL, font, code[i], x, y, - p, 0x700, n, i + 1 == len); - x += (s->padding_p ? 1 : xadvance); - } - } - - unblock_input (); - - return len; -} - -static int -ftxfont_end_for_frame (struct frame *f) -{ - struct ftxfont_frame_data *data = font_get_frame_data (f, Qftx); - - block_input (); - while (data) - { - struct ftxfont_frame_data *next = data->next; - int i; - - for (i = 0; i < 6; i++) - XFreeGC (FRAME_X_DISPLAY (f), data->gcs[i]); - xfree (data); - data = next; - } - unblock_input (); - font_put_frame_data (f, Qftx, NULL); - return 0; -} - - - -static void syms_of_ftxfont_for_pdumper (void); - -struct font_driver const ftxfont_driver = - { - /* We can't draw a text without device dependent functions. */ - .type = LISPSYM_INITIALLY (Qftx), - .get_cache = ftfont_get_cache, - .list = ftxfont_list, - .match = ftxfont_match, - .list_family = ftfont_list_family, - .open_font = ftxfont_open, - .close_font = ftxfont_close, - .has_char = ftfont_has_char, - .encode_char = ftfont_encode_char, - .text_extents = ftfont_text_extents, - .draw = ftxfont_draw, - .get_bitmap = ftfont_get_bitmap, - .anchor_point = ftfont_anchor_point, -#ifdef HAVE_LIBOTF - .otf_capability = ftfont_otf_capability, -#endif - .end_for_frame = ftxfont_end_for_frame, -#if defined HAVE_M17N_FLT && defined HAVE_LIBOTF - .shape = ftfont_shape, -#endif -#if defined HAVE_OTF_GET_VARIATION_GLYPHS || defined HAVE_FT_FACE_GETCHARVARIANTINDEX - .get_variation_glyphs = ftfont_variation_glyphs, -#endif - .filter_properties = ftfont_filter_properties, - .combining_capability = ftfont_combining_capability, - }; - -void -syms_of_ftxfont (void) -{ - DEFSYM (Qftx, "ftx"); - pdumper_do_now_and_after_load (syms_of_ftxfont_for_pdumper); -} - -static void -syms_of_ftxfont_for_pdumper (void) -{ - register_font_driver (&ftxfont_driver, NULL); -} diff --git a/src/gmalloc.c b/src/gmalloc.c index 00a5a273ab5..66008ea69b2 100644 --- a/src/gmalloc.c +++ b/src/gmalloc.c @@ -38,8 +38,6 @@ License along with this library. If not, see <https://www.gnu.org/licenses/>. #include "lisp.h" -#include "ptr-bounds.h" - #ifdef HAVE_MALLOC_H # if GNUC_PREREQ (4, 2, 0) # pragma GCC diagnostic ignored "-Wdeprecated-declarations" @@ -200,8 +198,7 @@ extern size_t _bytes_free; /* Internal versions of `malloc', `realloc', and `free' used when these functions need to call each other. - They are the same but don't call the hooks - and don't bound the resulting pointers. */ + They are the same but don't call the hooks. */ extern void *_malloc_internal (size_t); extern void *_realloc_internal (void *, size_t); extern void _free_internal (void *); @@ -551,7 +548,7 @@ malloc_initialize_1 (void) _heapinfo[0].free.size = 0; _heapinfo[0].free.next = _heapinfo[0].free.prev = 0; _heapindex = 0; - _heapbase = (char *) ptr_bounds_init (_heapinfo); + _heapbase = (char *) _heapinfo; _heaplimit = BLOCK (_heapbase + heapsize * sizeof (malloc_info)); register_heapinfo (); @@ -912,8 +909,7 @@ malloc (size_t size) among multiple threads. We just leave it for compatibility with glibc malloc (i.e., assignments to gmalloc_hook) for now. */ hook = gmalloc_hook; - void *result = (hook ? hook : _malloc_internal) (size); - return ptr_bounds_clip (result, size); + return (hook ? hook : _malloc_internal) (size); } #if !(defined (_LIBC) || defined (HYBRID_MALLOC)) @@ -991,7 +987,6 @@ _free_internal_nolock (void *ptr) if (ptr == NULL) return; - ptr = ptr_bounds_init (ptr); PROTECT_MALLOC_STATE (0); @@ -1303,7 +1298,6 @@ _realloc_internal_nolock (void *ptr, size_t size) else if (ptr == NULL) return _malloc_internal_nolock (size); - ptr = ptr_bounds_init (ptr); block = BLOCK (ptr); PROTECT_MALLOC_STATE (0); @@ -1426,8 +1420,7 @@ realloc (void *ptr, size_t size) return NULL; hook = grealloc_hook; - void *result = (hook ? hook : _realloc_internal) (ptr, size); - return ptr_bounds_clip (result, size); + return (hook ? hook : _realloc_internal) (ptr, size); } /* Copyright (C) 1991, 1992, 1994 Free Software Foundation, Inc. @@ -1601,7 +1594,6 @@ aligned_alloc (size_t alignment, size_t size) { l->exact = result; result = l->aligned = (char *) result + adj; - result = ptr_bounds_clip (result, size); } UNLOCK_ALIGNED_BLOCKS (); if (l == NULL) diff --git a/src/gnutls.c b/src/gnutls.c index 74162dc1a9f..aa245ee5c39 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -230,7 +230,6 @@ DEF_DLL_FN (const char *, gnutls_compression_get_name, DEF_DLL_FN (unsigned, gnutls_safe_renegotiation_status, (gnutls_session_t)); # ifdef HAVE_GNUTLS3 -DEF_DLL_FN (int, gnutls_rnd, (gnutls_rnd_level_t, void *, size_t)); DEF_DLL_FN (const gnutls_mac_algorithm_t *, gnutls_mac_list, (void)); # ifdef HAVE_GNUTLS_MAC_GET_NONCE_SIZE DEF_DLL_FN (size_t, gnutls_mac_get_nonce_size, (gnutls_mac_algorithm_t)); @@ -381,7 +380,6 @@ init_gnutls_functions (void) # endif LOAD_DLL_FN (library, gnutls_safe_renegotiation_status); # ifdef HAVE_GNUTLS3 - LOAD_DLL_FN (library, gnutls_rnd); LOAD_DLL_FN (library, gnutls_mac_list); # ifdef HAVE_GNUTLS_MAC_GET_NONCE_SIZE LOAD_DLL_FN (library, gnutls_mac_get_nonce_size); @@ -519,7 +517,6 @@ init_gnutls_functions (void) # define gnutls_x509_crt_import fn_gnutls_x509_crt_import # define gnutls_x509_crt_init fn_gnutls_x509_crt_init # ifdef HAVE_GNUTLS3 -# define gnutls_rnd fn_gnutls_rnd # define gnutls_mac_list fn_gnutls_mac_list # ifdef HAVE_GNUTLS_MAC_GET_NONCE_SIZE # define gnutls_mac_get_nonce_size fn_gnutls_mac_get_nonce_size @@ -573,14 +570,6 @@ init_gnutls_functions (void) # undef gnutls_free # define gnutls_free (*gnutls_free_func) -/* This wrapper is called from fns.c, which doesn't know about the - LOAD_DLL_FN stuff above. */ -int -w32_gnutls_rnd (gnutls_rnd_level_t level, void *data, size_t len) -{ - return gnutls_rnd (level, data, len); -} - # endif /* WINDOWSNT */ @@ -2309,6 +2298,8 @@ gnutls_symmetric_aead (bool encrypting, gnutls_cipher_algorithm_t gca, # endif } +static Lisp_Object cipher_cache; + static Lisp_Object gnutls_symmetric (bool encrypting, Lisp_Object cipher, Lisp_Object key, Lisp_Object iv, @@ -2340,7 +2331,9 @@ gnutls_symmetric (bool encrypting, Lisp_Object cipher, if (SYMBOLP (cipher)) { - info = Fassq (cipher, Fgnutls_ciphers ()); + if (NILP (cipher_cache)) + cipher_cache = Fgnutls_ciphers (); + info = Fassq (cipher, cipher_cache); if (!CONSP (info)) xsignal2 (Qerror, build_string ("GnuTLS cipher is invalid or not found"), @@ -2773,7 +2766,7 @@ GnuTLS MACs : the list will contain `macs'. GnuTLS digests : the list will contain `digests'. GnuTLS symmetric ciphers: the list will contain `ciphers'. GnuTLS AEAD ciphers : the list will contain `AEAD-ciphers'. -%DUMBFW : the list will contain `ClientHello\ Padding'. +%DUMBFW : the list will contain `ClientHello\\ Padding'. Any GnuTLS extension with ID up to 100 : the list will contain its name. */) (void) @@ -2925,6 +2918,9 @@ level in the ones. For builds without libgnutls, the value is -1. */); defsubr (&Sgnutls_hash_digest); defsubr (&Sgnutls_symmetric_encrypt); defsubr (&Sgnutls_symmetric_decrypt); + + cipher_cache = Qnil; + staticpro (&cipher_cache); #endif DEFVAR_INT ("gnutls-log-level", global_gnutls_log_level, diff --git a/src/gtkutil.c b/src/gtkutil.c index d824601be55..11e59b9fae5 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -1411,10 +1411,15 @@ xg_free_frame_widgets (struct frame *f) FRAME_X_WINDOW (f) = 0; /* Set to avoid XDestroyWindow in xterm.c */ FRAME_X_RAW_DRAWABLE (f) = 0; FRAME_GTK_OUTER_WIDGET (f) = 0; + if (x->ttip_widget) + { + /* Remove ttip_lbl from ttip_widget's custom slot before + destroying it, to avoid double-free (Bug#41239). */ + gtk_tooltip_set_custom (x->ttip_widget, NULL); + g_object_unref (G_OBJECT (x->ttip_widget)); + } if (x->ttip_lbl) gtk_widget_destroy (x->ttip_lbl); - if (x->ttip_widget) - g_object_unref (G_OBJECT (x->ttip_widget)); } } @@ -2939,14 +2944,11 @@ xg_get_menu_item_label (GtkMenuItem *witem) static bool xg_item_label_same_p (GtkMenuItem *witem, const char *label) { - bool is_same = 0; char *utf8_label = get_utf8_string (label); const char *old_label = witem ? xg_get_menu_item_label (witem) : 0; - if (! old_label && ! utf8_label) - is_same = 1; - else if (old_label && utf8_label) - is_same = strcmp (utf8_label, old_label) == 0; + bool is_same = (!old_label == !utf8_label + && (!old_label || strcmp (utf8_label, old_label) == 0)); if (utf8_label) g_free (utf8_label); @@ -4436,13 +4438,6 @@ xg_tool_bar_callback (GtkWidget *w, gpointer client_data) key = AREF (f->tool_bar_items, idx + TOOL_BAR_ITEM_KEY); XSETFRAME (frame, f); - /* We generate two events here. The first one is to set the prefix - to `(tool_bar)', see keyboard.c. */ - event.kind = TOOL_BAR_EVENT; - event.frame_or_window = frame; - event.arg = frame; - kbd_buffer_store_event (&event); - event.kind = TOOL_BAR_EVENT; event.frame_or_window = frame; event.arg = key; @@ -5115,7 +5110,7 @@ update_frame_tool_bar (struct frame *f) else idx = -1; - img_id = lookup_image (f, image); + img_id = lookup_image (f, image, -1); img = IMAGE_FROM_ID (f, img_id); prepare_image_for_display (f, img); diff --git a/src/hbfont.c b/src/hbfont.c index 0c734365ce9..e9f4085b1ae 100644 --- a/src/hbfont.c +++ b/src/hbfont.c @@ -594,13 +594,10 @@ hbfont_shape (Lisp_Object lgstring, Lisp_Object direction) yoff = - lround (pos[i].y_offset * position_unit); wadjust = lround (pos[i].x_advance * position_unit); if (xoff || yoff || wadjust != metrics.width) - { - Lisp_Object vec = make_uninit_vector (3); - ASET (vec, 0, make_fixnum (xoff)); - ASET (vec, 1, make_fixnum (yoff)); - ASET (vec, 2, make_fixnum (wadjust)); - LGLYPH_SET_ADJUSTMENT (lglyph, vec); - } + LGLYPH_SET_ADJUSTMENT (lglyph, CALLN (Fvector, + make_fixnum (xoff), + make_fixnum (yoff), + make_fixnum (wadjust))); } return make_fixnum (glyph_len); diff --git a/src/image.c b/src/image.c index cd095e0e659..a124cf91ba0 100644 --- a/src/image.c +++ b/src/image.c @@ -24,7 +24,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ /* Include this before including <setjmp.h> to work around bugs with older libpng; see Bug#17429. */ -#if defined HAVE_PNG && !defined HAVE_NS +#if defined HAVE_PNG # include <png.h> #endif @@ -125,6 +125,7 @@ typedef struct ns_bitmap_record Bitmap_Record; #define NO_PIXMAP 0 #define PIX_MASK_RETAIN 0 +#define PIX_MASK_DRAW 1 #endif /* HAVE_NS */ @@ -258,6 +259,8 @@ cr_put_image_to_cr_data (struct image *img) cairo_matrix_t matrix; cairo_pattern_get_matrix (img->cr_data, &matrix); cairo_pattern_set_matrix (pattern, &matrix); + cairo_pattern_set_filter + (pattern, cairo_pattern_get_filter (img->cr_data)); cairo_pattern_destroy (img->cr_data); } cairo_surface_destroy (surface); @@ -755,10 +758,10 @@ struct image_type /* Load IMG which is used on frame F from information contained in IMG->spec. Value is true if successful. */ - bool (*load) (struct frame *f, struct image *img); + bool (*load_img) (struct frame *f, struct image *img); /* Free resources of image IMG which is used on frame F. */ - void (*free) (struct frame *f, struct image *img); + void (*free_img) (struct frame *f, struct image *img); #ifdef WINDOWSNT /* Initialization function (used for dynamic loading of image @@ -800,23 +803,28 @@ valid_image_p (Lisp_Object object) { Lisp_Object tail = XCDR (object); FOR_EACH_TAIL_SAFE (tail) - if (EQ (XCAR (tail), QCtype)) - { - tail = XCDR (tail); - if (CONSP (tail)) - { - struct image_type const *type = lookup_image_type (XCAR (tail)); - if (type) - return type->valid_p (object); - } - break; - } + { + if (EQ (XCAR (tail), QCtype)) + { + tail = XCDR (tail); + if (CONSP (tail)) + { + struct image_type const *type = + lookup_image_type (XCAR (tail)); + if (type) + return type->valid_p (object); + } + break; + } + tail = XCDR (tail); + if (! CONSP (tail)) + return false; + } } return false; } - /* Log error message with format string FORMAT and trailing arguments. Signaling an error, e.g. when an image cannot be loaded, is not a good idea because this would interrupt redisplay, and the error @@ -897,7 +905,7 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords, return false; plist = XCDR (spec); - while (CONSP (plist)) + FOR_EACH_TAIL_SAFE (plist) { Lisp_Object key, value; @@ -911,7 +919,6 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords, if (!CONSP (plist)) return false; value = XCAR (plist); - plist = XCDR (plist); /* Find key in KEYWORDS. Error if not found. */ for (i = 0; i < nkeywords; ++i) @@ -919,7 +926,7 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords, break; if (i == nkeywords) - continue; + goto maybe_done; /* Record that we recognized the keyword. If a keyword was found more than once, it's an error. */ @@ -1004,16 +1011,23 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords, break; } - if (EQ (key, QCtype) && !EQ (type, value)) + if (EQ (key, QCtype) + && !(EQ (type, value) || EQ (type, Qnative_image))) return false; - } - /* Check that all mandatory fields are present. */ - for (i = 0; i < nkeywords; ++i) - if (keywords[i].count < keywords[i].mandatory_p) - return false; + maybe_done: + if (EQ (XCDR (plist), Qnil)) + { + /* Check that all mandatory fields are present. */ + for (i = 0; i < nkeywords; ++i) + if (keywords[i].mandatory_p && keywords[i].count == 0) + return false; + + return true; + } + } - return NILP (plist); + return false; } @@ -1028,9 +1042,8 @@ image_spec_value (Lisp_Object spec, Lisp_Object key, bool *found) eassert (valid_image_p (spec)); - for (tail = XCDR (spec); - CONSP (tail) && CONSP (XCDR (tail)); - tail = XCDR (XCDR (tail))) + tail = XCDR (spec); + FOR_EACH_TAIL_SAFE (tail) { if (EQ (XCAR (tail), key)) { @@ -1038,6 +1051,9 @@ image_spec_value (Lisp_Object spec, Lisp_Object key, bool *found) *found = 1; return XCAR (XCDR (tail)); } + tail = XCDR (tail); + if (! CONSP (tail)) + break; } if (found) @@ -1065,7 +1081,7 @@ calling this function. */) if (valid_image_p (spec)) { struct frame *f = decode_window_system_frame (frame); - ptrdiff_t id = lookup_image (f, spec); + ptrdiff_t id = lookup_image (f, spec, -1); struct image *img = IMAGE_FROM_ID (f, id); int width = img->width + 2 * img->hmargin; int height = img->height + 2 * img->vmargin; @@ -1095,7 +1111,7 @@ or omitted means use the selected frame. */) if (valid_image_p (spec)) { struct frame *f = decode_window_system_frame (frame); - ptrdiff_t id = lookup_image (f, spec); + ptrdiff_t id = lookup_image (f, spec, -1); struct image *img = IMAGE_FROM_ID (f, id); if (img->mask) mask = Qt; @@ -1118,7 +1134,7 @@ or omitted means use the selected frame. */) if (valid_image_p (spec)) { struct frame *f = decode_window_system_frame (frame); - ptrdiff_t id = lookup_image (f, spec); + ptrdiff_t id = lookup_image (f, spec, -1); struct image *img = IMAGE_FROM_ID (f, id); ext = img->lisp_data; } @@ -1181,13 +1197,8 @@ free_image (struct frame *f, struct image *img) XRenderFreePicture (FRAME_X_DISPLAY (f), img->mask_picture); #endif - /* Windows NT redefines 'free', but in this file, we need to - avoid the redefinition. */ -#ifdef WINDOWSNT -#undef free -#endif /* Free resources, then free IMG. */ - img->type->free (f, img); + img->type->free_img (f, img); xfree (img); } } @@ -1233,7 +1244,7 @@ prepare_image_for_display (struct frame *f, struct image *img) /* If IMG doesn't have a pixmap yet, load it now, using the image type dependent loader function. */ if (img->pixmap == NO_PIXMAP && !img->load_failed_p) - img->load_failed_p = ! img->type->load (f, img); + img->load_failed_p = ! img->type->load_img (f, img); #ifdef USE_CAIRO if (!img->load_failed_p) @@ -1250,7 +1261,7 @@ prepare_image_for_display (struct frame *f, struct image *img) if (img->cr_data == NULL) { img->load_failed_p = 1; - img->type->free (f, img); + img->type->free_img (f, img); } } unblock_input (); @@ -1581,11 +1592,12 @@ make_image_cache (void) return c; } - /* Find an image matching SPEC in the cache, and return it. If no image is found, return NULL. */ static struct image * -search_image_cache (struct frame *f, Lisp_Object spec, EMACS_UINT hash) +search_image_cache (struct frame *f, Lisp_Object spec, EMACS_UINT hash, + unsigned long foreground, unsigned long background, + bool ignore_colors) { struct image *img; struct image_cache *c = FRAME_IMAGE_CACHE (f); @@ -1608,8 +1620,8 @@ search_image_cache (struct frame *f, Lisp_Object spec, EMACS_UINT hash) for (img = c->buckets[i]; img; img = img->next) if (img->hash == hash && !NILP (Fequal (img->spec, spec)) - && img->frame_foreground == FRAME_FOREGROUND_PIXEL (f) - && img->frame_background == FRAME_BACKGROUND_PIXEL (f)) + && (ignore_colors || (img->face_foreground == foreground + && img->face_background == background))) break; return img; } @@ -1620,8 +1632,14 @@ search_image_cache (struct frame *f, Lisp_Object spec, EMACS_UINT hash) static void uncache_image (struct frame *f, Lisp_Object spec) { - struct image *img = search_image_cache (f, spec, sxhash (spec, 0)); - if (img) + struct image *img; + EMACS_UINT hash = sxhash (spec); + + /* Because the background colors are based on the current face, we + can have multiple copies of an image with the same spec. We want + to remove them all to ensure the user doesn't see an old version + of the image when the face changes. */ + while ((img = search_image_cache (f, spec, hash, 0, 0, true))) { free_image (f, img); /* As display glyphs may still be referring to the image ID, we @@ -1774,6 +1792,79 @@ which is then usually a filename. */) return Qnil; } +static size_t +image_size_in_bytes (struct image *img) +{ + size_t size = 0; + +#if defined USE_CAIRO + Emacs_Pixmap pm = img->pixmap; + if (pm) + size += pm->height * pm->bytes_per_line; + Emacs_Pixmap msk = img->mask; + if (msk) + size += msk->height * msk->bytes_per_line; + +#elif defined HAVE_X_WINDOWS + /* Use a nominal depth of 24 bpp for pixmap and 1 bpp for mask, + to avoid having to query the server. */ + if (img->pixmap != NO_PIXMAP) + size += img->width * img->height * 3; + if (img->mask != NO_PIXMAP) + size += img->width * img->height / 8; + + if (img->ximg && img->ximg->data) + size += img->ximg->bytes_per_line * img->ximg->height; + if (img->mask_img && img->mask_img->data) + size += img->mask_img->bytes_per_line * img->mask_img->height; + +#elif defined HAVE_NS + if (img->pixmap) + size += ns_image_size_in_bytes (img->pixmap); + if (img->mask) + size += ns_image_size_in_bytes (img->mask); + +#elif defined HAVE_NTGUI + if (img->pixmap) + size += w32_image_size (img->pixmap); + if (img->mask) + size += w32_image_size (img->mask); + +#endif + + return size; +} + +static size_t +image_frame_cache_size (struct frame *f) +{ + struct image_cache *c = FRAME_IMAGE_CACHE (f); + if (!c) + return 0; + + size_t total = 0; + for (ptrdiff_t i = 0; i < c->used; ++i) + { + struct image *img = c->images[i]; + total += img ? image_size_in_bytes (img) : 0; + } + return total; +} + +DEFUN ("image-cache-size", Fimage_cache_size, Simage_cache_size, 0, 0, 0, + doc: /* Return the size of the image cache. */) + (void) +{ + Lisp_Object tail, frame; + size_t total = 0; + + FOR_EACH_FRAME (tail, frame) + if (FRAME_WINDOW_P (XFRAME (frame))) + total += image_frame_cache_size (XFRAME (frame)); + + return make_int (total); +} + DEFUN ("image-flush", Fimage_flush, Simage_flush, 1, 2, 0, @@ -2111,12 +2202,31 @@ image_set_transform (struct frame *f, struct image *img) /* Determine size. */ int width, height; - compute_image_size (img->width, img->height, img->spec, &width, &height); + +#ifdef HAVE_RSVG + /* SVGs are pre-scaled to the correct size. */ + if (EQ (image_spec_value (img->spec, QCtype, NULL), Qsvg)) + { + width = img->width; + height = img->height; + } + else +#endif + compute_image_size (img->width, img->height, img->spec, &width, &height); /* Determine rotation. */ double rotation = 0.0; compute_image_rotation (img, &rotation); +# if defined USE_CAIRO || defined HAVE_XRENDER || defined HAVE_NS + /* We want scale up operations to use a nearest neighbour filter to + show real pixels instead of munging them, but scale down + operations to use a blended filter, to avoid aliasing and the like. + + TODO: implement for Windows. */ + bool scale_down = (width < img->width) || (height < img->height); +# endif + /* Perform scale transformation. */ matrix3x3 matrix @@ -2228,11 +2338,14 @@ image_set_transform (struct frame *f, struct image *img) /* Under NS the transform is applied to the drawing surface at drawing time, so store it for later. */ ns_image_set_transform (img->pixmap, matrix); + ns_image_set_smoothing (img->pixmap, scale_down); # elif defined USE_CAIRO cairo_matrix_t cr_matrix = {matrix[0][0], matrix[0][1], matrix[1][0], matrix[1][1], matrix[2][0], matrix[2][1]}; cairo_pattern_t *pattern = cairo_pattern_create_rgb (0, 0, 0); cairo_pattern_set_matrix (pattern, &cr_matrix); + cairo_pattern_set_filter (pattern, scale_down + ? CAIRO_FILTER_BEST : CAIRO_FILTER_NEAREST); /* Dummy solid color pattern just to record pattern matrix. */ img->cr_data = pattern; # elif defined (HAVE_XRENDER) @@ -2249,14 +2362,14 @@ image_set_transform (struct frame *f, struct image *img) XDoubleToFixed (matrix[1][2]), XDoubleToFixed (matrix[2][2])}}}; - XRenderSetPictureFilter (FRAME_X_DISPLAY (f), img->picture, FilterBest, - 0, 0); + XRenderSetPictureFilter (FRAME_X_DISPLAY (f), img->picture, + scale_down ? FilterBest : FilterNearest, 0, 0); XRenderSetPictureTransform (FRAME_X_DISPLAY (f), img->picture, &tmat); if (img->mask_picture) { XRenderSetPictureFilter (FRAME_X_DISPLAY (f), img->mask_picture, - FilterBest, 0, 0); + scale_down ? FilterBest : FilterNearest, 0, 0); XRenderSetPictureTransform (FRAME_X_DISPLAY (f), img->mask_picture, &tmat); } @@ -2278,19 +2391,30 @@ image_set_transform (struct frame *f, struct image *img) SPEC must be a valid Lisp image specification (see valid_image_p). */ ptrdiff_t -lookup_image (struct frame *f, Lisp_Object spec) +lookup_image (struct frame *f, Lisp_Object spec, int face_id) { struct image *img; EMACS_UINT hash; + if (FRAME_FACE_CACHE (f) == NULL) + init_frame_faces (f); + if (FRAME_FACE_CACHE (f)->used == 0) + recompute_basic_faces (f); + if (face_id < 0 || face_id >= FRAME_FACE_CACHE (f)->used) + face_id = DEFAULT_FACE_ID; + + struct face *face = FACE_FROM_ID (f, face_id); + unsigned long foreground = FACE_COLOR_TO_PIXEL (face->foreground, f); + unsigned long background = FACE_COLOR_TO_PIXEL (face->background, f); + /* F must be a window-system frame, and SPEC must be a valid image specification. */ eassert (FRAME_WINDOW_P (f)); eassert (valid_image_p (spec)); /* Look up SPEC in the hash table of the image cache. */ - hash = sxhash (spec, 0); - img = search_image_cache (f, spec, hash); + hash = sxhash (spec); + img = search_image_cache (f, spec, hash, foreground, background, false); if (img && img->load_failed_p) { free_image (f, img); @@ -2303,9 +2427,9 @@ lookup_image (struct frame *f, Lisp_Object spec) block_input (); img = make_image (spec, hash); cache_image (f, img); - img->load_failed_p = ! img->type->load (f, img); - img->frame_foreground = FRAME_FOREGROUND_PIXEL (f); - img->frame_background = FRAME_BACKGROUND_PIXEL (f); + img->face_foreground = foreground; + img->face_background = background; + img->load_failed_p = ! img->type->load_img (f, img); /* If we can't load the image, and we don't have a width and height, use some arbitrary width and height so that we can @@ -2359,8 +2483,7 @@ lookup_image (struct frame *f, Lisp_Object spec) if (!NILP (bg)) { img->background - = image_alloc_image_color (f, img, bg, - FRAME_BACKGROUND_PIXEL (f)); + = image_alloc_image_color (f, img, bg, background); img->background_valid = 1; } } @@ -3638,8 +3761,8 @@ xbm_load_image (struct frame *f, struct image *img, char *contents, char *end) &data, 0); if (rc) { - unsigned long foreground = FRAME_FOREGROUND_PIXEL (f); - unsigned long background = FRAME_BACKGROUND_PIXEL (f); + unsigned long foreground = img->face_foreground; + unsigned long background = img->face_background; bool non_default_colors = 0; Lisp_Object value; @@ -3735,8 +3858,8 @@ xbm_load (struct frame *f, struct image *img) { struct image_keyword fmt[XBM_LAST]; Lisp_Object data; - unsigned long foreground = FRAME_FOREGROUND_PIXEL (f); - unsigned long background = FRAME_BACKGROUND_PIXEL (f); + unsigned long foreground = img->face_foreground; + unsigned long background = img->face_background; bool non_default_colors = 0; char *bits; bool parsed_p; @@ -4581,8 +4704,9 @@ xpm_scan (const char **s, const char *end, const char **beg, ptrdiff_t *len) while (*s < end) { /* Skip white-space. */ - while (*s < end && (c = *(*s)++, c_isspace (c))) - ; + do + c = *(*s)++; + while (c_isspace (c) && *s < end); /* gnus-pointer.xpm uses '-' in its identifier. sb-dir-plus.xpm uses '+' in its identifier. */ @@ -6095,8 +6219,8 @@ pbm_load (struct frame *f, struct image *img) unsigned char c = 0; int g; struct image_keyword fmt[PBM_LAST]; - unsigned long fg = FRAME_FOREGROUND_PIXEL (f); - unsigned long bg = FRAME_BACKGROUND_PIXEL (f); + unsigned long fg = img->face_foreground; + unsigned long bg = img->face_background; /* Parse the image specification. */ memcpy (fmt, pbm_format, sizeof fmt); parse_image_spec (img->spec, fmt, PBM_LAST, Qpbm); @@ -6241,10 +6365,104 @@ pbm_load (struct frame *f, struct image *img) /*********************************************************************** + NATIVE IMAGE HANDLING + ***********************************************************************/ + +#if HAVE_NATIVE_IMAGE_API +static bool +image_can_use_native_api (Lisp_Object type) +{ +# ifdef HAVE_NTGUI + return w32_can_use_native_image_api (type); +# elif defined HAVE_NS + return ns_can_use_native_image_api (type); +# else + return false; +# endif +} + +/* + * These functions are actually defined in the OS-native implementation + * file. Currently, for Windows GDI+ interface, w32image.c, but other + * operating systems can follow suit. + */ + +/* Indices of image specification fields in native format, below. */ +enum native_image_keyword_index +{ + NATIVE_IMAGE_TYPE, + NATIVE_IMAGE_DATA, + NATIVE_IMAGE_FILE, + NATIVE_IMAGE_ASCENT, + NATIVE_IMAGE_MARGIN, + NATIVE_IMAGE_RELIEF, + NATIVE_IMAGE_ALGORITHM, + NATIVE_IMAGE_HEURISTIC_MASK, + NATIVE_IMAGE_MASK, + NATIVE_IMAGE_BACKGROUND, + NATIVE_IMAGE_INDEX, + NATIVE_IMAGE_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid user-defined image specifications. */ +static const struct image_keyword native_image_format[] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":data", IMAGE_STRING_VALUE, 0}, + {":file", IMAGE_STRING_VALUE, 0}, + {":ascent", IMAGE_ASCENT_VALUE, 0}, + {":margin", IMAGE_NON_NEGATIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":background", IMAGE_STRING_OR_NIL_VALUE, 0}, + {":index", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0} +}; + +/* Return true if OBJECT is a valid native API image specification. */ + +static bool +native_image_p (Lisp_Object object) +{ + struct image_keyword fmt[NATIVE_IMAGE_LAST]; + memcpy (fmt, native_image_format, sizeof fmt); + + if (!parse_image_spec (object, fmt, 10, Qnative_image)) + return 0; + + /* Must specify either the :data or :file keyword. */ + return fmt[NATIVE_IMAGE_FILE].count + fmt[NATIVE_IMAGE_DATA].count == 1; +} + +static bool +native_image_load (struct frame *f, struct image *img) +{ + Lisp_Object image_file = image_spec_value (img->spec, QCfile, NULL); + + if (STRINGP (image_file)) + image_file = image_find_image_file (image_file); + +# ifdef HAVE_NTGUI + return w32_load_image (f, img, image_file, + image_spec_value (img->spec, QCdata, NULL)); +# elif defined HAVE_NS + return ns_load_image (f, img, image_file, + image_spec_value (img->spec, QCdata, NULL)); +# else + return 0; +# endif +} + +#endif /* HAVE_NATIVE_IMAGE_API */ + + +/*********************************************************************** PNG ***********************************************************************/ -#if defined (HAVE_PNG) || defined (HAVE_NS) +#if defined (HAVE_PNG) /* Indices of image specification fields in png_format, below. */ @@ -6295,10 +6513,10 @@ png_image_p (Lisp_Object object) return fmt[PNG_FILE].count + fmt[PNG_DATA].count == 1; } -#endif /* HAVE_PNG || HAVE_NS */ +#endif /* HAVE_PNG */ -#if defined HAVE_PNG && !defined HAVE_NS +#ifdef HAVE_PNG # ifdef WINDOWSNT /* PNG library details. */ @@ -6888,18 +7106,7 @@ png_load (struct frame *f, struct image *img) return png_load_body (f, img, &c); } -#elif defined HAVE_NS - -static bool -png_load (struct frame *f, struct image *img) -{ - return ns_load_image (f, img, - image_spec_value (img->spec, QCfile, NULL), - image_spec_value (img->spec, QCdata, NULL)); -} - - -#endif /* HAVE_NS */ +#endif /* HAVE_PNG */ @@ -6907,7 +7114,7 @@ png_load (struct frame *f, struct image *img) JPEG ***********************************************************************/ -#if defined (HAVE_JPEG) || defined (HAVE_NS) +#if defined (HAVE_JPEG) /* Indices of image specification fields in gs_format, below. */ @@ -6959,7 +7166,7 @@ jpeg_image_p (Lisp_Object object) return fmt[JPEG_FILE].count + fmt[JPEG_DATA].count == 1; } -#endif /* HAVE_JPEG || HAVE_NS */ +#endif /* HAVE_JPEG */ #ifdef HAVE_JPEG @@ -7461,18 +7668,6 @@ jpeg_load (struct frame *f, struct image *img) return jpeg_load_body (f, img, &mgr); } -#else /* HAVE_JPEG */ - -#ifdef HAVE_NS -static bool -jpeg_load (struct frame *f, struct image *img) -{ - return ns_load_image (f, img, - image_spec_value (img->spec, QCfile, NULL), - image_spec_value (img->spec, QCdata, NULL)); -} -#endif /* HAVE_NS */ - #endif /* !HAVE_JPEG */ @@ -7481,7 +7676,7 @@ jpeg_load (struct frame *f, struct image *img) TIFF ***********************************************************************/ -#if defined (HAVE_TIFF) || defined (HAVE_NS) +#if defined (HAVE_TIFF) /* Indices of image specification fields in tiff_format, below. */ @@ -7534,7 +7729,7 @@ tiff_image_p (Lisp_Object object) return fmt[TIFF_FILE].count + fmt[TIFF_DATA].count == 1; } -#endif /* HAVE_TIFF || HAVE_NS */ +#endif /* HAVE_TIFF */ #ifdef HAVE_TIFF @@ -7902,16 +8097,6 @@ tiff_load (struct frame *f, struct image *img) return 1; } -#elif defined HAVE_NS - -static bool -tiff_load (struct frame *f, struct image *img) -{ - return ns_load_image (f, img, - image_spec_value (img->spec, QCfile, NULL), - image_spec_value (img->spec, QCdata, NULL)); -} - #endif @@ -7920,7 +8105,7 @@ tiff_load (struct frame *f, struct image *img) GIF ***********************************************************************/ -#if defined (HAVE_GIF) || defined (HAVE_NS) +#if defined (HAVE_GIF) /* Indices of image specification fields in gif_format, below. */ @@ -8224,7 +8409,10 @@ gif_load (struct frame *f, struct image *img) rc = DGifSlurp (gif); if (rc == GIF_ERROR || gif->ImageCount <= 0) { - image_error ("Error reading `%s'", img->spec); + if (NILP (specified_data)) + image_error ("Error reading `%s'", img->spec); + else + image_error ("Error reading GIF data"); gif_close (gif, NULL); return 0; } @@ -8503,18 +8691,6 @@ gif_load (struct frame *f, struct image *img) return 1; } -#else /* !HAVE_GIF */ - -#ifdef HAVE_NS -static bool -gif_load (struct frame *f, struct image *img) -{ - return ns_load_image (f, img, - image_spec_value (img->spec, QCfile, NULL), - image_spec_value (img->spec, QCdata, NULL)); -} -#endif /* HAVE_NS */ - #endif /* HAVE_GIF */ @@ -9349,12 +9525,14 @@ enum svg_keyword_index SVG_TYPE, SVG_DATA, SVG_FILE, + SVG_BASE_URI, SVG_ASCENT, SVG_MARGIN, SVG_RELIEF, SVG_ALGORITHM, SVG_HEURISTIC_MASK, SVG_MASK, + SVG_FOREGROUND, SVG_BACKGROUND, SVG_LAST }; @@ -9367,12 +9545,14 @@ static const struct image_keyword svg_format[SVG_LAST] = {":type", IMAGE_SYMBOL_VALUE, 1}, {":data", IMAGE_STRING_VALUE, 0}, {":file", IMAGE_STRING_VALUE, 0}, + {":base-uri", IMAGE_STRING_VALUE, 0}, {":ascent", IMAGE_ASCENT_VALUE, 0}, {":margin", IMAGE_NON_NEGATIVE_INTEGER_VALUE_OR_PAIR, 0}, {":relief", IMAGE_INTEGER_VALUE, 0}, {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":foreground", IMAGE_STRING_OR_NIL_VALUE, 0}, {":background", IMAGE_STRING_OR_NIL_VALUE, 0} }; @@ -9436,11 +9616,22 @@ DEF_DLL_FN (void, rsvg_handle_set_base_uri, (RsvgHandle *, const char *)); DEF_DLL_FN (gboolean, rsvg_handle_write, (RsvgHandle *, const guchar *, gsize, GError **)); DEF_DLL_FN (gboolean, rsvg_handle_close, (RsvgHandle *, GError **)); -#endif +# endif + +DEF_DLL_FN (void, rsvg_handle_set_dpi_x_y, + (RsvgHandle * handle, double dpi_x, double dpi_y)); + +# if LIBRSVG_CHECK_VERSION (2, 46, 0) +DEF_DLL_FN (void, rsvg_handle_get_intrinsic_dimensions, + (RsvgHandle *, gboolean *, RsvgLength *, gboolean *, + RsvgLength *, gboolean *, RsvgRectangle *)); +DEF_DLL_FN (gboolean, rsvg_handle_get_geometry_for_layer, + (RsvgHandle *, const char *, const RsvgRectangle *, + RsvgRectangle *, RsvgRectangle *, GError **)); +# endif DEF_DLL_FN (void, rsvg_handle_get_dimensions, (RsvgHandle *, RsvgDimensionData *)); DEF_DLL_FN (GdkPixbuf *, rsvg_handle_get_pixbuf, (RsvgHandle *)); - DEF_DLL_FN (int, gdk_pixbuf_get_width, (const GdkPixbuf *)); DEF_DLL_FN (int, gdk_pixbuf_get_height, (const GdkPixbuf *)); DEF_DLL_FN (guchar *, gdk_pixbuf_get_pixels, (const GdkPixbuf *)); @@ -9486,6 +9677,11 @@ init_svg_functions (void) LOAD_DLL_FN (library, rsvg_handle_write); LOAD_DLL_FN (library, rsvg_handle_close); #endif + LOAD_DLL_FN (library, rsvg_handle_set_dpi_x_y); +#if LIBRSVG_CHECK_VERSION (2, 46, 0) + LOAD_DLL_FN (library, rsvg_handle_get_intrinsic_dimensions); + LOAD_DLL_FN (library, rsvg_handle_get_geometry_for_layer); +#endif LOAD_DLL_FN (library, rsvg_handle_get_dimensions); LOAD_DLL_FN (library, rsvg_handle_get_pixbuf); @@ -9521,6 +9717,10 @@ init_svg_functions (void) # undef g_clear_error # undef g_object_unref # undef g_type_init +# if LIBRSVG_CHECK_VERSION (2, 46, 0) +# undef rsvg_handle_get_intrinsic_dimensions +# undef rsvg_handle_get_geometry_for_layer +# endif # undef rsvg_handle_get_dimensions # undef rsvg_handle_get_pixbuf # if LIBRSVG_CHECK_VERSION (2, 32, 0) @@ -9533,6 +9733,7 @@ init_svg_functions (void) # undef rsvg_handle_set_base_uri # undef rsvg_handle_write # endif +# undef rsvg_handle_set_dpi_x_y # define gdk_pixbuf_get_bits_per_sample fn_gdk_pixbuf_get_bits_per_sample # define gdk_pixbuf_get_colorspace fn_gdk_pixbuf_get_colorspace @@ -9547,6 +9748,12 @@ init_svg_functions (void) # if ! GLIB_CHECK_VERSION (2, 36, 0) # define g_type_init fn_g_type_init # endif +# if LIBRSVG_CHECK_VERSION (2, 46, 0) +# define rsvg_handle_get_intrinsic_dimensions \ + fn_rsvg_handle_get_intrinsic_dimensions +# define rsvg_handle_get_geometry_for_layer \ + fn_rsvg_handle_get_geometry_for_layer +# endif # define rsvg_handle_get_dimensions fn_rsvg_handle_get_dimensions # define rsvg_handle_get_pixbuf fn_rsvg_handle_get_pixbuf # if LIBRSVG_CHECK_VERSION (2, 32, 0) @@ -9560,6 +9767,7 @@ init_svg_functions (void) # define rsvg_handle_set_base_uri fn_rsvg_handle_set_base_uri # define rsvg_handle_write fn_rsvg_handle_write # endif +# define rsvg_handle_set_dpi_x_y fn_rsvg_handle_set_dpi_x_y # endif /* !WINDOWSNT */ @@ -9570,10 +9778,11 @@ static bool svg_load (struct frame *f, struct image *img) { bool success_p = 0; - Lisp_Object file_name; + Lisp_Object file_name, base_uri; /* If IMG->spec specifies a file name, create a non-file spec from it. */ file_name = image_spec_value (img->spec, QCfile, NULL); + base_uri = image_spec_value (img->spec, QCbase_uri, NULL); if (STRINGP (file_name)) { int fd; @@ -9593,15 +9802,17 @@ svg_load (struct frame *f, struct image *img) return 0; } /* If the file was slurped into memory properly, parse it. */ + if (!STRINGP (base_uri)) + base_uri = file; success_p = svg_load_image (f, img, contents, size, - SSDATA (ENCODE_FILE (file))); + SSDATA (ENCODE_FILE (base_uri))); xfree (contents); } /* Else it's not a file, it's a Lisp object. Load the image from a Lisp object rather than a file. */ else { - Lisp_Object data, original_filename; + Lisp_Object data; data = image_spec_value (img->spec, QCdata, NULL); if (!STRINGP (data)) @@ -9609,15 +9820,56 @@ svg_load (struct frame *f, struct image *img) image_error ("Invalid image data `%s'", data); return 0; } - original_filename = BVAR (current_buffer, filename); + if (!STRINGP (base_uri)) + base_uri = BVAR (current_buffer, filename); success_p = svg_load_image (f, img, SSDATA (data), SBYTES (data), - (NILP (original_filename) ? NULL - : SSDATA (original_filename))); + (STRINGP (base_uri) ? + SSDATA (ENCODE_FILE (base_uri)) : NULL)); } return success_p; } +#if LIBRSVG_CHECK_VERSION (2, 46, 0) +static double +svg_css_length_to_pixels (RsvgLength length, double dpi) +{ + double value = length.length; + + switch (length.unit) + { + case RSVG_UNIT_PX: + /* Already a pixel value. */ + break; + case RSVG_UNIT_CM: + /* 2.54 cm in an inch. */ + value = dpi * value / 2.54; + break; + case RSVG_UNIT_MM: + /* 25.4 mm in an inch. */ + value = dpi * value / 25.4; + break; + case RSVG_UNIT_PT: + /* 72 points in an inch. */ + value = dpi * value / 72; + break; + case RSVG_UNIT_PC: + /* 6 picas in an inch. */ + value = dpi * value / 6; + break; + case RSVG_UNIT_IN: + value *= dpi; + break; + default: + /* Probably one of em, ex, or %. We can't know what the pixel + value is without more information. */ + value = 0; + } + + return value; +} +#endif + /* Load frame F and image IMG. CONTENTS contains the SVG XML data to be parsed, SIZE is its size, and FILENAME is the name of the SVG file being loaded. @@ -9630,13 +9882,15 @@ svg_load_image (struct frame *f, struct image *img, char *contents, ptrdiff_t size, char *filename) { RsvgHandle *rsvg_handle; - RsvgDimensionData dimension_data; + double viewbox_width, viewbox_height; GError *err = NULL; GdkPixbuf *pixbuf; int width; int height; const guint8 *pixels; int rowstride; + char *wrapped_contents = NULL; + ptrdiff_t wrapped_size; #if ! GLIB_CHECK_VERSION (2, 36, 0) /* g_type_init is a glib function that must be called prior to @@ -9644,6 +9898,8 @@ svg_load_image (struct frame *f, struct image *img, char *contents, g_type_init (); #endif + /* Parse the unmodified SVG data so we can get its initial size. */ + #if LIBRSVG_CHECK_VERSION (2, 32, 0) GInputStream *input_stream = g_memory_input_stream_new_from_data (contents, size, NULL); @@ -9651,18 +9907,26 @@ svg_load_image (struct frame *f, struct image *img, char *contents, rsvg_handle = rsvg_handle_new_from_stream_sync (input_stream, base_file, RSVG_HANDLE_FLAGS_NONE, NULL, &err); + if (base_file) g_object_unref (base_file); g_object_unref (input_stream); /* Check rsvg_handle too, to avoid librsvg 2.40.13 bug (Bug#36773#26). */ if (!rsvg_handle || err) goto rsvg_error; + + rsvg_handle_set_dpi_x_y (rsvg_handle, FRAME_DISPLAY_INFO (f)->resx, + FRAME_DISPLAY_INFO (f)->resy); #else /* Make a handle to a new rsvg object. */ rsvg_handle = rsvg_handle_new (); eassume (rsvg_handle); + rsvg_handle_set_dpi_x_y (rsvg_handle, FRAME_DISPLAY_INFO (f)->resx, + FRAME_DISPLAY_INFO (f)->resy); + /* Set base_uri for properly handling referenced images (via 'href'). + Can be explicitly specified using `:base_uri' image property. See rsvg bug 596114 - "image refs are relative to curdir, not .svg file" <https://gitlab.gnome.org/GNOME/librsvg/issues/33>. */ if (filename) @@ -9672,24 +9936,192 @@ svg_load_image (struct frame *f, struct image *img, char *contents, rsvg_handle_write (rsvg_handle, (unsigned char *) contents, size, &err); if (err) goto rsvg_error; - /* The parsing is complete, rsvg_handle is ready to used, close it - for further writes. */ + /* The parsing is complete, rsvg_handle is ready to be used, close + it for further writes. */ rsvg_handle_close (rsvg_handle, &err); if (err) goto rsvg_error; #endif - rsvg_handle_get_dimensions (rsvg_handle, &dimension_data); - if (! check_image_size (f, dimension_data.width, dimension_data.height)) + /* Get the image dimensions. */ +#if LIBRSVG_CHECK_VERSION (2, 46, 0) + RsvgRectangle zero_rect, viewbox, out_logical_rect; + + /* Try the instrinsic dimensions first. */ + gboolean has_width, has_height, has_viewbox; + RsvgLength iwidth, iheight; + double dpi = FRAME_DISPLAY_INFO (f)->resx; + + rsvg_handle_get_intrinsic_dimensions (rsvg_handle, + &has_width, &iwidth, + &has_height, &iheight, + &has_viewbox, &viewbox); + + if (has_width && has_height) + { + /* Success! We can use these values directly. */ + viewbox_width = svg_css_length_to_pixels (iwidth, dpi); + viewbox_height = svg_css_length_to_pixels (iheight, dpi); + } + else if (has_width && has_viewbox) + { + viewbox_width = svg_css_length_to_pixels (iwidth, dpi); + viewbox_height = svg_css_length_to_pixels (iwidth, dpi) + * viewbox.width / viewbox.height; + } + else if (has_height && has_viewbox) + { + viewbox_height = svg_css_length_to_pixels (iheight, dpi); + viewbox_width = svg_css_length_to_pixels (iheight, dpi) + * viewbox.height / viewbox.width; + } + else if (has_viewbox) + { + viewbox_width = viewbox.width; + viewbox_height = viewbox.height; + } + else + { + /* We haven't found a useable set of sizes, so try working out + the visible area. */ + rsvg_handle_get_geometry_for_layer (rsvg_handle, NULL, + &zero_rect, &viewbox, + &out_logical_rect, NULL); + viewbox_width = viewbox.x + viewbox.width; + viewbox_height = viewbox.y + viewbox.height; + } + + if (viewbox_width == 0 || viewbox_height == 0) +#endif + { + /* The functions used above to get the geometry of the visible + area of the SVG are only available in librsvg 2.46 and above, + so in certain circumstances this code path can result in some + parts of the SVG being cropped. */ + RsvgDimensionData dimension_data; + + rsvg_handle_get_dimensions (rsvg_handle, &dimension_data); + + viewbox_width = dimension_data.width; + viewbox_height = dimension_data.height; + } + + compute_image_size (viewbox_width, viewbox_height, img->spec, + &width, &height); + + if (! check_image_size (f, width, height)) { image_size_error (); goto rsvg_error; } + /* We are now done with the unmodified data. */ + g_object_unref (rsvg_handle); + + /* Wrap the SVG data in another SVG. This allows us to set the + width and height, as well as modify the foreground and background + colors. */ + { + Lisp_Object value; + unsigned long foreground = img->face_foreground; + unsigned long background = img->face_background; + + Lisp_Object encoded_contents + = Fbase64_encode_string (make_unibyte_string (contents, size), Qt); + + /* The wrapper sets the foreground color, width and height, and + viewBox must contain the dimensions of the original image. It + also draws a rectangle over the whole space, set to the + background color, before including the original image. This + acts to set the background color, instead of leaving it + transparent. */ + const char *wrapper = + "<svg xmlns:xlink=\"http://www.w3.org/1999/xlink\" " + "xmlns:xi=\"http://www.w3.org/2001/XInclude\" " + "style=\"color: #%06X; fill: currentColor;\" " + "width=\"%d\" height=\"%d\" preserveAspectRatio=\"none\" " + "viewBox=\"0 0 %f %f\">" + "<rect width=\"100%%\" height=\"100%%\" fill=\"#%06X\"/>" + "<xi:include href=\"data:image/svg+xml;base64,%s\"></xi:include>" + "</svg>"; + + /* FIXME: I've added 64 in the hope it will cover the size of the + width and height strings and things. */ + int buffer_size = SBYTES (encoded_contents) + strlen (wrapper) + 64; + + value = image_spec_value (img->spec, QCforeground, NULL); + if (!NILP (value)) + foreground = image_alloc_image_color (f, img, value, img->face_foreground); + value = image_spec_value (img->spec, QCbackground, NULL); + if (!NILP (value)) + { + background = image_alloc_image_color (f, img, value, img->face_background); + img->background = background; + img->background_valid = 1; + } + + wrapped_contents = xmalloc (buffer_size); + + if (!wrapped_contents + || buffer_size <= snprintf (wrapped_contents, buffer_size, wrapper, + foreground & 0xFFFFFF, width, height, + viewbox_width, viewbox_height, + background & 0xFFFFFF, + SSDATA (encoded_contents))) + goto rsvg_error; + + wrapped_size = strlen (wrapped_contents); + } + + /* Now we parse the wrapped version. */ + +#if LIBRSVG_CHECK_VERSION (2, 32, 0) + input_stream = g_memory_input_stream_new_from_data (wrapped_contents, wrapped_size, NULL); + base_file = filename ? g_file_new_for_path (filename) : NULL; + rsvg_handle = rsvg_handle_new_from_stream_sync (input_stream, base_file, + RSVG_HANDLE_FLAGS_NONE, + NULL, &err); + + if (base_file) + g_object_unref (base_file); + g_object_unref (input_stream); + + /* Check rsvg_handle too, to avoid librsvg 2.40.13 bug (Bug#36773#26). */ + if (!rsvg_handle || err) goto rsvg_error; + + rsvg_handle_set_dpi_x_y (rsvg_handle, FRAME_DISPLAY_INFO (f)->resx, + FRAME_DISPLAY_INFO (f)->resy); +#else + /* Make a handle to a new rsvg object. */ + rsvg_handle = rsvg_handle_new (); + eassume (rsvg_handle); + + rsvg_handle_set_dpi_x_y (rsvg_handle, FRAME_DISPLAY_INFO (f)->resx, + FRAME_DISPLAY_INFO (f)->resy); + + /* Set base_uri for properly handling referenced images (via 'href'). + Can be explicitly specified using `:base_uri' image property. + See rsvg bug 596114 - "image refs are relative to curdir, not .svg file" + <https://gitlab.gnome.org/GNOME/librsvg/issues/33>. */ + if (filename) + rsvg_handle_set_base_uri (rsvg_handle, filename); + + /* Parse the contents argument and fill in the rsvg_handle. */ + rsvg_handle_write (rsvg_handle, (unsigned char *) wrapped_contents, wrapped_size, &err); + if (err) goto rsvg_error; + + /* The parsing is complete, rsvg_handle is ready to used, close it + for further writes. */ + rsvg_handle_close (rsvg_handle, &err); + if (err) goto rsvg_error; +#endif + + /* We can now get a valid pixel buffer from the svg file, if all went ok. */ pixbuf = rsvg_handle_get_pixbuf (rsvg_handle); if (!pixbuf) goto rsvg_error; g_object_unref (rsvg_handle); + xfree (wrapped_contents); /* Extract some meta data from the svg handle. */ width = gdk_pixbuf_get_width (pixbuf); @@ -9714,25 +10146,6 @@ svg_load_image (struct frame *f, struct image *img, char *contents, init_color_table (); - /* Handle alpha channel by combining the image with a background - color. */ - Emacs_Color background; - Lisp_Object specified_bg = image_spec_value (img->spec, QCbackground, NULL); - if (!STRINGP (specified_bg) - || !FRAME_TERMINAL (f)->defined_color_hook (f, - SSDATA (specified_bg), - &background, - false, - false)) - FRAME_TERMINAL (f)->query_frame_background_color (f, &background); - - /* SVG pixmaps specify transparency in the last byte, so right - shift 8 bits to get rid of it, since emacs doesn't support - transparency. */ - background.red >>= 8; - background.green >>= 8; - background.blue >>= 8; - /* This loop handles opacity values, since Emacs assumes non-transparent images. Each pixel must be "flattened" by calculating the resulting color, given the transparency of the @@ -9744,16 +10157,11 @@ svg_load_image (struct frame *f, struct image *img, char *contents, int red = *pixels++; int green = *pixels++; int blue = *pixels++; - int opacity = *pixels++; - red = ((red * opacity) - + (background.red * ((1 << 8) - opacity))); - green = ((green * opacity) - + (background.green * ((1 << 8) - opacity))); - blue = ((blue * opacity) - + (background.blue * ((1 << 8) - opacity))); + /* Skip opacity. */ + pixels++; - PUT_PIXEL (ximg, x, y, lookup_rgb_color (f, red, green, blue)); + PUT_PIXEL (ximg, x, y, lookup_rgb_color (f, red << 8, green << 8, blue << 8)); } pixels += rowstride - 4 * width; @@ -9783,6 +10191,8 @@ svg_load_image (struct frame *f, struct image *img, char *contents, rsvg_error: if (rsvg_handle) g_object_unref (rsvg_handle); + if (wrapped_contents) + xfree (wrapped_contents); /* FIXME: Use error->message so the user knows what is the actual problem with the image. */ image_error ("Error parsing SVG image `%s'", img->spec); @@ -10081,7 +10491,7 @@ DEFUN ("lookup-image", Flookup_image, Slookup_image, 1, 1, 0, ptrdiff_t id = -1; if (valid_image_p (spec)) - id = lookup_image (SELECTED_FRAME (), spec); + id = lookup_image (SELECTED_FRAME (), spec, -1); debug_print (spec); return make_fixnum (id); @@ -10145,6 +10555,12 @@ initialize_image_type (struct image_type const *type) { #ifdef WINDOWSNT Lisp_Object typesym = builtin_lisp_symbol (type->type); + +# if HAVE_NATIVE_IMAGE_API + if (image_can_use_native_api (typesym)) + return true; +# endif + Lisp_Object tested = Fassq (typesym, Vlibrary_cache); /* If we failed to load the library before, don't try again. */ if (CONSP (tested)) @@ -10177,19 +10593,19 @@ static struct image_type const image_types[] = { SYMBOL_INDEX (Qsvg), svg_image_p, svg_load, image_clear_image, IMAGE_TYPE_INIT (init_svg_functions) }, #endif -#if defined HAVE_PNG || defined HAVE_NS +#if defined HAVE_PNG { SYMBOL_INDEX (Qpng), png_image_p, png_load, image_clear_image, IMAGE_TYPE_INIT (init_png_functions) }, #endif -#if defined HAVE_GIF || defined HAVE_NS +#if defined HAVE_GIF { SYMBOL_INDEX (Qgif), gif_image_p, gif_load, gif_clear_image, IMAGE_TYPE_INIT (init_gif_functions) }, #endif -#if defined HAVE_TIFF || defined HAVE_NS +#if defined HAVE_TIFF { SYMBOL_INDEX (Qtiff), tiff_image_p, tiff_load, image_clear_image, IMAGE_TYPE_INIT (init_tiff_functions) }, #endif -#if defined HAVE_JPEG || defined HAVE_NS +#if defined HAVE_JPEG { SYMBOL_INDEX (Qjpeg), jpeg_image_p, jpeg_load, image_clear_image, IMAGE_TYPE_INIT (init_jpeg_functions) }, #endif @@ -10201,12 +10617,23 @@ static struct image_type const image_types[] = { SYMBOL_INDEX (Qpbm), pbm_image_p, pbm_load, image_clear_image }, }; +#if HAVE_NATIVE_IMAGE_API +struct image_type native_image_type = + { SYMBOL_INDEX (Qnative_image), native_image_p, native_image_load, + image_clear_image }; +#endif + /* Look up image type TYPE, and return a pointer to its image_type structure. Return 0 if TYPE is not a known image type. */ static struct image_type const * lookup_image_type (Lisp_Object type) { +#if HAVE_NATIVE_IMAGE_API + if (image_can_use_native_api (type)) + return &native_image_type; +#endif + for (int i = 0; i < ARRAYELTS (image_types); i++) { struct image_type const *r = &image_types[i]; @@ -10328,22 +10755,22 @@ non-numeric, there is no explicit limit on the size of images. */); add_image_type (Qxpm); #endif -#if defined (HAVE_JPEG) || defined (HAVE_NS) +#if defined (HAVE_JPEG) || defined (HAVE_NATIVE_IMAGE_API) DEFSYM (Qjpeg, "jpeg"); add_image_type (Qjpeg); #endif -#if defined (HAVE_TIFF) || defined (HAVE_NS) +#if defined (HAVE_TIFF) || defined (HAVE_NATIVE_IMAGE_API) DEFSYM (Qtiff, "tiff"); add_image_type (Qtiff); #endif -#if defined (HAVE_GIF) || defined (HAVE_NS) +#if defined (HAVE_GIF) || defined (HAVE_NATIVE_IMAGE_API) DEFSYM (Qgif, "gif"); add_image_type (Qgif); #endif -#if defined (HAVE_PNG) || defined (HAVE_NS) +#if defined (HAVE_PNG) || defined (HAVE_NATIVE_IMAGE_API) DEFSYM (Qpng, "png"); add_image_type (Qpng); #endif @@ -10355,6 +10782,7 @@ non-numeric, there is no explicit limit on the size of images. */); #if defined (HAVE_RSVG) DEFSYM (Qsvg, "svg"); + DEFSYM (QCbase_uri, ":base-uri"); add_image_type (Qsvg); #ifdef HAVE_NTGUI /* Other libraries used directly by svg code. */ @@ -10367,6 +10795,14 @@ non-numeric, there is no explicit limit on the size of images. */); #endif /* HAVE_NTGUI */ #endif /* HAVE_RSVG */ +#if HAVE_NATIVE_IMAGE_API + DEFSYM (Qnative_image, "native-image"); +# ifdef HAVE_NTGUI + DEFSYM (Qgdiplus, "gdiplus"); + DEFSYM (Qshlwapi, "shlwapi"); +# endif +#endif + defsubr (&Sinit_image_library); #ifdef HAVE_IMAGEMAGICK defsubr (&Simagemagick_types); @@ -10376,6 +10812,7 @@ non-numeric, there is no explicit limit on the size of images. */); defsubr (&Simage_size); defsubr (&Simage_mask_p); defsubr (&Simage_metadata); + defsubr (&Simage_cache_size); #ifdef GLYPH_DEBUG defsubr (&Simagep); diff --git a/src/indent.c b/src/indent.c index bf539047026..0a6b460f753 100644 --- a/src/indent.c +++ b/src/indent.c @@ -285,9 +285,7 @@ skip_invisible (ptrdiff_t pos, ptrdiff_t *next_boundary_p, ptrdiff_t to, Lisp_Ob #define MULTIBYTE_BYTES_WIDTH(p, dp, bytes, width) \ do { \ - int ch; \ - \ - ch = STRING_CHAR_AND_LENGTH (p, bytes); \ + int ch = string_char_and_length (p, &(bytes)); \ if (BYTES_BY_CHAR_HEAD (*p) != bytes) \ width = bytes * 4; \ else \ @@ -526,9 +524,11 @@ check_display_width (ptrdiff_t pos, ptrdiff_t col, ptrdiff_t *endpos) comes first. Return the resulting buffer position and column in ENDPOS and GOALCOL. PREVCOL gets set to the column of the previous position (it's always - strictly smaller than the goal column). */ + strictly smaller than the goal column), and PREVPOS and PREVBPOS get set + to the corresponding buffer character and byte positions. */ static void -scan_for_column (ptrdiff_t *endpos, EMACS_INT *goalcol, ptrdiff_t *prevcol) +scan_for_column (ptrdiff_t *endpos, EMACS_INT *goalcol, + ptrdiff_t *prevpos, ptrdiff_t *prevbpos, ptrdiff_t *prevcol) { int tab_width = SANE_TAB_WIDTH (current_buffer); bool ctl_arrow = !NILP (BVAR (current_buffer, ctl_arrow)); @@ -542,10 +542,12 @@ scan_for_column (ptrdiff_t *endpos, EMACS_INT *goalcol, ptrdiff_t *prevcol) register ptrdiff_t col = 0, prev_col = 0; EMACS_INT goal = goalcol ? *goalcol : MOST_POSITIVE_FIXNUM; ptrdiff_t end = endpos ? *endpos : PT; - ptrdiff_t scan, scan_byte, next_boundary; + ptrdiff_t scan, scan_byte, next_boundary, prev_pos, prev_bpos; scan = find_newline (PT, PT_BYTE, BEGV, BEGV_BYTE, -1, NULL, &scan_byte, 1); next_boundary = scan; + prev_pos = scan; + prev_bpos = scan_byte; window = Fget_buffer_window (Fcurrent_buffer (), Qnil); w = ! NILP (window) ? XWINDOW (window) : NULL; @@ -578,6 +580,8 @@ scan_for_column (ptrdiff_t *endpos, EMACS_INT *goalcol, ptrdiff_t *prevcol) if (col >= goal) break; prev_col = col; + prev_pos = scan; + prev_bpos = scan_byte; { /* Check display property. */ ptrdiff_t endp; @@ -707,6 +711,10 @@ scan_for_column (ptrdiff_t *endpos, EMACS_INT *goalcol, ptrdiff_t *prevcol) *goalcol = col; if (endpos) *endpos = scan; + if (prevpos) + *prevpos = prev_pos; + if (prevbpos) + *prevbpos = prev_bpos; if (prevcol) *prevcol = prev_col; } @@ -722,7 +730,7 @@ current_column_1 (void) EMACS_INT col = MOST_POSITIVE_FIXNUM; ptrdiff_t opoint = PT; - scan_for_column (&opoint, &col, NULL); + scan_for_column (&opoint, &col, NULL, NULL, NULL); return col; } @@ -942,7 +950,7 @@ position_indentation (ptrdiff_t pos_byte) if (CHAR_HAS_CATEGORY (c, ' ')) { column++; - INC_POS (pos_byte); + pos_byte += next_char_len (pos_byte); p = BYTE_POS_ADDR (pos_byte); } else @@ -961,7 +969,7 @@ indented_beyond_p (ptrdiff_t pos, ptrdiff_t pos_byte, EMACS_INT column) { while (pos > BEGV && FETCH_BYTE (pos_byte) == '\n') { - DEC_BOTH (pos, pos_byte); + dec_both (&pos, &pos_byte); pos = find_newline (pos, pos_byte, BEGV, BEGV_BYTE, -1, NULL, &pos_byte, 0); } @@ -990,7 +998,7 @@ to reach COLUMN, add spaces/tabs to get there. The return value is the current column. */) (Lisp_Object column, Lisp_Object force) { - ptrdiff_t pos, prev_col; + ptrdiff_t pos, prev_pos, prev_bpos, prev_col; EMACS_INT col; EMACS_INT goal; @@ -999,7 +1007,7 @@ The return value is the current column. */) col = goal; pos = ZV; - scan_for_column (&pos, &col, &prev_col); + scan_for_column (&pos, &col, &prev_pos, &prev_bpos, &prev_col); SET_PT (pos); @@ -1008,18 +1016,16 @@ The return value is the current column. */) if (!NILP (force) && col > goal) { int c; - ptrdiff_t pos_byte = PT_BYTE; - DEC_POS (pos_byte); - c = FETCH_CHAR (pos_byte); - if (c == '\t' && prev_col < goal) + c = FETCH_CHAR (prev_bpos); + if (c == '\t' && prev_col < goal && prev_bpos < PT_BYTE) { ptrdiff_t goal_pt, goal_pt_byte; /* Insert spaces in front of the tab to reach GOAL. Do this first so that a marker at the end of the tab gets adjusted. */ - SET_PT_BOTH (PT - 1, PT_BYTE - 1); + SET_PT_BOTH (prev_pos, prev_bpos); Finsert_char (make_fixnum (' '), make_fixnum (goal - prev_col), Qt); /* Now delete the tab, and indent to COL. */ @@ -1605,7 +1611,7 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos, { pos = find_before_next_newline (pos, to, 1, &pos_byte); if (pos < to) - INC_BOTH (pos, pos_byte); + inc_both (&pos, &pos_byte); rarely_quit (++quit_count); } while (pos < to @@ -1618,7 +1624,7 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos, if (hpos >= width) hpos = width; } - DEC_BOTH (pos, pos_byte); + dec_both (&pos, &pos_byte); /* We have skipped the invis text, but not the newline after. */ } @@ -1820,8 +1826,8 @@ visible section of the buffer, and pass LINE and COL as TOPOS. */) static struct position val_vmotion; struct position * -vmotion (register ptrdiff_t from, register ptrdiff_t from_byte, - register EMACS_INT vtarget, struct window *w) +vmotion (ptrdiff_t from, ptrdiff_t from_byte, + EMACS_INT vtarget, struct window *w) { ptrdiff_t hscroll = w->hscroll; struct position pos; @@ -1862,7 +1868,7 @@ vmotion (register ptrdiff_t from, register ptrdiff_t from_byte, Lisp_Object propval; prevline = from; - DEC_BOTH (prevline, bytepos); + dec_both (&prevline, &bytepos); prevline = find_newline_no_quit (prevline, bytepos, -1, &bytepos); while (prevline > BEGV @@ -1875,7 +1881,7 @@ vmotion (register ptrdiff_t from, register ptrdiff_t from_byte, text_prop_object), TEXT_PROP_MEANS_INVISIBLE (propval)))) { - DEC_BOTH (prevline, bytepos); + dec_both (&prevline, &bytepos); prevline = find_newline_no_quit (prevline, bytepos, -1, &bytepos); } pos = *compute_motion (prevline, bytepos, 0, lmargin, 0, from, @@ -1925,7 +1931,7 @@ vmotion (register ptrdiff_t from, register ptrdiff_t from_byte, text_prop_object), TEXT_PROP_MEANS_INVISIBLE (propval)))) { - DEC_BOTH (prevline, bytepos); + dec_both (&prevline, &bytepos); prevline = find_newline_no_quit (prevline, bytepos, -1, &bytepos); } pos = *compute_motion (prevline, bytepos, 0, lmargin, 0, from, @@ -2091,15 +2097,15 @@ whether or not it is currently displayed in some window. */) struct it it; struct text_pos pt; struct window *w; - Lisp_Object lcols; + Lisp_Object lcols = Qnil; void *itdata = NULL; ptrdiff_t count = SPECPDL_INDEX (); /* Allow LINES to be of the form (HPOS . VPOS) aka (COLUMNS . LINES). */ - bool lcols_given = CONSP (lines); - if (lcols_given) + if (CONSP (lines)) { lcols = XCAR (lines); + CHECK_NUMBER (lcols); lines = XCDR (lines); } @@ -2279,9 +2285,9 @@ whether or not it is currently displayed in some window. */) overshoot_handled = 1; } - if (lcols_given) + if (!NILP (lcols)) to_x = - window_column_x (w, window, extract_float (lcols), lcols) + window_column_x (w, window, XFLOATINT (lcols), lcols) + lnum_pixel_width; if (nlines <= 0) { @@ -2332,7 +2338,7 @@ whether or not it is currently displayed in some window. */) /* Move to the goal column, if one was specified. If the window was originally hscrolled, the goal column is interpreted as an addition to the hscroll amount. */ - if (lcols_given) + if (!NILP (lcols)) { move_it_in_display_line (&it, ZV, first_x + to_x, MOVE_TO_X); /* If we find ourselves in the middle of an overlay string diff --git a/src/insdel.c b/src/insdel.c index 22bfd30c255..e38b091f542 100644 --- a/src/insdel.c +++ b/src/insdel.c @@ -382,10 +382,10 @@ count_bytes (ptrdiff_t pos, ptrdiff_t bytepos, ptrdiff_t endpos) if (pos <= endpos) for ( ; pos < endpos; pos++) - INC_POS (bytepos); + bytepos += next_char_len (bytepos); else for ( ; pos > endpos; pos--) - DEC_POS (bytepos); + bytepos -= prev_char_len (bytepos); return bytepos; } @@ -626,8 +626,7 @@ copy_text (const unsigned char *from_addr, unsigned char *to_addr, while (bytes_left > 0) { - int thislen, c; - c = STRING_CHAR_AND_LENGTH (from_addr, thislen); + int thislen, c = string_char_and_length (from_addr, &thislen); if (! ASCII_CHAR_P (c)) c &= 0xFF; *to_addr++ = c; @@ -715,7 +714,7 @@ insert_char (int c) insert ((char *) str, len); } -/* Insert the NUL-terminated string S before point. */ +/* Insert the null-terminated string S before point. */ void insert_string (const char *s) diff --git a/src/intervals.c b/src/intervals.c index d102d809737..f88a41f2549 100644 --- a/src/intervals.c +++ b/src/intervals.c @@ -117,10 +117,11 @@ create_root_interval (Lisp_Object parent) /* Make the interval TARGET have exactly the properties of SOURCE. */ void -copy_properties (register INTERVAL source, register INTERVAL target) +copy_properties (INTERVAL source, INTERVAL target) { if (DEFAULT_INTERVAL_P (source) && DEFAULT_INTERVAL_P (target)) return; + eassume (source && target); COPY_INTERVAL_CACHE (source, target); set_interval_plist (target, Fcopy_sequence (source->plist)); @@ -298,7 +299,7 @@ rotate_right (INTERVAL A) set_interval_parent (c, A); /* A's total length is decreased by the length of B and its left child. */ - A->total_length -= B->total_length - TOTAL_LENGTH (c); + A->total_length -= TOTAL_LENGTH (B) - TOTAL_LENGTH0 (c); eassert (TOTAL_LENGTH (A) > 0); eassert (LENGTH (A) > 0); @@ -349,7 +350,7 @@ rotate_left (INTERVAL A) set_interval_parent (c, A); /* A's total length is decreased by the length of B and its right child. */ - A->total_length -= B->total_length - TOTAL_LENGTH (c); + A->total_length -= TOTAL_LENGTH (B) - TOTAL_LENGTH0 (c); eassert (TOTAL_LENGTH (A) > 0); eassert (LENGTH (A) > 0); @@ -723,13 +724,13 @@ previous_interval (register INTERVAL interval) i->position - LEFT_TOTAL_LENGTH (i) \ - LENGTH (INTERVAL_PARENT (i)) -/* Find the interval containing POS, given some non-NULL INTERVAL in +/* Find the interval containing POS, given some interval I in the same tree. Note that we update interval->position in each interval we traverse, assuming it is already correctly set for the argument I. We don't assume that any other interval already has a correctly set ->position. */ INTERVAL -update_interval (register INTERVAL i, ptrdiff_t pos) +update_interval (INTERVAL i, ptrdiff_t pos) { if (!i) return NULL; @@ -739,7 +740,7 @@ update_interval (register INTERVAL i, ptrdiff_t pos) if (pos < i->position) { /* Move left. */ - if (pos >= i->position - TOTAL_LENGTH (i->left)) + if (pos >= i->position - LEFT_TOTAL_LENGTH (i)) { i->left->position = i->position - TOTAL_LENGTH (i->left) + LEFT_TOTAL_LENGTH (i->left); @@ -757,7 +758,7 @@ update_interval (register INTERVAL i, ptrdiff_t pos) else if (pos >= INTERVAL_LAST_POS (i)) { /* Move right. */ - if (pos < INTERVAL_LAST_POS (i) + TOTAL_LENGTH (i->right)) + if (pos < INTERVAL_LAST_POS (i) + RIGHT_TOTAL_LENGTH (i)) { i->right->position = INTERVAL_LAST_POS (i) + LEFT_TOTAL_LENGTH (i->right); diff --git a/src/intervals.h b/src/intervals.h index 1b2c5196e91..c1b19345d2e 100644 --- a/src/intervals.h +++ b/src/intervals.h @@ -96,24 +96,27 @@ struct interval /* True if this interval has both left and right children. */ #define BOTH_KIDS_P(i) ((i)->left != NULL && (i)->right != NULL) -/* The total size of all text represented by this interval and all its - children in the tree. This is zero if the interval is null. */ -#define TOTAL_LENGTH(i) ((i) == NULL ? 0 : (i)->total_length) +/* The total size of all text represented by the nonnull interval I + and all its children in the tree. */ +#define TOTAL_LENGTH(i) ((i)->total_length) + +/* Likewise, but also defined to be zero if I is null. */ +#define TOTAL_LENGTH0(i) ((i) ? TOTAL_LENGTH (i) : 0) /* The size of text represented by this interval alone. */ -#define LENGTH(i) ((i)->total_length \ - - TOTAL_LENGTH ((i)->right) \ - - TOTAL_LENGTH ((i)->left)) +#define LENGTH(i) (TOTAL_LENGTH (i) \ + - RIGHT_TOTAL_LENGTH (i) \ + - LEFT_TOTAL_LENGTH (i)) /* The position of the character just past the end of I. Note that the position cache i->position must be valid for this to work. */ #define INTERVAL_LAST_POS(i) ((i)->position + LENGTH (i)) /* The total size of the left subtree of this interval. */ -#define LEFT_TOTAL_LENGTH(i) ((i)->left ? (i)->left->total_length : 0) +#define LEFT_TOTAL_LENGTH(i) TOTAL_LENGTH0 ((i)->left) /* The total size of the right subtree of this interval. */ -#define RIGHT_TOTAL_LENGTH(i) ((i)->right ? (i)->right->total_length : 0) +#define RIGHT_TOTAL_LENGTH(i) TOTAL_LENGTH0 ((i)->right) /* These macros are for dealing with the interval properties. */ @@ -234,7 +237,7 @@ set_interval_plist (INTERVAL i, Lisp_Object plist) /* Declared in alloc.c. */ -extern INTERVAL make_interval (void); +extern INTERVAL make_interval (void) ATTRIBUTE_RETURNS_NONNULL; /* Declared in intervals.c. */ @@ -246,7 +249,8 @@ extern void traverse_intervals (INTERVAL, ptrdiff_t, Lisp_Object); extern void traverse_intervals_noorder (INTERVAL, void (*) (INTERVAL, void *), void *); -extern INTERVAL split_interval_right (INTERVAL, ptrdiff_t); +extern INTERVAL split_interval_right (INTERVAL, ptrdiff_t) + ATTRIBUTE_RETURNS_NONNULL; extern INTERVAL split_interval_left (INTERVAL, ptrdiff_t); extern INTERVAL find_interval (INTERVAL, ptrdiff_t); extern INTERVAL next_interval (INTERVAL); diff --git a/src/json.c b/src/json.c index 0181780935d..2901a20811a 100644 --- a/src/json.c +++ b/src/json.c @@ -279,10 +279,10 @@ json_release_object (void *object) } /* Signal an error if OBJECT is not a string, or if OBJECT contains - embedded NUL characters. */ + embedded null characters. */ static void -check_string_without_embedded_nuls (Lisp_Object object) +check_string_without_embedded_nulls (Lisp_Object object) { CHECK_STRING (object); CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) == NULL, @@ -368,11 +368,11 @@ lisp_to_json_toplevel_1 (Lisp_Object lisp, CHECK_STRING (key); Lisp_Object ekey = json_encode (key); /* We can't specify the length, so the string must be - NUL-terminated. */ - check_string_without_embedded_nuls (ekey); + null-terminated. */ + check_string_without_embedded_nulls (ekey); const char *key_str = SSDATA (ekey); /* Reject duplicate keys. These are possible if the hash - table test is not `equal'. */ + table test is not `equal'. */ if (json_object_get (json, key_str) != NULL) wrong_type_argument (Qjson_value_p, lisp); int status @@ -419,8 +419,8 @@ lisp_to_json_toplevel_1 (Lisp_Object lisp, CHECK_SYMBOL (key_symbol); Lisp_Object key = SYMBOL_NAME (key_symbol); /* We can't specify the length, so the string must be - NUL-terminated. */ - check_string_without_embedded_nuls (key); + null-terminated. */ + check_string_without_embedded_nulls (key); key_str = SSDATA (key); /* In plists, ensure leading ":" in keys is stripped. It will be reconstructed later in `json_to_lisp'.*/ @@ -479,9 +479,7 @@ lisp_to_json (Lisp_Object lisp, struct json_configuration *conf) { intmax_t low = TYPE_MINIMUM (json_int_t); intmax_t high = TYPE_MAXIMUM (json_int_t); - intmax_t value; - if (! (integer_to_intmax (lisp, &value) && low <= value && value <= high)) - args_out_of_range_3 (lisp, make_int (low), make_int (high)); + intmax_t value = check_integer_range (lisp, low, high); return json_check (json_integer (value)); } else if (FLOATP (lisp)) @@ -565,7 +563,7 @@ false values, t, numbers, strings, or other vectors hashtables, alists or plists. t will be converted to the JSON true value. Vectors will be converted to JSON arrays, whereas hashtables, alists and plists are converted to JSON objects. Hashtable keys must be strings without -embedded NUL characters and must be unique within each object. Alist +embedded null characters and must be unique within each object. Alist and plist keys must be symbols; if a key is duplicate, the first instance is used. @@ -978,7 +976,7 @@ usage: (json-parse-string STRING &rest ARGS) */) Lisp_Object string = args[0]; CHECK_STRING (string); Lisp_Object encoded = json_encode (string); - check_string_without_embedded_nuls (encoded); + check_string_without_embedded_nulls (encoded); struct json_configuration conf = {json_object_hashtable, json_array_array, QCnull, QCfalse}; json_parse_args (nargs - 1, args + 1, &conf, true); @@ -1123,7 +1121,6 @@ syms_of_json (void) DEFSYM (Qstring_without_embedded_nulls_p, "string-without-embedded-nulls-p"); DEFSYM (Qjson_value_p, "json-value-p"); - DEFSYM (Qutf_8_string_p, "utf-8-string-p"); DEFSYM (Qjson_error, "json-error"); DEFSYM (Qjson_out_of_memory, "json-out-of-memory"); diff --git a/src/keyboard.c b/src/keyboard.c index d142d4c1979..9ee4c4f6d68 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -103,7 +103,8 @@ static KBOARD *all_kboards; /* True in the single-kboard state, false in the any-kboard state. */ static bool single_kboard; -#define NUM_RECENT_KEYS (300) +/* Minimum allowed size of the recent_keys vector. */ +#define MIN_NUM_RECENT_KEYS (100) /* Index for storing next element into recent_keys. */ static int recent_keys_index; @@ -111,7 +112,10 @@ static int recent_keys_index; /* Total number of elements stored into recent_keys. */ static int total_keys; -/* This vector holds the last NUM_RECENT_KEYS keystrokes. */ +/* Size of the recent_keys vector. */ +static int lossage_limit = 3 * MIN_NUM_RECENT_KEYS; + +/* This vector holds the last lossage_limit keystrokes. */ static Lisp_Object recent_keys; /* Vector holding the key sequence that invoked the current command. @@ -281,7 +285,7 @@ bool input_pending; with the input rate, but if it can keep up just enough that there's no input_pending when we begin the command, then redisplay is not skipped which results in better feedback to the user. */ -static bool input_was_pending; +bool input_was_pending; /* Circular buffer for pre-read keyboard input. */ @@ -380,11 +384,13 @@ next_kbd_event (union buffered_input_event *ptr) return ptr == kbd_buffer + KBD_BUFFER_SIZE - 1 ? kbd_buffer : ptr + 1; } +#ifdef HAVE_X11 static union buffered_input_event * prev_kbd_event (union buffered_input_event *ptr) { return ptr == kbd_buffer ? kbd_buffer + KBD_BUFFER_SIZE - 1 : ptr - 1; } +#endif /* Like EVENT_START, but assume EVENT is an event. This pacifies gcc -Wnull-dereference, which might otherwise @@ -737,9 +743,6 @@ void force_auto_save_soon (void) { last_auto_save = - auto_save_interval - 1; - /* FIXME: What's the relationship between forcing auto-save and adding - a buffer-switch event? */ - record_asynch_buffer_change (); } #endif @@ -1421,10 +1424,10 @@ command_loop_1 (void) /* Execute the command. */ { - total_keys += total_keys < NUM_RECENT_KEYS; + total_keys += total_keys < lossage_limit; ASET (recent_keys, recent_keys_index, Fcons (Qnil, cmd)); - if (++recent_keys_index >= NUM_RECENT_KEYS) + if (++recent_keys_index >= lossage_limit) recent_keys_index = 0; } Vthis_command = cmd; @@ -2036,7 +2039,7 @@ help_echo_substitute_command_keys (Lisp_Object help) help))) return help; - return Fsubstitute_command_keys (help); + return call1 (Qsubstitute_command_keys, help); } /* Display the help-echo property of the character after the mouse pointer. @@ -2118,7 +2121,7 @@ read_char_help_form_unwind (void) Lisp_Object window_config = XCAR (help_form_saved_window_configs); help_form_saved_window_configs = XCDR (help_form_saved_window_configs); if (!NILP (window_config)) - Fset_window_configuration (window_config); + Fset_window_configuration (window_config, Qnil); } #define STOP_POLLING \ @@ -2279,7 +2282,7 @@ read_decoded_event_from_main_queue (struct timespec *end_time, eassert (coding->carryover_bytes == 0); n = 0; while (n < coding->produced_char) - events[n++] = make_fixnum (STRING_CHAR_ADVANCE (p)); + events[n++] = make_fixnum (string_char_advance (&p)); } } } @@ -2901,6 +2904,12 @@ read_char (int commandflag, Lisp_Object map, example banishing the mouse under mouse-avoidance-mode. */ timer_resume_idle (); +#ifdef HAVE_NS + if (CONSP (c) + && (EQ (XCAR (c), intern ("ns-unput-working-text")))) + input_was_pending = input_pending; +#endif + if (current_buffer != prev_buffer) { /* The command may have changed the keymaps. Pretend there @@ -2921,13 +2930,11 @@ read_char (int commandflag, Lisp_Object map, goto exit; if ((STRINGP (KVAR (current_kboard, Vkeyboard_translate_table)) - && UNSIGNED_CMP (XFIXNAT (c), <, - SCHARS (KVAR (current_kboard, - Vkeyboard_translate_table)))) + && XFIXNAT (c) < SCHARS (KVAR (current_kboard, + Vkeyboard_translate_table))) || (VECTORP (KVAR (current_kboard, Vkeyboard_translate_table)) - && UNSIGNED_CMP (XFIXNAT (c), <, - ASIZE (KVAR (current_kboard, - Vkeyboard_translate_table)))) + && XFIXNAT (c) < ASIZE (KVAR (current_kboard, + Vkeyboard_translate_table))) || (CHAR_TABLE_P (KVAR (current_kboard, Vkeyboard_translate_table)) && CHARACTERP (c))) { @@ -3244,15 +3251,15 @@ record_char (Lisp_Object c) int ix1, ix2, ix3; if ((ix1 = recent_keys_index - 1) < 0) - ix1 = NUM_RECENT_KEYS - 1; + ix1 = lossage_limit - 1; ev1 = AREF (recent_keys, ix1); if ((ix2 = ix1 - 1) < 0) - ix2 = NUM_RECENT_KEYS - 1; + ix2 = lossage_limit - 1; ev2 = AREF (recent_keys, ix2); if ((ix3 = ix2 - 1) < 0) - ix3 = NUM_RECENT_KEYS - 1; + ix3 = lossage_limit - 1; ev3 = AREF (recent_keys, ix3); if (EQ (XCAR (c), Qhelp_echo)) @@ -3303,12 +3310,12 @@ record_char (Lisp_Object c) { if (!recorded) { - total_keys += total_keys < NUM_RECENT_KEYS; + total_keys += total_keys < lossage_limit; ASET (recent_keys, recent_keys_index, /* Copy the event, in case it gets modified by side-effect by some remapping function (bug#30955). */ CONSP (c) ? Fcopy_sequence (c) : c); - if (++recent_keys_index >= NUM_RECENT_KEYS) + if (++recent_keys_index >= lossage_limit) recent_keys_index = 0; } else if (recorded < 0) @@ -3322,10 +3329,10 @@ record_char (Lisp_Object c) while (recorded++ < 0 && total_keys > 0) { - if (total_keys < NUM_RECENT_KEYS) + if (total_keys < lossage_limit) total_keys--; if (--recent_keys_index < 0) - recent_keys_index = NUM_RECENT_KEYS - 1; + recent_keys_index = lossage_limit - 1; ASET (recent_keys, recent_keys_index, Qnil); } } @@ -3423,8 +3430,7 @@ readable_events (int flags) && event->ie.part == scroll_bar_handle && event->ie.modifiers == 0) #endif - && !((flags & READABLE_EVENTS_FILTER_EVENTS) - && event->kind == BUFFER_SWITCH_EVENT)) + ) return 1; event = next_kbd_event (event); } @@ -3575,12 +3581,6 @@ kbd_buffer_store_buffered_event (union buffered_input_event *event, return; } } - /* Don't insert two BUFFER_SWITCH_EVENT's in a row. - Just ignore the second one. */ - else if (event->kind == BUFFER_SWITCH_EVENT - && kbd_fetch_ptr != kbd_store_ptr - && prev_kbd_event (kbd_store_ptr)->kind == BUFFER_SWITCH_EVENT) - return; /* Don't let the very last slot in the buffer become full, since that would make the two pointers equal, @@ -3614,7 +3614,6 @@ kbd_buffer_store_buffered_event (union buffered_input_event *event, case ICONIFY_EVENT: ignore_event = Qiconify_frame; break; case DEICONIFY_EVENT: ignore_event = Qmake_frame_visible; break; case SELECTION_REQUEST_EVENT: ignore_event = Qselection_request; break; - case BUFFER_SWITCH_EVENT: ignore_event = Qbuffer_switch; break; default: ignore_event = Qnil; break; } @@ -3648,7 +3647,8 @@ kbd_buffer_unget_event (struct selection_input_event *event) #define INPUT_EVENT_POS_MAX \ ((ptrdiff_t) min (PTRDIFF_MAX, min (TYPE_MAXIMUM (Time) / 2, \ MOST_POSITIVE_FIXNUM))) -#define INPUT_EVENT_POS_MIN (-1 - INPUT_EVENT_POS_MAX) +#define INPUT_EVENT_POS_MIN (PTRDIFF_MIN < -INPUT_EVENT_POS_MAX \ + ? -1 - INPUT_EVENT_POS_MAX : PTRDIFF_MIN) /* Return a Time that encodes position POS. POS must be in range. */ @@ -3728,9 +3728,6 @@ discard_mouse_events (void) if (sp->kind == MOUSE_CLICK_EVENT || sp->kind == WHEEL_EVENT || sp->kind == HORIZ_WHEEL_EVENT -#ifdef HAVE_GPM - || sp->kind == GPM_CLICK_EVENT -#endif || sp->kind == SCROLL_BAR_CLICK_EVENT || sp->kind == HORIZONTAL_SCROLL_BAR_CLICK_EVENT) { @@ -3956,7 +3953,6 @@ kbd_buffer_get_event (KBOARD **kbp, #ifdef HAVE_XWIDGETS case XWIDGET_EVENT: #endif - case BUFFER_SWITCH_EVENT: case SAVE_SESSION_EVENT: case NO_EVENT: case HELP_EVENT: @@ -5336,14 +5332,6 @@ make_lispy_event (struct input_event *event) return list2 (Qmove_frame, list1 (event->frame_or_window)); #endif - case BUFFER_SWITCH_EVENT: - { - /* The value doesn't matter here; only the type is tested. */ - Lisp_Object obj; - XSETBUFFER (obj, current_buffer); - return obj; - } - /* Just discard these, by returning nil. With MULTI_KBOARD, these events are used as placeholders when we need to randomly delete events from the queue. @@ -5534,9 +5522,6 @@ make_lispy_event (struct input_event *event) /* A mouse click. Figure out where it is, decide whether it's a press, click or drag, and build the appropriate structure. */ case MOUSE_CLICK_EVENT: -#ifdef HAVE_GPM - case GPM_CLICK_EVENT: -#endif #ifndef USE_TOOLKIT_SCROLL_BARS case SCROLL_BAR_CLICK_EVENT: case HORIZONTAL_SCROLL_BAR_CLICK_EVENT: @@ -5551,11 +5536,7 @@ make_lispy_event (struct input_event *event) position = Qnil; /* Build the position as appropriate for this mouse click. */ - if (event->kind == MOUSE_CLICK_EVENT -#ifdef HAVE_GPM - || event->kind == GPM_CLICK_EVENT -#endif - ) + if (event->kind == MOUSE_CLICK_EVENT) { struct frame *f = XFRAME (event->frame_or_window); int row, column; @@ -5689,7 +5670,7 @@ make_lispy_event (struct input_event *event) ignore_mouse_drag_p = false; } - /* Now we're releasing a button - check the co-ordinates to + /* Now we're releasing a button - check the coordinates to see if this was a click or a drag. */ else if (event->modifiers & up_modifier) { @@ -5993,24 +5974,14 @@ make_lispy_event (struct input_event *event) return list2 (Qselect_window, list1 (event->frame_or_window)); case TAB_BAR_EVENT: - if (EQ (event->arg, event->frame_or_window)) - /* This is the prefix key. We translate this to - `(tab_bar)' because the code in keyboard.c for tab bar - events, which we use, relies on this. */ - return list1 (Qtab_bar); - else if (SYMBOLP (event->arg)) - return apply_modifiers (event->modifiers, event->arg); - return event->arg; - case TOOL_BAR_EVENT: - if (EQ (event->arg, event->frame_or_window)) - /* This is the prefix key. We translate this to - `(tool_bar)' because the code in keyboard.c for tool bar - events, which we use, relies on this. */ - return list1 (Qtool_bar); - else if (SYMBOLP (event->arg)) - return apply_modifiers (event->modifiers, event->arg); - return event->arg; + { + Lisp_Object res = event->arg; + Lisp_Object location + = event->kind == TAB_BAR_EVENT ? Qtab_bar : Qtool_bar; + if (SYMBOLP (res)) res = apply_modifiers (event->modifiers, res); + return list2 (res, list2 (event->frame_or_window, location)); + } case USER_SIGNAL_EVENT: /* A user signal. */ @@ -6237,7 +6208,7 @@ parse_modifiers_uncached (Lisp_Object symbol, ptrdiff_t *modifier_end) static Lisp_Object apply_modifiers_uncached (int modifiers, char *base, int base_len, int base_len_byte) { - /* Since BASE could contain NULs, we can't use intern here; we have + /* Since BASE could contain nulls, we can't use intern here; we have to use Fintern, which expects a genuine Lisp_String, and keeps a reference to it. */ char new_mods[sizeof "A-C-H-M-S-s-up-down-drag-double-triple-"]; @@ -6647,7 +6618,7 @@ has the same base event type and all the specified modifiers. */) DEFUN ("internal-handle-focus-in", Finternal_handle_focus_in, Sinternal_handle_focus_in, 1, 1, 0, doc: /* Internally handle focus-in events. -This function potentially generates an artifical switch-frame event. */) +This function potentially generates an artificial switch-frame event. */) (Lisp_Object event) { Lisp_Object frame; @@ -6817,41 +6788,6 @@ get_input_pending (int flags) return input_pending; } -/* Put a BUFFER_SWITCH_EVENT in the buffer - so that read_key_sequence will notice the new current buffer. */ - -void -record_asynch_buffer_change (void) -{ - /* We don't need a buffer-switch event unless Emacs is waiting for input. - The purpose of the event is to make read_key_sequence look up the - keymaps again. If we aren't in read_key_sequence, we don't need one, - and the event could cause trouble by messing up (input-pending-p). - Note: Fwaiting_for_user_input_p always returns nil when async - subprocesses aren't supported. */ - if (!NILP (Fwaiting_for_user_input_p ())) - { - struct input_event event; - - EVENT_INIT (event); - event.kind = BUFFER_SWITCH_EVENT; - event.frame_or_window = Qnil; - event.arg = Qnil; - - /* Make sure no interrupt happens while storing the event. */ -#ifdef USABLE_SIGIO - if (interrupt_input) - kbd_buffer_store_event (&event); - else -#endif - { - stop_polling (); - kbd_buffer_store_event (&event); - start_polling (); - } - } -} - /* Read any terminal input already buffered up by the system into the kbd_buffer, but do not wait. @@ -7007,12 +6943,8 @@ tty_read_avail_input (struct terminal *terminal, if (gpm_tty == tty) { Gpm_Event event; - struct input_event gpm_hold_quit; int gpm, fd = gpm_fd; - EVENT_INIT (gpm_hold_quit); - gpm_hold_quit.kind = NO_EVENT; - /* gpm==1 if event received. gpm==0 if the GPM daemon has closed the connection, in which case Gpm_GetEvent closes gpm_fd and clears it to -1, which is why @@ -7020,13 +6952,11 @@ tty_read_avail_input (struct terminal *terminal, select masks. gpm==-1 if a protocol error or EWOULDBLOCK; the latter is normal. */ while (gpm = Gpm_GetEvent (&event), gpm == 1) { - nread += handle_one_term_event (tty, &event, &gpm_hold_quit); + nread += handle_one_term_event (tty, &event); } if (gpm == 0) /* Presumably the GPM daemon has closed the connection. */ close_gpm (fd); - if (gpm_hold_quit.kind != NO_EVENT) - kbd_buffer_store_event (&gpm_hold_quit); if (nread) return nread; } @@ -7858,7 +7788,7 @@ parse_menu_item (Lisp_Object item, int inmenubar) /* The previous code preferred :key-sequence to :keys, so we preserve this behavior. */ if (STRINGP (keyeq) && !CONSP (keyhint)) - keyeq = concat2 (space_space, Fsubstitute_command_keys (keyeq)); + keyeq = concat2 (space_space, call1 (Qsubstitute_command_keys, keyeq)); else { Lisp_Object prefix = keyeq; @@ -8309,7 +8239,7 @@ append_tab_bar_item (void) /* Append entries from tab_bar_item_properties to the end of tab_bar_items_vector. */ vcopy (tab_bar_items_vector, ntab_bar_items, - XVECTOR (tab_bar_item_properties)->contents, TAB_BAR_ITEM_NSLOTS); + xvector_contents (tab_bar_item_properties), TAB_BAR_ITEM_NSLOTS); ntab_bar_items += TAB_BAR_ITEM_NSLOTS; } @@ -8786,7 +8716,7 @@ append_tool_bar_item (void) /* Append entries from tool_bar_item_properties to the end of tool_bar_items_vector. */ vcopy (tool_bar_items_vector, ntool_bar_items, - XVECTOR (tool_bar_item_properties)->contents, TOOL_BAR_ITEM_NSLOTS); + xvector_contents (tool_bar_item_properties), TOOL_BAR_ITEM_NSLOTS); ntool_bar_items += TOOL_BAR_ITEM_NSLOTS; } @@ -10417,6 +10347,64 @@ If CHECK-TIMERS is non-nil, timers that are ready to run will do so. */) ? Qt : Qnil); } +/* Reallocate recent_keys copying the recorded keystrokes + in the right order. */ +static void +update_recent_keys (int new_size, int kept_keys) +{ + int osize = ASIZE (recent_keys); + eassert (recent_keys_index < osize); + eassert (kept_keys <= min (osize, new_size)); + Lisp_Object v = make_nil_vector (new_size); + int i, idx; + for (i = 0; i < kept_keys; ++i) + { + idx = recent_keys_index - kept_keys + i; + while (idx < 0) + idx += osize; + ASET (v, i, AREF (recent_keys, idx)); + } + recent_keys = v; + total_keys = kept_keys; + recent_keys_index = total_keys % new_size; + lossage_limit = new_size; + +} + +DEFUN ("lossage-size", Flossage_size, Slossage_size, 0, 1, + "(list (read-number \"new-size: \" (lossage-size)))", + doc: /* Return or set the maximum number of keystrokes to save. +If called with a non-nil ARG, set the limit to ARG and return it. +Otherwise, return the current limit. + +The saved keystrokes are shown by `view-lossage'. */) + (Lisp_Object arg) +{ + if (NILP(arg)) + return make_fixnum (lossage_limit); + + if (!FIXNATP (arg)) + user_error ("Value must be a positive integer"); + int osize = ASIZE (recent_keys); + eassert (lossage_limit == osize); + int min_size = MIN_NUM_RECENT_KEYS; + int new_size = XFIXNAT (arg); + + if (new_size == osize) + return make_fixnum (lossage_limit); + + if (new_size < min_size) + { + AUTO_STRING (fmt, "Value must be >= %d"); + Fsignal (Quser_error, list1 (CALLN (Fformat, fmt, make_fixnum (min_size)))); + } + + int kept_keys = new_size > osize ? total_keys : min (new_size, total_keys); + update_recent_keys (new_size, kept_keys); + + return make_fixnum (lossage_limit); +} + DEFUN ("recent-keys", Frecent_keys, Srecent_keys, 0, 1, 0, doc: /* Return vector of last few events, not counting those from keyboard macros. If INCLUDE-CMDS is non-nil, include the commands that were run, @@ -10426,21 +10414,21 @@ represented as pseudo-events of the form (nil . COMMAND). */) bool cmds = !NILP (include_cmds); if (!total_keys - || (cmds && total_keys < NUM_RECENT_KEYS)) + || (cmds && total_keys < lossage_limit)) return Fvector (total_keys, XVECTOR (recent_keys)->contents); else { Lisp_Object es = Qnil; - int i = (total_keys < NUM_RECENT_KEYS + int i = (total_keys < lossage_limit ? 0 : recent_keys_index); - eassert (recent_keys_index < NUM_RECENT_KEYS); + eassert (recent_keys_index < lossage_limit); do { Lisp_Object e = AREF (recent_keys, i); if (cmds || !CONSP (e) || !NILP (XCAR (e))) es = Fcons (e, es); - if (++i >= NUM_RECENT_KEYS) + if (++i >= lossage_limit) i = 0; } while (i != recent_keys_index); es = Fnreverse (es); @@ -10473,9 +10461,8 @@ Internal use only. */) this_command_key_count = 0; this_single_command_key_start = 0; - int charidx = 0, byteidx = 0; - int key0; - FETCH_STRING_CHAR_ADVANCE (key0, keys, charidx, byteidx); + ptrdiff_t charidx = 0, byteidx = 0; + int key0 = fetch_string_char_advance (keys, &charidx, &byteidx); if (CHAR_BYTE8_P (key0)) key0 = CHAR_TO_BYTE8 (key0); @@ -10487,8 +10474,7 @@ Internal use only. */) add_command_key (make_fixnum (key0)); for (ptrdiff_t i = 1; i < SCHARS (keys); i++) { - int key_i; - FETCH_STRING_CHAR_ADVANCE (key_i, keys, charidx, byteidx); + int key_i = fetch_string_char_advance (keys, &charidx, &byteidx); if (CHAR_BYTE8_P (key_i)) key_i = CHAR_TO_BYTE8 (key_i); add_command_key (make_fixnum (key_i)); @@ -10513,8 +10499,6 @@ DEFUN ("this-single-command-keys", Fthis_single_command_keys, doc: /* Return the key sequence that invoked this command. More generally, it returns the last key sequence read, either by the command loop or by `read-key-sequence'. -Unlike `this-command-keys', this function's value -does not include prefix arguments. The value is always a vector. */) (void) { @@ -11537,8 +11521,6 @@ syms_of_keyboard (void) /* Menu and tool bar item parts. */ DEFSYM (Qmenu_enable, "menu-enable"); - DEFSYM (Qbuffer_switch, "buffer-switch"); - #ifdef HAVE_NTGUI DEFSYM (Qlanguage_change, "language-change"); DEFSYM (Qend_session, "end-session"); @@ -11695,7 +11677,7 @@ syms_of_keyboard (void) staticpro (&modifier_symbols); } - recent_keys = make_nil_vector (NUM_RECENT_KEYS); + recent_keys = make_nil_vector (lossage_limit); staticpro (&recent_keys); this_command_keys = make_nil_vector (40); @@ -11745,6 +11727,7 @@ syms_of_keyboard (void) defsubr (&Srecursive_edit); defsubr (&Sinternal_track_mouse); defsubr (&Sinput_pending_p); + defsubr (&Slossage_size); defsubr (&Srecent_keys); defsubr (&Sthis_command_keys); defsubr (&Sthis_command_keys_vector); @@ -11848,6 +11831,13 @@ will be in `last-command' during the following command. */); doc: /* This is like `this-command', except that commands should never modify it. */); Vreal_this_command = Qnil; + DEFSYM (Qcurrent_minibuffer_command, "current-minibuffer-command"); + DEFVAR_LISP ("current-minibuffer-command", Vcurrent_minibuffer_command, + doc: /* This is like `this-command', but bound recursively. +Code running from (for instance) a minibuffer hook can check this variable +to see what command invoked the current minibuffer. */); + Vcurrent_minibuffer_command = Qnil; + DEFVAR_LISP ("this-command-keys-shift-translated", Vthis_command_keys_shift_translated, doc: /* Non-nil if the key sequence activating this command was shift-translated. @@ -12052,7 +12042,8 @@ See also `pre-command-hook'. */); DEFVAR_LISP ("menu-bar-final-items", Vmenu_bar_final_items, doc: /* List of menu bar items to move to the end of the menu bar. -The elements of the list are event types that may have menu bar bindings. */); +The elements of the list are event types that may have menu bar +bindings. The order of this list controls the order of the items. */); Vmenu_bar_final_items = Qnil; DEFVAR_LISP ("tab-bar-separator-image-expression", Vtab_bar_separator_image_expression, @@ -12397,12 +12388,6 @@ syms_of_keyboard_for_pdumper (void) void keys_of_keyboard (void) { - initial_define_key (global_map, Ctl ('Z'), "suspend-emacs"); - initial_define_key (control_x_map, Ctl ('Z'), "suspend-emacs"); - initial_define_key (meta_map, Ctl ('C'), "exit-recursive-edit"); - initial_define_key (global_map, Ctl (']'), "abort-recursive-edit"); - initial_define_key (meta_map, 'x', "execute-extended-command"); - initial_define_lispy_key (Vspecial_event_map, "delete-frame", "handle-delete-frame"); #ifdef HAVE_NTGUI @@ -12484,13 +12469,11 @@ keys_of_keyboard (void) void mark_kboards (void) { - KBOARD *kb; - Lisp_Object *p; - for (kb = all_kboards; kb; kb = kb->next_kboard) + for (KBOARD *kb = all_kboards; kb; kb = kb->next_kboard) { if (kb->kbd_macro_buffer) - for (p = kb->kbd_macro_buffer; p < kb->kbd_macro_ptr; p++) - mark_object (*p); + mark_objects (kb->kbd_macro_buffer, + kb->kbd_macro_ptr - kb->kbd_macro_buffer); mark_object (KVAR (kb, Voverriding_terminal_local_map)); mark_object (KVAR (kb, Vlast_command)); mark_object (KVAR (kb, Vreal_last_command)); diff --git a/src/keyboard.h b/src/keyboard.h index 180e6c703d7..8bdffaa2bff 100644 --- a/src/keyboard.h +++ b/src/keyboard.h @@ -432,7 +432,7 @@ extern int parse_solitary_modifier (Lisp_Object symbol); extern Lisp_Object real_this_command; extern int quit_char; - +extern bool input_was_pending; extern unsigned int timers_run; extern bool menu_separator_name_p (const char *); @@ -446,7 +446,6 @@ extern void push_kboard (struct kboard *); extern void push_frame_kboard (struct frame *); extern void pop_kboard (void); extern void temporarily_switch_to_single_kboard (struct frame *); -extern void record_asynch_buffer_change (void); extern void input_poll_signal (int); extern void start_polling (void); extern void stop_polling (void); diff --git a/src/keymap.c b/src/keymap.c index 120071ff291..782931fadff 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -59,22 +59,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ Lisp_Object current_global_map; /* Current global keymap. */ -Lisp_Object global_map; /* Default global key bindings. */ - -Lisp_Object meta_map; /* The keymap used for globally bound - ESC-prefixed default commands. */ - -Lisp_Object control_x_map; /* The keymap used for globally bound - C-x-prefixed default commands. */ - - /* The keymap used by the minibuf for local - bindings when spaces are allowed in the - minibuf. */ - - /* The keymap used by the minibuf for local - bindings when spaces are not encouraged - in the minibuf. */ - /* Alist of elements like (DEL . "\d"). */ static Lisp_Object exclude_keys; @@ -89,11 +73,6 @@ static Lisp_Object where_is_cache_keymaps; static Lisp_Object store_in_keymap (Lisp_Object, Lisp_Object, Lisp_Object); static Lisp_Object define_as_prefix (Lisp_Object, Lisp_Object); -static void describe_command (Lisp_Object, Lisp_Object); -static void describe_translation (Lisp_Object, Lisp_Object); -static void describe_map (Lisp_Object, Lisp_Object, - void (*) (Lisp_Object, Lisp_Object), - bool, Lisp_Object, Lisp_Object *, bool, bool); static void describe_vector (Lisp_Object, Lisp_Object, Lisp_Object, void (*) (Lisp_Object, Lisp_Object), bool, Lisp_Object, Lisp_Object, bool, bool); @@ -145,19 +124,6 @@ in case you use it as a menu with `x-popup-menu'. */) return list1 (Qkeymap); } -/* This function is used for installing the standard key bindings - at initialization time. - - For example: - - initial_define_key (control_x_map, Ctl('X'), "exchange-point-and-mark"); */ - -void -initial_define_key (Lisp_Object keymap, int key, const char *defname) -{ - store_in_keymap (keymap, make_fixnum (key), intern_c_string (defname)); -} - void initial_define_lispy_key (Lisp_Object keymap, const char *keyname, const char *defname) { @@ -223,15 +189,13 @@ when reading a key-sequence to be looked-up in this keymap. */) Lisp_Object get_keymap (Lisp_Object object, bool error_if_not_keymap, bool autoload) { - Lisp_Object tem; - autoload_retry: if (NILP (object)) goto end; if (CONSP (object) && EQ (XCAR (object), Qkeymap)) return object; - tem = indirect_function (object); + Lisp_Object tem = indirect_function (object); if (CONSP (tem)) { if (EQ (XCAR (tem), Qkeymap)) @@ -270,12 +234,10 @@ get_keymap (Lisp_Object object, bool error_if_not_keymap, bool autoload) static Lisp_Object keymap_parent (Lisp_Object keymap, bool autoload) { - Lisp_Object list; - keymap = get_keymap (keymap, 1, autoload); /* Skip past the initial element `keymap'. */ - list = XCDR (keymap); + Lisp_Object list = XCDR (keymap); for (; CONSP (list); list = XCDR (list)) { /* See if there is another `keymap'. */ @@ -311,8 +273,6 @@ DEFUN ("set-keymap-parent", Fset_keymap_parent, Sset_keymap_parent, 2, 2, 0, Return PARENT. PARENT should be nil or another keymap. */) (Lisp_Object keymap, Lisp_Object parent) { - Lisp_Object list, prev; - /* Flush any reverse-map cache. */ where_is_cache = Qnil; where_is_cache_keymaps = Qt; @@ -328,10 +288,10 @@ Return PARENT. PARENT should be nil or another keymap. */) } /* Skip past the initial element `keymap'. */ - prev = keymap; + Lisp_Object prev = keymap; while (1) { - list = XCDR (prev); + Lisp_Object list = XCDR (prev); /* If there is a parent keymap here, replace it. If we came to the end, add the parent in PREV. */ if (!CONSP (list) || KEYMAPP (list)) @@ -679,6 +639,23 @@ usage: (map-keymap FUNCTION KEYMAP) */) return Qnil; } +DEFUN ("keymap--get-keyelt", Fkeymap__get_keyelt, Skeymap__get_keyelt, 2, 2, 0, + doc: /* Given OBJECT which was found in a slot in a keymap, +trace indirect definitions to get the actual definition of that slot. +An indirect definition is a list of the form +(KEYMAP . INDEX), where KEYMAP is a keymap or a symbol defined as one +and INDEX is the object to look up in KEYMAP to yield the definition. + +Also if OBJECT has a menu string as the first element, +remove that. Also remove a menu help string as second element. + +If AUTOLOAD, load autoloadable keymaps +that are referred to with indirection. */) + (Lisp_Object object, Lisp_Object autoload) +{ + return get_keyelt (object, NILP (autoload) ? false : true); +} + /* Given OBJECT which was found in a slot in a keymap, trace indirect definitions to get the actual definition of that slot. An indirect definition is a list of the form @@ -793,14 +770,10 @@ store_in_keymap (Lisp_Object keymap, register Lisp_Object idx, Lisp_Object def) towards the front of the alist and character lookups in dense keymaps will remain fast. Otherwise, this just points at the front of the keymap. */ - Lisp_Object insertion_point; - - insertion_point = keymap; + Lisp_Object insertion_point = keymap; for (tail = XCDR (keymap); CONSP (tail); tail = XCDR (tail)) { - Lisp_Object elt; - - elt = XCAR (tail); + Lisp_Object elt = XCAR (tail); if (VECTORP (elt)) { if (FIXNATP (idx) && XFIXNAT (idx) < ASIZE (elt)) @@ -1006,9 +979,8 @@ copy_keymap_1 (Lisp_Object keymap, int depth) } else if (VECTORP (elt)) { - int i; elt = Fcopy_sequence (elt); - for (i = 0; i < ASIZE (elt); i++) + for (int i = 0; i < ASIZE (elt); i++) ASET (elt, i, copy_keymap_item (AREF (elt, i), depth + 1)); } else if (CONSP (elt)) @@ -1085,24 +1057,16 @@ binding is altered. If there is no binding for KEY, the new pair binding KEY to DEF is added at the front of KEYMAP. */) (Lisp_Object keymap, Lisp_Object key, Lisp_Object def) { - ptrdiff_t idx; - Lisp_Object c; - Lisp_Object cmd; - bool metized = 0; - int meta_bit; - ptrdiff_t length; + bool metized = false; keymap = get_keymap (keymap, 1, 1); - length = CHECK_VECTOR_OR_STRING (key); + ptrdiff_t length = CHECK_VECTOR_OR_STRING (key); if (length == 0) return Qnil; - if (SYMBOLP (def) && !EQ (Vdefine_key_rebound_commands, Qt)) - Vdefine_key_rebound_commands = Fcons (def, Vdefine_key_rebound_commands); - - meta_bit = (VECTORP (key) || (STRINGP (key) && STRING_MULTIBYTE (key)) - ? meta_modifier : 0x80); + int meta_bit = (VECTORP (key) || (STRINGP (key) && STRING_MULTIBYTE (key)) + ? meta_modifier : 0x80); if (VECTORP (def) && ASIZE (def) > 0 && CONSP (AREF (def, 0))) { /* DEF is apparently an XEmacs-style keyboard macro. */ @@ -1118,10 +1082,10 @@ binding KEY to DEF is added at the front of KEYMAP. */) def = tmp; } - idx = 0; + ptrdiff_t idx = 0; while (1) { - c = Faref (key, make_fixnum (idx)); + Lisp_Object c = Faref (key, make_fixnum (idx)); if (CONSP (c)) { @@ -1141,14 +1105,14 @@ binding KEY to DEF is added at the front of KEYMAP. */) && !metized) { c = meta_prefix_char; - metized = 1; + metized = true; } else { if (FIXNUMP (c)) XSETINT (c, XFIXNUM (c) & ~meta_bit); - metized = 0; + metized = false; idx++; } @@ -1161,7 +1125,7 @@ binding KEY to DEF is added at the front of KEYMAP. */) if (idx == length) return store_in_keymap (keymap, c, def); - cmd = access_keymap (keymap, c, 0, 1, 1); + Lisp_Object cmd = access_keymap (keymap, c, 0, 1, 1); /* If this key is undefined, make it a prefix. */ if (NILP (cmd)) @@ -1238,23 +1202,19 @@ third optional argument ACCEPT-DEFAULT is non-nil, `lookup-key' will recognize the default bindings, just as `read-key-sequence' does. */) (Lisp_Object keymap, Lisp_Object key, Lisp_Object accept_default) { - ptrdiff_t idx; - Lisp_Object cmd; - Lisp_Object c; - ptrdiff_t length; bool t_ok = !NILP (accept_default); if (!CONSP (keymap) && !NILP (keymap)) keymap = get_keymap (keymap, true, true); - length = CHECK_VECTOR_OR_STRING (key); + ptrdiff_t length = CHECK_VECTOR_OR_STRING (key); if (length == 0) return keymap; - idx = 0; + ptrdiff_t idx = 0; while (1) { - c = Faref (key, make_fixnum (idx++)); + Lisp_Object c = Faref (key, make_fixnum (idx++)); if (CONSP (c) && lucid_event_type_list_p (c)) c = Fevent_convert_list (c); @@ -1268,7 +1228,7 @@ recognize the default bindings, just as `read-key-sequence' does. */) if (!FIXNUMP (c) && !SYMBOLP (c) && !CONSP (c) && !STRINGP (c)) message_with_string ("Key sequence contains invalid event %s", c, 1); - cmd = access_keymap (keymap, c, t_ok, 0, 1); + Lisp_Object cmd = access_keymap (keymap, c, t_ok, 0, 1); if (idx == length) return cmd; @@ -1287,9 +1247,7 @@ recognize the default bindings, just as `read-key-sequence' does. */) static Lisp_Object define_as_prefix (Lisp_Object keymap, Lisp_Object c) { - Lisp_Object cmd; - - cmd = Fmake_sparse_keymap (Qnil); + Lisp_Object cmd = Fmake_sparse_keymap (Qnil); store_in_keymap (keymap, c, cmd); return cmd; @@ -1310,15 +1268,12 @@ append_key (Lisp_Object key_sequence, Lisp_Object key) static void silly_event_symbol_error (Lisp_Object c) { - Lisp_Object parsed, base, name, assoc; - int modifiers; - - parsed = parse_modifiers (c); - modifiers = XFIXNAT (XCAR (XCDR (parsed))); - base = XCAR (parsed); - name = Fsymbol_name (base); + Lisp_Object parsed = parse_modifiers (c); + int modifiers = XFIXNAT (XCAR (XCDR (parsed))); + Lisp_Object base = XCAR (parsed); + Lisp_Object name = Fsymbol_name (base); /* This alist includes elements such as ("RET" . "\\r"). */ - assoc = Fassoc (name, exclude_keys, Qnil); + Lisp_Object assoc = Fassoc (name, exclude_keys, Qnil); if (! NILP (assoc)) { @@ -1379,16 +1334,14 @@ ptrdiff_t current_minor_maps (Lisp_Object **modeptr, Lisp_Object **mapptr) { ptrdiff_t i = 0; - int list_number = 0; Lisp_Object alist, assoc, var, val; - Lisp_Object emulation_alists; + Lisp_Object emulation_alists = Vemulation_mode_map_alists; Lisp_Object lists[2]; - emulation_alists = Vemulation_mode_map_alists; lists[0] = Vminor_mode_overriding_map_alist; lists[1] = Vminor_mode_map_alist; - for (list_number = 0; list_number < 2; list_number++) + for (int list_number = 0; list_number < 2; list_number++) { if (CONSP (emulation_alists)) { @@ -1514,9 +1467,7 @@ like in the respective argument of `key-binding'. */) if (CONSP (position)) { - Lisp_Object window; - - window = POSN_WINDOW (position); + Lisp_Object window = POSN_WINDOW (position); if (WINDOWP (window) && BUFFERP (XWINDOW (window)->contents) @@ -1545,7 +1496,7 @@ like in the respective argument of `key-binding'. */) if (NILP (XCDR (keymaps))) { Lisp_Object *maps; - int nmaps, i; + int nmaps; ptrdiff_t pt = click_position (position); /* This usually returns the buffer's local map, but that can be overridden by a `local-map' property. */ @@ -1563,9 +1514,7 @@ like in the respective argument of `key-binding'. */) if (POSN_INBUFFER_P (position)) { - Lisp_Object pos; - - pos = POSN_BUFFER_POSN (position); + Lisp_Object pos = POSN_BUFFER_POSN (position); if (FIXNUMP (pos) && XFIXNUM (pos) >= BEG && XFIXNUM (pos) <= Z) { @@ -1585,15 +1534,13 @@ like in the respective argument of `key-binding'. */) if (CONSP (string) && STRINGP (XCAR (string))) { - Lisp_Object pos, map; - - pos = XCDR (string); + Lisp_Object pos = XCDR (string); string = XCAR (string); if (FIXNUMP (pos) && XFIXNUM (pos) >= 0 && XFIXNUM (pos) < SCHARS (string)) { - map = Fget_text_property (pos, Qlocal_map, string); + Lisp_Object map = Fget_text_property (pos, Qlocal_map, string); if (!NILP (map)) local_map = map; @@ -1611,7 +1558,7 @@ like in the respective argument of `key-binding'. */) /* Now put all the minor mode keymaps on the list. */ nmaps = current_minor_maps (0, &maps); - for (i = --nmaps; i >= 0; i--) + for (int i = --nmaps; i >= 0; i--) if (!NILP (maps[i])) keymaps = Fcons (maps[i], keymaps); @@ -1655,18 +1602,15 @@ specified buffer position instead of point are used. */) (Lisp_Object key, Lisp_Object accept_default, Lisp_Object no_remap, Lisp_Object position) { - Lisp_Object value; - if (NILP (position) && VECTORP (key)) { - Lisp_Object event; - if (ASIZE (key) == 0) return Qnil; /* mouse events may have a symbolic prefix indicating the scrollbar or mode line */ - event = AREF (key, SYMBOLP (AREF (key, 0)) && ASIZE (key) > 1 ? 1 : 0); + Lisp_Object event + = AREF (key, SYMBOLP (AREF (key, 0)) && ASIZE (key) > 1 ? 1 : 0); /* We are not interested in locations without event data */ @@ -1678,8 +1622,8 @@ specified buffer position instead of point are used. } } - value = Flookup_key (Fcurrent_active_maps (Qt, position), - key, accept_default); + Lisp_Object value = Flookup_key (Fcurrent_active_maps (Qt, position), + key, accept_default); if (NILP (value) || FIXNUMP (value)) return Qnil; @@ -1699,40 +1643,6 @@ specified buffer position instead of point are used. /* GC is possible in this function if it autoloads a keymap. */ -DEFUN ("local-key-binding", Flocal_key_binding, Slocal_key_binding, 1, 2, 0, - doc: /* Return the binding for command KEYS in current local keymap only. -KEYS is a string or vector, a sequence of keystrokes. -The binding is probably a symbol with a function definition. - -If optional argument ACCEPT-DEFAULT is non-nil, recognize default -bindings; see the description of `lookup-key' for more details about this. */) - (Lisp_Object keys, Lisp_Object accept_default) -{ - register Lisp_Object map; - map = BVAR (current_buffer, keymap); - if (NILP (map)) - return Qnil; - return Flookup_key (map, keys, accept_default); -} - -/* GC is possible in this function if it autoloads a keymap. */ - -DEFUN ("global-key-binding", Fglobal_key_binding, Sglobal_key_binding, 1, 2, 0, - doc: /* Return the binding for command KEYS in current global keymap only. -KEYS is a string or vector, a sequence of keystrokes. -The binding is probably a symbol with a function definition. -This function's return values are the same as those of `lookup-key' -\(which see). - -If optional argument ACCEPT-DEFAULT is non-nil, recognize default -bindings; see the description of `lookup-key' for more details about this. */) - (Lisp_Object keys, Lisp_Object accept_default) -{ - return Flookup_key (current_global_map, keys, accept_default); -} - -/* GC is possible in this function if it autoloads a keymap. */ - DEFUN ("minor-mode-key-binding", Fminor_mode_key_binding, Sminor_mode_key_binding, 1, 2, 0, doc: /* Find the visible minor mode bindings of KEY. Return an alist of pairs (MODENAME . BINDING), where MODENAME is @@ -1748,15 +1658,11 @@ bindings; see the description of `lookup-key' for more details about this. */) (Lisp_Object key, Lisp_Object accept_default) { Lisp_Object *modes, *maps; - int nmaps; - Lisp_Object binding; - int i, j; + int nmaps = current_minor_maps (&modes, &maps); + Lisp_Object binding = Qnil; - nmaps = current_minor_maps (&modes, &maps); - - binding = Qnil; - - for (i = j = 0; i < nmaps; i++) + int j; + for (int i = j = 0; i < nmaps; i++) if (!NILP (maps[i]) && !NILP (binding = Flookup_key (maps[i], key, accept_default)) && !FIXNUMP (binding)) @@ -1770,29 +1676,6 @@ bindings; see the description of `lookup-key' for more details about this. */) return Flist (j, maps); } -DEFUN ("define-prefix-command", Fdefine_prefix_command, Sdefine_prefix_command, 1, 3, 0, - doc: /* Define COMMAND as a prefix command. COMMAND should be a symbol. -A new sparse keymap is stored as COMMAND's function definition and its -value. -This prepares COMMAND for use as a prefix key's binding. -If a second optional argument MAPVAR is given, it should be a symbol. -The map is then stored as MAPVAR's value instead of as COMMAND's -value; but COMMAND is still defined as a function. -The third optional argument NAME, if given, supplies a menu name -string for the map. This is required to use the keymap as a menu. -This function returns COMMAND. */) - (Lisp_Object command, Lisp_Object mapvar, Lisp_Object name) -{ - Lisp_Object map; - map = Fmake_sparse_keymap (name); - Ffset (command, map); - if (!NILP (mapvar)) - Fset (mapvar, map); - else - Fset (command, map); - return command; -} - DEFUN ("use-global-map", Fuse_global_map, Suse_global_map, 1, 1, 0, doc: /* Select KEYMAP as the global keymap. */) (Lisp_Object keymap) @@ -1930,8 +1813,7 @@ then the value includes only maps for prefixes that start with PREFIX. */) { /* If a prefix was specified, start with the keymap (if any) for that prefix, so we don't waste time considering other prefixes. */ - Lisp_Object tem; - tem = Flookup_key (keymap, prefix, Qt); + Lisp_Object tem = Flookup_key (keymap, prefix, Qt); /* Flookup_key may give us nil, or a number, if the prefix is not defined in this particular map. It might even give us a list that isn't a keymap. */ @@ -1949,8 +1831,7 @@ then the value includes only maps for prefixes that start with PREFIX. */) for (ptrdiff_t i = 0; i < SCHARS (prefix); ) { ptrdiff_t i_before = i; - int c; - FETCH_STRING_CHAR_ADVANCE (c, prefix, i, i_byte); + int c = fetch_string_char_advance (prefix, &i, &i_byte); if (SINGLE_BYTE_CHAR_P (c) && (c & 0200)) c ^= 0200 | meta_modifier; ASET (copy, i_before, make_fixnum (c)); @@ -2000,29 +1881,22 @@ then the value includes only maps for prefixes that start with PREFIX. */) DEFUN ("key-description", Fkey_description, Skey_description, 1, 2, 0, doc: /* Return a pretty description of key-sequence KEYS. Optional arg PREFIX is the sequence of keys leading up to KEYS. -For example, [?\C-x ?l] is converted into the string \"C-x l\". +For example, [?\\C-x ?l] is converted into the string \"C-x l\". For an approximate inverse of this, see `kbd'. */) (Lisp_Object keys, Lisp_Object prefix) { ptrdiff_t len = 0; - EMACS_INT i; - ptrdiff_t i_byte; Lisp_Object *args; - EMACS_INT size = XFIXNUM (Flength (keys)); - Lisp_Object list; + EMACS_INT nkeys = XFIXNUM (Flength (keys)); + EMACS_INT nprefix = XFIXNUM (Flength (prefix)); Lisp_Object sep = build_string (" "); - Lisp_Object key; - Lisp_Object result; - bool add_meta = 0; + bool add_meta = false; USE_SAFE_ALLOCA; - if (!NILP (prefix)) - size += XFIXNUM (Flength (prefix)); - /* This has one extra element at the end that we don't pass to Fconcat. */ - EMACS_INT size4; - if (INT_MULTIPLY_WRAPV (size, 4, &size4)) + ptrdiff_t size4; + if (INT_MULTIPLY_WRAPV (nkeys + nprefix, 4, &size4)) memory_full (SIZE_MAX); SAFE_ALLOCA_LISP (args, size4); @@ -2030,82 +1904,76 @@ For an approximate inverse of this, see `kbd'. */) (mapconcat 'single-key-description keys " ") but we shouldn't use mapconcat because it can do GC. */ - next_list: - if (!NILP (prefix)) - list = prefix, prefix = Qnil; - else if (!NILP (keys)) - list = keys, keys = Qnil; - else + Lisp_Object lists[2] = { prefix, keys }; + ptrdiff_t listlens[2] = { nprefix, nkeys }; + for (int li = 0; li < ARRAYELTS (lists); li++) { - if (add_meta) - { - args[len] = Fsingle_key_description (meta_prefix_char, Qnil); - result = Fconcat (len + 1, args); - } - else if (len == 0) - result = empty_unibyte_string; - else - result = Fconcat (len - 1, args); - SAFE_FREE (); - return result; - } + Lisp_Object list = lists[li]; + ptrdiff_t listlen = listlens[li], i_byte = 0; - if (STRINGP (list)) - size = SCHARS (list); - else if (VECTORP (list)) - size = ASIZE (list); - else if (CONSP (list)) - size = list_length (list); - else - wrong_type_argument (Qarrayp, list); - - i = i_byte = 0; - - while (i < size) - { - if (STRINGP (list)) - { - int c; - FETCH_STRING_CHAR_ADVANCE (c, list, i, i_byte); - if (SINGLE_BYTE_CHAR_P (c) && (c & 0200)) - c ^= 0200 | meta_modifier; - XSETFASTINT (key, c); - } - else if (VECTORP (list)) - { - key = AREF (list, i); i++; - } - else - { - key = XCAR (list); - list = XCDR (list); - i++; - } + if (! (NILP (list) || STRINGP (list) || VECTORP (list) || CONSP (list))) + wrong_type_argument (Qarrayp, list); - if (add_meta) + for (ptrdiff_t i = 0; i < listlen; ) { - if (!FIXNUMP (key) - || EQ (key, meta_prefix_char) - || (XFIXNUM (key) & meta_modifier)) + Lisp_Object key; + if (STRINGP (list)) { - args[len++] = Fsingle_key_description (meta_prefix_char, Qnil); - args[len++] = sep; - if (EQ (key, meta_prefix_char)) - continue; + int c = fetch_string_char_advance (list, &i, &i_byte); + if (SINGLE_BYTE_CHAR_P (c) && (c & 0200)) + c ^= 0200 | meta_modifier; + key = make_fixnum (c); + } + else if (VECTORP (list)) + { + key = AREF (list, i); + i++; } else - XSETINT (key, XFIXNUM (key) | meta_modifier); - add_meta = 0; - } - else if (EQ (key, meta_prefix_char)) - { - add_meta = 1; - continue; + { + key = XCAR (list); + list = XCDR (list); + i++; + } + + if (add_meta) + { + if (!FIXNUMP (key) + || EQ (key, meta_prefix_char) + || (XFIXNUM (key) & meta_modifier)) + { + args[len++] = Fsingle_key_description (meta_prefix_char, + Qnil); + args[len++] = sep; + if (EQ (key, meta_prefix_char)) + continue; + } + else + key = make_fixnum (XFIXNUM (key) | meta_modifier); + add_meta = false; + } + else if (EQ (key, meta_prefix_char)) + { + add_meta = true; + continue; + } + args[len++] = Fsingle_key_description (key, Qnil); + args[len++] = sep; } - args[len++] = Fsingle_key_description (key, Qnil); - args[len++] = sep; } - goto next_list; + + Lisp_Object result; + if (add_meta) + { + args[len] = Fsingle_key_description (meta_prefix_char, Qnil); + result = Fconcat (len + 1, args); + } + else if (len == 0) + result = empty_unibyte_string; + else + result = Fconcat (len - 1, args); + SAFE_FREE (); + return result; } @@ -2262,11 +2130,21 @@ See `text-char-description' for describing character codes. */) { if (NILP (no_angles)) { - Lisp_Object result; - char *buffer = SAFE_ALLOCA (sizeof "<>" - + SBYTES (SYMBOL_NAME (key))); - esprintf (buffer, "<%s>", SDATA (SYMBOL_NAME (key))); - result = build_string (buffer); + Lisp_Object namestr = SYMBOL_NAME (key); + const char *sym = SSDATA (namestr); + ptrdiff_t len = SBYTES (namestr); + /* Find the extent of the modifier prefix, like "C-M-". */ + int i = 0; + while (i < len - 3 && sym[i + 1] == '-' && strchr ("CMSsHA", sym[i])) + i += 2; + /* First I bytes of SYM are modifiers; put <> around the rest. */ + char *buffer = SAFE_ALLOCA (len + 3); + memcpy (buffer, sym, i); + buffer[i] = '<'; + memcpy (buffer + i + 1, sym + i, len - i); + buffer [len + 1] = '>'; + buffer [len + 2] = '\0'; + Lisp_Object result = build_string (buffer); SAFE_FREE (); return result; } @@ -2282,12 +2160,6 @@ See `text-char-description' for describing character codes. */) static char * push_text_char_description (register unsigned int c, register char *p) { - if (c >= 0200) - { - *p++ = 'M'; - *p++ = '-'; - c -= 0200; - } if (c < 040) { *p++ = '^'; @@ -2316,23 +2188,22 @@ characters into "C-char", and uses the 2**27 bit for Meta. See Info node `(elisp)Describing Characters' for examples. */) (Lisp_Object character) { - /* Currently MAX_MULTIBYTE_LENGTH is 4 (< 6). */ - char str[6]; - int c; - CHECK_CHARACTER (character); - c = XFIXNUM (character); + int c = XFIXNUM (character); if (!ASCII_CHAR_P (c)) { + char str[MAX_MULTIBYTE_LENGTH]; int len = CHAR_STRING (c, (unsigned char *) str); return make_multibyte_string (str, 1, len); } - - *push_text_char_description (c & 0377, str) = 0; - - return build_string (str); + else + { + char desc[4]; + int len = push_text_char_description (c, desc) - desc; + return make_string (desc, len); + } } static int where_is_preferred_modifier; @@ -2415,7 +2286,6 @@ where_is_internal (Lisp_Object definition, Lisp_Object keymaps, bool noindirect, bool nomenus) { Lisp_Object maps = Qnil; - Lisp_Object found; struct where_is_internal_data data; /* Only important use of caching is for the menubar @@ -2441,7 +2311,7 @@ where_is_internal (Lisp_Object definition, Lisp_Object keymaps, we're filling it up. */ where_is_cache = Qnil; - found = keymaps; + Lisp_Object found = keymaps; while (CONSP (found)) { maps = @@ -2550,8 +2420,7 @@ The optional 5th arg NO-REMAP alters how command remapping is handled: /* Whether or not we're handling remapped sequences. This is needed because remapping is not done recursively by Fcommand_remapping: you can't remap a remapped command. */ - bool remapped = 0; - Lisp_Object tem = Qnil; + bool remapped = false; /* Refresh the C version of the modifier preference. */ where_is_preferred_modifier @@ -2565,7 +2434,7 @@ The optional 5th arg NO-REMAP alters how command remapping is handled: else keymaps = Fcurrent_active_maps (Qnil, Qnil); - tem = Fcommand_remapping (definition, Qnil, keymaps); + Lisp_Object tem = Fcommand_remapping (definition, Qnil, keymaps); /* If `definition' is remapped to `tem', then OT1H no key will run that command (since they will run `tem' instead), so we should return nil; but OTOH all keys bound to `definition' (or to `tem') @@ -2607,7 +2476,7 @@ The optional 5th arg NO-REMAP alters how command remapping is handled: considered remapped sequences yet, copy them over and process them. */ || (!remapped && (sequences = remapped_sequences, - remapped = 1, + remapped = true, CONSP (sequences)))) { Lisp_Object sequence, function; @@ -2753,9 +2622,7 @@ The optional argument MENUS, if non-nil, says to mention menu bindings. \(Ordinarily these are omitted from the output.) */) (Lisp_Object buffer, Lisp_Object prefix, Lisp_Object menus) { - Lisp_Object outbuf, shadow; - bool nomenu = NILP (menus); - Lisp_Object start1; + Lisp_Object nomenu = NILP (menus) ? Qt : Qnil; const char *alternate_heading = "\ @@ -2765,17 +2632,16 @@ You type Translation\n\ CHECK_BUFFER (buffer); - shadow = Qnil; - outbuf = Fcurrent_buffer (); + Lisp_Object shadow = Qnil; + Lisp_Object outbuf = Fcurrent_buffer (); /* Report on alternates for keys. */ if (STRINGP (KVAR (current_kboard, Vkeyboard_translate_table)) && !NILP (prefix)) { - int c; const unsigned char *translate = SDATA (KVAR (current_kboard, Vkeyboard_translate_table)); int translate_len = SCHARS (KVAR (current_kboard, Vkeyboard_translate_table)); - for (c = 0; c < translate_len; c++) + for (int c = 0; c < translate_len; c++) if (translate[c] != c) { char buf[KEY_DESCRIPTION_SIZE]; @@ -2803,19 +2669,26 @@ You type Translation\n\ } if (!NILP (Vkey_translation_map)) - describe_map_tree (Vkey_translation_map, 0, Qnil, prefix, - "Key translations", nomenu, 1, 0, 0); - + { + Lisp_Object msg = build_unibyte_string ("Key translations"); + CALLN (Ffuncall, + Qdescribe_map_tree, + Vkey_translation_map, Qnil, Qnil, prefix, + msg, nomenu, Qt, Qnil, Qnil); + } /* Print the (major mode) local map. */ - start1 = Qnil; + Lisp_Object start1 = Qnil; if (!NILP (KVAR (current_kboard, Voverriding_terminal_local_map))) start1 = KVAR (current_kboard, Voverriding_terminal_local_map); if (!NILP (start1)) { - describe_map_tree (start1, 1, shadow, prefix, - "\f\nOverriding Bindings", nomenu, 0, 0, 0); + Lisp_Object msg = build_unibyte_string ("\f\nOverriding Bindings"); + CALLN (Ffuncall, + Qdescribe_map_tree, + start1, Qt, shadow, prefix, + msg, nomenu, Qnil, Qnil, Qnil); shadow = Fcons (start1, shadow); start1 = Qnil; } @@ -2824,39 +2697,43 @@ You type Translation\n\ if (!NILP (start1)) { - describe_map_tree (start1, 1, shadow, prefix, - "\f\nOverriding Bindings", nomenu, 0, 0, 0); + Lisp_Object msg = build_unibyte_string ("\f\nOverriding Bindings"); + CALLN (Ffuncall, + Qdescribe_map_tree, + start1, Qt, shadow, prefix, + msg, nomenu, Qnil, Qnil, Qnil); shadow = Fcons (start1, shadow); } else { /* Print the minor mode and major mode keymaps. */ - int i, nmaps; Lisp_Object *modes, *maps; /* Temporarily switch to `buffer', so that we can get that buffer's minor modes correctly. */ Fset_buffer (buffer); - nmaps = current_minor_maps (&modes, &maps); + int nmaps = current_minor_maps (&modes, &maps); Fset_buffer (outbuf); start1 = get_local_map (BUF_PT (XBUFFER (buffer)), XBUFFER (buffer), Qkeymap); if (!NILP (start1)) { - describe_map_tree (start1, 1, shadow, prefix, - "\f\n`keymap' Property Bindings", nomenu, - 0, 0, 0); + Lisp_Object msg = build_unibyte_string ("\f\n`keymap' Property Bindings"); + CALLN (Ffuncall, + Qdescribe_map_tree, + start1, Qt, shadow, prefix, + msg, nomenu, Qnil, Qnil, Qnil); shadow = Fcons (start1, shadow); } /* Print the minor mode maps. */ - for (i = 0; i < nmaps; i++) + for (int i = 0; i < nmaps; i++) { /* The title for a minor mode keymap is constructed at run time. - We let describe_map_tree do the actual insertion + We let describe-map-tree do the actual insertion because it takes care of other features when doing so. */ char *title, *p; @@ -2876,8 +2753,11 @@ You type Translation\n\ p += strlen (" Minor Mode Bindings"); *p = 0; - describe_map_tree (maps[i], 1, shadow, prefix, - title, nomenu, 0, 0, 0); + Lisp_Object msg = build_unibyte_string (title); + CALLN (Ffuncall, + Qdescribe_map_tree, + maps[i], Qt, shadow, prefix, + msg, nomenu, Qnil, Qnil, Qnil); shadow = Fcons (maps[i], shadow); SAFE_FREE (); } @@ -2887,432 +2767,66 @@ You type Translation\n\ if (!NILP (start1)) { if (EQ (start1, BVAR (XBUFFER (buffer), keymap))) - describe_map_tree (start1, 1, shadow, prefix, - "\f\nMajor Mode Bindings", nomenu, 0, 0, 0); - else - describe_map_tree (start1, 1, shadow, prefix, - "\f\n`local-map' Property Bindings", - nomenu, 0, 0, 0); - - shadow = Fcons (start1, shadow); - } - } - - describe_map_tree (current_global_map, 1, shadow, prefix, - "\f\nGlobal Bindings", nomenu, 0, 1, 0); - - /* Print the function-key-map translations under this prefix. */ - if (!NILP (KVAR (current_kboard, Vlocal_function_key_map))) - describe_map_tree (KVAR (current_kboard, Vlocal_function_key_map), 0, Qnil, prefix, - "\f\nFunction key map translations", nomenu, 1, 0, 0); - - /* Print the input-decode-map translations under this prefix. */ - if (!NILP (KVAR (current_kboard, Vinput_decode_map))) - describe_map_tree (KVAR (current_kboard, Vinput_decode_map), 0, Qnil, prefix, - "\f\nInput decoding map translations", nomenu, 1, 0, 0); - - return Qnil; -} - -/* Insert a description of the key bindings in STARTMAP, - followed by those of all maps reachable through STARTMAP. - If PARTIAL, omit certain "uninteresting" commands - (such as `undefined'). - If SHADOW is non-nil, it is a list of maps; - don't mention keys which would be shadowed by any of them. - PREFIX, if non-nil, says mention only keys that start with PREFIX. - TITLE, if not 0, is a string to insert at the beginning. - TITLE should not end with a colon or a newline; we supply that. - If NOMENU, then omit menu-bar commands. - - If TRANSL, the definitions are actually key translations - so print strings and vectors differently. - - If ALWAYS_TITLE, print the title even if there are no maps - to look through. - - If MENTION_SHADOW, then when something is shadowed by SHADOW, - don't omit it; instead, mention it but say it is shadowed. - - Any inserted text ends in two newlines (used by `help-make-xrefs'). */ - -void -describe_map_tree (Lisp_Object startmap, bool partial, Lisp_Object shadow, - Lisp_Object prefix, const char *title, bool nomenu, - bool transl, bool always_title, bool mention_shadow) -{ - Lisp_Object maps, orig_maps, seen, sub_shadows; - bool something = 0; - const char *key_heading - = "\ -key binding\n\ ---- -------\n"; - - orig_maps = maps = Faccessible_keymaps (startmap, prefix); - seen = Qnil; - sub_shadows = Qnil; - - if (nomenu) - { - Lisp_Object list; - - /* Delete from MAPS each element that is for the menu bar. */ - for (list = maps; CONSP (list); list = XCDR (list)) - { - Lisp_Object elt, elt_prefix, tem; - - elt = XCAR (list); - elt_prefix = Fcar (elt); - if (ASIZE (elt_prefix) >= 1) { - tem = Faref (elt_prefix, make_fixnum (0)); - if (EQ (tem, Qmenu_bar)) - maps = Fdelq (elt, maps); + Lisp_Object msg = build_unibyte_string ("\f\nMajor Mode Bindings"); + CALLN (Ffuncall, + Qdescribe_map_tree, + start1, Qt, shadow, prefix, + msg, nomenu, Qnil, Qnil, Qnil); } - } - } - - if (!NILP (maps) || always_title) - { - if (title) - { - insert_string (title); - if (!NILP (prefix)) + else { - insert_string (" Starting With "); - insert1 (Fkey_description (prefix, Qnil)); + Lisp_Object msg = build_unibyte_string ("\f\n`local-map' Property Bindings"); + CALLN (Ffuncall, + Qdescribe_map_tree, + start1, Qt, shadow, prefix, + msg, nomenu, Qnil, Qnil, Qnil); } - insert_string (":\n"); - } - insert_string (key_heading); - something = 1; - } - for (; CONSP (maps); maps = XCDR (maps)) - { - register Lisp_Object elt, elt_prefix, tail; - - elt = XCAR (maps); - elt_prefix = Fcar (elt); - - sub_shadows = Flookup_key (shadow, elt_prefix, Qt); - if (FIXNATP (sub_shadows)) - sub_shadows = Qnil; - else if (!KEYMAPP (sub_shadows) - && !NILP (sub_shadows) - && !(CONSP (sub_shadows) - && KEYMAPP (XCAR (sub_shadows)))) - /* If elt_prefix is bound to something that's not a keymap, - it completely shadows this map, so don't - describe this map at all. */ - goto skip; - - /* Maps we have already listed in this loop shadow this map. */ - for (tail = orig_maps; !EQ (tail, maps); tail = XCDR (tail)) - { - Lisp_Object tem; - tem = Fequal (Fcar (XCAR (tail)), elt_prefix); - if (!NILP (tem)) - sub_shadows = Fcons (XCDR (XCAR (tail)), sub_shadows); + shadow = Fcons (start1, shadow); } - - describe_map (Fcdr (elt), elt_prefix, - transl ? describe_translation : describe_command, - partial, sub_shadows, &seen, nomenu, mention_shadow); - - skip: ; } - if (something) - insert_string ("\n"); -} - -static int previous_description_column; - -static void -describe_command (Lisp_Object definition, Lisp_Object args) -{ - register Lisp_Object tem1; - ptrdiff_t column = current_column (); - int description_column; + Lisp_Object msg = build_unibyte_string ("\f\nGlobal Bindings"); + CALLN (Ffuncall, + Qdescribe_map_tree, + current_global_map, Qt, shadow, prefix, + msg, nomenu, Qnil, Qt, Qnil); - /* If column 16 is no good, go to col 32; - but don't push beyond that--go to next line instead. */ - if (column > 30) + /* Print the function-key-map translations under this prefix. */ + if (!NILP (KVAR (current_kboard, Vlocal_function_key_map))) { - insert_char ('\n'); - description_column = 32; + Lisp_Object msg = build_unibyte_string ("\f\nFunction key map translations"); + CALLN (Ffuncall, + Qdescribe_map_tree, + KVAR (current_kboard, Vlocal_function_key_map), Qnil, Qnil, prefix, + msg, nomenu, Qt, Qnil, Qnil); } - else if (column > 14 || (column > 10 && previous_description_column == 32)) - description_column = 32; - else - description_column = 16; - Findent_to (make_fixnum (description_column), make_fixnum (1)); - previous_description_column = description_column; - - if (SYMBOLP (definition)) + /* Print the input-decode-map translations under this prefix. */ + if (!NILP (KVAR (current_kboard, Vinput_decode_map))) { - tem1 = SYMBOL_NAME (definition); - insert1 (tem1); - insert_string ("\n"); + Lisp_Object msg = build_unibyte_string ("\f\nInput decoding map translations"); + CALLN (Ffuncall, + Qdescribe_map_tree, + KVAR (current_kboard, Vinput_decode_map), Qnil, Qnil, prefix, + msg, nomenu, Qt, Qnil, Qnil); } - else if (STRINGP (definition) || VECTORP (definition)) - insert_string ("Keyboard Macro\n"); - else if (KEYMAPP (definition)) - insert_string ("Prefix Command\n"); - else - insert_string ("??\n"); + return Qnil; } static void -describe_translation (Lisp_Object definition, Lisp_Object args) +describe_vector_princ (Lisp_Object elt, Lisp_Object fun) { - register Lisp_Object tem1; - Findent_to (make_fixnum (16), make_fixnum (1)); - - if (SYMBOLP (definition)) - { - tem1 = SYMBOL_NAME (definition); - insert1 (tem1); - insert_string ("\n"); - } - else if (STRINGP (definition) || VECTORP (definition)) - { - insert1 (Fkey_description (definition, Qnil)); - insert_string ("\n"); - } - else if (KEYMAPP (definition)) - insert_string ("Prefix Command\n"); - else - insert_string ("??\n"); -} - -/* describe_map puts all the usable elements of a sparse keymap - into an array of `struct describe_map_elt', - then sorts them by the events. */ - -struct describe_map_elt -{ - Lisp_Object event; - Lisp_Object definition; - bool shadowed; -}; - -/* qsort comparison function for sorting `struct describe_map_elt' by - the event field. */ - -static int -describe_map_compare (const void *aa, const void *bb) -{ - const struct describe_map_elt *a = aa, *b = bb; - if (FIXNUMP (a->event) && FIXNUMP (b->event)) - return ((XFIXNUM (a->event) > XFIXNUM (b->event)) - - (XFIXNUM (a->event) < XFIXNUM (b->event))); - if (!FIXNUMP (a->event) && FIXNUMP (b->event)) - return 1; - if (FIXNUMP (a->event) && !FIXNUMP (b->event)) - return -1; - if (SYMBOLP (a->event) && SYMBOLP (b->event)) - /* Sort the keystroke names in the "natural" way, with (for - instance) "<f2>" coming between "<f1>" and "<f11>". */ - return string_version_cmp (SYMBOL_NAME (a->event), SYMBOL_NAME (b->event)); - return 0; -} - -/* Describe the contents of map MAP, assuming that this map itself is - reached by the sequence of prefix keys PREFIX (a string or vector). - PARTIAL, SHADOW, NOMENU are as in `describe_map_tree' above. */ - -static void -describe_map (Lisp_Object map, Lisp_Object prefix, - void (*elt_describer) (Lisp_Object, Lisp_Object), - bool partial, Lisp_Object shadow, - Lisp_Object *seen, bool nomenu, bool mention_shadow) -{ - Lisp_Object tail, definition, event; - Lisp_Object tem; - Lisp_Object suppress; - Lisp_Object kludge; - bool first = 1; - - /* These accumulate the values from sparse keymap bindings, - so we can sort them and handle them in order. */ - ptrdiff_t length_needed = 0; - struct describe_map_elt *vect; - ptrdiff_t slots_used = 0; - ptrdiff_t i; - - suppress = Qnil; - - if (partial) - suppress = intern ("suppress-keymap"); - - /* This vector gets used to present single keys to Flookup_key. Since - that is done once per keymap element, we don't want to cons up a - fresh vector every time. */ - kludge = make_nil_vector (1); - definition = Qnil; - - map = call1 (Qkeymap_canonicalize, map); - - for (tail = map; CONSP (tail); tail = XCDR (tail)) - length_needed++; - - USE_SAFE_ALLOCA; - SAFE_NALLOCA (vect, 1, length_needed); - - for (tail = map; CONSP (tail); tail = XCDR (tail)) - { - maybe_quit (); - - if (VECTORP (XCAR (tail)) - || CHAR_TABLE_P (XCAR (tail))) - describe_vector (XCAR (tail), - prefix, Qnil, elt_describer, partial, shadow, map, - 1, mention_shadow); - else if (CONSP (XCAR (tail))) - { - bool this_shadowed = 0; - - event = XCAR (XCAR (tail)); - - /* Ignore bindings whose "prefix" are not really valid events. - (We get these in the frames and buffers menu.) */ - if (!(SYMBOLP (event) || FIXNUMP (event))) - continue; - - if (nomenu && EQ (event, Qmenu_bar)) - continue; - - definition = get_keyelt (XCDR (XCAR (tail)), 0); - - /* Don't show undefined commands or suppressed commands. */ - if (NILP (definition)) continue; - if (SYMBOLP (definition) && partial) - { - tem = Fget (definition, suppress); - if (!NILP (tem)) - continue; - } - - /* Don't show a command that isn't really visible - because a local definition of the same key shadows it. */ - - ASET (kludge, 0, event); - if (!NILP (shadow)) - { - tem = shadow_lookup (shadow, kludge, Qt, 0); - if (!NILP (tem)) - { - /* If both bindings are keymaps, this key is a prefix key, - so don't say it is shadowed. */ - if (KEYMAPP (definition) && KEYMAPP (tem)) - ; - /* Avoid generating duplicate entries if the - shadowed binding has the same definition. */ - else if (mention_shadow && !EQ (tem, definition)) - this_shadowed = 1; - else - continue; - } - } - - tem = Flookup_key (map, kludge, Qt); - if (!EQ (tem, definition)) continue; - - vect[slots_used].event = event; - vect[slots_used].definition = definition; - vect[slots_used].shadowed = this_shadowed; - slots_used++; - } - else if (EQ (XCAR (tail), Qkeymap)) - { - /* The same keymap might be in the structure twice, if we're - using an inherited keymap. So skip anything we've already - encountered. */ - tem = Fassq (tail, *seen); - if (CONSP (tem) && !NILP (Fequal (XCAR (tem), prefix))) - break; - *seen = Fcons (Fcons (tail, prefix), *seen); - } - } - - /* If we found some sparse map events, sort them. */ - - qsort (vect, slots_used, sizeof (struct describe_map_elt), - describe_map_compare); - - /* Now output them in sorted order. */ - - for (i = 0; i < slots_used; i++) - { - Lisp_Object start, end; - - if (first) - { - previous_description_column = 0; - insert ("\n", 1); - first = 0; - } - - ASET (kludge, 0, vect[i].event); - start = vect[i].event; - end = start; - - definition = vect[i].definition; - - /* Find consecutive chars that are identically defined. */ - if (FIXNUMP (vect[i].event)) - { - while (i + 1 < slots_used - && EQ (vect[i+1].event, make_fixnum (XFIXNUM (vect[i].event) + 1)) - && !NILP (Fequal (vect[i + 1].definition, definition)) - && vect[i].shadowed == vect[i + 1].shadowed) - i++; - end = vect[i].event; - } - - /* Now START .. END is the range to describe next. */ - - /* Insert the string to describe the event START. */ - insert1 (Fkey_description (kludge, prefix)); - - if (!EQ (start, end)) - { - insert (" .. ", 4); - - ASET (kludge, 0, end); - /* Insert the string to describe the character END. */ - insert1 (Fkey_description (kludge, prefix)); - } - - /* Print a description of the definition of this character. - elt_describer will take care of spacing out far enough - for alignment purposes. */ - (*elt_describer) (vect[i].definition, Qnil); - - if (vect[i].shadowed) - { - ptrdiff_t pt = max (PT - 1, BEG); - - SET_PT (pt); - insert_string ("\n (that binding is currently shadowed by another mode)"); - pt = min (PT + 1, Z); - SET_PT (pt); - } - } - - SAFE_FREE (); + call1 (fun, elt); + Fterpri (Qnil, Qnil); } static void -describe_vector_princ (Lisp_Object elt, Lisp_Object fun) +describe_vector_basic (Lisp_Object elt, Lisp_Object fun) { - Findent_to (make_fixnum (16), make_fixnum (1)); call1 (fun, elt); - Fterpri (Qnil, Qnil); } DEFUN ("describe-vector", Fdescribe_vector, Sdescribe_vector, 1, 2, 0, @@ -3332,8 +2846,40 @@ DESCRIBER is the output function used; nil means use `princ'. */) return unbind_to (count, Qnil); } +DEFUN ("help--describe-vector", Fhelp__describe_vector, Shelp__describe_vector, 7, 7, 0, + doc: /* Insert in the current buffer a description of the contents of VECTOR. +Call DESCRIBER to insert the description of one value found in VECTOR. + +PREFIX is a string describing the key which leads to the keymap that +this vector is in. + +If PARTIAL, it means do not mention suppressed commands. + +SHADOW is a list of keymaps that shadow this map. +If it is non-nil, look up the key in those maps and don't mention it +if it is defined by any of them. + +ENTIRE-MAP is the keymap in which this vector appears. +If the definition in effect in the whole map does not match +the one in this keymap, we ignore this one. */) + (Lisp_Object vector, Lisp_Object prefix, Lisp_Object describer, + Lisp_Object partial, Lisp_Object shadow, Lisp_Object entire_map, + Lisp_Object mention_shadow) +{ + ptrdiff_t count = SPECPDL_INDEX (); + specbind (Qstandard_output, Fcurrent_buffer ()); + CHECK_VECTOR_OR_CHAR_TABLE (vector); + + bool b_partial = NILP (partial) ? false : true; + bool b_mention_shadow = NILP (mention_shadow) ? false : true; + + describe_vector (vector, prefix, describer, describe_vector_basic, b_partial, + shadow, entire_map, true, b_mention_shadow); + return unbind_to (count, Qnil); +} + /* Insert in the current buffer a description of the contents of VECTOR. - We call ELT_DESCRIBER to insert the description of one value found + Call ELT_DESCRIBER to insert the description of one value found in VECTOR. ELT_PREFIX describes what "comes before" the keys or indices defined @@ -3370,21 +2916,11 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, bool partial, Lisp_Object shadow, Lisp_Object entire_map, bool keymap_p, bool mention_shadow) { - Lisp_Object definition; - Lisp_Object tem2; Lisp_Object elt_prefix = Qnil; - int i; - Lisp_Object suppress; - Lisp_Object kludge; - bool first = 1; + Lisp_Object suppress = Qnil; + bool first = true; /* Range of elements to be handled. */ int from, to, stop; - Lisp_Object character; - int starting_i; - - suppress = Qnil; - - definition = Qnil; if (!keymap_p) { @@ -3399,7 +2935,7 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, /* This vector gets used to present single keys to Flookup_key. Since that is done once per vector element, we don't want to cons up a fresh vector every time. */ - kludge = make_nil_vector (1); + Lisp_Object kludge = make_nil_vector (1); if (partial) suppress = intern ("suppress-keymap"); @@ -3410,11 +2946,12 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, else stop = to = ASIZE (vector); - for (i = from; ; i++) + for (int i = from; ; i++) { - bool this_shadowed = 0; + bool this_shadowed = false; + Lisp_Object shadowed_by = Qnil; int range_beg, range_end; - Lisp_Object val; + Lisp_Object val, tem2; maybe_quit (); @@ -3425,7 +2962,7 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, stop = to; } - starting_i = i; + int starting_i = i; if (CHAR_TABLE_P (vector)) { @@ -3435,34 +2972,30 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, } else val = AREF (vector, i); - definition = get_keyelt (val, 0); + Lisp_Object definition = get_keyelt (val, 0); if (NILP (definition)) continue; /* Don't mention suppressed commands. */ if (SYMBOLP (definition) && partial) { - Lisp_Object tem; - - tem = Fget (definition, suppress); + Lisp_Object tem = Fget (definition, suppress); if (!NILP (tem)) continue; } - character = make_fixnum (starting_i); + Lisp_Object character = make_fixnum (starting_i); ASET (kludge, 0, character); /* If this binding is shadowed by some other map, ignore it. */ if (!NILP (shadow)) { - Lisp_Object tem; + shadowed_by = shadow_lookup (shadow, kludge, Qt, 0); - tem = shadow_lookup (shadow, kludge, Qt, 0); - - if (!NILP (tem)) + if (!NILP (shadowed_by) && !EQ (shadowed_by, definition)) { if (mention_shadow) - this_shadowed = 1; + this_shadowed = true; else continue; } @@ -3472,9 +3005,7 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, one in the same keymap. */ if (!NILP (entire_map)) { - Lisp_Object tem; - - tem = Flookup_key (entire_map, kludge, Qt); + Lisp_Object tem = Flookup_key (entire_map, kludge, Qt); if (!EQ (tem, definition)) continue; @@ -3483,7 +3014,7 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, if (first) { insert ("\n", 1); - first = 0; + first = false; } /* Output the prefix that applies to every entry in this map. */ @@ -3493,9 +3024,9 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, insert1 (Fkey_description (kludge, prefix)); /* Find all consecutive characters or rows that have the same - definition. But, VECTOR is a char-table, we had better put a - boundary between normal characters (-#x3FFF7F) and 8-bit - characters (#x3FFF80-). */ + definition. But, if VECTOR is a char-table, we had better + put a boundary between normal characters (-#x3FFF7F) and + 8-bit characters (#x3FFF80-). */ if (CHAR_TABLE_P (vector)) { while (i + 1 < stop @@ -3514,6 +3045,20 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, && !NILP (Fequal (tem2, definition))) i++; + /* Make sure found consecutive keys are either not shadowed or, + if they are, that they are shadowed by the same command. */ + if (CHAR_TABLE_P (vector) && i != starting_i) + { + Lisp_Object key = make_nil_vector (1); + for (int j = starting_i + 1; j <= i; j++) + { + ASET (key, 0, make_fixnum (j)); + Lisp_Object tem = shadow_lookup (shadow, key, Qt, 0); + if (NILP (Fequal (tem, shadowed_by))) + i = j - 1; + } + } + /* If we have a range of more than one character, print where the range reaches to. */ @@ -3537,7 +3082,13 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, if (this_shadowed) { SET_PT (PT - 1); - insert_string (" (binding currently shadowed)"); + static char const fmt[] = " (currently shadowed by `%s')"; + USE_SAFE_ALLOCA; + char *buffer = SAFE_ALLOCA (sizeof fmt + + SBYTES (SYMBOL_NAME (shadowed_by))); + esprintf (buffer, fmt, SDATA (SYMBOL_NAME (shadowed_by))); + insert_string (buffer); + SAFE_FREE(); SET_PT (PT + 1); } } @@ -3551,48 +3102,11 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, } } -/* Apropos - finding all symbols whose names match a regexp. */ -static Lisp_Object apropos_predicate; -static Lisp_Object apropos_accumulate; - -static void -apropos_accum (Lisp_Object symbol, Lisp_Object string) -{ - register Lisp_Object tem; - - tem = Fstring_match (string, Fsymbol_name (symbol), Qnil); - if (!NILP (tem) && !NILP (apropos_predicate)) - tem = call1 (apropos_predicate, symbol); - if (!NILP (tem)) - apropos_accumulate = Fcons (symbol, apropos_accumulate); -} - -DEFUN ("apropos-internal", Fapropos_internal, Sapropos_internal, 1, 2, 0, - doc: /* Show all symbols whose names contain match for REGEXP. -If optional 2nd arg PREDICATE is non-nil, (funcall PREDICATE SYMBOL) is done -for each symbol and a symbol is mentioned only if that returns non-nil. -Return list of symbols found. */) - (Lisp_Object regexp, Lisp_Object predicate) -{ - Lisp_Object tem; - CHECK_STRING (regexp); - apropos_predicate = predicate; - apropos_accumulate = Qnil; - map_obarray (Vobarray, apropos_accum, regexp); - tem = Fsort (apropos_accumulate, Qstring_lessp); - apropos_accumulate = Qnil; - apropos_predicate = Qnil; - return tem; -} - void syms_of_keymap (void) { DEFSYM (Qkeymap, "keymap"); - staticpro (&apropos_predicate); - staticpro (&apropos_accumulate); - apropos_predicate = Qnil; - apropos_accumulate = Qnil; + DEFSYM (Qdescribe_map_tree, "describe-map-tree"); DEFSYM (Qkeymap_canonicalize, "keymap-canonicalize"); @@ -3604,21 +3118,9 @@ syms_of_keymap (void) Each one is the value of a Lisp variable, and is also pointed to by a C variable */ - global_map = Fmake_keymap (Qnil); - Fset (intern_c_string ("global-map"), global_map); - - current_global_map = global_map; - staticpro (&global_map); + current_global_map = Qnil; staticpro (¤t_global_map); - meta_map = Fmake_keymap (Qnil); - Fset (intern_c_string ("esc-map"), meta_map); - Ffset (intern_c_string ("ESC-prefix"), meta_map); - - control_x_map = Fmake_keymap (Qnil); - Fset (intern_c_string ("ctl-x-map"), control_x_map); - Ffset (intern_c_string ("Control-X-prefix"), control_x_map); - exclude_keys = pure_list (pure_cons (build_pure_c_string ("DEL"), build_pure_c_string ("\\d")), pure_cons (build_pure_c_string ("TAB"), build_pure_c_string ("\\t")), @@ -3627,12 +3129,6 @@ syms_of_keymap (void) pure_cons (build_pure_c_string ("SPC"), build_pure_c_string (" "))); staticpro (&exclude_keys); - DEFVAR_LISP ("define-key-rebound-commands", Vdefine_key_rebound_commands, - doc: /* List of commands given new key bindings recently. -This is used for internal purposes during Emacs startup; -don't alter it yourself. */); - Vdefine_key_rebound_commands = Qt; - DEFVAR_LISP ("minibuffer-local-map", Vminibuffer_local_map, doc: /* Default keymap to use when reading from the minibuffer. */); Vminibuffer_local_map = Fmake_sparse_keymap (Qnil); @@ -3715,12 +3211,9 @@ be preferred. */); defsubr (&Scopy_keymap); defsubr (&Scommand_remapping); defsubr (&Skey_binding); - defsubr (&Slocal_key_binding); - defsubr (&Sglobal_key_binding); defsubr (&Sminor_mode_key_binding); defsubr (&Sdefine_key); defsubr (&Slookup_key); - defsubr (&Sdefine_prefix_command); defsubr (&Suse_global_map); defsubr (&Suse_local_map); defsubr (&Scurrent_local_map); @@ -3729,17 +3222,11 @@ be preferred. */); defsubr (&Scurrent_active_maps); defsubr (&Saccessible_keymaps); defsubr (&Skey_description); + defsubr (&Skeymap__get_keyelt); + defsubr (&Shelp__describe_vector); defsubr (&Sdescribe_vector); defsubr (&Ssingle_key_description); defsubr (&Stext_char_description); defsubr (&Swhere_is_internal); defsubr (&Sdescribe_buffer_bindings); - defsubr (&Sapropos_internal); -} - -void -keys_of_keymap (void) -{ - initial_define_key (global_map, 033, "ESC-prefix"); - initial_define_key (global_map, Ctl ('X'), "Control-X-prefix"); } diff --git a/src/keymap.h b/src/keymap.h index 53496b00062..f417301c8f2 100644 --- a/src/keymap.h +++ b/src/keymap.h @@ -36,13 +36,9 @@ extern Lisp_Object current_global_map; extern char *push_key_description (EMACS_INT, char *); extern Lisp_Object access_keymap (Lisp_Object, Lisp_Object, bool, bool, bool); extern Lisp_Object get_keymap (Lisp_Object, bool, bool); -extern void describe_map_tree (Lisp_Object, bool, Lisp_Object, Lisp_Object, - const char *, bool, bool, bool, bool); extern ptrdiff_t current_minor_maps (Lisp_Object **, Lisp_Object **); -extern void initial_define_key (Lisp_Object, int, const char *); extern void initial_define_lispy_key (Lisp_Object, const char *, const char *); extern void syms_of_keymap (void); -extern void keys_of_keymap (void); typedef void (*map_keymap_function_t) (Lisp_Object key, Lisp_Object val, Lisp_Object args, void *data); diff --git a/src/kqueue.c b/src/kqueue.c index 8a1d0c99879..0a0650d2081 100644 --- a/src/kqueue.c +++ b/src/kqueue.c @@ -128,7 +128,7 @@ kqueue_compare_dir_list (Lisp_Object watch_object) return; } new_directory_files = - directory_files_internal (dir, Qnil, Qnil, Qnil, true, Qnil); + directory_files_internal (dir, Qnil, Qnil, Qnil, true, Qnil, Qnil); new_dl = kqueue_directory_listing (new_directory_files); /* Parse through the old list. */ @@ -452,7 +452,8 @@ only when the upper directory of the renamed file is watched. */) if (NILP (Ffile_directory_p (file))) watch_object = list4 (watch_descriptor, file, flags, callback); else { - dir_list = directory_files_internal (file, Qnil, Qnil, Qnil, true, Qnil); + dir_list = directory_files_internal (file, Qnil, Qnil, Qnil, true, Qnil, + Qnil); watch_object = list5 (watch_descriptor, file, flags, callback, dir_list); } watch_list = Fcons (watch_object, watch_list); diff --git a/src/lcms.c b/src/lcms.c index 27df7228b59..b998c8c4eb2 100644 --- a/src/lcms.c +++ b/src/lcms.c @@ -254,8 +254,7 @@ parse_viewing_conditions (Lisp_Object view, const cmsCIEXYZ *wp, #define PARSE_VIEW_CONDITION_INT(field) \ if (CONSP (view) && FIXNATP (XCAR (view))) \ { \ - CHECK_RANGED_INTEGER (XCAR (view), 1, 4); \ - vc->field = XFIXNUM (XCAR (view)); \ + vc->field = check_integer_range (XCAR (view), 1, 4); \ view = XCDR (view); \ } \ else \ @@ -317,7 +316,7 @@ jab_to_jch (const lcmsJab_t *jab, cmsJCh *jch, double FL, double c1, double c2) } DEFUN ("lcms-xyz->jch", Flcms_xyz_to_jch, Slcms_xyz_to_jch, 1, 3, 0, - doc: /* Convert CIE CAM02 JCh to CIE XYZ. + doc: /* Convert CIE XYZ to CIE CAM02 JCh. COLOR is a list (X Y Z), with Y scaled about unity. Optional arguments WHITEPOINT and VIEW are the same as in `lcms-cam02-ucs', which see. */) @@ -353,7 +352,7 @@ which see. */) } DEFUN ("lcms-jch->xyz", Flcms_jch_to_xyz, Slcms_jch_to_xyz, 1, 3, 0, - doc: /* Convert CIE XYZ to CIE CAM02 JCh. + doc: /* Convert CIE CAM02 JCh to CIE XYZ. COLOR is a list (J C h), where lightness of white is equal to 100, and hue is given in degrees. Optional arguments WHITEPOINT and VIEW are the same as in `lcms-cam02-ucs', diff --git a/src/lisp.h b/src/lisp.h index 7f015da0fee..409a1e70608 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -251,12 +251,6 @@ DEFINE_GDB_SYMBOL_BEGIN (EMACS_INT, VALMASK) # define VALMASK (USE_LSB_TAG ? - (1 << GCTYPEBITS) : VAL_MAX) DEFINE_GDB_SYMBOL_END (VALMASK) -#if !USE_LSB_TAG && !defined WIDE_EMACS_INT -# error "USE_LSB_TAG not supported on this platform; please report this." \ - "Try 'configure --with-wide-int' to work around the problem." -error !; -#endif - /* Minimum alignment requirement for Lisp objects, imposed by the internal representation of tagged pointers. It is 2**GCTYPEBITS if USE_LSB_TAG, 1 otherwise. It must be a literal integer constant, @@ -277,7 +271,8 @@ error !; allocation in a containing union that has GCALIGNED_UNION_MEMBER) and does not contain a GC-aligned struct or union, putting GCALIGNED_STRUCT after its closing '}' can help the compiler - generate better code. + generate better code. Also, such structs should be added to the + emacs_align_type union in alloc.c. Although these macros are reasonably portable, they are not guaranteed on non-GCC platforms, as C11 does not require support @@ -331,8 +326,8 @@ typedef EMACS_INT Lisp_Word; used elsewhere. FIXME: Remove the lisp_h_OP macros, and define just the inline OP - functions, once "gcc -Og" (new to GCC 4.8) works well enough for - Emacs developers. Maybe in the year 2020. See Bug#11935. + functions, once "gcc -Og" (new to GCC 4.8) or equivalent works well + enough for Emacs developers. Maybe in the year 2025. See Bug#11935. For the macros that have corresponding functions (defined later), see these functions for commentary. */ @@ -344,24 +339,20 @@ typedef EMACS_INT Lisp_Word; # define lisp_h_XLI(o) ((EMACS_INT) (o)) # define lisp_h_XIL(i) ((Lisp_Object) (i)) # define lisp_h_XLP(o) ((void *) (o)) -# define lisp_h_XPL(p) ((Lisp_Object) (p)) # else # define lisp_h_XLI(o) (o) # define lisp_h_XIL(i) (i) # define lisp_h_XLP(o) ((void *) (uintptr_t) (o)) -# define lisp_h_XPL(p) ((Lisp_Object) (uintptr_t) (p)) # endif #else # if LISP_WORDS_ARE_POINTERS # define lisp_h_XLI(o) ((EMACS_INT) (o).i) # define lisp_h_XIL(i) ((Lisp_Object) {(Lisp_Word) (i)}) # define lisp_h_XLP(o) ((void *) (o).i) -# define lisp_h_XPL(p) lisp_h_XIL (p) # else # define lisp_h_XLI(o) ((o).i) # define lisp_h_XIL(i) ((Lisp_Object) {i}) # define lisp_h_XLP(o) ((void *) (uintptr_t) (o).i) -# define lisp_h_XPL(p) ((Lisp_Object) {(uintptr_t) (p)}) # endif #endif @@ -411,22 +402,25 @@ typedef EMACS_INT Lisp_Word; # define lisp_h_XTYPE(a) ((enum Lisp_Type) (XLI (a) & ~VALMASK)) #endif -/* When compiling via gcc -O0, define the key operations as macros, as - Emacs is too slow otherwise. To disable this optimization, compile - with -DINLINING=false. */ -#if (defined __NO_INLINE__ \ - && ! defined __OPTIMIZE__ && ! defined __OPTIMIZE_SIZE__ \ - && ! (defined INLINING && ! INLINING)) -# define DEFINE_KEY_OPS_AS_MACROS true -#else -# define DEFINE_KEY_OPS_AS_MACROS false +/* When DEFINE_KEY_OPS_AS_MACROS, define key operations as macros to + cajole the compiler into inlining them; otherwise define them as + inline functions as this is cleaner and can be more efficient. + The default is true if the compiler is GCC-like and if function + inlining is disabled because the compiler is not optimizing or is + optimizing for size. Otherwise the default is false. */ +#ifndef DEFINE_KEY_OPS_AS_MACROS +# if (defined __NO_INLINE__ \ + && ! defined __OPTIMIZE__ && ! defined __OPTIMIZE_SIZE__) +# define DEFINE_KEY_OPS_AS_MACROS true +# else +# define DEFINE_KEY_OPS_AS_MACROS false +# endif #endif #if DEFINE_KEY_OPS_AS_MACROS # define XLI(o) lisp_h_XLI (o) # define XIL(i) lisp_h_XIL (i) # define XLP(o) lisp_h_XLP (o) -# define XPL(p) lisp_h_XPL (p) # define CHECK_FIXNUM(x) lisp_h_CHECK_FIXNUM (x) # define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x) # define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x) @@ -481,6 +475,7 @@ enum Lisp_Type Lisp_Symbol = 0, /* Type 1 is currently unused. */ + Lisp_Type_Unused0 = 1, /* Fixnum. XFIXNUM (obj) is the integer value. */ Lisp_Int0 = 2, @@ -584,15 +579,19 @@ INLINE void set_sub_char_table_contents (Lisp_Object, ptrdiff_t, Lisp_Object); /* Defined in bignum.c. */ -extern double bignum_to_double (Lisp_Object); +extern int check_int_nonnegative (Lisp_Object); +extern intmax_t check_integer_range (Lisp_Object, intmax_t, intmax_t); +extern double bignum_to_double (Lisp_Object) ATTRIBUTE_CONST; extern Lisp_Object make_bigint (intmax_t); extern Lisp_Object make_biguint (uintmax_t); +extern uintmax_t check_uinteger_max (Lisp_Object, uintmax_t); /* Defined in chartab.c. */ -extern Lisp_Object char_table_ref (Lisp_Object, int); +extern Lisp_Object char_table_ref (Lisp_Object, int) ATTRIBUTE_PURE; extern void char_table_set (Lisp_Object, int, Lisp_Object); /* Defined in data.c. */ +extern AVOID args_out_of_range_3 (Lisp_Object, Lisp_Object, Lisp_Object); extern AVOID wrong_type_argument (Lisp_Object, Lisp_Object); extern Lisp_Object default_value (Lisp_Object symbol); @@ -731,12 +730,6 @@ INLINE void * return lisp_h_XLP (o); } -INLINE Lisp_Object -(XPL) (void *p) -{ - return lisp_h_XPL (p); -} - /* Extract A's type. */ INLINE enum Lisp_Type @@ -889,8 +882,8 @@ verify (GCALIGNED (struct Lisp_Symbol)); convert it to a Lisp_Word. */ #if LISP_WORDS_ARE_POINTERS /* untagged_ptr is a pointer so that the compiler knows that TAG_PTR - yields a pointer; this can help with gcc -fcheck-pointer-bounds. - It is char * so that adding a tag uses simple machine addition. */ + yields a pointer. It is char * so that adding a tag uses simple + machine addition. */ typedef char *untagged_ptr; typedef uintptr_t Lisp_Word_tag; #else @@ -918,13 +911,9 @@ typedef EMACS_UINT Lisp_Word_tag; when using a debugger like GDB, on older platforms where the debug format does not represent C macros. However, they are unbounded and would just be asking for trouble if checking pointer bounds. */ -#ifdef __CHKP__ -# define DEFINE_LISP_SYMBOL(name) -#else -# define DEFINE_LISP_SYMBOL(name) \ - DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \ - DEFINE_GDB_SYMBOL_END (LISPSYM_INITIALLY (name)) -#endif +#define DEFINE_LISP_SYMBOL(name) \ + DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \ + DEFINE_GDB_SYMBOL_END (LISPSYM_INITIALLY (name)) /* The index of the C-defined Lisp symbol SYM. This can be used in a static initializer. */ @@ -998,30 +987,15 @@ XSYMBOL (Lisp_Object a) eassert (SYMBOLP (a)); intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol); void *p = (char *) lispsym + i; -#ifdef __CHKP__ - /* Bypass pointer checking. Although this could be improved it is - probably not worth the trouble. */ - p = __builtin___bnd_set_ptr_bounds (p, sizeof (struct Lisp_Symbol)); -#endif return p; } INLINE Lisp_Object make_lisp_symbol (struct Lisp_Symbol *sym) { -#ifdef __CHKP__ - /* Although '__builtin___bnd_narrow_ptr_bounds (sym, sym, sizeof *sym)' - should be more efficient, it runs afoul of GCC bug 83251 - <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=83251>. - Also, attempting to call __builtin___bnd_chk_ptr_bounds (sym, sizeof *sym) - here seems to trigger a GCC bug, as yet undiagnosed. */ - char *addr = __builtin___bnd_set_ptr_bounds (sym, sizeof *sym); - char *symoffset = addr - (intptr_t) lispsym; -#else - /* If !__CHKP__, GCC 7 x86-64 generates faster code if lispsym is + /* GCC 7 x86-64 generates faster code if lispsym is cast to char * rather than to intptr_t. */ char *symoffset = (char *) ((char *) sym - (char *) lispsym); -#endif Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset); eassert (XSYMBOL (a) == sym); return a; @@ -1070,7 +1044,7 @@ DEFINE_GDB_SYMBOL_END (PSEUDOVECTOR_FLAG) with PVEC_TYPE_MASK to indicate the actual type. */ enum pvec_type { - PVEC_NORMAL_VECTOR, + PVEC_NORMAL_VECTOR, /* Should be first, for sxhash_obj. */ PVEC_FREE, PVEC_BIGNUM, PVEC_MARKER, @@ -1095,7 +1069,7 @@ enum pvec_type PVEC_CONDVAR, PVEC_MODULE_FUNCTION, - /* These should be last, check internal_equal to see why. */ + /* These should be last, for internal_equal and sxhash_obj. */ PVEC_COMPILED, PVEC_CHAR_TABLE, PVEC_SUB_CHAR_TABLE, @@ -1332,7 +1306,6 @@ dead_object (void) #define XSETWINDOW(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW)) #define XSETTERMINAL(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_TERMINAL)) #define XSETSUBR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUBR)) -#define XSETCOMPILED(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_COMPILED)) #define XSETBUFFER(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BUFFER)) #define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE)) #define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR)) @@ -1505,8 +1478,8 @@ struct Lisp_String { struct { - ptrdiff_t size; - ptrdiff_t size_byte; + ptrdiff_t size; /* MSB is used as the markbit. */ + ptrdiff_t size_byte; /* Set to -1 for unibyte strings. */ INTERVAL intervals; /* Text properties in this string. */ unsigned char *data; } s; @@ -1543,11 +1516,11 @@ STRING_MULTIBYTE (Lisp_Object str) } /* An upper bound on the number of bytes in a Lisp string, not - counting the terminating NUL. This a tight enough bound to + counting the terminating null. This a tight enough bound to prevent integer overflow errors that would otherwise occur during string size calculations. A string cannot contain more bytes than a fixnum can represent, nor can it be so long that C pointer - arithmetic stops working on the string plus its terminating NUL. + arithmetic stops working on the string plus its terminating null. Although the actual size limit (see STRING_BYTES_MAX in alloc.c) may be a bit smaller than STRING_BYTES_BOUND, calculating it here would expose alloc.c internal details that we'd rather keep @@ -1669,6 +1642,13 @@ ASIZE (Lisp_Object array) } INLINE ptrdiff_t +gc_asize (Lisp_Object array) +{ + /* Like ASIZE, but also can be used in the garbage collector. */ + return XVECTOR (array)->header.size & ~ARRAY_MARK_FLAG; +} + +INLINE ptrdiff_t PVSIZE (Lisp_Object pv) { return ASIZE (pv) & PSEUDOVECTOR_SIZE_MASK; @@ -1818,7 +1798,8 @@ bool_vector_uchar_data (Lisp_Object a) INLINE bool bool_vector_bitref (Lisp_Object a, EMACS_INT i) { - eassume (0 <= i && i < bool_vector_size (a)); + eassume (0 <= i); + eassert (i < bool_vector_size (a)); return !! (bool_vector_uchar_data (a)[i / BOOL_VECTOR_BITS_PER_CHAR] & (1 << (i % BOOL_VECTOR_BITS_PER_CHAR))); } @@ -1834,11 +1815,11 @@ bool_vector_ref (Lisp_Object a, EMACS_INT i) INLINE void bool_vector_set (Lisp_Object a, EMACS_INT i, bool b) { - unsigned char *addr; - - eassume (0 <= i && i < bool_vector_size (a)); - addr = &bool_vector_uchar_data (a)[i / BOOL_VECTOR_BITS_PER_CHAR]; + eassume (0 <= i); + eassert (i < bool_vector_size (a)); + unsigned char *addr + = &bool_vector_uchar_data (a)[i / BOOL_VECTOR_BITS_PER_CHAR]; if (b) *addr |= 1 << (i % BOOL_VECTOR_BITS_PER_CHAR); else @@ -1850,22 +1831,17 @@ bool_vector_set (Lisp_Object a, EMACS_INT i, bool b) INLINE Lisp_Object AREF (Lisp_Object array, ptrdiff_t idx) { + eassert (0 <= idx && idx < gc_asize (array)); return XVECTOR (array)->contents[idx]; } INLINE Lisp_Object * aref_addr (Lisp_Object array, ptrdiff_t idx) { + eassert (0 <= idx && idx <= gc_asize (array)); return & XVECTOR (array)->contents[idx]; } -INLINE ptrdiff_t -gc_asize (Lisp_Object array) -{ - /* Like ASIZE, but also can be used in the garbage collector. */ - return XVECTOR (array)->header.size & ~ARRAY_MARK_FLAG; -} - INLINE void ASET (Lisp_Object array, ptrdiff_t idx, Lisp_Object val) { @@ -1914,18 +1890,12 @@ memclear (void *p, ptrdiff_t nbytes) (offsetof (type, lastlispfield) + word_size < header_size \ ? 0 : (offsetof (type, lastlispfield) + word_size - header_size) / word_size) -/* Compute A OP B, using the unsigned comparison operator OP. A and B - should be integer expressions. This is not the same as - mathematical comparison; for example, UNSIGNED_CMP (0, <, -1) - returns true. For efficiency, prefer plain unsigned comparison if A - and B's sizes both fit (after integer promotion). */ -#define UNSIGNED_CMP(a, op, b) \ - (max (sizeof ((a) + 0), sizeof ((b) + 0)) <= sizeof (unsigned) \ - ? ((a) + (unsigned) 0) op ((b) + (unsigned) 0) \ - : ((a) + (uintmax_t) 0) op ((b) + (uintmax_t) 0)) - /* True iff C is an ASCII character. */ -#define ASCII_CHAR_P(c) UNSIGNED_CMP (c, <, 0x80) +INLINE bool +ASCII_CHAR_P (intmax_t c) +{ + return 0 <= c && c < 0x80; +} /* A char-table is a kind of vectorlike, with contents like a vector, but with a few additional slots. For some purposes, it makes sense @@ -2296,11 +2266,7 @@ struct hash_table_test struct Lisp_Hash_Table { - /* Change pdumper.c if you change the fields here. - - IMPORTANT!!!!!!! - - Call hash_rehash_if_needed() before accessing. */ + /* Change pdumper.c if you change the fields here. */ /* This is for Lisp; the hash table code does not refer to it. */ union vectorlike_header header; @@ -2419,20 +2385,7 @@ HASH_TABLE_SIZE (const struct Lisp_Hash_Table *h) return size; } -void hash_table_rehash (struct Lisp_Hash_Table *h); - -INLINE bool -hash_rehash_needed_p (const struct Lisp_Hash_Table *h) -{ - return NILP (h->hash); -} - -INLINE void -hash_rehash_if_needed (struct Lisp_Hash_Table *h) -{ - if (hash_rehash_needed_p (h)) - hash_table_rehash (h); -} +void hash_table_rehash (Lisp_Object); /* Default size for hash tables if not specified. */ @@ -2799,8 +2752,10 @@ struct Lisp_Float { double data; struct Lisp_Float *chain; + GCALIGNED_UNION_MEMBER } u; - } GCALIGNED_STRUCT; + }; +verify (GCALIGNED (struct Lisp_Float)); INLINE bool (FLOATP) (Lisp_Object x) @@ -2998,28 +2953,6 @@ CHECK_FIXNAT (Lisp_Object x) CHECK_TYPE (FIXNATP (x), Qwholenump, x); } -#define CHECK_RANGED_INTEGER(x, lo, hi) \ - do { \ - CHECK_FIXNUM (x); \ - if (! ((lo) <= XFIXNUM (x) && XFIXNUM (x) <= (hi))) \ - args_out_of_range_3 (x, INT_TO_INTEGER (lo), INT_TO_INTEGER (hi)); \ - } while (false) -#define CHECK_TYPE_RANGED_INTEGER(type, x) \ - do { \ - if (TYPE_SIGNED (type)) \ - CHECK_RANGED_INTEGER (x, TYPE_MINIMUM (type), TYPE_MAXIMUM (type)); \ - else \ - CHECK_RANGED_INTEGER (x, 0, TYPE_MAXIMUM (type)); \ - } while (false) - -#define CHECK_FIXNUM_COERCE_MARKER(x) \ - do { \ - if (MARKERP ((x))) \ - XSETFASTINT (x, marker_position (x)); \ - else \ - CHECK_TYPE (FIXNUMP (x), Qinteger_or_marker_p, x); \ - } while (false) - INLINE double XFLOATINT (Lisp_Object n) { @@ -3039,22 +2972,6 @@ CHECK_INTEGER (Lisp_Object x) { CHECK_TYPE (INTEGERP (x), Qnumberp, x); } - -#define CHECK_NUMBER_COERCE_MARKER(x) \ - do { \ - if (MARKERP (x)) \ - XSETFASTINT (x, marker_position (x)); \ - else \ - CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x); \ - } while (false) - -#define CHECK_INTEGER_COERCE_MARKER(x) \ - do { \ - if (MARKERP (x)) \ - XSETFASTINT (x, marker_position (x)); \ - else \ - CHECK_TYPE (INTEGERP (x), Qnumber_or_marker_p, x); \ - } while (false) /* If we're not dumping using the legacy dumper and we might be using @@ -3072,7 +2989,7 @@ CHECK_INTEGER (Lisp_Object x) /* Define a built-in function for calling from Lisp. `lname' should be the name to give the function in Lisp, - as a NUL-terminated C string. + as a null-terminated C string. `fnname' should be the name of the function in C. By convention, it starts with F. `sname' should be the name for the C constant structure @@ -3208,9 +3125,13 @@ enum specbind_tag { SPECPDL_UNWIND_PTR, /* Likewise, on void *. */ SPECPDL_UNWIND_INT, /* Likewise, on int. */ SPECPDL_UNWIND_INTMAX, /* Likewise, on intmax_t. */ - SPECPDL_UNWIND_EXCURSION, /* Likewise, on an execursion. */ + SPECPDL_UNWIND_EXCURSION, /* Likewise, on an excursion. */ SPECPDL_UNWIND_VOID, /* Likewise, with no arg. */ SPECPDL_BACKTRACE, /* An element of the backtrace. */ +#ifdef HAVE_MODULES + SPECPDL_MODULE_RUNTIME, /* A live module runtime. */ + SPECPDL_MODULE_ENVIRONMENT, /* A live module environment. */ +#endif SPECPDL_LET, /* A plain and simple dynamic let-binding. */ /* Tags greater than SPECPDL_LET must be "subkinds" of LET. */ SPECPDL_LET_LOCAL, /* A buffer-local let-binding. */ @@ -3386,6 +3307,27 @@ struct frame; #define HAVE_EXT_TOOL_BAR true #endif +/* Return the address of vector A's element at index I. */ + +INLINE Lisp_Object * +xvector_contents_addr (Lisp_Object a, ptrdiff_t i) +{ + /* This should return &XVECTOR (a)->contents[i], but that would run + afoul of GCC bug 95072. */ + void *v = XVECTOR (a); + char *p = v; + void *w = p + header_size + i * word_size; + return w; +} + +/* Return the address of vector A's elements. */ + +INLINE Lisp_Object * +xvector_contents (Lisp_Object a) +{ + return xvector_contents_addr (a, 0); +} + /* Copy COUNT Lisp_Objects from ARGS to contents of V starting from OFFSET. */ INLINE void @@ -3393,7 +3335,7 @@ vcopy (Lisp_Object v, ptrdiff_t offset, Lisp_Object const *args, ptrdiff_t count) { eassert (0 <= offset && 0 <= count && offset + count <= ASIZE (v)); - memcpy (XVECTOR (v)->contents + offset, args, count * sizeof *args); + memcpy (xvector_contents_addr (v, offset), args, count * sizeof *args); } /* Functions to modify hash tables. */ @@ -3508,9 +3450,9 @@ set_sub_char_table_contents (Lisp_Object table, ptrdiff_t idx, Lisp_Object val) /* Defined in bignum.c. This part of bignum.c's API does not require the caller to access bignum internals; see bignum.h for that. */ -extern intmax_t bignum_to_intmax (Lisp_Object); -extern uintmax_t bignum_to_uintmax (Lisp_Object); -extern ptrdiff_t bignum_bufsize (Lisp_Object, int); +extern intmax_t bignum_to_intmax (Lisp_Object) ATTRIBUTE_CONST; +extern uintmax_t bignum_to_uintmax (Lisp_Object) ATTRIBUTE_CONST; +extern ptrdiff_t bignum_bufsize (Lisp_Object, int) ATTRIBUTE_CONST; extern ptrdiff_t bignum_to_c_string (char *, ptrdiff_t, Lisp_Object, int); extern Lisp_Object bignum_to_string (Lisp_Object, int); extern Lisp_Object make_bignum_str (char const *, int); @@ -3601,7 +3543,6 @@ extern uintmax_t cons_to_unsigned (Lisp_Object, uintmax_t); extern struct Lisp_Symbol *indirect_variable (struct Lisp_Symbol *); extern AVOID args_out_of_range (Lisp_Object, Lisp_Object); -extern AVOID args_out_of_range_3 (Lisp_Object, Lisp_Object, Lisp_Object); extern AVOID circular_list (Lisp_Object); extern Lisp_Object do_symval_forwarding (lispfwd); enum Set_Internal_Bind { @@ -3620,7 +3561,6 @@ extern void swap_in_global_binding (struct Lisp_Symbol *); /* Defined in cmds.c */ extern void syms_of_cmds (void); -extern void keys_of_cmds (void); /* Defined in coding.c. */ extern Lisp_Object detect_coding_system (const unsigned char *, ptrdiff_t, @@ -3654,7 +3594,7 @@ extern bool sweep_weak_table (struct Lisp_Hash_Table *, bool); extern void hexbuf_digest (char *, void const *, int); extern char *extract_data_from_object (Lisp_Object, ptrdiff_t *, ptrdiff_t *); EMACS_UINT hash_string (char const *, ptrdiff_t); -EMACS_UINT sxhash (Lisp_Object, int); +EMACS_UINT sxhash (Lisp_Object); Lisp_Object hashfn_eql (Lisp_Object, struct Lisp_Hash_Table *); Lisp_Object hashfn_equal (Lisp_Object, struct Lisp_Hash_Table *); Lisp_Object hashfn_user_defined (Lisp_Object, struct Lisp_Hash_Table *); @@ -3775,6 +3715,7 @@ extern Lisp_Object echo_area_buffer[2]; extern void add_to_log (char const *, ...); extern void vadd_to_log (char const *, va_list); extern void check_message_stack (void); +extern void clear_message_stack (void); extern void setup_echo_area_for_printing (bool); extern bool push_message (void); extern void pop_message_unwind (void); @@ -3793,6 +3734,7 @@ extern void message_log_maybe_newline (void); extern void update_echo_area (void); extern void truncate_echo_area (ptrdiff_t); extern void redisplay (void); +extern ptrdiff_t count_lines (ptrdiff_t start_byte, ptrdiff_t end_byte); void set_frame_cursor_types (struct frame *, Lisp_Object); extern void syms_of_xdisp (void); @@ -3814,22 +3756,50 @@ extern void parse_str_as_multibyte (const unsigned char *, ptrdiff_t, /* Defined in alloc.c. */ extern void *my_heap_start (void); extern void check_pure_size (void); -extern void allocate_string_data (struct Lisp_String *, EMACS_INT, EMACS_INT); +unsigned char *resize_string_data (Lisp_Object, ptrdiff_t, int, int); extern void malloc_warning (const char *); extern AVOID memory_full (size_t); extern AVOID buffer_memory_full (ptrdiff_t); extern bool survives_gc_p (Lisp_Object); extern void mark_object (Lisp_Object); +extern void mark_objects (Lisp_Object *, ptrdiff_t); #if defined REL_ALLOC && !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC extern void refill_memory_reserve (void); #endif extern void alloc_unexec_pre (void); extern void alloc_unexec_post (void); -extern void mark_maybe_objects (Lisp_Object const *, ptrdiff_t); extern void mark_stack (char const *, char const *); -extern void flush_stack_call_func (void (*func) (void *arg), void *arg); +extern void flush_stack_call_func1 (void (*func) (void *arg), void *arg); + +/* Force callee-saved registers and register windows onto the stack, + so that conservative garbage collection can see their values. */ +#ifndef HAVE___BUILTIN_UNWIND_INIT +# ifdef __sparc__ + /* This trick flushes the register windows so that all the state of + the process is contained in the stack. + FreeBSD does not have a ta 3 handler, so handle it specially. + FIXME: Code in the Boehm GC suggests flushing (with 'flushrs') is + needed on ia64 too. See mach_dep.c, where it also says inline + assembler doesn't work with relevant proprietary compilers. */ +# if defined __sparc64__ && defined __FreeBSD__ +# define __builtin_unwind_init() asm ("flushw") +# else +# define __builtin_unwind_init() asm ("ta 3") +# endif +# else +# define __builtin_unwind_init() ((void) 0) +# endif +#endif +INLINE void +flush_stack_call_func (void (*func) (void *arg), void *arg) +{ + __builtin_unwind_init (); + flush_stack_call_func1 (func, arg); +} + extern void garbage_collect (void); extern void maybe_garbage_collect (void); +extern bool maybe_garbage_collect_eagerly (EMACS_INT factor); extern const char *pending_malloc_warning; extern Lisp_Object zero_vector; extern EMACS_INT consing_until_gc; @@ -3942,8 +3912,7 @@ build_string (const char *str) extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object); extern Lisp_Object make_vector (ptrdiff_t, Lisp_Object); -extern void make_byte_code (struct Lisp_Vector *); -extern struct Lisp_Vector *allocate_vector (ptrdiff_t); +extern struct Lisp_Vector *allocate_nil_vector (ptrdiff_t); /* Make an uninitialized vector for SIZE objects. NOTE: you must be sure that GC cannot happen until the vector is completely @@ -3952,7 +3921,11 @@ extern struct Lisp_Vector *allocate_vector (ptrdiff_t); v = make_uninit_vector (3); ASET (v, 0, obj0); ASET (v, 1, Ffunction_can_gc ()); - ASET (v, 2, obj1); */ + ASET (v, 2, obj1); + + allocate_vector has a similar problem. */ + +extern struct Lisp_Vector *allocate_vector (ptrdiff_t); INLINE Lisp_Object make_uninit_vector (ptrdiff_t size) @@ -3974,14 +3947,13 @@ make_uninit_sub_char_table (int depth, int min_char) return v; } -/* Make a vector of SIZE nils. */ +/* Make a vector of SIZE nils - faster than make_vector (size, Qnil) + if the OS already cleared the new memory. */ INLINE Lisp_Object make_nil_vector (ptrdiff_t size) { - Lisp_Object vec = make_uninit_vector (size); - memclear (XVECTOR (vec)->contents, size * word_size); - return vec; + return make_lisp_ptr (allocate_nil_vector (size), Lisp_Vectorlike); } extern struct Lisp_Vector *allocate_pseudovector (int, int, int, @@ -4181,6 +4153,7 @@ extern void record_unwind_protect_intmax (void (*) (intmax_t), intmax_t); extern void record_unwind_protect_void (void (*) (void)); extern void record_unwind_protect_excursion (void); extern void record_unwind_protect_nothing (void); +extern void record_unwind_protect_module (enum specbind_tag, void *); extern void clear_unwind_protect (ptrdiff_t); extern void set_unwind_protect (ptrdiff_t, void (*) (Lisp_Object), Lisp_Object); extern void set_unwind_protect_ptr (ptrdiff_t, void (*) (void *), void *); @@ -4245,9 +4218,15 @@ extern Lisp_Object funcall_module (Lisp_Object, ptrdiff_t, Lisp_Object *); extern Lisp_Object module_function_arity (const struct Lisp_Module_Function *); extern Lisp_Object module_function_documentation (struct Lisp_Module_Function const *); +extern Lisp_Object module_function_interactive_form + (const struct Lisp_Module_Function *); extern module_funcptr module_function_address (struct Lisp_Module_Function const *); -extern void mark_modules (void); +extern void *module_function_data (const struct Lisp_Module_Function *); +extern void module_finalize_function (const struct Lisp_Module_Function *); +extern void mark_module_environment (void *); +extern void finalize_runtime_unwind (void *); +extern void finalize_environment_unwind (void *); extern void init_module_assertions (bool); extern void syms_of_module (void); #endif @@ -4283,7 +4262,6 @@ extern Lisp_Object get_truename_buffer (Lisp_Object); extern void init_buffer_once (void); extern void init_buffer (void); extern void syms_of_buffer (void); -extern void keys_of_buffer (void); /* Defined in marker.c. */ @@ -4367,9 +4345,14 @@ extern void clear_regexp_cache (void); extern Lisp_Object Vminibuffer_list; extern Lisp_Object last_minibuf_string; +extern void move_minibuffer_onto_frame (void); +extern bool is_minibuffer (EMACS_INT, Lisp_Object); +extern EMACS_INT this_minibuffer_depth (Lisp_Object); +extern EMACS_INT minibuf_level; extern Lisp_Object get_minibuffer (EMACS_INT); extern void init_minibuf_once (void); extern void syms_of_minibuf (void); +extern void barf_if_interaction_inhibited (void); /* Defined in callint.c. */ @@ -4378,7 +4361,6 @@ extern void syms_of_callint (void); /* Defined in casefiddle.c. */ extern void syms_of_casefiddle (void); -extern void keys_of_casefiddle (void); /* Defined in casetab.c. */ @@ -4512,32 +4494,20 @@ extern void setup_process_coding_systems (Lisp_Object); /* Defined in callproc.c. */ #ifdef DOS_NT -# define CHILD_SETUP_TYPE int # define CHILD_SETUP_ERROR_DESC "Spawning child process" #else -# define CHILD_SETUP_TYPE _Noreturn void # define CHILD_SETUP_ERROR_DESC "Doing vfork" #endif -extern CHILD_SETUP_TYPE child_setup (int, int, int, char **, bool, Lisp_Object); +extern int emacs_spawn (pid_t *, int, int, int, char **, char **, + const char *, const char *, const sigset_t *); +extern char **make_environment_block (Lisp_Object); extern void init_callproc_1 (void); extern void init_callproc (void); extern void set_initial_environment (void); extern void syms_of_callproc (void); /* Defined in doc.c. */ -enum text_quoting_style - { - /* Use curved single quotes ‘like this’. */ - CURVE_QUOTING_STYLE, - - /* Use grave accent and apostrophe `like this'. */ - GRAVE_QUOTING_STYLE, - - /* Use apostrophes 'like this'. */ - STRAIGHT_QUOTING_STYLE - }; -extern enum text_quoting_style text_quoting_style (void); extern Lisp_Object read_doc_string (Lisp_Object); extern Lisp_Object get_doc_string (Lisp_Object, bool, bool); extern void syms_of_doc (void); @@ -4606,7 +4576,10 @@ extern void seed_random (void *, ptrdiff_t); extern void init_random (void); extern void emacs_backtrace (int); extern AVOID emacs_abort (void) NO_INLINE; +extern int emacs_fstatat (int, char const *, void *, int); +extern int emacs_openat (int, char const *, int, int); extern int emacs_open (const char *, int, int); +extern int emacs_open_noquit (const char *, int, int); extern int emacs_pipe (int[2]); extern int emacs_close (int); extern ptrdiff_t emacs_read (int, void *, ptrdiff_t); @@ -4641,7 +4614,7 @@ extern void syms_of_ccl (void); extern void syms_of_dired (void); extern Lisp_Object directory_files_internal (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, - bool, Lisp_Object); + bool, Lisp_Object, Lisp_Object); /* Defined in term.c. */ extern int *char_ins_del_vector; @@ -4768,7 +4741,7 @@ extern char *xlispstrdup (Lisp_Object) ATTRIBUTE_MALLOC; extern void dupstring (char **, char const *); /* Make DEST a copy of STRING's data. Return a pointer to DEST's terminating - NUL byte. This is like stpcpy, except the source is a Lisp string. */ + null byte. This is like stpcpy, except the source is a Lisp string. */ INLINE char * lispstpcpy (char *dest, Lisp_Object string) @@ -4778,6 +4751,17 @@ lispstpcpy (char *dest, Lisp_Object string) return dest + len; } +#if (defined HAVE___LSAN_IGNORE_OBJECT \ + && defined HAVE_SANITIZER_LSAN_INTERFACE_H) +# include <sanitizer/lsan_interface.h> +#else +/* Treat *P as a non-leak. */ +INLINE void +__lsan_ignore_object (void const *p) +{ +} +#endif + extern void xputenv (const char *); extern char *egetenv_internal (const char *, ptrdiff_t); @@ -4893,7 +4877,10 @@ safe_free_unbind_to (ptrdiff_t count, ptrdiff_t sa_count, Lisp_Object val) (buf) = AVAIL_ALLOCA (alloca_nbytes); \ else \ { \ - (buf) = xmalloc (alloca_nbytes); \ + /* Although only the first nelt words need clearing, \ + typically EXTRA is 0 or small so just use xzalloc; \ + this is simpler and often faster. */ \ + (buf) = xzalloc (alloca_nbytes); \ record_unwind_protect_array (buf, nelt); \ } \ } while (false) @@ -4972,7 +4959,7 @@ enum : list4 (a, b, c, d)) /* Declare NAME as an auto Lisp string if possible, a GC-based one if not. - Take its unibyte value from the NUL-terminated string STR, + Take its unibyte value from the null-terminated string STR, an expression that should not have side effects. STR's value is not necessarily copied. The resulting Lisp string should not be modified or given text properties or made visible to @@ -4982,8 +4969,8 @@ enum AUTO_STRING_WITH_LEN (name, str, strlen (str)) /* Declare NAME as an auto Lisp string if possible, a GC-based one if not. - Take its unibyte value from the NUL-terminated string STR with length LEN. - STR may have side effects and may contain NUL bytes. + Take its unibyte value from the null-terminated string STR with length LEN. + STR may have side effects and may contain null bytes. STR's value is not necessarily copied. The resulting Lisp string should not be modified or given text properties or made visible to user code. */ diff --git a/src/lread.c b/src/lread.c index 47116ad5ae7..010194c34ea 100644 --- a/src/lread.c +++ b/src/lread.c @@ -152,12 +152,6 @@ static ptrdiff_t prev_saved_doc_string_length; /* This is the file position that string came from. */ static file_offset prev_saved_doc_string_position; -/* True means inside a new-style backquote with no surrounding - parentheses. Fread initializes this to the value of - `force_new_style_backquotes', so we need not specbind it or worry - about what happens to it when there is an error. */ -static bool new_backquote_flag; - /* A list of file names for files being loaded in Fload. Used to check for recursive loads. */ @@ -231,8 +225,9 @@ readchar (Lisp_Object readcharfun, bool *multibyte) { /* Fetch the character code from the buffer. */ unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, pt_byte); - BUF_INC_POS (inbuffer, pt_byte); - c = STRING_CHAR (p); + int clen; + c = string_char_and_length (p, &clen); + pt_byte += clen; if (multibyte) *multibyte = 1; } @@ -260,8 +255,9 @@ readchar (Lisp_Object readcharfun, bool *multibyte) { /* Fetch the character code from the buffer. */ unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, bytepos); - BUF_INC_POS (inbuffer, bytepos); - c = STRING_CHAR (p); + int clen; + c = string_char_and_length (p, &clen); + bytepos += clen; if (multibyte) *multibyte = 1; } @@ -300,9 +296,10 @@ readchar (Lisp_Object readcharfun, bool *multibyte) { if (multibyte) *multibyte = 1; - FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, readcharfun, - read_from_string_index, - read_from_string_index_byte); + c = (fetch_string_char_advance_no_check + (readcharfun, + &read_from_string_index, + &read_from_string_index_byte)); } else { @@ -433,7 +430,7 @@ unreadchar (Lisp_Object readcharfun, int c) ptrdiff_t bytepos = BUF_PT_BYTE (b); if (! NILP (BVAR (b, enable_multibyte_characters))) - BUF_DEC_POS (b, bytepos); + bytepos -= buf_prev_char_len (b, bytepos); else bytepos--; @@ -446,7 +443,7 @@ unreadchar (Lisp_Object readcharfun, int c) XMARKER (readcharfun)->charpos--; if (! NILP (BVAR (b, enable_multibyte_characters))) - BUF_DEC_POS (b, bytepos); + bytepos -= buf_prev_char_len (b, bytepos); else bytepos--; @@ -532,13 +529,38 @@ readbyte_from_string (int c, Lisp_Object readcharfun) = string_char_to_byte (string, read_from_string_index); } - if (read_from_string_index >= read_from_string_limit) - c = -1; + return (read_from_string_index < read_from_string_limit + ? fetch_string_char_advance (string, + &read_from_string_index, + &read_from_string_index_byte) + : -1); +} + + +/* Signal Qinvalid_read_syntax error. + S is error string of length N (if > 0) */ + +static AVOID +invalid_syntax_lisp (Lisp_Object s, Lisp_Object readcharfun) +{ + if (BUFFERP (readcharfun)) + { + xsignal (Qinvalid_read_syntax, + list3 (s, + /* We should already be in the readcharfun + buffer when this error is called, so no need + to switch to it first. */ + make_fixnum (count_lines (BEGV_BYTE, PT_BYTE) + 1), + make_fixnum (current_column ()))); + } else - FETCH_STRING_CHAR_ADVANCE (c, string, - read_from_string_index, - read_from_string_index_byte); - return c; + xsignal1 (Qinvalid_read_syntax, s); +} + +static AVOID +invalid_syntax (const char *s, Lisp_Object readcharfun) +{ + invalid_syntax_lisp (build_string (s), readcharfun); } @@ -599,8 +621,7 @@ read_emacs_mule_char (int c, int (*readbyte) (int, Lisp_Object), Lisp_Object rea } c = DECODE_CHAR (charset, code); if (c < 0) - Fsignal (Qinvalid_read_syntax, - list1 (build_string ("invalid multibyte form"))); + invalid_syntax ("invalid multibyte form", readcharfun); return c; } @@ -772,13 +793,21 @@ is used for reading a character. If the optional argument SECONDS is non-nil, it should be a number specifying the maximum number of seconds to wait for input. If no input arrives in that time, return nil. SECONDS may be a -floating-point value. */) +floating-point value. + +If `inhibit-interaction' is non-nil, this function will signal an +`inhibited-interaction' error. */) (Lisp_Object prompt, Lisp_Object inherit_input_method, Lisp_Object seconds) { Lisp_Object val; + barf_if_interaction_inhibited (); + if (! NILP (prompt)) - message_with_string ("%s", prompt, 0); + { + cancel_echoing (); + message_with_string ("%s", prompt, 0); + } val = read_filtered_event (1, 1, 1, ! NILP (inherit_input_method), seconds); return (NILP (val) ? Qnil @@ -787,6 +816,12 @@ floating-point value. */) DEFUN ("read-event", Fread_event, Sread_event, 0, 3, 0, doc: /* Read an event object from the input stream. + +If you want to read non-character events, consider calling `read-key' +instead. `read-key' will decode events via `input-decode-map' that +`read-event' will not. On a terminal this includes function keys such +as <F7> and <RIGHT>, or mouse events generated by `xterm-mouse-mode'. + If the optional argument PROMPT is non-nil, display that as a prompt. If PROMPT is nil or the string \"\", the key sequence/events that led to the current command is used as the prompt. @@ -798,11 +833,19 @@ is used for reading a character. If the optional argument SECONDS is non-nil, it should be a number specifying the maximum number of seconds to wait for input. If no input arrives in that time, return nil. SECONDS may be a -floating-point value. */) +floating-point value. + +If `inhibit-interaction' is non-nil, this function will signal an +`inhibited-interaction' error. */) (Lisp_Object prompt, Lisp_Object inherit_input_method, Lisp_Object seconds) { + barf_if_interaction_inhibited (); + if (! NILP (prompt)) - message_with_string ("%s", prompt, 0); + { + cancel_echoing (); + message_with_string ("%s", prompt, 0); + } return read_filtered_event (0, 0, 0, ! NILP (inherit_input_method), seconds); } @@ -827,13 +870,21 @@ is used for reading a character. If the optional argument SECONDS is non-nil, it should be a number specifying the maximum number of seconds to wait for input. If no input arrives in that time, return nil. SECONDS may be a -floating-point value. */) - (Lisp_Object prompt, Lisp_Object inherit_input_method, Lisp_Object seconds) +floating-point value. + +If `inhibit-interaction' is non-nil, this function will signal an +`inhibited-interaction' error. */) +(Lisp_Object prompt, Lisp_Object inherit_input_method, Lisp_Object seconds) { Lisp_Object val; + barf_if_interaction_inhibited (); + if (! NILP (prompt)) - message_with_string ("%s", prompt, 0); + { + cancel_echoing (); + message_with_string ("%s", prompt, 0); + } val = read_filtered_event (1, 1, 0, ! NILP (inherit_input_method), seconds); @@ -985,9 +1036,7 @@ lisp_file_lexically_bound_p (Lisp_Object readcharfun) /* Value is a version number of byte compiled code if the file associated with file descriptor FD is a compiled Lisp file that's - safe to load. Only files compiled with Emacs are safe to load. - Files compiled with XEmacs can lead to a crash in Fbyte_code - because of an incompatible change in the byte compiler. */ + safe to load. Only files compiled with Emacs can be loaded. */ static int safe_to_load_version (int fd) @@ -1035,22 +1084,16 @@ load_error_handler (Lisp_Object data) return Qnil; } -static AVOID -load_error_old_style_backquotes (void) -{ - if (NILP (Vload_file_name)) - xsignal1 (Qerror, build_string ("Old-style backquotes detected!")); - else - { - AUTO_STRING (format, "Loading `%s': old-style backquotes detected!"); - xsignal1 (Qerror, CALLN (Fformat_message, format, Vload_file_name)); - } -} - static void load_warn_unescaped_character_literals (Lisp_Object file) { - Lisp_Object warning = call0 (Qbyte_run_unescaped_character_literals_warning); + Lisp_Object function + = Fsymbol_function (Qbyte_run_unescaped_character_literals_warning); + /* If byte-run.el is being loaded, + `byte-run--unescaped-character-literals-warning' isn't yet + defined. Since it'll be byte-compiled later, ignore potential + unescaped character literals. */ + Lisp_Object warning = NILP (function) ? Qnil : call0 (function); if (!NILP (warning)) { AUTO_STRING (format, "Loading `%s': %s"); @@ -1153,7 +1196,6 @@ Return t if the file exists and loads successfully. */) /* True means we are loading a compiled file. */ bool compiled = 0; Lisp_Object handler; - bool safe_p = 1; const char *fmode = "r" FOPEN_TEXT; int version; @@ -1199,6 +1241,9 @@ Return t if the file exists and loads successfully. */) || suffix_p (file, ".elc") #ifdef HAVE_MODULES || suffix_p (file, MODULES_SUFFIX) +#ifdef MODULES_SECONDARY_SUFFIX + || suffix_p (file, MODULES_SECONDARY_SUFFIX) +#endif #endif ) must_suffix = Qnil; @@ -1268,7 +1313,12 @@ Return t if the file exists and loads successfully. */) } #ifdef HAVE_MODULES - bool is_module = suffix_p (found, MODULES_SUFFIX); + bool is_module = + suffix_p (found, MODULES_SUFFIX) +#ifdef MODULES_SECONDARY_SUFFIX + || suffix_p (found, MODULES_SECONDARY_SUFFIX) +#endif + ; #else bool is_module = false; #endif @@ -1328,11 +1378,7 @@ Return t if the file exists and loads successfully. */) if (version < 0 && ! (version = safe_to_load_version (fd))) { - safe_p = 0; - if (!load_dangerous_libraries) - error ("File `%s' was not compiled in Emacs", SDATA (found)); - else if (!NILP (nomessage) && !force_load_messages) - message_with_string ("File `%s' not compiled in Emacs", found, 1); + error ("File `%s' was not compiled in Emacs", SDATA (found)); } compiled = 1; @@ -1345,11 +1391,11 @@ Return t if the file exists and loads successfully. */) ignores suffix order due to load_prefer_newer. */ if (!load_prefer_newer && is_elc) { - result = stat (SSDATA (efound), &s1); + result = emacs_fstatat (AT_FDCWD, SSDATA (efound), &s1, 0); if (result == 0) { SSET (efound, SBYTES (efound) - 1, 0); - result = stat (SSDATA (efound), &s2); + result = emacs_fstatat (AT_FDCWD, SSDATA (efound), &s2, 0); SSET (efound, SBYTES (efound) - 1, 'c'); } @@ -1439,10 +1485,7 @@ Return t if the file exists and loads successfully. */) if (NILP (nomessage) || force_load_messages) { - if (!safe_p) - message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...", - file, 1); - else if (is_module) + if (is_module) message_with_string ("Loading %s (module)...", file, 1); else if (!compiled) message_with_string ("Loading %s (source)...", file, 1); @@ -1502,10 +1545,7 @@ Return t if the file exists and loads successfully. */) if (!noninteractive && (NILP (nomessage) || force_load_messages)) { - if (!safe_p) - message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...done", - file, 1); - else if (is_module) + if (is_module) message_with_string ("Loading %s (module)...done", file, 1); else if (!compiled) message_with_string ("Loading %s (source)...done", file, 1); @@ -2275,7 +2315,6 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end) Lisp_Object retval; readchar_count = 0; - new_backquote_flag = force_new_style_backquotes; /* We can get called from readevalloop which may have set these already. */ if (! HASH_TABLE_P (read_objects_map) @@ -2326,16 +2365,6 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end) } -/* Signal Qinvalid_read_syntax error. - S is error string of length N (if > 0) */ - -static AVOID -invalid_syntax (const char *s) -{ - xsignal1 (Qinvalid_read_syntax, build_string (s)); -} - - /* Use this for recursive reads, in contexts where internal tokens are not allowed. */ @@ -2349,8 +2378,8 @@ read0 (Lisp_Object readcharfun) if (!c) return val; - xsignal1 (Qinvalid_read_syntax, - Fmake_string (make_fixnum (1), make_fixnum (c), Qnil)); + invalid_syntax_lisp (Fmake_string (make_fixnum (1), make_fixnum (c), Qnil), + readcharfun); } /* Grow a read buffer BUF that contains OFFSET useful bytes of data, @@ -2380,7 +2409,8 @@ grow_read_buffer (char *buf, ptrdiff_t offset, /* Return the scalar value that has the Unicode character name NAME. Raise 'invalid-read-syntax' if there is no such character. */ static int -character_name_to_code (char const *name, ptrdiff_t name_len) +character_name_to_code (char const *name, ptrdiff_t name_len, + Lisp_Object readcharfun) { /* For "U+XXXX", pass the leading '+' to string_to_number to reject monstrosities like "U+-0000". */ @@ -2396,7 +2426,7 @@ character_name_to_code (char const *name, ptrdiff_t name_len) { AUTO_STRING (format, "\\N{%s}"); AUTO_STRING_WITH_LEN (namestr, name, name_len); - xsignal1 (Qinvalid_read_syntax, CALLN (Fformat, format, namestr)); + invalid_syntax_lisp (CALLN (Fformat, format, namestr), readcharfun); } return XFIXNUM (code); @@ -2590,6 +2620,13 @@ read_escape (Lisp_Object readcharfun, bool stringp) while (++count <= unicode_hex_count) { c = READCHAR; + if (c < 0) + { + if (unicode_hex_count > 4) + error ("Malformed Unicode escape: \\U%x", i); + else + error ("Malformed Unicode escape: \\u%x", i); + } /* `isdigit' and `isalpha' may be locale-specific, which we don't want. */ int digit = char_hexdigit (c); @@ -2608,7 +2645,7 @@ read_escape (Lisp_Object readcharfun, bool stringp) { c = READCHAR; if (c != '{') - invalid_syntax ("Expected opening brace after \\N"); + invalid_syntax ("Expected opening brace after \\N", readcharfun); char name[UNICODE_CHARACTER_NAME_LENGTH_BOUND + 1]; bool whitespace = false; ptrdiff_t length = 0; @@ -2623,8 +2660,9 @@ read_escape (Lisp_Object readcharfun, bool stringp) { AUTO_STRING (format, "Invalid character U+%04X in character name"); - xsignal1 (Qinvalid_read_syntax, - CALLN (Fformat, format, make_fixed_natnum (c))); + invalid_syntax_lisp (CALLN (Fformat, format, + make_fixed_natnum (c)), + readcharfun); } /* Treat multiple adjacent whitespace characters as a single space character. This makes it easier to use @@ -2640,15 +2678,15 @@ read_escape (Lisp_Object readcharfun, bool stringp) whitespace = false; name[length++] = c; if (length >= sizeof name) - invalid_syntax ("Character name too long"); + invalid_syntax ("Character name too long", readcharfun); } if (length == 0) - invalid_syntax ("Empty character name"); + invalid_syntax ("Empty character name", readcharfun); name[length] = '\0'; /* character_name_to_code can invoke read1, recursively. This is why read1's buffer is not static. */ - return character_name_to_code (name, length); + return character_name_to_code (name, length, readcharfun); } default: @@ -2686,10 +2724,11 @@ enum { stackbufsize = max (64, + INT_STRLEN_BOUND (EMACS_INT) + 1)) }; static void -invalid_radix_integer (EMACS_INT radix, char stackbuf[VLA_ELEMS (stackbufsize)]) +invalid_radix_integer (EMACS_INT radix, char stackbuf[VLA_ELEMS (stackbufsize)], + Lisp_Object readcharfun) { sprintf (stackbuf, invalid_radix_integer_format, radix); - invalid_syntax (stackbuf); + invalid_syntax (stackbuf, readcharfun); } /* Read an integer in radix RADIX using READCHARFUN to read @@ -2749,7 +2788,7 @@ read_integer (Lisp_Object readcharfun, int radix, UNREAD (c); if (valid != 1) - invalid_radix_integer (radix, stackbuf); + invalid_radix_integer (radix, stackbuf, readcharfun); *p = '\0'; return unbind_to (count, string_to_number (read_buffer, radix, NULL)); @@ -2885,7 +2924,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) return ht; } UNREAD (c); - invalid_syntax ("#"); + invalid_syntax ("#", readcharfun); } if (c == '^') { @@ -2937,9 +2976,9 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) } return tbl; } - invalid_syntax ("#^^"); + invalid_syntax ("#^^", readcharfun); } - invalid_syntax ("#^"); + invalid_syntax ("#^", readcharfun); } if (c == '&') { @@ -2962,7 +3001,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) version. */ && ! (XFIXNAT (length) == (SCHARS (tmp) - 1) * BOOL_VECTOR_BITS_PER_CHAR))) - invalid_syntax ("#&..."); + invalid_syntax ("#&...", readcharfun); val = make_uninit_bool_vector (XFIXNAT (length)); data = bool_vector_uchar_data (val); @@ -2973,7 +3012,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) &= (1 << (XFIXNUM (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1; return val; } - invalid_syntax ("#&..."); + invalid_syntax ("#&...", readcharfun); } if (c == '[') { @@ -2983,9 +3022,46 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) struct Lisp_Vector *vec; tmp = read_vector (readcharfun, 1); vec = XVECTOR (tmp); - if (vec->header.size == 0) - invalid_syntax ("Empty byte-code object"); - make_byte_code (vec); + if (! (COMPILED_STACK_DEPTH < ASIZE (tmp) + && (FIXNUMP (AREF (tmp, COMPILED_ARGLIST)) + || CONSP (AREF (tmp, COMPILED_ARGLIST)) + || NILP (AREF (tmp, COMPILED_ARGLIST))) + && ((STRINGP (AREF (tmp, COMPILED_BYTECODE)) + && VECTORP (AREF (tmp, COMPILED_CONSTANTS))) + || CONSP (AREF (tmp, COMPILED_BYTECODE))) + && FIXNATP (AREF (tmp, COMPILED_STACK_DEPTH)))) + invalid_syntax ("Invalid byte-code object", readcharfun); + + if (STRINGP (AREF (tmp, COMPILED_BYTECODE)) + && STRING_MULTIBYTE (AREF (tmp, COMPILED_BYTECODE))) + { + /* BYTESTR must have been produced by Emacs 20.2 or earlier + because it produced a raw 8-bit string for byte-code and + now such a byte-code string is loaded as multibyte with + raw 8-bit characters converted to multibyte form. + Convert them back to the original unibyte form. */ + ASET (tmp, COMPILED_BYTECODE, + Fstring_as_unibyte (AREF (tmp, COMPILED_BYTECODE))); + } + + if (COMPILED_DOC_STRING < ASIZE (tmp) + && EQ (AREF (tmp, COMPILED_DOC_STRING), make_fixnum (0))) + { + /* read_list found a docstring like '(#$ . 5521)' and treated it + as 0. This placeholder 0 would lead to accidental sharing in + purecopy's hash-consing, so replace it with a (hopefully) + unique integer placeholder, which is negative so that it is + not confused with a DOC file offset (the USE_LSB_TAG shift + relies on the fact that VALMASK is one bit narrower than + INTMASK). Eventually Snarf-documentation should replace the + placeholder with the actual docstring. */ + verify (INTMASK & ~VALMASK); + EMACS_UINT hash = ((XHASH (tmp) >> USE_LSB_TAG) + | (INTMASK - INTMASK / 2)); + ASET (tmp, COMPILED_DOC_STRING, make_ufixnum (hash)); + } + + XSETPVECTYPE (vec, PVEC_COMPILED); return tmp; } if (c == '(') @@ -2996,7 +3072,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) /* Read the string itself. */ tmp = read1 (readcharfun, &ch, 0); if (ch != 0 || !STRINGP (tmp)) - invalid_syntax ("#"); + invalid_syntax ("#", readcharfun); /* Read the intervals and their properties. */ while (1) { @@ -3011,7 +3087,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (ch == 0) plist = read1 (readcharfun, &ch, 0); if (ch) - invalid_syntax ("Invalid string property list"); + invalid_syntax ("Invalid string property list", readcharfun); Fset_text_properties (beg, end, plist, tmp); } @@ -3159,7 +3235,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (c == 'r' || c == 'R') { if (! (2 <= n && n <= 36)) - invalid_radix_integer (n, stackbuf); + invalid_radix_integer (n, stackbuf, readcharfun); return read_integer (readcharfun, n, stackbuf); } @@ -3253,7 +3329,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) return read_integer (readcharfun, 2, stackbuf); UNREAD (c); - invalid_syntax ("#"); + invalid_syntax ("#", readcharfun); case ';': while ((c = READCHAR) >= 0 && c != '\n'); @@ -3263,70 +3339,24 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) return list2 (Qquote, read0 (readcharfun)); case '`': - { - int next_char = READCHAR; - UNREAD (next_char); - /* Transition from old-style to new-style: - If we see "(`" it used to mean old-style, which usually works - fine because ` should almost never appear in such a position - for new-style. But occasionally we need "(`" to mean new - style, so we try to distinguish the two by the fact that we - can either write "( `foo" or "(` foo", where the first - intends to use new-style whereas the second intends to use - old-style. For Emacs-25, we should completely remove this - first_in_list exception (old-style can still be obtained via - "(\`" anyway). */ - if (!new_backquote_flag && first_in_list && next_char == ' ') - load_error_old_style_backquotes (); - else - { - Lisp_Object value; - bool saved_new_backquote_flag = new_backquote_flag; - - new_backquote_flag = 1; - value = read0 (readcharfun); - new_backquote_flag = saved_new_backquote_flag; + return list2 (Qbackquote, read0 (readcharfun)); - return list2 (Qbackquote, value); - } - } case ',': { - int next_char = READCHAR; - UNREAD (next_char); - /* Transition from old-style to new-style: - It used to be impossible to have a new-style , other than within - a new-style `. This is sufficient when ` and , are used in the - normal way, but ` and , can also appear in args to macros that - will not interpret them in the usual way, in which case , may be - used without any ` anywhere near. - So we now use the same heuristic as for backquote: old-style - unquotes are only recognized when first on a list, and when - followed by a space. - Because it's more difficult to peek 2 chars ahead, a new-style - ,@ can still not be used outside of a `, unless it's in the middle - of a list. */ - if (new_backquote_flag - || !first_in_list - || (next_char != ' ' && next_char != '@')) - { - Lisp_Object comma_type = Qnil; - Lisp_Object value; - int ch = READCHAR; + Lisp_Object comma_type = Qnil; + Lisp_Object value; + int ch = READCHAR; - if (ch == '@') - comma_type = Qcomma_at; - else - { - if (ch >= 0) UNREAD (ch); - comma_type = Qcomma; - } - - value = read0 (readcharfun); - return list2 (comma_type, value); - } + if (ch == '@') + comma_type = Qcomma_at; else - load_error_old_style_backquotes (); + { + if (ch >= 0) UNREAD (ch); + comma_type = Qcomma; + } + + value = read0 (readcharfun); + return list2 (comma_type, value); } case '?': { @@ -3371,7 +3401,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (ok) return make_fixnum (c); - invalid_syntax ("?"); + invalid_syntax ("?", readcharfun); } case '"': @@ -3457,7 +3487,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) /* Any modifiers remaining are invalid. */ if (modifiers) - error ("Invalid modifier in string"); + invalid_syntax ("Invalid modifier in string", readcharfun); p += CHAR_STRING (ch, (unsigned char *) p); } else @@ -3869,10 +3899,12 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag) { Lisp_Object tem = read_list (1, readcharfun); ptrdiff_t size = list_length (tem); - if (bytecodeflag && size <= COMPILED_STACK_DEPTH) - error ("Invalid byte code"); Lisp_Object vector = make_nil_vector (size); + /* Avoid accessing past the end of a vector if the vector is too + small to be valid for bytecode. */ + bytecodeflag &= COMPILED_STACK_DEPTH < size; + Lisp_Object *ptr = XVECTOR (vector)->contents; for (ptrdiff_t i = 0; i < size; i++) { @@ -3995,7 +4027,7 @@ read_list (bool flag, Lisp_Object readcharfun) { if (ch == ']') return val; - invalid_syntax (") or . in a vector"); + invalid_syntax (") or . in a vector", readcharfun); } if (ch == ')') return val; @@ -4075,9 +4107,9 @@ read_list (bool flag, Lisp_Object readcharfun) return val; } - invalid_syntax (". in wrong context"); + invalid_syntax (". in wrong context", readcharfun); } - invalid_syntax ("] in a list"); + invalid_syntax ("] in a list", readcharfun); } tem = list1 (elt); if (!NILP (tail)) @@ -4128,6 +4160,9 @@ intern_sym (Lisp_Object sym, Lisp_Object obarray, Lisp_Object index) { make_symbol_constant (sym); XSYMBOL (sym)->u.s.redirect = SYMBOL_PLAINVAL; + /* Mark keywords as special. This makes (let ((:key 'foo)) ...) + in lexically bound elisp signal an error, as documented. */ + XSYMBOL (sym)->u.s.declared_special = true; SET_SYMBOL_VAL (XSYMBOL (sym), sym); } @@ -4856,9 +4891,16 @@ This list should not include the empty string. `load' and related functions try to append these suffixes, in order, to the specified file name if a suffix is allowed or required. */); #ifdef HAVE_MODULES +#ifdef MODULES_SECONDARY_SUFFIX + Vload_suffixes = list4 (build_pure_c_string (".elc"), + build_pure_c_string (".el"), + build_pure_c_string (MODULES_SUFFIX), + build_pure_c_string (MODULES_SECONDARY_SUFFIX)); +#else Vload_suffixes = list3 (build_pure_c_string (".elc"), build_pure_c_string (".el"), build_pure_c_string (MODULES_SUFFIX)); +#endif #else Vload_suffixes = list2 (build_pure_c_string (".elc"), build_pure_c_string (".el")); @@ -5007,7 +5049,7 @@ This overrides the value of the NOMESSAGE argument to `load'. */); When Emacs loads a compiled Lisp file, it reads the first 512 bytes from the file, and matches them against this regular expression. When the regular expression matches, the file is considered to be safe -to load. See also `load-dangerous-libraries'. */); +to load. */); Vbytecomp_version_regexp = build_pure_c_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)"); @@ -5050,17 +5092,6 @@ Note that if you customize this, obviously it will not affect files that are loaded before your customizations are read! */); load_prefer_newer = 0; - DEFVAR_BOOL ("force-new-style-backquotes", force_new_style_backquotes, - doc: /* Non-nil means to always use the current syntax for backquotes. -If nil, `load' and `read' raise errors when encountering some -old-style variants of backquote and comma. If non-nil, these -constructs are always interpreted as described in the Info node -`(elisp)Backquote', even if that interpretation is incompatible with -previous versions of Emacs. Setting this variable to non-nil makes -Emacs compatible with the behavior planned for Emacs 28. In Emacs 28, -this variable will become obsolete. */); - force_new_style_backquotes = false; - /* Vsource_directory was initialized in init_lread. */ DEFSYM (Qcurrent_load_list, "current-load-list"); diff --git a/src/macfont.m b/src/macfont.m index 0c552e1c1d8..d86f09f4850 100644 --- a/src/macfont.m +++ b/src/macfont.m @@ -1120,13 +1120,17 @@ struct macfont_metrics glyph width. The `width_int' member is an integer that is closest to the width. The `width_frac' member is the fractional adjustment representing a value in [-.5, .5], multiplied by - WIDTH_FRAC_SCALE. For synthetic monospace fonts, they represent + WIDTH_FRAC_SCALE. For monospace fonts, non-zero `width_frac' + means `width_int' is further adjusted to a multiple of the + (rounded) font width, and `width_frac' represents adjustment per + unit character. For synthetic monospace fonts, they represent the advance delta for centering instead of the glyph width. */ signed width_frac : WIDTH_FRAC_BITS, width_int : 16 - WIDTH_FRAC_BITS; }; #define METRICS_VALUE(metrics, member) \ - (((metrics)->member##_high << 8) | (metrics)->member##_low) + ((int) (((unsigned int) (metrics)->member##_high << 8) \ + | (metrics)->member##_low)) #define METRICS_SET_VALUE(metrics, member, value) \ do {short tmp = (value); (metrics)->member##_low = tmp & 0xff; \ (metrics)->member##_high = tmp >> 8;} while (0) @@ -1147,6 +1151,27 @@ enum metrics_status #define LCD_FONT_SMOOTHING_LEFT_MARGIN (0.396f) #define LCD_FONT_SMOOTHING_RIGHT_MARGIN (0.396f) +/* If FONT is monospace and WIDTH can be regarded as a multiple of its + width where the multiplier is greater than 1, then return the + multiplier. Otherwise return 0. */ +static int +macfont_monospace_width_multiplier (struct font *font, CGFloat width) +{ + struct macfont_info *macfont_info = (struct macfont_info *) font; + int multiplier = 0; + + if (macfont_info->spacing == MACFONT_SPACING_MONO + && font->space_width != 0) + { + multiplier = lround (width / font->space_width); + if (multiplier == 1 + || lround (width / multiplier) != font->space_width) + multiplier = 0; + } + + return multiplier; +} + static int macfont_glyph_extents (struct font *font, CGGlyph glyph, struct font_metrics *metrics, CGFloat *advance_delta, @@ -1191,13 +1216,38 @@ macfont_glyph_extents (struct font *font, CGGlyph glyph, else fwidth = mac_font_get_advance_width_for_glyph (macfont, glyph); - /* For synthetic mono fonts, cache->width_{int,frac} holds the - advance delta value. */ - if (macfont_info->spacing == MACFONT_SPACING_SYNTHETIC_MONO) - fwidth = (font->pixel_size - fwidth) / 2; - cache->width_int = lround (fwidth); - cache->width_frac = lround ((fwidth - cache->width_int) - * WIDTH_FRAC_SCALE); + if (macfont_info->spacing == MACFONT_SPACING_MONO) + { + /* Some monospace fonts for programming languages contain + wider ligature glyphs consisting of multiple characters. + For such glyphs, simply rounding the combined fractional + width to an integer can result in a value that is not a + multiple of the (rounded) font width. */ + int multiplier = macfont_monospace_width_multiplier (font, fwidth); + + if (multiplier) + { + cache->width_int = font->space_width * multiplier; + cache->width_frac = lround ((fwidth / multiplier + - font->space_width) + * WIDTH_FRAC_SCALE); + } + else + { + cache->width_int = lround (fwidth); + cache->width_frac = 0; + } + } + else + { + /* For synthetic mono fonts, cache->width_{int,frac} holds + the advance delta value. */ + if (macfont_info->spacing == MACFONT_SPACING_SYNTHETIC_MONO) + fwidth = (font->pixel_size - fwidth) / 2; + cache->width_int = lround (fwidth); + cache->width_frac = lround ((fwidth - cache->width_int) + * WIDTH_FRAC_SCALE); + } METRICS_SET_STATUS (cache, METRICS_WIDTH_VALID); } if (macfont_info->spacing == MACFONT_SPACING_SYNTHETIC_MONO) @@ -1234,6 +1284,10 @@ macfont_glyph_extents (struct font *font, CGGlyph glyph, / (CGFloat) (WIDTH_FRAC_SCALE * 2)); break; case MACFONT_SPACING_MONO: + if (cache->width_frac) + bounds.origin.x += - ((cache->width_frac + / (CGFloat) (WIDTH_FRAC_SCALE * 2)) + * (cache->width_int / font->space_width)); break; case MACFONT_SPACING_SYNTHETIC_MONO: bounds.origin.x += (cache->width_int @@ -1270,7 +1324,16 @@ macfont_glyph_extents (struct font *font, CGGlyph glyph, / (CGFloat) (WIDTH_FRAC_SCALE * 2))); break; case MACFONT_SPACING_MONO: - *advance_delta = 0; + if (cache->width_frac) + *advance_delta = 0; + else + { + CGFloat delta = - ((cache->width_frac + / (CGFloat) (WIDTH_FRAC_SCALE * 2)) + * (cache->width_int / font->space_width)); + + *advance_delta = (force_integral_p ? round (delta) : delta); + } break; case MACFONT_SPACING_SYNTHETIC_MONO: *advance_delta = (force_integral_p ? cache->width_int @@ -3014,7 +3077,7 @@ macfont_shape (Lisp_Object lgstring, Lisp_Object direction) struct mac_glyph_layout *gl = glyph_layouts + i; EMACS_INT from, to; struct font_metrics metrics; - int xoff, yoff, wadjust; + int xoff, yoff, wadjust, multiplier; if (NILP (lglyph)) { @@ -3067,13 +3130,15 @@ macfont_shape (Lisp_Object lgstring, Lisp_Object direction) xoff = lround (gl->advance_delta); yoff = lround (- gl->baseline_delta); - wadjust = lround (gl->advance); + multiplier = macfont_monospace_width_multiplier (font, gl->advance); + if (multiplier) + wadjust = font->space_width * multiplier; + else + wadjust = lround (gl->advance); if (xoff != 0 || yoff != 0 || wadjust != metrics.width) { - Lisp_Object vec = make_uninit_vector (3); - ASET (vec, 0, make_fixnum (xoff)); - ASET (vec, 1, make_fixnum (yoff)); - ASET (vec, 2, make_fixnum (wadjust)); + Lisp_Object vec = CALLN (Fvector, make_fixnum (xoff), + make_fixnum (yoff), make_fixnum (wadjust)); LGLYPH_SET_ADJUSTMENT (lglyph, vec); } } diff --git a/src/macros.c b/src/macros.c index c8ce94e63b1..60d0766a754 100644 --- a/src/macros.c +++ b/src/macros.c @@ -279,7 +279,10 @@ its function definition is used. COUNT is a repeat count, or nil for once, or 0 for infinite loop. Optional third arg LOOPFUNC may be a function that is called prior to -each iteration of the macro. Iteration stops if LOOPFUNC returns nil. */) +each iteration of the macro. Iteration stops if LOOPFUNC returns nil. + +The buffer shown in the currently selected window will be made the current +buffer before the macro is executed. */) (Lisp_Object macro, Lisp_Object count, Lisp_Object loopfunc) { Lisp_Object final; diff --git a/src/marker.c b/src/marker.c index e8103473d65..59791513170 100644 --- a/src/marker.c +++ b/src/marker.c @@ -221,7 +221,7 @@ buf_charpos_to_bytepos (struct buffer *b, ptrdiff_t charpos) while (best_below != charpos) { best_below++; - BUF_INC_POS (b, best_below_byte); + best_below_byte += buf_next_char_len (b, best_below_byte); } /* If this position is quite far from the nearest known position, @@ -246,7 +246,7 @@ buf_charpos_to_bytepos (struct buffer *b, ptrdiff_t charpos) while (best_above != charpos) { best_above--; - BUF_DEC_POS (b, best_above_byte); + best_above_byte -= buf_prev_char_len (b, best_above_byte); } /* If this position is quite far from the nearest known position, @@ -372,7 +372,7 @@ buf_bytepos_to_charpos (struct buffer *b, ptrdiff_t bytepos) while (best_below_byte < bytepos) { best_below++; - BUF_INC_POS (b, best_below_byte); + best_below_byte += buf_next_char_len (b, best_below_byte); } /* If this position is quite far from the nearest known position, @@ -399,7 +399,7 @@ buf_bytepos_to_charpos (struct buffer *b, ptrdiff_t bytepos) while (best_above_byte > bytepos) { best_above--; - BUF_DEC_POS (b, best_above_byte); + best_above_byte -= buf_prev_char_len (b, best_above_byte); } /* If this position is quite far from the nearest known position, @@ -804,7 +804,7 @@ verify_bytepos (ptrdiff_t charpos) while (below != charpos) { below++; - BUF_INC_POS (current_buffer, below_byte); + below_byte += buf_next_char_len (current_buffer, below_byte); } return below_byte; diff --git a/src/menu.c b/src/menu.c index 693986bec7d..3b1d7402571 100644 --- a/src/menu.c +++ b/src/menu.c @@ -1036,9 +1036,7 @@ menu_item_width (const unsigned char *str) for (len = 0, p = str; *p; ) { - int ch_len; - int ch = STRING_CHAR_AND_LENGTH (p, ch_len); - + int ch_len, ch = string_char_and_length (p, &ch_len); len += CHARACTER_WIDTH (ch); p += ch_len; } @@ -1253,18 +1251,16 @@ x_popup_menu_1 (Lisp_Object position, Lisp_Object menu) but I don't want to make one now. */ CHECK_WINDOW (window); - CHECK_RANGED_INTEGER (x, - (xpos < INT_MIN - MOST_NEGATIVE_FIXNUM - ? (EMACS_INT) INT_MIN - xpos - : MOST_NEGATIVE_FIXNUM), - INT_MAX - xpos); - CHECK_RANGED_INTEGER (y, - (ypos < INT_MIN - MOST_NEGATIVE_FIXNUM - ? (EMACS_INT) INT_MIN - ypos - : MOST_NEGATIVE_FIXNUM), - INT_MAX - ypos); - xpos += XFIXNUM (x); - ypos += XFIXNUM (y); + xpos += check_integer_range (x, + (xpos < INT_MIN - MOST_NEGATIVE_FIXNUM + ? (EMACS_INT) INT_MIN - xpos + : MOST_NEGATIVE_FIXNUM), + INT_MAX - xpos); + ypos += check_integer_range (y, + (ypos < INT_MIN - MOST_NEGATIVE_FIXNUM + ? (EMACS_INT) INT_MIN - ypos + : MOST_NEGATIVE_FIXNUM), + INT_MAX - ypos); XSETFRAME (Vmenu_updating_frame, f); } diff --git a/src/mini-gmp-emacs.c b/src/mini-gmp-emacs.c deleted file mode 100644 index 943664a5aeb..00000000000 --- a/src/mini-gmp-emacs.c +++ /dev/null @@ -1,32 +0,0 @@ -/* Tailor mini-gmp.c for GNU Emacs - -Copyright 2018-2021 Free Software Foundation, Inc. - -This file is part of GNU Emacs. - -GNU Emacs is free software: you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation, either version 3 of the License, or (at -your option) any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ - -#include <config.h> - -#include <stddef.h> - -/* Pacify GCC -Wsuggest-attribute=malloc. */ -static void *gmp_default_alloc (size_t) ATTRIBUTE_MALLOC; - -/* Pacify GCC -Wunused-variable for variables used only in 'assert' calls. */ -#if defined NDEBUG && GNUC_PREREQ (4, 6, 0) -# pragma GCC diagnostic ignored "-Wunused-variable" -#endif - -#include "mini-gmp.c" diff --git a/src/mini-gmp.c b/src/mini-gmp.c deleted file mode 100644 index bf8a6164981..00000000000 --- a/src/mini-gmp.c +++ /dev/null @@ -1,4559 +0,0 @@ -/* mini-gmp, a minimalistic implementation of a GNU GMP subset. - - Contributed to the GNU project by Niels Möller - -Copyright 1991-1997, 1999-2019 Free Software Foundation, Inc. - -This file is part of the GNU MP Library. - -The GNU MP Library is free software; you can redistribute it and/or modify -it under the terms of either: - - * the GNU Lesser General Public License as published by the Free - Software Foundation; either version 3 of the License, or (at your - option) any later version. - -or - - * the GNU General Public License as published by the Free Software - Foundation; either version 2 of the License, or (at your option) any - later version. - -or both in parallel, as here. - -The GNU MP Library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received copies of the GNU General Public License and the -GNU Lesser General Public License along with the GNU MP Library. If not, -see https://www.gnu.org/licenses/. */ - -/* NOTE: All functions in this file which are not declared in - mini-gmp.h are internal, and are not intended to be compatible - neither with GMP nor with future versions of mini-gmp. */ - -/* Much of the material copied from GMP files, including: gmp-impl.h, - longlong.h, mpn/generic/add_n.c, mpn/generic/addmul_1.c, - mpn/generic/lshift.c, mpn/generic/mul_1.c, - mpn/generic/mul_basecase.c, mpn/generic/rshift.c, - mpn/generic/sbpi1_div_qr.c, mpn/generic/sub_n.c, - mpn/generic/submul_1.c. */ - -#include <assert.h> -#include <ctype.h> -#include <limits.h> -#include <stdio.h> -#include <stdlib.h> -#include <string.h> - -#include "mini-gmp.h" - -#if !defined(MINI_GMP_DONT_USE_FLOAT_H) -#include <float.h> -#endif - - -/* Macros */ -#define GMP_LIMB_BITS (sizeof(mp_limb_t) * CHAR_BIT) - -#define GMP_LIMB_MAX ((mp_limb_t) ~ (mp_limb_t) 0) -#define GMP_LIMB_HIGHBIT ((mp_limb_t) 1 << (GMP_LIMB_BITS - 1)) - -#define GMP_HLIMB_BIT ((mp_limb_t) 1 << (GMP_LIMB_BITS / 2)) -#define GMP_LLIMB_MASK (GMP_HLIMB_BIT - 1) - -#define GMP_ULONG_BITS (sizeof(unsigned long) * CHAR_BIT) -#define GMP_ULONG_HIGHBIT ((unsigned long) 1 << (GMP_ULONG_BITS - 1)) - -#define GMP_ABS(x) ((x) >= 0 ? (x) : -(x)) -#define GMP_NEG_CAST(T,x) (-((T)((x) + 1) - 1)) - -#define GMP_MIN(a, b) ((a) < (b) ? (a) : (b)) -#define GMP_MAX(a, b) ((a) > (b) ? (a) : (b)) - -#define GMP_CMP(a,b) (((a) > (b)) - ((a) < (b))) - -#if defined(DBL_MANT_DIG) && FLT_RADIX == 2 -#define GMP_DBL_MANT_BITS DBL_MANT_DIG -#else -#define GMP_DBL_MANT_BITS (53) -#endif - -/* Return non-zero if xp,xsize and yp,ysize overlap. - If xp+xsize<=yp there's no overlap, or if yp+ysize<=xp there's no - overlap. If both these are false, there's an overlap. */ -#define GMP_MPN_OVERLAP_P(xp, xsize, yp, ysize) \ - ((xp) + (xsize) > (yp) && (yp) + (ysize) > (xp)) - -#define gmp_assert_nocarry(x) do { \ - mp_limb_t __cy = (x); \ - assert (__cy == 0); \ - } while (0) - -#define gmp_clz(count, x) do { \ - mp_limb_t __clz_x = (x); \ - unsigned __clz_c; \ - for (__clz_c = 0; \ - (__clz_x & ((mp_limb_t) 0xff << (GMP_LIMB_BITS - 8))) == 0; \ - __clz_c += 8) \ - __clz_x <<= 8; \ - for (; (__clz_x & GMP_LIMB_HIGHBIT) == 0; __clz_c++) \ - __clz_x <<= 1; \ - (count) = __clz_c; \ - } while (0) - -#define gmp_ctz(count, x) do { \ - mp_limb_t __ctz_x = (x); \ - unsigned __ctz_c = 0; \ - gmp_clz (__ctz_c, __ctz_x & - __ctz_x); \ - (count) = GMP_LIMB_BITS - 1 - __ctz_c; \ - } while (0) - -#define gmp_add_ssaaaa(sh, sl, ah, al, bh, bl) \ - do { \ - mp_limb_t __x; \ - __x = (al) + (bl); \ - (sh) = (ah) + (bh) + (__x < (al)); \ - (sl) = __x; \ - } while (0) - -#define gmp_sub_ddmmss(sh, sl, ah, al, bh, bl) \ - do { \ - mp_limb_t __x; \ - __x = (al) - (bl); \ - (sh) = (ah) - (bh) - ((al) < (bl)); \ - (sl) = __x; \ - } while (0) - -#define gmp_umul_ppmm(w1, w0, u, v) \ - do { \ - int LOCAL_GMP_LIMB_BITS = GMP_LIMB_BITS; \ - if (sizeof(unsigned int) * CHAR_BIT >= 2 * GMP_LIMB_BITS) \ - { \ - unsigned int __ww = (unsigned int) (u) * (v); \ - w0 = (mp_limb_t) __ww; \ - w1 = (mp_limb_t) (__ww >> LOCAL_GMP_LIMB_BITS); \ - } \ - else if (GMP_ULONG_BITS >= 2 * GMP_LIMB_BITS) \ - { \ - unsigned long int __ww = (unsigned long int) (u) * (v); \ - w0 = (mp_limb_t) __ww; \ - w1 = (mp_limb_t) (__ww >> LOCAL_GMP_LIMB_BITS); \ - } \ - else { \ - mp_limb_t __x0, __x1, __x2, __x3; \ - unsigned __ul, __vl, __uh, __vh; \ - mp_limb_t __u = (u), __v = (v); \ - \ - __ul = __u & GMP_LLIMB_MASK; \ - __uh = __u >> (GMP_LIMB_BITS / 2); \ - __vl = __v & GMP_LLIMB_MASK; \ - __vh = __v >> (GMP_LIMB_BITS / 2); \ - \ - __x0 = (mp_limb_t) __ul * __vl; \ - __x1 = (mp_limb_t) __ul * __vh; \ - __x2 = (mp_limb_t) __uh * __vl; \ - __x3 = (mp_limb_t) __uh * __vh; \ - \ - __x1 += __x0 >> (GMP_LIMB_BITS / 2);/* this can't give carry */ \ - __x1 += __x2; /* but this indeed can */ \ - if (__x1 < __x2) /* did we get it? */ \ - __x3 += GMP_HLIMB_BIT; /* yes, add it in the proper pos. */ \ - \ - (w1) = __x3 + (__x1 >> (GMP_LIMB_BITS / 2)); \ - (w0) = (__x1 << (GMP_LIMB_BITS / 2)) + (__x0 & GMP_LLIMB_MASK); \ - } \ - } while (0) - -#define gmp_udiv_qrnnd_preinv(q, r, nh, nl, d, di) \ - do { \ - mp_limb_t _qh, _ql, _r, _mask; \ - gmp_umul_ppmm (_qh, _ql, (nh), (di)); \ - gmp_add_ssaaaa (_qh, _ql, _qh, _ql, (nh) + 1, (nl)); \ - _r = (nl) - _qh * (d); \ - _mask = -(mp_limb_t) (_r > _ql); /* both > and >= are OK */ \ - _qh += _mask; \ - _r += _mask & (d); \ - if (_r >= (d)) \ - { \ - _r -= (d); \ - _qh++; \ - } \ - \ - (r) = _r; \ - (q) = _qh; \ - } while (0) - -#define gmp_udiv_qr_3by2(q, r1, r0, n2, n1, n0, d1, d0, dinv) \ - do { \ - mp_limb_t _q0, _t1, _t0, _mask; \ - gmp_umul_ppmm ((q), _q0, (n2), (dinv)); \ - gmp_add_ssaaaa ((q), _q0, (q), _q0, (n2), (n1)); \ - \ - /* Compute the two most significant limbs of n - q'd */ \ - (r1) = (n1) - (d1) * (q); \ - gmp_sub_ddmmss ((r1), (r0), (r1), (n0), (d1), (d0)); \ - gmp_umul_ppmm (_t1, _t0, (d0), (q)); \ - gmp_sub_ddmmss ((r1), (r0), (r1), (r0), _t1, _t0); \ - (q)++; \ - \ - /* Conditionally adjust q and the remainders */ \ - _mask = - (mp_limb_t) ((r1) >= _q0); \ - (q) += _mask; \ - gmp_add_ssaaaa ((r1), (r0), (r1), (r0), _mask & (d1), _mask & (d0)); \ - if ((r1) >= (d1)) \ - { \ - if ((r1) > (d1) || (r0) >= (d0)) \ - { \ - (q)++; \ - gmp_sub_ddmmss ((r1), (r0), (r1), (r0), (d1), (d0)); \ - } \ - } \ - } while (0) - -/* Swap macros. */ -#define MP_LIMB_T_SWAP(x, y) \ - do { \ - mp_limb_t __mp_limb_t_swap__tmp = (x); \ - (x) = (y); \ - (y) = __mp_limb_t_swap__tmp; \ - } while (0) -#define MP_SIZE_T_SWAP(x, y) \ - do { \ - mp_size_t __mp_size_t_swap__tmp = (x); \ - (x) = (y); \ - (y) = __mp_size_t_swap__tmp; \ - } while (0) -#define MP_BITCNT_T_SWAP(x,y) \ - do { \ - mp_bitcnt_t __mp_bitcnt_t_swap__tmp = (x); \ - (x) = (y); \ - (y) = __mp_bitcnt_t_swap__tmp; \ - } while (0) -#define MP_PTR_SWAP(x, y) \ - do { \ - mp_ptr __mp_ptr_swap__tmp = (x); \ - (x) = (y); \ - (y) = __mp_ptr_swap__tmp; \ - } while (0) -#define MP_SRCPTR_SWAP(x, y) \ - do { \ - mp_srcptr __mp_srcptr_swap__tmp = (x); \ - (x) = (y); \ - (y) = __mp_srcptr_swap__tmp; \ - } while (0) - -#define MPN_PTR_SWAP(xp,xs, yp,ys) \ - do { \ - MP_PTR_SWAP (xp, yp); \ - MP_SIZE_T_SWAP (xs, ys); \ - } while(0) -#define MPN_SRCPTR_SWAP(xp,xs, yp,ys) \ - do { \ - MP_SRCPTR_SWAP (xp, yp); \ - MP_SIZE_T_SWAP (xs, ys); \ - } while(0) - -#define MPZ_PTR_SWAP(x, y) \ - do { \ - mpz_ptr __mpz_ptr_swap__tmp = (x); \ - (x) = (y); \ - (y) = __mpz_ptr_swap__tmp; \ - } while (0) -#define MPZ_SRCPTR_SWAP(x, y) \ - do { \ - mpz_srcptr __mpz_srcptr_swap__tmp = (x); \ - (x) = (y); \ - (y) = __mpz_srcptr_swap__tmp; \ - } while (0) - -const int mp_bits_per_limb = GMP_LIMB_BITS; - - -/* Memory allocation and other helper functions. */ -static void -gmp_die (const char *msg) -{ - fprintf (stderr, "%s\n", msg); - abort(); -} - -static void * -gmp_default_alloc (size_t size) -{ - void *p; - - assert (size > 0); - - p = malloc (size); - if (!p) - gmp_die("gmp_default_alloc: Virtual memory exhausted."); - - return p; -} - -static void * -gmp_default_realloc (void *old, size_t unused_old_size, size_t new_size) -{ - void * p; - - p = realloc (old, new_size); - - if (!p) - gmp_die("gmp_default_realloc: Virtual memory exhausted."); - - return p; -} - -static void -gmp_default_free (void *p, size_t unused_size) -{ - free (p); -} - -static void * (*gmp_allocate_func) (size_t) = gmp_default_alloc; -static void * (*gmp_reallocate_func) (void *, size_t, size_t) = gmp_default_realloc; -static void (*gmp_free_func) (void *, size_t) = gmp_default_free; - -void -mp_get_memory_functions (void *(**alloc_func) (size_t), - void *(**realloc_func) (void *, size_t, size_t), - void (**free_func) (void *, size_t)) -{ - if (alloc_func) - *alloc_func = gmp_allocate_func; - - if (realloc_func) - *realloc_func = gmp_reallocate_func; - - if (free_func) - *free_func = gmp_free_func; -} - -void -mp_set_memory_functions (void *(*alloc_func) (size_t), - void *(*realloc_func) (void *, size_t, size_t), - void (*free_func) (void *, size_t)) -{ - if (!alloc_func) - alloc_func = gmp_default_alloc; - if (!realloc_func) - realloc_func = gmp_default_realloc; - if (!free_func) - free_func = gmp_default_free; - - gmp_allocate_func = alloc_func; - gmp_reallocate_func = realloc_func; - gmp_free_func = free_func; -} - -#define gmp_xalloc(size) ((*gmp_allocate_func)((size))) -#define gmp_free(p) ((*gmp_free_func) ((p), 0)) - -static mp_ptr -gmp_xalloc_limbs (mp_size_t size) -{ - return (mp_ptr) gmp_xalloc (size * sizeof (mp_limb_t)); -} - -static mp_ptr -gmp_xrealloc_limbs (mp_ptr old, mp_size_t size) -{ - assert (size > 0); - return (mp_ptr) (*gmp_reallocate_func) (old, 0, size * sizeof (mp_limb_t)); -} - - -/* MPN interface */ - -void -mpn_copyi (mp_ptr d, mp_srcptr s, mp_size_t n) -{ - mp_size_t i; - for (i = 0; i < n; i++) - d[i] = s[i]; -} - -void -mpn_copyd (mp_ptr d, mp_srcptr s, mp_size_t n) -{ - while (--n >= 0) - d[n] = s[n]; -} - -int -mpn_cmp (mp_srcptr ap, mp_srcptr bp, mp_size_t n) -{ - while (--n >= 0) - { - if (ap[n] != bp[n]) - return ap[n] > bp[n] ? 1 : -1; - } - return 0; -} - -static int -mpn_cmp4 (mp_srcptr ap, mp_size_t an, mp_srcptr bp, mp_size_t bn) -{ - if (an != bn) - return an < bn ? -1 : 1; - else - return mpn_cmp (ap, bp, an); -} - -static mp_size_t -mpn_normalized_size (mp_srcptr xp, mp_size_t n) -{ - while (n > 0 && xp[n-1] == 0) - --n; - return n; -} - -int -mpn_zero_p(mp_srcptr rp, mp_size_t n) -{ - return mpn_normalized_size (rp, n) == 0; -} - -void -mpn_zero (mp_ptr rp, mp_size_t n) -{ - while (--n >= 0) - rp[n] = 0; -} - -mp_limb_t -mpn_add_1 (mp_ptr rp, mp_srcptr ap, mp_size_t n, mp_limb_t b) -{ - mp_size_t i; - - assert (n > 0); - i = 0; - do - { - mp_limb_t r = ap[i] + b; - /* Carry out */ - b = (r < b); - rp[i] = r; - } - while (++i < n); - - return b; -} - -mp_limb_t -mpn_add_n (mp_ptr rp, mp_srcptr ap, mp_srcptr bp, mp_size_t n) -{ - mp_size_t i; - mp_limb_t cy; - - for (i = 0, cy = 0; i < n; i++) - { - mp_limb_t a, b, r; - a = ap[i]; b = bp[i]; - r = a + cy; - cy = (r < cy); - r += b; - cy += (r < b); - rp[i] = r; - } - return cy; -} - -mp_limb_t -mpn_add (mp_ptr rp, mp_srcptr ap, mp_size_t an, mp_srcptr bp, mp_size_t bn) -{ - mp_limb_t cy; - - assert (an >= bn); - - cy = mpn_add_n (rp, ap, bp, bn); - if (an > bn) - cy = mpn_add_1 (rp + bn, ap + bn, an - bn, cy); - return cy; -} - -mp_limb_t -mpn_sub_1 (mp_ptr rp, mp_srcptr ap, mp_size_t n, mp_limb_t b) -{ - mp_size_t i; - - assert (n > 0); - - i = 0; - do - { - mp_limb_t a = ap[i]; - /* Carry out */ - mp_limb_t cy = a < b; - rp[i] = a - b; - b = cy; - } - while (++i < n); - - return b; -} - -mp_limb_t -mpn_sub_n (mp_ptr rp, mp_srcptr ap, mp_srcptr bp, mp_size_t n) -{ - mp_size_t i; - mp_limb_t cy; - - for (i = 0, cy = 0; i < n; i++) - { - mp_limb_t a, b; - a = ap[i]; b = bp[i]; - b += cy; - cy = (b < cy); - cy += (a < b); - rp[i] = a - b; - } - return cy; -} - -mp_limb_t -mpn_sub (mp_ptr rp, mp_srcptr ap, mp_size_t an, mp_srcptr bp, mp_size_t bn) -{ - mp_limb_t cy; - - assert (an >= bn); - - cy = mpn_sub_n (rp, ap, bp, bn); - if (an > bn) - cy = mpn_sub_1 (rp + bn, ap + bn, an - bn, cy); - return cy; -} - -mp_limb_t -mpn_mul_1 (mp_ptr rp, mp_srcptr up, mp_size_t n, mp_limb_t vl) -{ - mp_limb_t ul, cl, hpl, lpl; - - assert (n >= 1); - - cl = 0; - do - { - ul = *up++; - gmp_umul_ppmm (hpl, lpl, ul, vl); - - lpl += cl; - cl = (lpl < cl) + hpl; - - *rp++ = lpl; - } - while (--n != 0); - - return cl; -} - -mp_limb_t -mpn_addmul_1 (mp_ptr rp, mp_srcptr up, mp_size_t n, mp_limb_t vl) -{ - mp_limb_t ul, cl, hpl, lpl, rl; - - assert (n >= 1); - - cl = 0; - do - { - ul = *up++; - gmp_umul_ppmm (hpl, lpl, ul, vl); - - lpl += cl; - cl = (lpl < cl) + hpl; - - rl = *rp; - lpl = rl + lpl; - cl += lpl < rl; - *rp++ = lpl; - } - while (--n != 0); - - return cl; -} - -mp_limb_t -mpn_submul_1 (mp_ptr rp, mp_srcptr up, mp_size_t n, mp_limb_t vl) -{ - mp_limb_t ul, cl, hpl, lpl, rl; - - assert (n >= 1); - - cl = 0; - do - { - ul = *up++; - gmp_umul_ppmm (hpl, lpl, ul, vl); - - lpl += cl; - cl = (lpl < cl) + hpl; - - rl = *rp; - lpl = rl - lpl; - cl += lpl > rl; - *rp++ = lpl; - } - while (--n != 0); - - return cl; -} - -mp_limb_t -mpn_mul (mp_ptr rp, mp_srcptr up, mp_size_t un, mp_srcptr vp, mp_size_t vn) -{ - assert (un >= vn); - assert (vn >= 1); - assert (!GMP_MPN_OVERLAP_P(rp, un + vn, up, un)); - assert (!GMP_MPN_OVERLAP_P(rp, un + vn, vp, vn)); - - /* We first multiply by the low order limb. This result can be - stored, not added, to rp. We also avoid a loop for zeroing this - way. */ - - rp[un] = mpn_mul_1 (rp, up, un, vp[0]); - - /* Now accumulate the product of up[] and the next higher limb from - vp[]. */ - - while (--vn >= 1) - { - rp += 1, vp += 1; - rp[un] = mpn_addmul_1 (rp, up, un, vp[0]); - } - return rp[un]; -} - -void -mpn_mul_n (mp_ptr rp, mp_srcptr ap, mp_srcptr bp, mp_size_t n) -{ - mpn_mul (rp, ap, n, bp, n); -} - -void -mpn_sqr (mp_ptr rp, mp_srcptr ap, mp_size_t n) -{ - mpn_mul (rp, ap, n, ap, n); -} - -mp_limb_t -mpn_lshift (mp_ptr rp, mp_srcptr up, mp_size_t n, unsigned int cnt) -{ - mp_limb_t high_limb, low_limb; - unsigned int tnc; - mp_limb_t retval; - - assert (n >= 1); - assert (cnt >= 1); - assert (cnt < GMP_LIMB_BITS); - - up += n; - rp += n; - - tnc = GMP_LIMB_BITS - cnt; - low_limb = *--up; - retval = low_limb >> tnc; - high_limb = (low_limb << cnt); - - while (--n != 0) - { - low_limb = *--up; - *--rp = high_limb | (low_limb >> tnc); - high_limb = (low_limb << cnt); - } - *--rp = high_limb; - - return retval; -} - -mp_limb_t -mpn_rshift (mp_ptr rp, mp_srcptr up, mp_size_t n, unsigned int cnt) -{ - mp_limb_t high_limb, low_limb; - unsigned int tnc; - mp_limb_t retval; - - assert (n >= 1); - assert (cnt >= 1); - assert (cnt < GMP_LIMB_BITS); - - tnc = GMP_LIMB_BITS - cnt; - high_limb = *up++; - retval = (high_limb << tnc); - low_limb = high_limb >> cnt; - - while (--n != 0) - { - high_limb = *up++; - *rp++ = low_limb | (high_limb << tnc); - low_limb = high_limb >> cnt; - } - *rp = low_limb; - - return retval; -} - -static mp_bitcnt_t -mpn_common_scan (mp_limb_t limb, mp_size_t i, mp_srcptr up, mp_size_t un, - mp_limb_t ux) -{ - unsigned cnt; - - assert (ux == 0 || ux == GMP_LIMB_MAX); - assert (0 <= i && i <= un ); - - while (limb == 0) - { - i++; - if (i == un) - return (ux == 0 ? ~(mp_bitcnt_t) 0 : un * GMP_LIMB_BITS); - limb = ux ^ up[i]; - } - gmp_ctz (cnt, limb); - return (mp_bitcnt_t) i * GMP_LIMB_BITS + cnt; -} - -mp_bitcnt_t -mpn_scan1 (mp_srcptr ptr, mp_bitcnt_t bit) -{ - mp_size_t i; - i = bit / GMP_LIMB_BITS; - - return mpn_common_scan ( ptr[i] & (GMP_LIMB_MAX << (bit % GMP_LIMB_BITS)), - i, ptr, i, 0); -} - -mp_bitcnt_t -mpn_scan0 (mp_srcptr ptr, mp_bitcnt_t bit) -{ - mp_size_t i; - i = bit / GMP_LIMB_BITS; - - return mpn_common_scan (~ptr[i] & (GMP_LIMB_MAX << (bit % GMP_LIMB_BITS)), - i, ptr, i, GMP_LIMB_MAX); -} - -void -mpn_com (mp_ptr rp, mp_srcptr up, mp_size_t n) -{ - while (--n >= 0) - *rp++ = ~ *up++; -} - -mp_limb_t -mpn_neg (mp_ptr rp, mp_srcptr up, mp_size_t n) -{ - while (*up == 0) - { - *rp = 0; - if (!--n) - return 0; - ++up; ++rp; - } - *rp = - *up; - mpn_com (++rp, ++up, --n); - return 1; -} - - -/* MPN division interface. */ - -/* The 3/2 inverse is defined as - - m = floor( (B^3-1) / (B u1 + u0)) - B -*/ -mp_limb_t -mpn_invert_3by2 (mp_limb_t u1, mp_limb_t u0) -{ - int GMP_LIMB_BITS_MUL_3 = GMP_LIMB_BITS * 3; - if (sizeof (unsigned) * CHAR_BIT > GMP_LIMB_BITS * 3) - { - return (((unsigned) 1 << GMP_LIMB_BITS_MUL_3) - 1) / - (((unsigned) u1 << GMP_LIMB_BITS_MUL_3 / 3) + u0); - } - else if (GMP_ULONG_BITS > GMP_LIMB_BITS * 3) - { - return (((unsigned long) 1 << GMP_LIMB_BITS_MUL_3) - 1) / - (((unsigned long) u1 << GMP_LIMB_BITS_MUL_3 / 3) + u0); - } - else { - mp_limb_t r, p, m, ql; - unsigned ul, uh, qh; - - assert (u1 >= GMP_LIMB_HIGHBIT); - - /* For notation, let b denote the half-limb base, so that B = b^2. - Split u1 = b uh + ul. */ - ul = u1 & GMP_LLIMB_MASK; - uh = u1 >> (GMP_LIMB_BITS / 2); - - /* Approximation of the high half of quotient. Differs from the 2/1 - inverse of the half limb uh, since we have already subtracted - u0. */ - qh = ~u1 / uh; - - /* Adjust to get a half-limb 3/2 inverse, i.e., we want - - qh' = floor( (b^3 - 1) / u) - b = floor ((b^3 - b u - 1) / u - = floor( (b (~u) + b-1) / u), - - and the remainder - - r = b (~u) + b-1 - qh (b uh + ul) - = b (~u - qh uh) + b-1 - qh ul - - Subtraction of qh ul may underflow, which implies adjustments. - But by normalization, 2 u >= B > qh ul, so we need to adjust by - at most 2. - */ - - r = ((~u1 - (mp_limb_t) qh * uh) << (GMP_LIMB_BITS / 2)) | GMP_LLIMB_MASK; - - p = (mp_limb_t) qh * ul; - /* Adjustment steps taken from udiv_qrnnd_c */ - if (r < p) - { - qh--; - r += u1; - if (r >= u1) /* i.e. we didn't get carry when adding to r */ - if (r < p) - { - qh--; - r += u1; - } - } - r -= p; - - /* Low half of the quotient is - - ql = floor ( (b r + b-1) / u1). - - This is a 3/2 division (on half-limbs), for which qh is a - suitable inverse. */ - - p = (r >> (GMP_LIMB_BITS / 2)) * qh + r; - /* Unlike full-limb 3/2, we can add 1 without overflow. For this to - work, it is essential that ql is a full mp_limb_t. */ - ql = (p >> (GMP_LIMB_BITS / 2)) + 1; - - /* By the 3/2 trick, we don't need the high half limb. */ - r = (r << (GMP_LIMB_BITS / 2)) + GMP_LLIMB_MASK - ql * u1; - - if (r >= (p << (GMP_LIMB_BITS / 2))) - { - ql--; - r += u1; - } - m = ((mp_limb_t) qh << (GMP_LIMB_BITS / 2)) + ql; - if (r >= u1) - { - m++; - r -= u1; - } - - /* Now m is the 2/1 inverse of u1. If u0 > 0, adjust it to become a - 3/2 inverse. */ - if (u0 > 0) - { - mp_limb_t th, tl; - r = ~r; - r += u0; - if (r < u0) - { - m--; - if (r >= u1) - { - m--; - r -= u1; - } - r -= u1; - } - gmp_umul_ppmm (th, tl, u0, m); - r += th; - if (r < th) - { - m--; - m -= ((r > u1) | ((r == u1) & (tl > u0))); - } - } - - return m; - } -} - -struct gmp_div_inverse -{ - /* Normalization shift count. */ - unsigned shift; - /* Normalized divisor (d0 unused for mpn_div_qr_1) */ - mp_limb_t d1, d0; - /* Inverse, for 2/1 or 3/2. */ - mp_limb_t di; -}; - -static void -mpn_div_qr_1_invert (struct gmp_div_inverse *inv, mp_limb_t d) -{ - unsigned shift; - - assert (d > 0); - gmp_clz (shift, d); - inv->shift = shift; - inv->d1 = d << shift; - inv->di = mpn_invert_limb (inv->d1); -} - -static void -mpn_div_qr_2_invert (struct gmp_div_inverse *inv, - mp_limb_t d1, mp_limb_t d0) -{ - unsigned shift; - - assert (d1 > 0); - gmp_clz (shift, d1); - inv->shift = shift; - if (shift > 0) - { - d1 = (d1 << shift) | (d0 >> (GMP_LIMB_BITS - shift)); - d0 <<= shift; - } - inv->d1 = d1; - inv->d0 = d0; - inv->di = mpn_invert_3by2 (d1, d0); -} - -static void -mpn_div_qr_invert (struct gmp_div_inverse *inv, - mp_srcptr dp, mp_size_t dn) -{ - assert (dn > 0); - - if (dn == 1) - mpn_div_qr_1_invert (inv, dp[0]); - else if (dn == 2) - mpn_div_qr_2_invert (inv, dp[1], dp[0]); - else - { - unsigned shift; - mp_limb_t d1, d0; - - d1 = dp[dn-1]; - d0 = dp[dn-2]; - assert (d1 > 0); - gmp_clz (shift, d1); - inv->shift = shift; - if (shift > 0) - { - d1 = (d1 << shift) | (d0 >> (GMP_LIMB_BITS - shift)); - d0 = (d0 << shift) | (dp[dn-3] >> (GMP_LIMB_BITS - shift)); - } - inv->d1 = d1; - inv->d0 = d0; - inv->di = mpn_invert_3by2 (d1, d0); - } -} - -/* Not matching current public gmp interface, rather corresponding to - the sbpi1_div_* functions. */ -static mp_limb_t -mpn_div_qr_1_preinv (mp_ptr qp, mp_srcptr np, mp_size_t nn, - const struct gmp_div_inverse *inv) -{ - mp_limb_t d, di; - mp_limb_t r; - mp_ptr tp = NULL; - - if (inv->shift > 0) - { - /* Shift, reusing qp area if possible. In-place shift if qp == np. */ - tp = qp ? qp : gmp_xalloc_limbs (nn); - r = mpn_lshift (tp, np, nn, inv->shift); - np = tp; - } - else - r = 0; - - d = inv->d1; - di = inv->di; - while (--nn >= 0) - { - mp_limb_t q; - - gmp_udiv_qrnnd_preinv (q, r, r, np[nn], d, di); - if (qp) - qp[nn] = q; - } - if ((inv->shift > 0) && (tp != qp)) - gmp_free (tp); - - return r >> inv->shift; -} - -static void -mpn_div_qr_2_preinv (mp_ptr qp, mp_ptr np, mp_size_t nn, - const struct gmp_div_inverse *inv) -{ - unsigned shift; - mp_size_t i; - mp_limb_t d1, d0, di, r1, r0; - - assert (nn >= 2); - shift = inv->shift; - d1 = inv->d1; - d0 = inv->d0; - di = inv->di; - - if (shift > 0) - r1 = mpn_lshift (np, np, nn, shift); - else - r1 = 0; - - r0 = np[nn - 1]; - - i = nn - 2; - do - { - mp_limb_t n0, q; - n0 = np[i]; - gmp_udiv_qr_3by2 (q, r1, r0, r1, r0, n0, d1, d0, di); - - if (qp) - qp[i] = q; - } - while (--i >= 0); - - if (shift > 0) - { - assert ((r0 & (GMP_LIMB_MAX >> (GMP_LIMB_BITS - shift))) == 0); - r0 = (r0 >> shift) | (r1 << (GMP_LIMB_BITS - shift)); - r1 >>= shift; - } - - np[1] = r1; - np[0] = r0; -} - -static void -mpn_div_qr_pi1 (mp_ptr qp, - mp_ptr np, mp_size_t nn, mp_limb_t n1, - mp_srcptr dp, mp_size_t dn, - mp_limb_t dinv) -{ - mp_size_t i; - - mp_limb_t d1, d0; - mp_limb_t cy, cy1; - mp_limb_t q; - - assert (dn > 2); - assert (nn >= dn); - - d1 = dp[dn - 1]; - d0 = dp[dn - 2]; - - assert ((d1 & GMP_LIMB_HIGHBIT) != 0); - /* Iteration variable is the index of the q limb. - * - * We divide <n1, np[dn-1+i], np[dn-2+i], np[dn-3+i],..., np[i]> - * by <d1, d0, dp[dn-3], ..., dp[0] > - */ - - i = nn - dn; - do - { - mp_limb_t n0 = np[dn-1+i]; - - if (n1 == d1 && n0 == d0) - { - q = GMP_LIMB_MAX; - mpn_submul_1 (np+i, dp, dn, q); - n1 = np[dn-1+i]; /* update n1, last loop's value will now be invalid */ - } - else - { - gmp_udiv_qr_3by2 (q, n1, n0, n1, n0, np[dn-2+i], d1, d0, dinv); - - cy = mpn_submul_1 (np + i, dp, dn-2, q); - - cy1 = n0 < cy; - n0 = n0 - cy; - cy = n1 < cy1; - n1 = n1 - cy1; - np[dn-2+i] = n0; - - if (cy != 0) - { - n1 += d1 + mpn_add_n (np + i, np + i, dp, dn - 1); - q--; - } - } - - if (qp) - qp[i] = q; - } - while (--i >= 0); - - np[dn - 1] = n1; -} - -static void -mpn_div_qr_preinv (mp_ptr qp, mp_ptr np, mp_size_t nn, - mp_srcptr dp, mp_size_t dn, - const struct gmp_div_inverse *inv) -{ - assert (dn > 0); - assert (nn >= dn); - - if (dn == 1) - np[0] = mpn_div_qr_1_preinv (qp, np, nn, inv); - else if (dn == 2) - mpn_div_qr_2_preinv (qp, np, nn, inv); - else - { - mp_limb_t nh; - unsigned shift; - - assert (inv->d1 == dp[dn-1]); - assert (inv->d0 == dp[dn-2]); - assert ((inv->d1 & GMP_LIMB_HIGHBIT) != 0); - - shift = inv->shift; - if (shift > 0) - nh = mpn_lshift (np, np, nn, shift); - else - nh = 0; - - mpn_div_qr_pi1 (qp, np, nn, nh, dp, dn, inv->di); - - if (shift > 0) - gmp_assert_nocarry (mpn_rshift (np, np, dn, shift)); - } -} - -static void -mpn_div_qr (mp_ptr qp, mp_ptr np, mp_size_t nn, mp_srcptr dp, mp_size_t dn) -{ - struct gmp_div_inverse inv; - mp_ptr tp = NULL; - - assert (dn > 0); - assert (nn >= dn); - - mpn_div_qr_invert (&inv, dp, dn); - if (dn > 2 && inv.shift > 0) - { - tp = gmp_xalloc_limbs (dn); - gmp_assert_nocarry (mpn_lshift (tp, dp, dn, inv.shift)); - dp = tp; - } - mpn_div_qr_preinv (qp, np, nn, dp, dn, &inv); - if (tp) - gmp_free (tp); -} - - -/* MPN base conversion. */ -static unsigned -mpn_base_power_of_two_p (unsigned b) -{ - switch (b) - { - case 2: return 1; - case 4: return 2; - case 8: return 3; - case 16: return 4; - case 32: return 5; - case 64: return 6; - case 128: return 7; - case 256: return 8; - default: return 0; - } -} - -struct mpn_base_info -{ - /* bb is the largest power of the base which fits in one limb, and - exp is the corresponding exponent. */ - unsigned exp; - mp_limb_t bb; -}; - -static void -mpn_get_base_info (struct mpn_base_info *info, mp_limb_t b) -{ - mp_limb_t m; - mp_limb_t p; - unsigned exp; - - m = GMP_LIMB_MAX / b; - for (exp = 1, p = b; p <= m; exp++) - p *= b; - - info->exp = exp; - info->bb = p; -} - -static mp_bitcnt_t -mpn_limb_size_in_base_2 (mp_limb_t u) -{ - unsigned shift; - - assert (u > 0); - gmp_clz (shift, u); - return GMP_LIMB_BITS - shift; -} - -static size_t -mpn_get_str_bits (unsigned char *sp, unsigned bits, mp_srcptr up, mp_size_t un) -{ - unsigned char mask; - size_t sn, j; - mp_size_t i; - unsigned shift; - - sn = ((un - 1) * GMP_LIMB_BITS + mpn_limb_size_in_base_2 (up[un-1]) - + bits - 1) / bits; - - mask = (1U << bits) - 1; - - for (i = 0, j = sn, shift = 0; j-- > 0;) - { - unsigned char digit = up[i] >> shift; - - shift += bits; - - if (shift >= GMP_LIMB_BITS && ++i < un) - { - shift -= GMP_LIMB_BITS; - digit |= up[i] << (bits - shift); - } - sp[j] = digit & mask; - } - return sn; -} - -/* We generate digits from the least significant end, and reverse at - the end. */ -static size_t -mpn_limb_get_str (unsigned char *sp, mp_limb_t w, - const struct gmp_div_inverse *binv) -{ - mp_size_t i; - for (i = 0; w > 0; i++) - { - mp_limb_t h, l, r; - - h = w >> (GMP_LIMB_BITS - binv->shift); - l = w << binv->shift; - - gmp_udiv_qrnnd_preinv (w, r, h, l, binv->d1, binv->di); - assert ((r & (GMP_LIMB_MAX >> (GMP_LIMB_BITS - binv->shift))) == 0); - r >>= binv->shift; - - sp[i] = r; - } - return i; -} - -static size_t -mpn_get_str_other (unsigned char *sp, - int base, const struct mpn_base_info *info, - mp_ptr up, mp_size_t un) -{ - struct gmp_div_inverse binv; - size_t sn; - size_t i; - - mpn_div_qr_1_invert (&binv, base); - - sn = 0; - - if (un > 1) - { - struct gmp_div_inverse bbinv; - mpn_div_qr_1_invert (&bbinv, info->bb); - - do - { - mp_limb_t w; - size_t done; - w = mpn_div_qr_1_preinv (up, up, un, &bbinv); - un -= (up[un-1] == 0); - done = mpn_limb_get_str (sp + sn, w, &binv); - - for (sn += done; done < info->exp; done++) - sp[sn++] = 0; - } - while (un > 1); - } - sn += mpn_limb_get_str (sp + sn, up[0], &binv); - - /* Reverse order */ - for (i = 0; 2*i + 1 < sn; i++) - { - unsigned char t = sp[i]; - sp[i] = sp[sn - i - 1]; - sp[sn - i - 1] = t; - } - - return sn; -} - -size_t -mpn_get_str (unsigned char *sp, int base, mp_ptr up, mp_size_t un) -{ - unsigned bits; - - assert (un > 0); - assert (up[un-1] > 0); - - bits = mpn_base_power_of_two_p (base); - if (bits) - return mpn_get_str_bits (sp, bits, up, un); - else - { - struct mpn_base_info info; - - mpn_get_base_info (&info, base); - return mpn_get_str_other (sp, base, &info, up, un); - } -} - -static mp_size_t -mpn_set_str_bits (mp_ptr rp, const unsigned char *sp, size_t sn, - unsigned bits) -{ - mp_size_t rn; - size_t j; - unsigned shift; - - for (j = sn, rn = 0, shift = 0; j-- > 0; ) - { - if (shift == 0) - { - rp[rn++] = sp[j]; - shift += bits; - } - else - { - rp[rn-1] |= (mp_limb_t) sp[j] << shift; - shift += bits; - if (shift >= GMP_LIMB_BITS) - { - shift -= GMP_LIMB_BITS; - if (shift > 0) - rp[rn++] = (mp_limb_t) sp[j] >> (bits - shift); - } - } - } - rn = mpn_normalized_size (rp, rn); - return rn; -} - -/* Result is usually normalized, except for all-zero input, in which - case a single zero limb is written at *RP, and 1 is returned. */ -static mp_size_t -mpn_set_str_other (mp_ptr rp, const unsigned char *sp, size_t sn, - mp_limb_t b, const struct mpn_base_info *info) -{ - mp_size_t rn; - mp_limb_t w; - unsigned k; - size_t j; - - assert (sn > 0); - - k = 1 + (sn - 1) % info->exp; - - j = 0; - w = sp[j++]; - while (--k != 0) - w = w * b + sp[j++]; - - rp[0] = w; - - for (rn = 1; j < sn;) - { - mp_limb_t cy; - - w = sp[j++]; - for (k = 1; k < info->exp; k++) - w = w * b + sp[j++]; - - cy = mpn_mul_1 (rp, rp, rn, info->bb); - cy += mpn_add_1 (rp, rp, rn, w); - if (cy > 0) - rp[rn++] = cy; - } - assert (j == sn); - - return rn; -} - -mp_size_t -mpn_set_str (mp_ptr rp, const unsigned char *sp, size_t sn, int base) -{ - unsigned bits; - - if (sn == 0) - return 0; - - bits = mpn_base_power_of_two_p (base); - if (bits) - return mpn_set_str_bits (rp, sp, sn, bits); - else - { - struct mpn_base_info info; - - mpn_get_base_info (&info, base); - return mpn_set_str_other (rp, sp, sn, base, &info); - } -} - - -/* MPZ interface */ -void -mpz_init (mpz_t r) -{ - static const mp_limb_t dummy_limb = GMP_LIMB_MAX & 0xc1a0; - - r->_mp_alloc = 0; - r->_mp_size = 0; - r->_mp_d = (mp_ptr) &dummy_limb; -} - -/* The utility of this function is a bit limited, since many functions - assigns the result variable using mpz_swap. */ -void -mpz_init2 (mpz_t r, mp_bitcnt_t bits) -{ - mp_size_t rn; - - bits -= (bits != 0); /* Round down, except if 0 */ - rn = 1 + bits / GMP_LIMB_BITS; - - r->_mp_alloc = rn; - r->_mp_size = 0; - r->_mp_d = gmp_xalloc_limbs (rn); -} - -void -mpz_clear (mpz_t r) -{ - if (r->_mp_alloc) - gmp_free (r->_mp_d); -} - -static mp_ptr -mpz_realloc (mpz_t r, mp_size_t size) -{ - size = GMP_MAX (size, 1); - - if (r->_mp_alloc) - r->_mp_d = gmp_xrealloc_limbs (r->_mp_d, size); - else - r->_mp_d = gmp_xalloc_limbs (size); - r->_mp_alloc = size; - - if (GMP_ABS (r->_mp_size) > size) - r->_mp_size = 0; - - return r->_mp_d; -} - -/* Realloc for an mpz_t WHAT if it has less than NEEDED limbs. */ -#define MPZ_REALLOC(z,n) ((n) > (z)->_mp_alloc \ - ? mpz_realloc(z,n) \ - : (z)->_mp_d) - -/* MPZ assignment and basic conversions. */ -void -mpz_set_si (mpz_t r, signed long int x) -{ - if (x >= 0) - mpz_set_ui (r, x); - else /* (x < 0) */ - if (GMP_LIMB_BITS < GMP_ULONG_BITS) - { - mpz_set_ui (r, GMP_NEG_CAST (unsigned long int, x)); - mpz_neg (r, r); - } - else - { - r->_mp_size = -1; - MPZ_REALLOC (r, 1)[0] = GMP_NEG_CAST (unsigned long int, x); - } -} - -void -mpz_set_ui (mpz_t r, unsigned long int x) -{ - if (x > 0) - { - r->_mp_size = 1; - MPZ_REALLOC (r, 1)[0] = x; - if (GMP_LIMB_BITS < GMP_ULONG_BITS) - { - int LOCAL_GMP_LIMB_BITS = GMP_LIMB_BITS; - while (x >>= LOCAL_GMP_LIMB_BITS) - { - ++ r->_mp_size; - MPZ_REALLOC (r, r->_mp_size)[r->_mp_size - 1] = x; - } - } - } - else - r->_mp_size = 0; -} - -void -mpz_set (mpz_t r, const mpz_t x) -{ - /* Allow the NOP r == x */ - if (r != x) - { - mp_size_t n; - mp_ptr rp; - - n = GMP_ABS (x->_mp_size); - rp = MPZ_REALLOC (r, n); - - mpn_copyi (rp, x->_mp_d, n); - r->_mp_size = x->_mp_size; - } -} - -void -mpz_init_set_si (mpz_t r, signed long int x) -{ - mpz_init (r); - mpz_set_si (r, x); -} - -void -mpz_init_set_ui (mpz_t r, unsigned long int x) -{ - mpz_init (r); - mpz_set_ui (r, x); -} - -void -mpz_init_set (mpz_t r, const mpz_t x) -{ - mpz_init (r); - mpz_set (r, x); -} - -int -mpz_fits_slong_p (const mpz_t u) -{ - return (LONG_MAX + LONG_MIN == 0 || mpz_cmp_ui (u, LONG_MAX) <= 0) && - mpz_cmpabs_ui (u, GMP_NEG_CAST (unsigned long int, LONG_MIN)) <= 0; -} - -static int -mpn_absfits_ulong_p (mp_srcptr up, mp_size_t un) -{ - int ulongsize = GMP_ULONG_BITS / GMP_LIMB_BITS; - mp_limb_t ulongrem = 0; - - if (GMP_ULONG_BITS % GMP_LIMB_BITS != 0) - ulongrem = (mp_limb_t) (ULONG_MAX >> GMP_LIMB_BITS * ulongsize) + 1; - - return un <= ulongsize || (up[ulongsize] < ulongrem && un == ulongsize + 1); -} - -int -mpz_fits_ulong_p (const mpz_t u) -{ - mp_size_t us = u->_mp_size; - - return us >= 0 && mpn_absfits_ulong_p (u->_mp_d, us); -} - -long int -mpz_get_si (const mpz_t u) -{ - unsigned long r = mpz_get_ui (u); - unsigned long c = -LONG_MAX - LONG_MIN; - - if (u->_mp_size < 0) - /* This expression is necessary to properly handle -LONG_MIN */ - return -(long) c - (long) ((r - c) & LONG_MAX); - else - return (long) (r & LONG_MAX); -} - -unsigned long int -mpz_get_ui (const mpz_t u) -{ - if (GMP_LIMB_BITS < GMP_ULONG_BITS) - { - int LOCAL_GMP_LIMB_BITS = GMP_LIMB_BITS; - unsigned long r = 0; - mp_size_t n = GMP_ABS (u->_mp_size); - n = GMP_MIN (n, 1 + (mp_size_t) (GMP_ULONG_BITS - 1) / GMP_LIMB_BITS); - while (--n >= 0) - r = (r << LOCAL_GMP_LIMB_BITS) + u->_mp_d[n]; - return r; - } - - return u->_mp_size == 0 ? 0 : u->_mp_d[0]; -} - -size_t -mpz_size (const mpz_t u) -{ - return GMP_ABS (u->_mp_size); -} - -mp_limb_t -mpz_getlimbn (const mpz_t u, mp_size_t n) -{ - if (n >= 0 && n < GMP_ABS (u->_mp_size)) - return u->_mp_d[n]; - else - return 0; -} - -void -mpz_realloc2 (mpz_t x, mp_bitcnt_t n) -{ - mpz_realloc (x, 1 + (n - (n != 0)) / GMP_LIMB_BITS); -} - -mp_srcptr -mpz_limbs_read (mpz_srcptr x) -{ - return x->_mp_d; -} - -mp_ptr -mpz_limbs_modify (mpz_t x, mp_size_t n) -{ - assert (n > 0); - return MPZ_REALLOC (x, n); -} - -mp_ptr -mpz_limbs_write (mpz_t x, mp_size_t n) -{ - return mpz_limbs_modify (x, n); -} - -void -mpz_limbs_finish (mpz_t x, mp_size_t xs) -{ - mp_size_t xn; - xn = mpn_normalized_size (x->_mp_d, GMP_ABS (xs)); - x->_mp_size = xs < 0 ? -xn : xn; -} - -static mpz_srcptr -mpz_roinit_normal_n (mpz_t x, mp_srcptr xp, mp_size_t xs) -{ - x->_mp_alloc = 0; - x->_mp_d = (mp_ptr) xp; - x->_mp_size = xs; - return x; -} - -mpz_srcptr -mpz_roinit_n (mpz_t x, mp_srcptr xp, mp_size_t xs) -{ - mpz_roinit_normal_n (x, xp, xs); - mpz_limbs_finish (x, xs); - return x; -} - - -/* Conversions and comparison to double. */ -void -mpz_set_d (mpz_t r, double x) -{ - int sign; - mp_ptr rp; - mp_size_t rn, i; - double B; - double Bi; - mp_limb_t f; - - /* x != x is true when x is a NaN, and x == x * 0.5 is true when x is - zero or infinity. */ - if (x != x || x == x * 0.5) - { - r->_mp_size = 0; - return; - } - - sign = x < 0.0 ; - if (sign) - x = - x; - - if (x < 1.0) - { - r->_mp_size = 0; - return; - } - B = 4.0 * (double) (GMP_LIMB_HIGHBIT >> 1); - Bi = 1.0 / B; - for (rn = 1; x >= B; rn++) - x *= Bi; - - rp = MPZ_REALLOC (r, rn); - - f = (mp_limb_t) x; - x -= f; - assert (x < 1.0); - i = rn-1; - rp[i] = f; - while (--i >= 0) - { - x = B * x; - f = (mp_limb_t) x; - x -= f; - assert (x < 1.0); - rp[i] = f; - } - - r->_mp_size = sign ? - rn : rn; -} - -void -mpz_init_set_d (mpz_t r, double x) -{ - mpz_init (r); - mpz_set_d (r, x); -} - -double -mpz_get_d (const mpz_t u) -{ - int m; - mp_limb_t l; - mp_size_t un; - double x; - double B = 4.0 * (double) (GMP_LIMB_HIGHBIT >> 1); - - un = GMP_ABS (u->_mp_size); - - if (un == 0) - return 0.0; - - l = u->_mp_d[--un]; - gmp_clz (m, l); - m = m + GMP_DBL_MANT_BITS - GMP_LIMB_BITS; - if (m < 0) - l &= GMP_LIMB_MAX << -m; - - for (x = l; --un >= 0;) - { - x = B*x; - if (m > 0) { - l = u->_mp_d[un]; - m -= GMP_LIMB_BITS; - if (m < 0) - l &= GMP_LIMB_MAX << -m; - x += l; - } - } - - if (u->_mp_size < 0) - x = -x; - - return x; -} - -int -mpz_cmpabs_d (const mpz_t x, double d) -{ - mp_size_t xn; - double B, Bi; - mp_size_t i; - - xn = x->_mp_size; - d = GMP_ABS (d); - - if (xn != 0) - { - xn = GMP_ABS (xn); - - B = 4.0 * (double) (GMP_LIMB_HIGHBIT >> 1); - Bi = 1.0 / B; - - /* Scale d so it can be compared with the top limb. */ - for (i = 1; i < xn; i++) - d *= Bi; - - if (d >= B) - return -1; - - /* Compare floor(d) to top limb, subtract and cancel when equal. */ - for (i = xn; i-- > 0;) - { - mp_limb_t f, xl; - - f = (mp_limb_t) d; - xl = x->_mp_d[i]; - if (xl > f) - return 1; - else if (xl < f) - return -1; - d = B * (d - f); - } - } - return - (d > 0.0); -} - -int -mpz_cmp_d (const mpz_t x, double d) -{ - if (x->_mp_size < 0) - { - if (d >= 0.0) - return -1; - else - return -mpz_cmpabs_d (x, d); - } - else - { - if (d < 0.0) - return 1; - else - return mpz_cmpabs_d (x, d); - } -} - - -/* MPZ comparisons and the like. */ -int -mpz_sgn (const mpz_t u) -{ - return GMP_CMP (u->_mp_size, 0); -} - -int -mpz_cmp_si (const mpz_t u, long v) -{ - mp_size_t usize = u->_mp_size; - - if (v >= 0) - return mpz_cmp_ui (u, v); - else if (usize >= 0) - return 1; - else - return - mpz_cmpabs_ui (u, GMP_NEG_CAST (unsigned long int, v)); -} - -int -mpz_cmp_ui (const mpz_t u, unsigned long v) -{ - mp_size_t usize = u->_mp_size; - - if (usize < 0) - return -1; - else - return mpz_cmpabs_ui (u, v); -} - -int -mpz_cmp (const mpz_t a, const mpz_t b) -{ - mp_size_t asize = a->_mp_size; - mp_size_t bsize = b->_mp_size; - - if (asize != bsize) - return (asize < bsize) ? -1 : 1; - else if (asize >= 0) - return mpn_cmp (a->_mp_d, b->_mp_d, asize); - else - return mpn_cmp (b->_mp_d, a->_mp_d, -asize); -} - -int -mpz_cmpabs_ui (const mpz_t u, unsigned long v) -{ - mp_size_t un = GMP_ABS (u->_mp_size); - - if (! mpn_absfits_ulong_p (u->_mp_d, un)) - return 1; - else - { - unsigned long uu = mpz_get_ui (u); - return GMP_CMP(uu, v); - } -} - -int -mpz_cmpabs (const mpz_t u, const mpz_t v) -{ - return mpn_cmp4 (u->_mp_d, GMP_ABS (u->_mp_size), - v->_mp_d, GMP_ABS (v->_mp_size)); -} - -void -mpz_abs (mpz_t r, const mpz_t u) -{ - mpz_set (r, u); - r->_mp_size = GMP_ABS (r->_mp_size); -} - -void -mpz_neg (mpz_t r, const mpz_t u) -{ - mpz_set (r, u); - r->_mp_size = -r->_mp_size; -} - -void -mpz_swap (mpz_t u, mpz_t v) -{ - MP_SIZE_T_SWAP (u->_mp_size, v->_mp_size); - MP_SIZE_T_SWAP (u->_mp_alloc, v->_mp_alloc); - MP_PTR_SWAP (u->_mp_d, v->_mp_d); -} - - -/* MPZ addition and subtraction */ - - -void -mpz_add_ui (mpz_t r, const mpz_t a, unsigned long b) -{ - mpz_t bb; - mpz_init_set_ui (bb, b); - mpz_add (r, a, bb); - mpz_clear (bb); -} - -void -mpz_sub_ui (mpz_t r, const mpz_t a, unsigned long b) -{ - mpz_ui_sub (r, b, a); - mpz_neg (r, r); -} - -void -mpz_ui_sub (mpz_t r, unsigned long a, const mpz_t b) -{ - mpz_neg (r, b); - mpz_add_ui (r, r, a); -} - -static mp_size_t -mpz_abs_add (mpz_t r, const mpz_t a, const mpz_t b) -{ - mp_size_t an = GMP_ABS (a->_mp_size); - mp_size_t bn = GMP_ABS (b->_mp_size); - mp_ptr rp; - mp_limb_t cy; - - if (an < bn) - { - MPZ_SRCPTR_SWAP (a, b); - MP_SIZE_T_SWAP (an, bn); - } - - rp = MPZ_REALLOC (r, an + 1); - cy = mpn_add (rp, a->_mp_d, an, b->_mp_d, bn); - - rp[an] = cy; - - return an + cy; -} - -static mp_size_t -mpz_abs_sub (mpz_t r, const mpz_t a, const mpz_t b) -{ - mp_size_t an = GMP_ABS (a->_mp_size); - mp_size_t bn = GMP_ABS (b->_mp_size); - int cmp; - mp_ptr rp; - - cmp = mpn_cmp4 (a->_mp_d, an, b->_mp_d, bn); - if (cmp > 0) - { - rp = MPZ_REALLOC (r, an); - gmp_assert_nocarry (mpn_sub (rp, a->_mp_d, an, b->_mp_d, bn)); - return mpn_normalized_size (rp, an); - } - else if (cmp < 0) - { - rp = MPZ_REALLOC (r, bn); - gmp_assert_nocarry (mpn_sub (rp, b->_mp_d, bn, a->_mp_d, an)); - return -mpn_normalized_size (rp, bn); - } - else - return 0; -} - -void -mpz_add (mpz_t r, const mpz_t a, const mpz_t b) -{ - mp_size_t rn; - - if ( (a->_mp_size ^ b->_mp_size) >= 0) - rn = mpz_abs_add (r, a, b); - else - rn = mpz_abs_sub (r, a, b); - - r->_mp_size = a->_mp_size >= 0 ? rn : - rn; -} - -void -mpz_sub (mpz_t r, const mpz_t a, const mpz_t b) -{ - mp_size_t rn; - - if ( (a->_mp_size ^ b->_mp_size) >= 0) - rn = mpz_abs_sub (r, a, b); - else - rn = mpz_abs_add (r, a, b); - - r->_mp_size = a->_mp_size >= 0 ? rn : - rn; -} - - -/* MPZ multiplication */ -void -mpz_mul_si (mpz_t r, const mpz_t u, long int v) -{ - if (v < 0) - { - mpz_mul_ui (r, u, GMP_NEG_CAST (unsigned long int, v)); - mpz_neg (r, r); - } - else - mpz_mul_ui (r, u, v); -} - -void -mpz_mul_ui (mpz_t r, const mpz_t u, unsigned long int v) -{ - mpz_t vv; - mpz_init_set_ui (vv, v); - mpz_mul (r, u, vv); - mpz_clear (vv); - return; -} - -void -mpz_mul (mpz_t r, const mpz_t u, const mpz_t v) -{ - int sign; - mp_size_t un, vn, rn; - mpz_t t; - mp_ptr tp; - - un = u->_mp_size; - vn = v->_mp_size; - - if (un == 0 || vn == 0) - { - r->_mp_size = 0; - return; - } - - sign = (un ^ vn) < 0; - - un = GMP_ABS (un); - vn = GMP_ABS (vn); - - mpz_init2 (t, (un + vn) * GMP_LIMB_BITS); - - tp = t->_mp_d; - if (un >= vn) - mpn_mul (tp, u->_mp_d, un, v->_mp_d, vn); - else - mpn_mul (tp, v->_mp_d, vn, u->_mp_d, un); - - rn = un + vn; - rn -= tp[rn-1] == 0; - - t->_mp_size = sign ? - rn : rn; - mpz_swap (r, t); - mpz_clear (t); -} - -void -mpz_mul_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t bits) -{ - mp_size_t un, rn; - mp_size_t limbs; - unsigned shift; - mp_ptr rp; - - un = GMP_ABS (u->_mp_size); - if (un == 0) - { - r->_mp_size = 0; - return; - } - - limbs = bits / GMP_LIMB_BITS; - shift = bits % GMP_LIMB_BITS; - - rn = un + limbs + (shift > 0); - rp = MPZ_REALLOC (r, rn); - if (shift > 0) - { - mp_limb_t cy = mpn_lshift (rp + limbs, u->_mp_d, un, shift); - rp[rn-1] = cy; - rn -= (cy == 0); - } - else - mpn_copyd (rp + limbs, u->_mp_d, un); - - mpn_zero (rp, limbs); - - r->_mp_size = (u->_mp_size < 0) ? - rn : rn; -} - -void -mpz_addmul_ui (mpz_t r, const mpz_t u, unsigned long int v) -{ - mpz_t t; - mpz_init_set_ui (t, v); - mpz_mul (t, u, t); - mpz_add (r, r, t); - mpz_clear (t); -} - -void -mpz_submul_ui (mpz_t r, const mpz_t u, unsigned long int v) -{ - mpz_t t; - mpz_init_set_ui (t, v); - mpz_mul (t, u, t); - mpz_sub (r, r, t); - mpz_clear (t); -} - -void -mpz_addmul (mpz_t r, const mpz_t u, const mpz_t v) -{ - mpz_t t; - mpz_init (t); - mpz_mul (t, u, v); - mpz_add (r, r, t); - mpz_clear (t); -} - -void -mpz_submul (mpz_t r, const mpz_t u, const mpz_t v) -{ - mpz_t t; - mpz_init (t); - mpz_mul (t, u, v); - mpz_sub (r, r, t); - mpz_clear (t); -} - - -/* MPZ division */ -enum mpz_div_round_mode { GMP_DIV_FLOOR, GMP_DIV_CEIL, GMP_DIV_TRUNC }; - -/* Allows q or r to be zero. Returns 1 iff remainder is non-zero. */ -static int -mpz_div_qr (mpz_t q, mpz_t r, - const mpz_t n, const mpz_t d, enum mpz_div_round_mode mode) -{ - mp_size_t ns, ds, nn, dn, qs; - ns = n->_mp_size; - ds = d->_mp_size; - - if (ds == 0) - gmp_die("mpz_div_qr: Divide by zero."); - - if (ns == 0) - { - if (q) - q->_mp_size = 0; - if (r) - r->_mp_size = 0; - return 0; - } - - nn = GMP_ABS (ns); - dn = GMP_ABS (ds); - - qs = ds ^ ns; - - if (nn < dn) - { - if (mode == GMP_DIV_CEIL && qs >= 0) - { - /* q = 1, r = n - d */ - if (r) - mpz_sub (r, n, d); - if (q) - mpz_set_ui (q, 1); - } - else if (mode == GMP_DIV_FLOOR && qs < 0) - { - /* q = -1, r = n + d */ - if (r) - mpz_add (r, n, d); - if (q) - mpz_set_si (q, -1); - } - else - { - /* q = 0, r = d */ - if (r) - mpz_set (r, n); - if (q) - q->_mp_size = 0; - } - return 1; - } - else - { - mp_ptr np, qp; - mp_size_t qn, rn; - mpz_t tq, tr; - - mpz_init_set (tr, n); - np = tr->_mp_d; - - qn = nn - dn + 1; - - if (q) - { - mpz_init2 (tq, qn * GMP_LIMB_BITS); - qp = tq->_mp_d; - } - else - qp = NULL; - - mpn_div_qr (qp, np, nn, d->_mp_d, dn); - - if (qp) - { - qn -= (qp[qn-1] == 0); - - tq->_mp_size = qs < 0 ? -qn : qn; - } - rn = mpn_normalized_size (np, dn); - tr->_mp_size = ns < 0 ? - rn : rn; - - if (mode == GMP_DIV_FLOOR && qs < 0 && rn != 0) - { - if (q) - mpz_sub_ui (tq, tq, 1); - if (r) - mpz_add (tr, tr, d); - } - else if (mode == GMP_DIV_CEIL && qs >= 0 && rn != 0) - { - if (q) - mpz_add_ui (tq, tq, 1); - if (r) - mpz_sub (tr, tr, d); - } - - if (q) - { - mpz_swap (tq, q); - mpz_clear (tq); - } - if (r) - mpz_swap (tr, r); - - mpz_clear (tr); - - return rn != 0; - } -} - -void -mpz_cdiv_qr (mpz_t q, mpz_t r, const mpz_t n, const mpz_t d) -{ - mpz_div_qr (q, r, n, d, GMP_DIV_CEIL); -} - -void -mpz_fdiv_qr (mpz_t q, mpz_t r, const mpz_t n, const mpz_t d) -{ - mpz_div_qr (q, r, n, d, GMP_DIV_FLOOR); -} - -void -mpz_tdiv_qr (mpz_t q, mpz_t r, const mpz_t n, const mpz_t d) -{ - mpz_div_qr (q, r, n, d, GMP_DIV_TRUNC); -} - -void -mpz_cdiv_q (mpz_t q, const mpz_t n, const mpz_t d) -{ - mpz_div_qr (q, NULL, n, d, GMP_DIV_CEIL); -} - -void -mpz_fdiv_q (mpz_t q, const mpz_t n, const mpz_t d) -{ - mpz_div_qr (q, NULL, n, d, GMP_DIV_FLOOR); -} - -void -mpz_tdiv_q (mpz_t q, const mpz_t n, const mpz_t d) -{ - mpz_div_qr (q, NULL, n, d, GMP_DIV_TRUNC); -} - -void -mpz_cdiv_r (mpz_t r, const mpz_t n, const mpz_t d) -{ - mpz_div_qr (NULL, r, n, d, GMP_DIV_CEIL); -} - -void -mpz_fdiv_r (mpz_t r, const mpz_t n, const mpz_t d) -{ - mpz_div_qr (NULL, r, n, d, GMP_DIV_FLOOR); -} - -void -mpz_tdiv_r (mpz_t r, const mpz_t n, const mpz_t d) -{ - mpz_div_qr (NULL, r, n, d, GMP_DIV_TRUNC); -} - -void -mpz_mod (mpz_t r, const mpz_t n, const mpz_t d) -{ - mpz_div_qr (NULL, r, n, d, d->_mp_size >= 0 ? GMP_DIV_FLOOR : GMP_DIV_CEIL); -} - -static void -mpz_div_q_2exp (mpz_t q, const mpz_t u, mp_bitcnt_t bit_index, - enum mpz_div_round_mode mode) -{ - mp_size_t un, qn; - mp_size_t limb_cnt; - mp_ptr qp; - int adjust; - - un = u->_mp_size; - if (un == 0) - { - q->_mp_size = 0; - return; - } - limb_cnt = bit_index / GMP_LIMB_BITS; - qn = GMP_ABS (un) - limb_cnt; - bit_index %= GMP_LIMB_BITS; - - if (mode == ((un > 0) ? GMP_DIV_CEIL : GMP_DIV_FLOOR)) /* un != 0 here. */ - /* Note: Below, the final indexing at limb_cnt is valid because at - that point we have qn > 0. */ - adjust = (qn <= 0 - || !mpn_zero_p (u->_mp_d, limb_cnt) - || (u->_mp_d[limb_cnt] - & (((mp_limb_t) 1 << bit_index) - 1))); - else - adjust = 0; - - if (qn <= 0) - qn = 0; - else - { - qp = MPZ_REALLOC (q, qn); - - if (bit_index != 0) - { - mpn_rshift (qp, u->_mp_d + limb_cnt, qn, bit_index); - qn -= qp[qn - 1] == 0; - } - else - { - mpn_copyi (qp, u->_mp_d + limb_cnt, qn); - } - } - - q->_mp_size = qn; - - if (adjust) - mpz_add_ui (q, q, 1); - if (un < 0) - mpz_neg (q, q); -} - -static void -mpz_div_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t bit_index, - enum mpz_div_round_mode mode) -{ - mp_size_t us, un, rn; - mp_ptr rp; - mp_limb_t mask; - - us = u->_mp_size; - if (us == 0 || bit_index == 0) - { - r->_mp_size = 0; - return; - } - rn = (bit_index + GMP_LIMB_BITS - 1) / GMP_LIMB_BITS; - assert (rn > 0); - - rp = MPZ_REALLOC (r, rn); - un = GMP_ABS (us); - - mask = GMP_LIMB_MAX >> (rn * GMP_LIMB_BITS - bit_index); - - if (rn > un) - { - /* Quotient (with truncation) is zero, and remainder is - non-zero */ - if (mode == ((us > 0) ? GMP_DIV_CEIL : GMP_DIV_FLOOR)) /* us != 0 here. */ - { - /* Have to negate and sign extend. */ - mp_size_t i; - - gmp_assert_nocarry (! mpn_neg (rp, u->_mp_d, un)); - for (i = un; i < rn - 1; i++) - rp[i] = GMP_LIMB_MAX; - - rp[rn-1] = mask; - us = -us; - } - else - { - /* Just copy */ - if (r != u) - mpn_copyi (rp, u->_mp_d, un); - - rn = un; - } - } - else - { - if (r != u) - mpn_copyi (rp, u->_mp_d, rn - 1); - - rp[rn-1] = u->_mp_d[rn-1] & mask; - - if (mode == ((us > 0) ? GMP_DIV_CEIL : GMP_DIV_FLOOR)) /* us != 0 here. */ - { - /* If r != 0, compute 2^{bit_count} - r. */ - mpn_neg (rp, rp, rn); - - rp[rn-1] &= mask; - - /* us is not used for anything else, so we can modify it - here to indicate flipped sign. */ - us = -us; - } - } - rn = mpn_normalized_size (rp, rn); - r->_mp_size = us < 0 ? -rn : rn; -} - -void -mpz_cdiv_q_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) -{ - mpz_div_q_2exp (r, u, cnt, GMP_DIV_CEIL); -} - -void -mpz_fdiv_q_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) -{ - mpz_div_q_2exp (r, u, cnt, GMP_DIV_FLOOR); -} - -void -mpz_tdiv_q_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) -{ - mpz_div_q_2exp (r, u, cnt, GMP_DIV_TRUNC); -} - -void -mpz_cdiv_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) -{ - mpz_div_r_2exp (r, u, cnt, GMP_DIV_CEIL); -} - -void -mpz_fdiv_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) -{ - mpz_div_r_2exp (r, u, cnt, GMP_DIV_FLOOR); -} - -void -mpz_tdiv_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) -{ - mpz_div_r_2exp (r, u, cnt, GMP_DIV_TRUNC); -} - -void -mpz_divexact (mpz_t q, const mpz_t n, const mpz_t d) -{ - gmp_assert_nocarry (mpz_div_qr (q, NULL, n, d, GMP_DIV_TRUNC)); -} - -int -mpz_divisible_p (const mpz_t n, const mpz_t d) -{ - return mpz_div_qr (NULL, NULL, n, d, GMP_DIV_TRUNC) == 0; -} - -int -mpz_congruent_p (const mpz_t a, const mpz_t b, const mpz_t m) -{ - mpz_t t; - int res; - - /* a == b (mod 0) iff a == b */ - if (mpz_sgn (m) == 0) - return (mpz_cmp (a, b) == 0); - - mpz_init (t); - mpz_sub (t, a, b); - res = mpz_divisible_p (t, m); - mpz_clear (t); - - return res; -} - -static unsigned long -mpz_div_qr_ui (mpz_t q, mpz_t r, - const mpz_t n, unsigned long d, enum mpz_div_round_mode mode) -{ - unsigned long ret; - mpz_t rr, dd; - - mpz_init (rr); - mpz_init_set_ui (dd, d); - mpz_div_qr (q, rr, n, dd, mode); - mpz_clear (dd); - ret = mpz_get_ui (rr); - - if (r) - mpz_swap (r, rr); - mpz_clear (rr); - - return ret; -} - -unsigned long -mpz_cdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, unsigned long d) -{ - return mpz_div_qr_ui (q, r, n, d, GMP_DIV_CEIL); -} - -unsigned long -mpz_fdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, unsigned long d) -{ - return mpz_div_qr_ui (q, r, n, d, GMP_DIV_FLOOR); -} - -unsigned long -mpz_tdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, unsigned long d) -{ - return mpz_div_qr_ui (q, r, n, d, GMP_DIV_TRUNC); -} - -unsigned long -mpz_cdiv_q_ui (mpz_t q, const mpz_t n, unsigned long d) -{ - return mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_CEIL); -} - -unsigned long -mpz_fdiv_q_ui (mpz_t q, const mpz_t n, unsigned long d) -{ - return mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_FLOOR); -} - -unsigned long -mpz_tdiv_q_ui (mpz_t q, const mpz_t n, unsigned long d) -{ - return mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_TRUNC); -} - -unsigned long -mpz_cdiv_r_ui (mpz_t r, const mpz_t n, unsigned long d) -{ - return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_CEIL); -} -unsigned long -mpz_fdiv_r_ui (mpz_t r, const mpz_t n, unsigned long d) -{ - return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_FLOOR); -} -unsigned long -mpz_tdiv_r_ui (mpz_t r, const mpz_t n, unsigned long d) -{ - return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_TRUNC); -} - -unsigned long -mpz_cdiv_ui (const mpz_t n, unsigned long d) -{ - return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_CEIL); -} - -unsigned long -mpz_fdiv_ui (const mpz_t n, unsigned long d) -{ - return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_FLOOR); -} - -unsigned long -mpz_tdiv_ui (const mpz_t n, unsigned long d) -{ - return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_TRUNC); -} - -unsigned long -mpz_mod_ui (mpz_t r, const mpz_t n, unsigned long d) -{ - return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_FLOOR); -} - -void -mpz_divexact_ui (mpz_t q, const mpz_t n, unsigned long d) -{ - gmp_assert_nocarry (mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_TRUNC)); -} - -int -mpz_divisible_ui_p (const mpz_t n, unsigned long d) -{ - return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_TRUNC) == 0; -} - - -/* GCD */ -static mp_limb_t -mpn_gcd_11 (mp_limb_t u, mp_limb_t v) -{ - unsigned shift; - - assert ( (u | v) > 0); - - if (u == 0) - return v; - else if (v == 0) - return u; - - gmp_ctz (shift, u | v); - - u >>= shift; - v >>= shift; - - if ( (u & 1) == 0) - MP_LIMB_T_SWAP (u, v); - - while ( (v & 1) == 0) - v >>= 1; - - while (u != v) - { - if (u > v) - { - u -= v; - do - u >>= 1; - while ( (u & 1) == 0); - } - else - { - v -= u; - do - v >>= 1; - while ( (v & 1) == 0); - } - } - return u << shift; -} - -unsigned long -mpz_gcd_ui (mpz_t g, const mpz_t u, unsigned long v) -{ - mpz_t t; - mpz_init_set_ui(t, v); - mpz_gcd (t, u, t); - if (v > 0) - v = mpz_get_ui (t); - - if (g) - mpz_swap (t, g); - - mpz_clear (t); - - return v; -} - -static mp_bitcnt_t -mpz_make_odd (mpz_t r) -{ - mp_bitcnt_t shift; - - assert (r->_mp_size > 0); - /* Count trailing zeros, equivalent to mpn_scan1, because we know that there is a 1 */ - shift = mpn_common_scan (r->_mp_d[0], 0, r->_mp_d, 0, 0); - mpz_tdiv_q_2exp (r, r, shift); - - return shift; -} - -void -mpz_gcd (mpz_t g, const mpz_t u, const mpz_t v) -{ - mpz_t tu, tv; - mp_bitcnt_t uz, vz, gz; - - if (u->_mp_size == 0) - { - mpz_abs (g, v); - return; - } - if (v->_mp_size == 0) - { - mpz_abs (g, u); - return; - } - - mpz_init (tu); - mpz_init (tv); - - mpz_abs (tu, u); - uz = mpz_make_odd (tu); - mpz_abs (tv, v); - vz = mpz_make_odd (tv); - gz = GMP_MIN (uz, vz); - - if (tu->_mp_size < tv->_mp_size) - mpz_swap (tu, tv); - - mpz_tdiv_r (tu, tu, tv); - if (tu->_mp_size == 0) - { - mpz_swap (g, tv); - } - else - for (;;) - { - int c; - - mpz_make_odd (tu); - c = mpz_cmp (tu, tv); - if (c == 0) - { - mpz_swap (g, tu); - break; - } - if (c < 0) - mpz_swap (tu, tv); - - if (tv->_mp_size == 1) - { - mp_limb_t vl = tv->_mp_d[0]; - mp_limb_t ul = mpz_tdiv_ui (tu, vl); - mpz_set_ui (g, mpn_gcd_11 (ul, vl)); - break; - } - mpz_sub (tu, tu, tv); - } - mpz_clear (tu); - mpz_clear (tv); - mpz_mul_2exp (g, g, gz); -} - -void -mpz_gcdext (mpz_t g, mpz_t s, mpz_t t, const mpz_t u, const mpz_t v) -{ - mpz_t tu, tv, s0, s1, t0, t1; - mp_bitcnt_t uz, vz, gz; - mp_bitcnt_t power; - - if (u->_mp_size == 0) - { - /* g = 0 u + sgn(v) v */ - signed long sign = mpz_sgn (v); - mpz_abs (g, v); - if (s) - s->_mp_size = 0; - if (t) - mpz_set_si (t, sign); - return; - } - - if (v->_mp_size == 0) - { - /* g = sgn(u) u + 0 v */ - signed long sign = mpz_sgn (u); - mpz_abs (g, u); - if (s) - mpz_set_si (s, sign); - if (t) - t->_mp_size = 0; - return; - } - - mpz_init (tu); - mpz_init (tv); - mpz_init (s0); - mpz_init (s1); - mpz_init (t0); - mpz_init (t1); - - mpz_abs (tu, u); - uz = mpz_make_odd (tu); - mpz_abs (tv, v); - vz = mpz_make_odd (tv); - gz = GMP_MIN (uz, vz); - - uz -= gz; - vz -= gz; - - /* Cofactors corresponding to odd gcd. gz handled later. */ - if (tu->_mp_size < tv->_mp_size) - { - mpz_swap (tu, tv); - MPZ_SRCPTR_SWAP (u, v); - MPZ_PTR_SWAP (s, t); - MP_BITCNT_T_SWAP (uz, vz); - } - - /* Maintain - * - * u = t0 tu + t1 tv - * v = s0 tu + s1 tv - * - * where u and v denote the inputs with common factors of two - * eliminated, and det (s0, t0; s1, t1) = 2^p. Then - * - * 2^p tu = s1 u - t1 v - * 2^p tv = -s0 u + t0 v - */ - - /* After initial division, tu = q tv + tu', we have - * - * u = 2^uz (tu' + q tv) - * v = 2^vz tv - * - * or - * - * t0 = 2^uz, t1 = 2^uz q - * s0 = 0, s1 = 2^vz - */ - - mpz_setbit (t0, uz); - mpz_tdiv_qr (t1, tu, tu, tv); - mpz_mul_2exp (t1, t1, uz); - - mpz_setbit (s1, vz); - power = uz + vz; - - if (tu->_mp_size > 0) - { - mp_bitcnt_t shift; - shift = mpz_make_odd (tu); - mpz_mul_2exp (t0, t0, shift); - mpz_mul_2exp (s0, s0, shift); - power += shift; - - for (;;) - { - int c; - c = mpz_cmp (tu, tv); - if (c == 0) - break; - - if (c < 0) - { - /* tv = tv' + tu - * - * u = t0 tu + t1 (tv' + tu) = (t0 + t1) tu + t1 tv' - * v = s0 tu + s1 (tv' + tu) = (s0 + s1) tu + s1 tv' */ - - mpz_sub (tv, tv, tu); - mpz_add (t0, t0, t1); - mpz_add (s0, s0, s1); - - shift = mpz_make_odd (tv); - mpz_mul_2exp (t1, t1, shift); - mpz_mul_2exp (s1, s1, shift); - } - else - { - mpz_sub (tu, tu, tv); - mpz_add (t1, t0, t1); - mpz_add (s1, s0, s1); - - shift = mpz_make_odd (tu); - mpz_mul_2exp (t0, t0, shift); - mpz_mul_2exp (s0, s0, shift); - } - power += shift; - } - } - - /* Now tv = odd part of gcd, and -s0 and t0 are corresponding - cofactors. */ - - mpz_mul_2exp (tv, tv, gz); - mpz_neg (s0, s0); - - /* 2^p g = s0 u + t0 v. Eliminate one factor of two at a time. To - adjust cofactors, we need u / g and v / g */ - - mpz_divexact (s1, v, tv); - mpz_abs (s1, s1); - mpz_divexact (t1, u, tv); - mpz_abs (t1, t1); - - while (power-- > 0) - { - /* s0 u + t0 v = (s0 - v/g) u - (t0 + u/g) v */ - if (mpz_odd_p (s0) || mpz_odd_p (t0)) - { - mpz_sub (s0, s0, s1); - mpz_add (t0, t0, t1); - } - assert (mpz_even_p (t0) && mpz_even_p (s0)); - mpz_tdiv_q_2exp (s0, s0, 1); - mpz_tdiv_q_2exp (t0, t0, 1); - } - - /* Arrange so that |s| < |u| / 2g */ - mpz_add (s1, s0, s1); - if (mpz_cmpabs (s0, s1) > 0) - { - mpz_swap (s0, s1); - mpz_sub (t0, t0, t1); - } - if (u->_mp_size < 0) - mpz_neg (s0, s0); - if (v->_mp_size < 0) - mpz_neg (t0, t0); - - mpz_swap (g, tv); - if (s) - mpz_swap (s, s0); - if (t) - mpz_swap (t, t0); - - mpz_clear (tu); - mpz_clear (tv); - mpz_clear (s0); - mpz_clear (s1); - mpz_clear (t0); - mpz_clear (t1); -} - -void -mpz_lcm (mpz_t r, const mpz_t u, const mpz_t v) -{ - mpz_t g; - - if (u->_mp_size == 0 || v->_mp_size == 0) - { - r->_mp_size = 0; - return; - } - - mpz_init (g); - - mpz_gcd (g, u, v); - mpz_divexact (g, u, g); - mpz_mul (r, g, v); - - mpz_clear (g); - mpz_abs (r, r); -} - -void -mpz_lcm_ui (mpz_t r, const mpz_t u, unsigned long v) -{ - if (v == 0 || u->_mp_size == 0) - { - r->_mp_size = 0; - return; - } - - v /= mpz_gcd_ui (NULL, u, v); - mpz_mul_ui (r, u, v); - - mpz_abs (r, r); -} - -int -mpz_invert (mpz_t r, const mpz_t u, const mpz_t m) -{ - mpz_t g, tr; - int invertible; - - if (u->_mp_size == 0 || mpz_cmpabs_ui (m, 1) <= 0) - return 0; - - mpz_init (g); - mpz_init (tr); - - mpz_gcdext (g, tr, NULL, u, m); - invertible = (mpz_cmp_ui (g, 1) == 0); - - if (invertible) - { - if (tr->_mp_size < 0) - { - if (m->_mp_size >= 0) - mpz_add (tr, tr, m); - else - mpz_sub (tr, tr, m); - } - mpz_swap (r, tr); - } - - mpz_clear (g); - mpz_clear (tr); - return invertible; -} - - -/* Higher level operations (sqrt, pow and root) */ - -void -mpz_pow_ui (mpz_t r, const mpz_t b, unsigned long e) -{ - unsigned long bit; - mpz_t tr; - mpz_init_set_ui (tr, 1); - - bit = GMP_ULONG_HIGHBIT; - do - { - mpz_mul (tr, tr, tr); - if (e & bit) - mpz_mul (tr, tr, b); - bit >>= 1; - } - while (bit > 0); - - mpz_swap (r, tr); - mpz_clear (tr); -} - -void -mpz_ui_pow_ui (mpz_t r, unsigned long blimb, unsigned long e) -{ - mpz_t b; - - mpz_init_set_ui (b, blimb); - mpz_pow_ui (r, b, e); - mpz_clear (b); -} - -void -mpz_powm (mpz_t r, const mpz_t b, const mpz_t e, const mpz_t m) -{ - mpz_t tr; - mpz_t base; - mp_size_t en, mn; - mp_srcptr mp; - struct gmp_div_inverse minv; - unsigned shift; - mp_ptr tp = NULL; - - en = GMP_ABS (e->_mp_size); - mn = GMP_ABS (m->_mp_size); - if (mn == 0) - gmp_die ("mpz_powm: Zero modulo."); - - if (en == 0) - { - mpz_set_ui (r, 1); - return; - } - - mp = m->_mp_d; - mpn_div_qr_invert (&minv, mp, mn); - shift = minv.shift; - - if (shift > 0) - { - /* To avoid shifts, we do all our reductions, except the final - one, using a *normalized* m. */ - minv.shift = 0; - - tp = gmp_xalloc_limbs (mn); - gmp_assert_nocarry (mpn_lshift (tp, mp, mn, shift)); - mp = tp; - } - - mpz_init (base); - - if (e->_mp_size < 0) - { - if (!mpz_invert (base, b, m)) - gmp_die ("mpz_powm: Negative exponent and non-invertible base."); - } - else - { - mp_size_t bn; - mpz_abs (base, b); - - bn = base->_mp_size; - if (bn >= mn) - { - mpn_div_qr_preinv (NULL, base->_mp_d, base->_mp_size, mp, mn, &minv); - bn = mn; - } - - /* We have reduced the absolute value. Now take care of the - sign. Note that we get zero represented non-canonically as - m. */ - if (b->_mp_size < 0) - { - mp_ptr bp = MPZ_REALLOC (base, mn); - gmp_assert_nocarry (mpn_sub (bp, mp, mn, bp, bn)); - bn = mn; - } - base->_mp_size = mpn_normalized_size (base->_mp_d, bn); - } - mpz_init_set_ui (tr, 1); - - while (--en >= 0) - { - mp_limb_t w = e->_mp_d[en]; - mp_limb_t bit; - - bit = GMP_LIMB_HIGHBIT; - do - { - mpz_mul (tr, tr, tr); - if (w & bit) - mpz_mul (tr, tr, base); - if (tr->_mp_size > mn) - { - mpn_div_qr_preinv (NULL, tr->_mp_d, tr->_mp_size, mp, mn, &minv); - tr->_mp_size = mpn_normalized_size (tr->_mp_d, mn); - } - bit >>= 1; - } - while (bit > 0); - } - - /* Final reduction */ - if (tr->_mp_size >= mn) - { - minv.shift = shift; - mpn_div_qr_preinv (NULL, tr->_mp_d, tr->_mp_size, mp, mn, &minv); - tr->_mp_size = mpn_normalized_size (tr->_mp_d, mn); - } - if (tp) - gmp_free (tp); - - mpz_swap (r, tr); - mpz_clear (tr); - mpz_clear (base); -} - -void -mpz_powm_ui (mpz_t r, const mpz_t b, unsigned long elimb, const mpz_t m) -{ - mpz_t e; - - mpz_init_set_ui (e, elimb); - mpz_powm (r, b, e, m); - mpz_clear (e); -} - -/* x=trunc(y^(1/z)), r=y-x^z */ -void -mpz_rootrem (mpz_t x, mpz_t r, const mpz_t y, unsigned long z) -{ - int sgn; - mpz_t t, u; - - sgn = y->_mp_size < 0; - if ((~z & sgn) != 0) - gmp_die ("mpz_rootrem: Negative argument, with even root."); - if (z == 0) - gmp_die ("mpz_rootrem: Zeroth root."); - - if (mpz_cmpabs_ui (y, 1) <= 0) { - if (x) - mpz_set (x, y); - if (r) - r->_mp_size = 0; - return; - } - - mpz_init (u); - mpz_init (t); - mpz_setbit (t, mpz_sizeinbase (y, 2) / z + 1); - - if (z == 2) /* simplify sqrt loop: z-1 == 1 */ - do { - mpz_swap (u, t); /* u = x */ - mpz_tdiv_q (t, y, u); /* t = y/x */ - mpz_add (t, t, u); /* t = y/x + x */ - mpz_tdiv_q_2exp (t, t, 1); /* x'= (y/x + x)/2 */ - } while (mpz_cmpabs (t, u) < 0); /* |x'| < |x| */ - else /* z != 2 */ { - mpz_t v; - - mpz_init (v); - if (sgn) - mpz_neg (t, t); - - do { - mpz_swap (u, t); /* u = x */ - mpz_pow_ui (t, u, z - 1); /* t = x^(z-1) */ - mpz_tdiv_q (t, y, t); /* t = y/x^(z-1) */ - mpz_mul_ui (v, u, z - 1); /* v = x*(z-1) */ - mpz_add (t, t, v); /* t = y/x^(z-1) + x*(z-1) */ - mpz_tdiv_q_ui (t, t, z); /* x'=(y/x^(z-1) + x*(z-1))/z */ - } while (mpz_cmpabs (t, u) < 0); /* |x'| < |x| */ - - mpz_clear (v); - } - - if (r) { - mpz_pow_ui (t, u, z); - mpz_sub (r, y, t); - } - if (x) - mpz_swap (x, u); - mpz_clear (u); - mpz_clear (t); -} - -int -mpz_root (mpz_t x, const mpz_t y, unsigned long z) -{ - int res; - mpz_t r; - - mpz_init (r); - mpz_rootrem (x, r, y, z); - res = r->_mp_size == 0; - mpz_clear (r); - - return res; -} - -/* Compute s = floor(sqrt(u)) and r = u - s^2. Allows r == NULL */ -void -mpz_sqrtrem (mpz_t s, mpz_t r, const mpz_t u) -{ - mpz_rootrem (s, r, u, 2); -} - -void -mpz_sqrt (mpz_t s, const mpz_t u) -{ - mpz_rootrem (s, NULL, u, 2); -} - -int -mpz_perfect_square_p (const mpz_t u) -{ - if (u->_mp_size <= 0) - return (u->_mp_size == 0); - else - return mpz_root (NULL, u, 2); -} - -int -mpn_perfect_square_p (mp_srcptr p, mp_size_t n) -{ - mpz_t t; - - assert (n > 0); - assert (p [n-1] != 0); - return mpz_root (NULL, mpz_roinit_normal_n (t, p, n), 2); -} - -mp_size_t -mpn_sqrtrem (mp_ptr sp, mp_ptr rp, mp_srcptr p, mp_size_t n) -{ - mpz_t s, r, u; - mp_size_t res; - - assert (n > 0); - assert (p [n-1] != 0); - - mpz_init (r); - mpz_init (s); - mpz_rootrem (s, r, mpz_roinit_normal_n (u, p, n), 2); - - assert (s->_mp_size == (n+1)/2); - mpn_copyd (sp, s->_mp_d, s->_mp_size); - mpz_clear (s); - res = r->_mp_size; - if (rp) - mpn_copyd (rp, r->_mp_d, res); - mpz_clear (r); - return res; -} - -/* Combinatorics */ - -void -mpz_mfac_uiui (mpz_t x, unsigned long n, unsigned long m) -{ - mpz_set_ui (x, n + (n == 0)); - if (m + 1 < 2) return; - while (n > m + 1) - mpz_mul_ui (x, x, n -= m); -} - -void -mpz_2fac_ui (mpz_t x, unsigned long n) -{ - mpz_mfac_uiui (x, n, 2); -} - -void -mpz_fac_ui (mpz_t x, unsigned long n) -{ - mpz_mfac_uiui (x, n, 1); -} - -void -mpz_bin_uiui (mpz_t r, unsigned long n, unsigned long k) -{ - mpz_t t; - - mpz_set_ui (r, k <= n); - - if (k > (n >> 1)) - k = (k <= n) ? n - k : 0; - - mpz_init (t); - mpz_fac_ui (t, k); - - for (; k > 0; --k) - mpz_mul_ui (r, r, n--); - - mpz_divexact (r, r, t); - mpz_clear (t); -} - - -/* Primality testing */ - -/* Computes Kronecker (a/b) with odd b, a!=0 and GCD(a,b) = 1 */ -/* Adapted from JACOBI_BASE_METHOD==4 in mpn/generic/jacbase.c */ -static int -gmp_jacobi_coprime (mp_limb_t a, mp_limb_t b) -{ - int c, bit = 0; - - assert (b & 1); - assert (a != 0); - /* assert (mpn_gcd_11 (a, b) == 1); */ - - /* Below, we represent a and b shifted right so that the least - significant one bit is implicit. */ - b >>= 1; - - gmp_ctz(c, a); - a >>= 1; - - do - { - a >>= c; - /* (2/b) = -1 if b = 3 or 5 mod 8 */ - bit ^= c & (b ^ (b >> 1)); - if (a < b) - { - bit ^= a & b; - a = b - a; - b -= a; - } - else - { - a -= b; - assert (a != 0); - } - - gmp_ctz(c, a); - ++c; - } - while (b > 0); - - return bit & 1 ? -1 : 1; -} - -static void -gmp_lucas_step_k_2k (mpz_t V, mpz_t Qk, const mpz_t n) -{ - mpz_mod (Qk, Qk, n); - /* V_{2k} <- V_k ^ 2 - 2Q^k */ - mpz_mul (V, V, V); - mpz_submul_ui (V, Qk, 2); - mpz_tdiv_r (V, V, n); - /* Q^{2k} = (Q^k)^2 */ - mpz_mul (Qk, Qk, Qk); -} - -/* Computes V_k, Q^k (mod n) for the Lucas' sequence */ -/* with P=1, Q=Q; k = (n>>b0)|1. */ -/* Requires an odd n > 4; b0 > 0; -2*Q must not overflow a long */ -/* Returns (U_k == 0) and sets V=V_k and Qk=Q^k. */ -static int -gmp_lucas_mod (mpz_t V, mpz_t Qk, long Q, - mp_bitcnt_t b0, const mpz_t n) -{ - mp_bitcnt_t bs; - mpz_t U; - int res; - - assert (b0 > 0); - assert (Q <= - (LONG_MIN / 2)); - assert (Q >= - (LONG_MAX / 2)); - assert (mpz_cmp_ui (n, 4) > 0); - assert (mpz_odd_p (n)); - - mpz_init_set_ui (U, 1); /* U1 = 1 */ - mpz_set_ui (V, 1); /* V1 = 1 */ - mpz_set_si (Qk, Q); - - for (bs = mpz_sizeinbase (n, 2) - 1; --bs >= b0;) - { - /* U_{2k} <- U_k * V_k */ - mpz_mul (U, U, V); - /* V_{2k} <- V_k ^ 2 - 2Q^k */ - /* Q^{2k} = (Q^k)^2 */ - gmp_lucas_step_k_2k (V, Qk, n); - - /* A step k->k+1 is performed if the bit in $n$ is 1 */ - /* mpz_tstbit(n,bs) or the bit is 0 in $n$ but */ - /* should be 1 in $n+1$ (bs == b0) */ - if (b0 == bs || mpz_tstbit (n, bs)) - { - /* Q^{k+1} <- Q^k * Q */ - mpz_mul_si (Qk, Qk, Q); - /* U_{k+1} <- (U_k + V_k) / 2 */ - mpz_swap (U, V); /* Keep in V the old value of U_k */ - mpz_add (U, U, V); - /* We have to compute U/2, so we need an even value, */ - /* equivalent (mod n) */ - if (mpz_odd_p (U)) - mpz_add (U, U, n); - mpz_tdiv_q_2exp (U, U, 1); - /* V_{k+1} <-(D*U_k + V_k) / 2 = - U_{k+1} + (D-1)/2*U_k = U_{k+1} - 2Q*U_k */ - mpz_mul_si (V, V, -2*Q); - mpz_add (V, U, V); - mpz_tdiv_r (V, V, n); - } - mpz_tdiv_r (U, U, n); - } - - res = U->_mp_size == 0; - mpz_clear (U); - return res; -} - -/* Performs strong Lucas' test on x, with parameters suggested */ -/* for the BPSW test. Qk is only passed to recycle a variable. */ -/* Requires GCD (x,6) = 1.*/ -static int -gmp_stronglucas (const mpz_t x, mpz_t Qk) -{ - mp_bitcnt_t b0; - mpz_t V, n; - mp_limb_t maxD, D; /* The absolute value is stored. */ - long Q; - mp_limb_t tl; - - /* Test on the absolute value. */ - mpz_roinit_normal_n (n, x->_mp_d, GMP_ABS (x->_mp_size)); - - assert (mpz_odd_p (n)); - /* assert (mpz_gcd_ui (NULL, n, 6) == 1); */ - if (mpz_root (Qk, n, 2)) - return 0; /* A square is composite. */ - - /* Check Ds up to square root (in case, n is prime) - or avoid overflows */ - maxD = (Qk->_mp_size == 1) ? Qk->_mp_d [0] - 1 : GMP_LIMB_MAX; - - D = 3; - /* Search a D such that (D/n) = -1 in the sequence 5,-7,9,-11,.. */ - /* For those Ds we have (D/n) = (n/|D|) */ - do - { - if (D >= maxD) - return 1 + (D != GMP_LIMB_MAX); /* (1 + ! ~ D) */ - D += 2; - tl = mpz_tdiv_ui (n, D); - if (tl == 0) - return 0; - } - while (gmp_jacobi_coprime (tl, D) == 1); - - mpz_init (V); - - /* n-(D/n) = n+1 = d*2^{b0}, with d = (n>>b0) | 1 */ - b0 = mpz_scan0 (n, 0); - - /* D= P^2 - 4Q; P = 1; Q = (1-D)/4 */ - Q = (D & 2) ? (long) (D >> 2) + 1 : -(long) (D >> 2); - - if (! gmp_lucas_mod (V, Qk, Q, b0, n)) /* If Ud != 0 */ - while (V->_mp_size != 0 && --b0 != 0) /* while Vk != 0 */ - /* V <- V ^ 2 - 2Q^k */ - /* Q^{2k} = (Q^k)^2 */ - gmp_lucas_step_k_2k (V, Qk, n); - - mpz_clear (V); - return (b0 != 0); -} - -static int -gmp_millerrabin (const mpz_t n, const mpz_t nm1, mpz_t y, - const mpz_t q, mp_bitcnt_t k) -{ - assert (k > 0); - - /* Caller must initialize y to the base. */ - mpz_powm (y, y, q, n); - - if (mpz_cmp_ui (y, 1) == 0 || mpz_cmp (y, nm1) == 0) - return 1; - - while (--k > 0) - { - mpz_powm_ui (y, y, 2, n); - if (mpz_cmp (y, nm1) == 0) - return 1; - /* y == 1 means that the previous y was a non-trivial square root - of 1 (mod n). y == 0 means that n is a power of the base. - In either case, n is not prime. */ - if (mpz_cmp_ui (y, 1) <= 0) - return 0; - } - return 0; -} - -/* This product is 0xc0cfd797, and fits in 32 bits. */ -#define GMP_PRIME_PRODUCT \ - (3UL*5UL*7UL*11UL*13UL*17UL*19UL*23UL*29UL) - -/* Bit (p+1)/2 is set, for each odd prime <= 61 */ -#define GMP_PRIME_MASK 0xc96996dcUL - -int -mpz_probab_prime_p (const mpz_t n, int reps) -{ - mpz_t nm1; - mpz_t q; - mpz_t y; - mp_bitcnt_t k; - int is_prime; - int j; - - /* Note that we use the absolute value of n only, for compatibility - with the real GMP. */ - if (mpz_even_p (n)) - return (mpz_cmpabs_ui (n, 2) == 0) ? 2 : 0; - - /* Above test excludes n == 0 */ - assert (n->_mp_size != 0); - - if (mpz_cmpabs_ui (n, 64) < 0) - return (GMP_PRIME_MASK >> (n->_mp_d[0] >> 1)) & 2; - - if (mpz_gcd_ui (NULL, n, GMP_PRIME_PRODUCT) != 1) - return 0; - - /* All prime factors are >= 31. */ - if (mpz_cmpabs_ui (n, 31*31) < 0) - return 2; - - mpz_init (nm1); - mpz_init (q); - - /* Find q and k, where q is odd and n = 1 + 2**k * q. */ - mpz_abs (nm1, n); - nm1->_mp_d[0] -= 1; - k = mpz_scan1 (nm1, 0); - mpz_tdiv_q_2exp (q, nm1, k); - - /* BPSW test */ - mpz_init_set_ui (y, 2); - is_prime = gmp_millerrabin (n, nm1, y, q, k) && gmp_stronglucas (n, y); - reps -= 24; /* skip the first 24 repetitions */ - - /* Use Miller-Rabin, with a deterministic sequence of bases, a[j] = - j^2 + j + 41 using Euler's polynomial. We potentially stop early, - if a[j] >= n - 1. Since n >= 31*31, this can happen only if reps > - 30 (a[30] == 971 > 31*31 == 961). */ - - for (j = 0; is_prime & (j < reps); j++) - { - mpz_set_ui (y, (unsigned long) j*j+j+41); - if (mpz_cmp (y, nm1) >= 0) - { - /* Don't try any further bases. This "early" break does not affect - the result for any reasonable reps value (<=5000 was tested) */ - assert (j >= 30); - break; - } - is_prime = gmp_millerrabin (n, nm1, y, q, k); - } - mpz_clear (nm1); - mpz_clear (q); - mpz_clear (y); - - return is_prime; -} - - -/* Logical operations and bit manipulation. */ - -/* Numbers are treated as if represented in two's complement (and - infinitely sign extended). For a negative values we get the two's - complement from -x = ~x + 1, where ~ is bitwise complement. - Negation transforms - - xxxx10...0 - - into - - yyyy10...0 - - where yyyy is the bitwise complement of xxxx. So least significant - bits, up to and including the first one bit, are unchanged, and - the more significant bits are all complemented. - - To change a bit from zero to one in a negative number, subtract the - corresponding power of two from the absolute value. This can never - underflow. To change a bit from one to zero, add the corresponding - power of two, and this might overflow. E.g., if x = -001111, the - two's complement is 110001. Clearing the least significant bit, we - get two's complement 110000, and -010000. */ - -int -mpz_tstbit (const mpz_t d, mp_bitcnt_t bit_index) -{ - mp_size_t limb_index; - unsigned shift; - mp_size_t ds; - mp_size_t dn; - mp_limb_t w; - int bit; - - ds = d->_mp_size; - dn = GMP_ABS (ds); - limb_index = bit_index / GMP_LIMB_BITS; - if (limb_index >= dn) - return ds < 0; - - shift = bit_index % GMP_LIMB_BITS; - w = d->_mp_d[limb_index]; - bit = (w >> shift) & 1; - - if (ds < 0) - { - /* d < 0. Check if any of the bits below is set: If so, our bit - must be complemented. */ - if (shift > 0 && (mp_limb_t) (w << (GMP_LIMB_BITS - shift)) > 0) - return bit ^ 1; - while (--limb_index >= 0) - if (d->_mp_d[limb_index] > 0) - return bit ^ 1; - } - return bit; -} - -static void -mpz_abs_add_bit (mpz_t d, mp_bitcnt_t bit_index) -{ - mp_size_t dn, limb_index; - mp_limb_t bit; - mp_ptr dp; - - dn = GMP_ABS (d->_mp_size); - - limb_index = bit_index / GMP_LIMB_BITS; - bit = (mp_limb_t) 1 << (bit_index % GMP_LIMB_BITS); - - if (limb_index >= dn) - { - mp_size_t i; - /* The bit should be set outside of the end of the number. - We have to increase the size of the number. */ - dp = MPZ_REALLOC (d, limb_index + 1); - - dp[limb_index] = bit; - for (i = dn; i < limb_index; i++) - dp[i] = 0; - dn = limb_index + 1; - } - else - { - mp_limb_t cy; - - dp = d->_mp_d; - - cy = mpn_add_1 (dp + limb_index, dp + limb_index, dn - limb_index, bit); - if (cy > 0) - { - dp = MPZ_REALLOC (d, dn + 1); - dp[dn++] = cy; - } - } - - d->_mp_size = (d->_mp_size < 0) ? - dn : dn; -} - -static void -mpz_abs_sub_bit (mpz_t d, mp_bitcnt_t bit_index) -{ - mp_size_t dn, limb_index; - mp_ptr dp; - mp_limb_t bit; - - dn = GMP_ABS (d->_mp_size); - dp = d->_mp_d; - - limb_index = bit_index / GMP_LIMB_BITS; - bit = (mp_limb_t) 1 << (bit_index % GMP_LIMB_BITS); - - assert (limb_index < dn); - - gmp_assert_nocarry (mpn_sub_1 (dp + limb_index, dp + limb_index, - dn - limb_index, bit)); - dn = mpn_normalized_size (dp, dn); - d->_mp_size = (d->_mp_size < 0) ? - dn : dn; -} - -void -mpz_setbit (mpz_t d, mp_bitcnt_t bit_index) -{ - if (!mpz_tstbit (d, bit_index)) - { - if (d->_mp_size >= 0) - mpz_abs_add_bit (d, bit_index); - else - mpz_abs_sub_bit (d, bit_index); - } -} - -void -mpz_clrbit (mpz_t d, mp_bitcnt_t bit_index) -{ - if (mpz_tstbit (d, bit_index)) - { - if (d->_mp_size >= 0) - mpz_abs_sub_bit (d, bit_index); - else - mpz_abs_add_bit (d, bit_index); - } -} - -void -mpz_combit (mpz_t d, mp_bitcnt_t bit_index) -{ - if (mpz_tstbit (d, bit_index) ^ (d->_mp_size < 0)) - mpz_abs_sub_bit (d, bit_index); - else - mpz_abs_add_bit (d, bit_index); -} - -void -mpz_com (mpz_t r, const mpz_t u) -{ - mpz_add_ui (r, u, 1); - mpz_neg (r, r); -} - -void -mpz_and (mpz_t r, const mpz_t u, const mpz_t v) -{ - mp_size_t un, vn, rn, i; - mp_ptr up, vp, rp; - - mp_limb_t ux, vx, rx; - mp_limb_t uc, vc, rc; - mp_limb_t ul, vl, rl; - - un = GMP_ABS (u->_mp_size); - vn = GMP_ABS (v->_mp_size); - if (un < vn) - { - MPZ_SRCPTR_SWAP (u, v); - MP_SIZE_T_SWAP (un, vn); - } - if (vn == 0) - { - r->_mp_size = 0; - return; - } - - uc = u->_mp_size < 0; - vc = v->_mp_size < 0; - rc = uc & vc; - - ux = -uc; - vx = -vc; - rx = -rc; - - /* If the smaller input is positive, higher limbs don't matter. */ - rn = vx ? un : vn; - - rp = MPZ_REALLOC (r, rn + (mp_size_t) rc); - - up = u->_mp_d; - vp = v->_mp_d; - - i = 0; - do - { - ul = (up[i] ^ ux) + uc; - uc = ul < uc; - - vl = (vp[i] ^ vx) + vc; - vc = vl < vc; - - rl = ( (ul & vl) ^ rx) + rc; - rc = rl < rc; - rp[i] = rl; - } - while (++i < vn); - assert (vc == 0); - - for (; i < rn; i++) - { - ul = (up[i] ^ ux) + uc; - uc = ul < uc; - - rl = ( (ul & vx) ^ rx) + rc; - rc = rl < rc; - rp[i] = rl; - } - if (rc) - rp[rn++] = rc; - else - rn = mpn_normalized_size (rp, rn); - - r->_mp_size = rx ? -rn : rn; -} - -void -mpz_ior (mpz_t r, const mpz_t u, const mpz_t v) -{ - mp_size_t un, vn, rn, i; - mp_ptr up, vp, rp; - - mp_limb_t ux, vx, rx; - mp_limb_t uc, vc, rc; - mp_limb_t ul, vl, rl; - - un = GMP_ABS (u->_mp_size); - vn = GMP_ABS (v->_mp_size); - if (un < vn) - { - MPZ_SRCPTR_SWAP (u, v); - MP_SIZE_T_SWAP (un, vn); - } - if (vn == 0) - { - mpz_set (r, u); - return; - } - - uc = u->_mp_size < 0; - vc = v->_mp_size < 0; - rc = uc | vc; - - ux = -uc; - vx = -vc; - rx = -rc; - - /* If the smaller input is negative, by sign extension higher limbs - don't matter. */ - rn = vx ? vn : un; - - rp = MPZ_REALLOC (r, rn + (mp_size_t) rc); - - up = u->_mp_d; - vp = v->_mp_d; - - i = 0; - do - { - ul = (up[i] ^ ux) + uc; - uc = ul < uc; - - vl = (vp[i] ^ vx) + vc; - vc = vl < vc; - - rl = ( (ul | vl) ^ rx) + rc; - rc = rl < rc; - rp[i] = rl; - } - while (++i < vn); - assert (vc == 0); - - for (; i < rn; i++) - { - ul = (up[i] ^ ux) + uc; - uc = ul < uc; - - rl = ( (ul | vx) ^ rx) + rc; - rc = rl < rc; - rp[i] = rl; - } - if (rc) - rp[rn++] = rc; - else - rn = mpn_normalized_size (rp, rn); - - r->_mp_size = rx ? -rn : rn; -} - -void -mpz_xor (mpz_t r, const mpz_t u, const mpz_t v) -{ - mp_size_t un, vn, i; - mp_ptr up, vp, rp; - - mp_limb_t ux, vx, rx; - mp_limb_t uc, vc, rc; - mp_limb_t ul, vl, rl; - - un = GMP_ABS (u->_mp_size); - vn = GMP_ABS (v->_mp_size); - if (un < vn) - { - MPZ_SRCPTR_SWAP (u, v); - MP_SIZE_T_SWAP (un, vn); - } - if (vn == 0) - { - mpz_set (r, u); - return; - } - - uc = u->_mp_size < 0; - vc = v->_mp_size < 0; - rc = uc ^ vc; - - ux = -uc; - vx = -vc; - rx = -rc; - - rp = MPZ_REALLOC (r, un + (mp_size_t) rc); - - up = u->_mp_d; - vp = v->_mp_d; - - i = 0; - do - { - ul = (up[i] ^ ux) + uc; - uc = ul < uc; - - vl = (vp[i] ^ vx) + vc; - vc = vl < vc; - - rl = (ul ^ vl ^ rx) + rc; - rc = rl < rc; - rp[i] = rl; - } - while (++i < vn); - assert (vc == 0); - - for (; i < un; i++) - { - ul = (up[i] ^ ux) + uc; - uc = ul < uc; - - rl = (ul ^ ux) + rc; - rc = rl < rc; - rp[i] = rl; - } - if (rc) - rp[un++] = rc; - else - un = mpn_normalized_size (rp, un); - - r->_mp_size = rx ? -un : un; -} - -static unsigned -gmp_popcount_limb (mp_limb_t x) -{ - unsigned c; - - /* Do 16 bits at a time, to avoid limb-sized constants. */ - for (c = 0; x > 0; x >>= 16) - { - unsigned w = x - ((x >> 1) & 0x5555); - w = ((w >> 2) & 0x3333) + (w & 0x3333); - w = (w >> 4) + w; - w = ((w >> 8) & 0x000f) + (w & 0x000f); - c += w; - } - return c; -} - -mp_bitcnt_t -mpn_popcount (mp_srcptr p, mp_size_t n) -{ - mp_size_t i; - mp_bitcnt_t c; - - for (c = 0, i = 0; i < n; i++) - c += gmp_popcount_limb (p[i]); - - return c; -} - -mp_bitcnt_t -mpz_popcount (const mpz_t u) -{ - mp_size_t un; - - un = u->_mp_size; - - if (un < 0) - return ~(mp_bitcnt_t) 0; - - return mpn_popcount (u->_mp_d, un); -} - -mp_bitcnt_t -mpz_hamdist (const mpz_t u, const mpz_t v) -{ - mp_size_t un, vn, i; - mp_limb_t uc, vc, ul, vl, comp; - mp_srcptr up, vp; - mp_bitcnt_t c; - - un = u->_mp_size; - vn = v->_mp_size; - - if ( (un ^ vn) < 0) - return ~(mp_bitcnt_t) 0; - - comp = - (uc = vc = (un < 0)); - if (uc) - { - assert (vn < 0); - un = -un; - vn = -vn; - } - - up = u->_mp_d; - vp = v->_mp_d; - - if (un < vn) - MPN_SRCPTR_SWAP (up, un, vp, vn); - - for (i = 0, c = 0; i < vn; i++) - { - ul = (up[i] ^ comp) + uc; - uc = ul < uc; - - vl = (vp[i] ^ comp) + vc; - vc = vl < vc; - - c += gmp_popcount_limb (ul ^ vl); - } - assert (vc == 0); - - for (; i < un; i++) - { - ul = (up[i] ^ comp) + uc; - uc = ul < uc; - - c += gmp_popcount_limb (ul ^ comp); - } - - return c; -} - -mp_bitcnt_t -mpz_scan1 (const mpz_t u, mp_bitcnt_t starting_bit) -{ - mp_ptr up; - mp_size_t us, un, i; - mp_limb_t limb, ux; - - us = u->_mp_size; - un = GMP_ABS (us); - i = starting_bit / GMP_LIMB_BITS; - - /* Past the end there's no 1 bits for u>=0, or an immediate 1 bit - for u<0. Notice this test picks up any u==0 too. */ - if (i >= un) - return (us >= 0 ? ~(mp_bitcnt_t) 0 : starting_bit); - - up = u->_mp_d; - ux = 0; - limb = up[i]; - - if (starting_bit != 0) - { - if (us < 0) - { - ux = mpn_zero_p (up, i); - limb = ~ limb + ux; - ux = - (mp_limb_t) (limb >= ux); - } - - /* Mask to 0 all bits before starting_bit, thus ignoring them. */ - limb &= GMP_LIMB_MAX << (starting_bit % GMP_LIMB_BITS); - } - - return mpn_common_scan (limb, i, up, un, ux); -} - -mp_bitcnt_t -mpz_scan0 (const mpz_t u, mp_bitcnt_t starting_bit) -{ - mp_ptr up; - mp_size_t us, un, i; - mp_limb_t limb, ux; - - us = u->_mp_size; - ux = - (mp_limb_t) (us >= 0); - un = GMP_ABS (us); - i = starting_bit / GMP_LIMB_BITS; - - /* When past end, there's an immediate 0 bit for u>=0, or no 0 bits for - u<0. Notice this test picks up all cases of u==0 too. */ - if (i >= un) - return (ux ? starting_bit : ~(mp_bitcnt_t) 0); - - up = u->_mp_d; - limb = up[i] ^ ux; - - if (ux == 0) - limb -= mpn_zero_p (up, i); /* limb = ~(~limb + zero_p) */ - - /* Mask all bits before starting_bit, thus ignoring them. */ - limb &= GMP_LIMB_MAX << (starting_bit % GMP_LIMB_BITS); - - return mpn_common_scan (limb, i, up, un, ux); -} - - -/* MPZ base conversion. */ - -size_t -mpz_sizeinbase (const mpz_t u, int base) -{ - mp_size_t un; - mp_srcptr up; - mp_ptr tp; - mp_bitcnt_t bits; - struct gmp_div_inverse bi; - size_t ndigits; - - assert (base >= 2); - assert (base <= 62); - - un = GMP_ABS (u->_mp_size); - if (un == 0) - return 1; - - up = u->_mp_d; - - bits = (un - 1) * GMP_LIMB_BITS + mpn_limb_size_in_base_2 (up[un-1]); - switch (base) - { - case 2: - return bits; - case 4: - return (bits + 1) / 2; - case 8: - return (bits + 2) / 3; - case 16: - return (bits + 3) / 4; - case 32: - return (bits + 4) / 5; - /* FIXME: Do something more clever for the common case of base - 10. */ - } - - tp = gmp_xalloc_limbs (un); - mpn_copyi (tp, up, un); - mpn_div_qr_1_invert (&bi, base); - - ndigits = 0; - do - { - ndigits++; - mpn_div_qr_1_preinv (tp, tp, un, &bi); - un -= (tp[un-1] == 0); - } - while (un > 0); - - gmp_free (tp); - return ndigits; -} - -char * -mpz_get_str (char *sp, int base, const mpz_t u) -{ - unsigned bits; - const char *digits; - mp_size_t un; - size_t i, sn; - - digits = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"; - if (base > 1) - { - if (base <= 36) - digits = "0123456789abcdefghijklmnopqrstuvwxyz"; - else if (base > 62) - return NULL; - } - else if (base >= -1) - base = 10; - else - { - base = -base; - if (base > 36) - return NULL; - } - - sn = 1 + mpz_sizeinbase (u, base); - if (!sp) - sp = (char *) gmp_xalloc (1 + sn); - - un = GMP_ABS (u->_mp_size); - - if (un == 0) - { - sp[0] = '0'; - sp[1] = '\0'; - return sp; - } - - i = 0; - - if (u->_mp_size < 0) - sp[i++] = '-'; - - bits = mpn_base_power_of_two_p (base); - - if (bits) - /* Not modified in this case. */ - sn = i + mpn_get_str_bits ((unsigned char *) sp + i, bits, u->_mp_d, un); - else - { - struct mpn_base_info info; - mp_ptr tp; - - mpn_get_base_info (&info, base); - tp = gmp_xalloc_limbs (un); - mpn_copyi (tp, u->_mp_d, un); - - sn = i + mpn_get_str_other ((unsigned char *) sp + i, base, &info, tp, un); - gmp_free (tp); - } - - for (; i < sn; i++) - sp[i] = digits[(unsigned char) sp[i]]; - - sp[sn] = '\0'; - return sp; -} - -int -mpz_set_str (mpz_t r, const char *sp, int base) -{ - unsigned bits, value_of_a; - mp_size_t rn, alloc; - mp_ptr rp; - size_t dn; - int sign; - unsigned char *dp; - - assert (base == 0 || (base >= 2 && base <= 62)); - - while (isspace( (unsigned char) *sp)) - sp++; - - sign = (*sp == '-'); - sp += sign; - - if (base == 0) - { - if (sp[0] == '0') - { - if (sp[1] == 'x' || sp[1] == 'X') - { - base = 16; - sp += 2; - } - else if (sp[1] == 'b' || sp[1] == 'B') - { - base = 2; - sp += 2; - } - else - base = 8; - } - else - base = 10; - } - - if (!*sp) - { - r->_mp_size = 0; - return -1; - } - dp = (unsigned char *) gmp_xalloc (strlen (sp)); - - value_of_a = (base > 36) ? 36 : 10; - for (dn = 0; *sp; sp++) - { - unsigned digit; - - if (isspace ((unsigned char) *sp)) - continue; - else if (*sp >= '0' && *sp <= '9') - digit = *sp - '0'; - else if (*sp >= 'a' && *sp <= 'z') - digit = *sp - 'a' + value_of_a; - else if (*sp >= 'A' && *sp <= 'Z') - digit = *sp - 'A' + 10; - else - digit = base; /* fail */ - - if (digit >= (unsigned) base) - { - gmp_free (dp); - r->_mp_size = 0; - return -1; - } - - dp[dn++] = digit; - } - - if (!dn) - { - gmp_free (dp); - r->_mp_size = 0; - return -1; - } - bits = mpn_base_power_of_two_p (base); - - if (bits > 0) - { - alloc = (dn * bits + GMP_LIMB_BITS - 1) / GMP_LIMB_BITS; - rp = MPZ_REALLOC (r, alloc); - rn = mpn_set_str_bits (rp, dp, dn, bits); - } - else - { - struct mpn_base_info info; - mpn_get_base_info (&info, base); - alloc = (dn + info.exp - 1) / info.exp; - rp = MPZ_REALLOC (r, alloc); - rn = mpn_set_str_other (rp, dp, dn, base, &info); - /* Normalization, needed for all-zero input. */ - assert (rn > 0); - rn -= rp[rn-1] == 0; - } - assert (rn <= alloc); - gmp_free (dp); - - r->_mp_size = sign ? - rn : rn; - - return 0; -} - -int -mpz_init_set_str (mpz_t r, const char *sp, int base) -{ - mpz_init (r); - return mpz_set_str (r, sp, base); -} - -size_t -mpz_out_str (FILE *stream, int base, const mpz_t x) -{ - char *str; - size_t len; - - str = mpz_get_str (NULL, base, x); - len = strlen (str); - len = fwrite (str, 1, len, stream); - gmp_free (str); - return len; -} - - -static int -gmp_detect_endian (void) -{ - static const int i = 2; - const unsigned char *p = (const unsigned char *) &i; - return 1 - *p; -} - -/* Import and export. Does not support nails. */ -void -mpz_import (mpz_t r, size_t count, int order, size_t size, int endian, - size_t nails, const void *src) -{ - const unsigned char *p; - ptrdiff_t word_step; - mp_ptr rp; - mp_size_t rn; - - /* The current (partial) limb. */ - mp_limb_t limb; - /* The number of bytes already copied to this limb (starting from - the low end). */ - size_t bytes; - /* The index where the limb should be stored, when completed. */ - mp_size_t i; - - if (nails != 0) - gmp_die ("mpz_import: Nails not supported."); - - assert (order == 1 || order == -1); - assert (endian >= -1 && endian <= 1); - - if (endian == 0) - endian = gmp_detect_endian (); - - p = (unsigned char *) src; - - word_step = (order != endian) ? 2 * size : 0; - - /* Process bytes from the least significant end, so point p at the - least significant word. */ - if (order == 1) - { - p += size * (count - 1); - word_step = - word_step; - } - - /* And at least significant byte of that word. */ - if (endian == 1) - p += (size - 1); - - rn = (size * count + sizeof(mp_limb_t) - 1) / sizeof(mp_limb_t); - rp = MPZ_REALLOC (r, rn); - - for (limb = 0, bytes = 0, i = 0; count > 0; count--, p += word_step) - { - size_t j; - for (j = 0; j < size; j++, p -= (ptrdiff_t) endian) - { - limb |= (mp_limb_t) *p << (bytes++ * CHAR_BIT); - if (bytes == sizeof(mp_limb_t)) - { - rp[i++] = limb; - bytes = 0; - limb = 0; - } - } - } - assert (i + (bytes > 0) == rn); - if (limb != 0) - rp[i++] = limb; - else - i = mpn_normalized_size (rp, i); - - r->_mp_size = i; -} - -void * -mpz_export (void *r, size_t *countp, int order, size_t size, int endian, - size_t nails, const mpz_t u) -{ - size_t count; - mp_size_t un; - - if (nails != 0) - gmp_die ("mpz_import: Nails not supported."); - - assert (order == 1 || order == -1); - assert (endian >= -1 && endian <= 1); - assert (size > 0 || u->_mp_size == 0); - - un = u->_mp_size; - count = 0; - if (un != 0) - { - size_t k; - unsigned char *p; - ptrdiff_t word_step; - /* The current (partial) limb. */ - mp_limb_t limb; - /* The number of bytes left to do in this limb. */ - size_t bytes; - /* The index where the limb was read. */ - mp_size_t i; - - un = GMP_ABS (un); - - /* Count bytes in top limb. */ - limb = u->_mp_d[un-1]; - assert (limb != 0); - - k = 0; - do { - k++; limb >>= CHAR_BIT; - } while (limb != 0); - - count = (k + (un-1) * sizeof (mp_limb_t) + size - 1) / size; - - if (!r) - r = gmp_xalloc (count * size); - - if (endian == 0) - endian = gmp_detect_endian (); - - p = (unsigned char *) r; - - word_step = (order != endian) ? 2 * size : 0; - - /* Process bytes from the least significant end, so point p at the - least significant word. */ - if (order == 1) - { - p += size * (count - 1); - word_step = - word_step; - } - - /* And at least significant byte of that word. */ - if (endian == 1) - p += (size - 1); - - for (bytes = 0, i = 0, k = 0; k < count; k++, p += word_step) - { - size_t j; - for (j = 0; j < size; j++, p -= (ptrdiff_t) endian) - { - if (bytes == 0) - { - if (i < un) - limb = u->_mp_d[i++]; - bytes = sizeof (mp_limb_t); - } - *p = limb; - limb >>= CHAR_BIT; - bytes--; - } - } - assert (i == un); - assert (k == count); - } - - if (countp) - *countp = count; - - return r; -} diff --git a/src/mini-gmp.h b/src/mini-gmp.h deleted file mode 100644 index 27e0c0671a2..00000000000 --- a/src/mini-gmp.h +++ /dev/null @@ -1,300 +0,0 @@ -/* mini-gmp, a minimalistic implementation of a GNU GMP subset. - -Copyright 2011-2015, 2017 Free Software Foundation, Inc. - -This file is part of the GNU MP Library. - -The GNU MP Library is free software; you can redistribute it and/or modify -it under the terms of either: - - * the GNU Lesser General Public License as published by the Free - Software Foundation; either version 3 of the License, or (at your - option) any later version. - -or - - * the GNU General Public License as published by the Free Software - Foundation; either version 2 of the License, or (at your option) any - later version. - -or both in parallel, as here. - -The GNU MP Library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received copies of the GNU General Public License and the -GNU Lesser General Public License along with the GNU MP Library. If not, -see https://www.gnu.org/licenses/. */ - -/* About mini-gmp: This is a minimal implementation of a subset of the - GMP interface. It is intended for inclusion into applications which - have modest bignums needs, as a fallback when the real GMP library - is not installed. - - This file defines the public interface. */ - -#ifndef __MINI_GMP_H__ -#define __MINI_GMP_H__ - -/* For size_t */ -#include <stddef.h> - -#if defined (__cplusplus) -extern "C" { -#endif - -void mp_set_memory_functions (void *(*) (size_t), - void *(*) (void *, size_t, size_t), - void (*) (void *, size_t)); - -void mp_get_memory_functions (void *(**) (size_t), - void *(**) (void *, size_t, size_t), - void (**) (void *, size_t)); - -typedef unsigned long mp_limb_t; -typedef long mp_size_t; -typedef unsigned long mp_bitcnt_t; - -typedef mp_limb_t *mp_ptr; -typedef const mp_limb_t *mp_srcptr; - -typedef struct -{ - int _mp_alloc; /* Number of *limbs* allocated and pointed - to by the _mp_d field. */ - int _mp_size; /* abs(_mp_size) is the number of limbs the - last field points to. If _mp_size is - negative this is a negative number. */ - mp_limb_t *_mp_d; /* Pointer to the limbs. */ -} __mpz_struct; - -typedef __mpz_struct mpz_t[1]; - -typedef __mpz_struct *mpz_ptr; -typedef const __mpz_struct *mpz_srcptr; - -extern const int mp_bits_per_limb; - -void mpn_copyi (mp_ptr, mp_srcptr, mp_size_t); -void mpn_copyd (mp_ptr, mp_srcptr, mp_size_t); -void mpn_zero (mp_ptr, mp_size_t); - -int mpn_cmp (mp_srcptr, mp_srcptr, mp_size_t); -int mpn_zero_p (mp_srcptr, mp_size_t); - -mp_limb_t mpn_add_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); -mp_limb_t mpn_add_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t); -mp_limb_t mpn_add (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t); - -mp_limb_t mpn_sub_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); -mp_limb_t mpn_sub_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t); -mp_limb_t mpn_sub (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t); - -mp_limb_t mpn_mul_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); -mp_limb_t mpn_addmul_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); -mp_limb_t mpn_submul_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); - -mp_limb_t mpn_mul (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t); -void mpn_mul_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t); -void mpn_sqr (mp_ptr, mp_srcptr, mp_size_t); -int mpn_perfect_square_p (mp_srcptr, mp_size_t); -mp_size_t mpn_sqrtrem (mp_ptr, mp_ptr, mp_srcptr, mp_size_t); - -mp_limb_t mpn_lshift (mp_ptr, mp_srcptr, mp_size_t, unsigned int); -mp_limb_t mpn_rshift (mp_ptr, mp_srcptr, mp_size_t, unsigned int); - -mp_bitcnt_t mpn_scan0 (mp_srcptr, mp_bitcnt_t); -mp_bitcnt_t mpn_scan1 (mp_srcptr, mp_bitcnt_t); - -void mpn_com (mp_ptr, mp_srcptr, mp_size_t); -mp_limb_t mpn_neg (mp_ptr, mp_srcptr, mp_size_t); - -mp_bitcnt_t mpn_popcount (mp_srcptr, mp_size_t); - -mp_limb_t mpn_invert_3by2 (mp_limb_t, mp_limb_t); -#define mpn_invert_limb(x) mpn_invert_3by2 ((x), 0) - -size_t mpn_get_str (unsigned char *, int, mp_ptr, mp_size_t); -mp_size_t mpn_set_str (mp_ptr, const unsigned char *, size_t, int); - -void mpz_init (mpz_t); -void mpz_init2 (mpz_t, mp_bitcnt_t); -void mpz_clear (mpz_t); - -#define mpz_odd_p(z) (((z)->_mp_size != 0) & (int) (z)->_mp_d[0]) -#define mpz_even_p(z) (! mpz_odd_p (z)) - -int mpz_sgn (const mpz_t); -int mpz_cmp_si (const mpz_t, long); -int mpz_cmp_ui (const mpz_t, unsigned long); -int mpz_cmp (const mpz_t, const mpz_t); -int mpz_cmpabs_ui (const mpz_t, unsigned long); -int mpz_cmpabs (const mpz_t, const mpz_t); -int mpz_cmp_d (const mpz_t, double); -int mpz_cmpabs_d (const mpz_t, double); - -void mpz_abs (mpz_t, const mpz_t); -void mpz_neg (mpz_t, const mpz_t); -void mpz_swap (mpz_t, mpz_t); - -void mpz_add_ui (mpz_t, const mpz_t, unsigned long); -void mpz_add (mpz_t, const mpz_t, const mpz_t); -void mpz_sub_ui (mpz_t, const mpz_t, unsigned long); -void mpz_ui_sub (mpz_t, unsigned long, const mpz_t); -void mpz_sub (mpz_t, const mpz_t, const mpz_t); - -void mpz_mul_si (mpz_t, const mpz_t, long int); -void mpz_mul_ui (mpz_t, const mpz_t, unsigned long int); -void mpz_mul (mpz_t, const mpz_t, const mpz_t); -void mpz_mul_2exp (mpz_t, const mpz_t, mp_bitcnt_t); -void mpz_addmul_ui (mpz_t, const mpz_t, unsigned long int); -void mpz_addmul (mpz_t, const mpz_t, const mpz_t); -void mpz_submul_ui (mpz_t, const mpz_t, unsigned long int); -void mpz_submul (mpz_t, const mpz_t, const mpz_t); - -void mpz_cdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t); -void mpz_fdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t); -void mpz_tdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t); -void mpz_cdiv_q (mpz_t, const mpz_t, const mpz_t); -void mpz_fdiv_q (mpz_t, const mpz_t, const mpz_t); -void mpz_tdiv_q (mpz_t, const mpz_t, const mpz_t); -void mpz_cdiv_r (mpz_t, const mpz_t, const mpz_t); -void mpz_fdiv_r (mpz_t, const mpz_t, const mpz_t); -void mpz_tdiv_r (mpz_t, const mpz_t, const mpz_t); - -void mpz_cdiv_q_2exp (mpz_t, const mpz_t, mp_bitcnt_t); -void mpz_fdiv_q_2exp (mpz_t, const mpz_t, mp_bitcnt_t); -void mpz_tdiv_q_2exp (mpz_t, const mpz_t, mp_bitcnt_t); -void mpz_cdiv_r_2exp (mpz_t, const mpz_t, mp_bitcnt_t); -void mpz_fdiv_r_2exp (mpz_t, const mpz_t, mp_bitcnt_t); -void mpz_tdiv_r_2exp (mpz_t, const mpz_t, mp_bitcnt_t); - -void mpz_mod (mpz_t, const mpz_t, const mpz_t); - -void mpz_divexact (mpz_t, const mpz_t, const mpz_t); - -int mpz_divisible_p (const mpz_t, const mpz_t); -int mpz_congruent_p (const mpz_t, const mpz_t, const mpz_t); - -unsigned long mpz_cdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long); -unsigned long mpz_fdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long); -unsigned long mpz_tdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long); -unsigned long mpz_cdiv_q_ui (mpz_t, const mpz_t, unsigned long); -unsigned long mpz_fdiv_q_ui (mpz_t, const mpz_t, unsigned long); -unsigned long mpz_tdiv_q_ui (mpz_t, const mpz_t, unsigned long); -unsigned long mpz_cdiv_r_ui (mpz_t, const mpz_t, unsigned long); -unsigned long mpz_fdiv_r_ui (mpz_t, const mpz_t, unsigned long); -unsigned long mpz_tdiv_r_ui (mpz_t, const mpz_t, unsigned long); -unsigned long mpz_cdiv_ui (const mpz_t, unsigned long); -unsigned long mpz_fdiv_ui (const mpz_t, unsigned long); -unsigned long mpz_tdiv_ui (const mpz_t, unsigned long); - -unsigned long mpz_mod_ui (mpz_t, const mpz_t, unsigned long); - -void mpz_divexact_ui (mpz_t, const mpz_t, unsigned long); - -int mpz_divisible_ui_p (const mpz_t, unsigned long); - -unsigned long mpz_gcd_ui (mpz_t, const mpz_t, unsigned long); -void mpz_gcd (mpz_t, const mpz_t, const mpz_t); -void mpz_gcdext (mpz_t, mpz_t, mpz_t, const mpz_t, const mpz_t); -void mpz_lcm_ui (mpz_t, const mpz_t, unsigned long); -void mpz_lcm (mpz_t, const mpz_t, const mpz_t); -int mpz_invert (mpz_t, const mpz_t, const mpz_t); - -void mpz_sqrtrem (mpz_t, mpz_t, const mpz_t); -void mpz_sqrt (mpz_t, const mpz_t); -int mpz_perfect_square_p (const mpz_t); - -void mpz_pow_ui (mpz_t, const mpz_t, unsigned long); -void mpz_ui_pow_ui (mpz_t, unsigned long, unsigned long); -void mpz_powm (mpz_t, const mpz_t, const mpz_t, const mpz_t); -void mpz_powm_ui (mpz_t, const mpz_t, unsigned long, const mpz_t); - -void mpz_rootrem (mpz_t, mpz_t, const mpz_t, unsigned long); -int mpz_root (mpz_t, const mpz_t, unsigned long); - -void mpz_fac_ui (mpz_t, unsigned long); -void mpz_2fac_ui (mpz_t, unsigned long); -void mpz_mfac_uiui (mpz_t, unsigned long, unsigned long); -void mpz_bin_uiui (mpz_t, unsigned long, unsigned long); - -int mpz_probab_prime_p (const mpz_t, int); - -int mpz_tstbit (const mpz_t, mp_bitcnt_t); -void mpz_setbit (mpz_t, mp_bitcnt_t); -void mpz_clrbit (mpz_t, mp_bitcnt_t); -void mpz_combit (mpz_t, mp_bitcnt_t); - -void mpz_com (mpz_t, const mpz_t); -void mpz_and (mpz_t, const mpz_t, const mpz_t); -void mpz_ior (mpz_t, const mpz_t, const mpz_t); -void mpz_xor (mpz_t, const mpz_t, const mpz_t); - -mp_bitcnt_t mpz_popcount (const mpz_t); -mp_bitcnt_t mpz_hamdist (const mpz_t, const mpz_t); -mp_bitcnt_t mpz_scan0 (const mpz_t, mp_bitcnt_t); -mp_bitcnt_t mpz_scan1 (const mpz_t, mp_bitcnt_t); - -int mpz_fits_slong_p (const mpz_t); -int mpz_fits_ulong_p (const mpz_t); -long int mpz_get_si (const mpz_t); -unsigned long int mpz_get_ui (const mpz_t); -double mpz_get_d (const mpz_t); -size_t mpz_size (const mpz_t); -mp_limb_t mpz_getlimbn (const mpz_t, mp_size_t); - -void mpz_realloc2 (mpz_t, mp_bitcnt_t); -mp_srcptr mpz_limbs_read (mpz_srcptr); -mp_ptr mpz_limbs_modify (mpz_t, mp_size_t); -mp_ptr mpz_limbs_write (mpz_t, mp_size_t); -void mpz_limbs_finish (mpz_t, mp_size_t); -mpz_srcptr mpz_roinit_n (mpz_t, mp_srcptr, mp_size_t); - -#define MPZ_ROINIT_N(xp, xs) {{0, (xs),(xp) }} - -void mpz_set_si (mpz_t, signed long int); -void mpz_set_ui (mpz_t, unsigned long int); -void mpz_set (mpz_t, const mpz_t); -void mpz_set_d (mpz_t, double); - -void mpz_init_set_si (mpz_t, signed long int); -void mpz_init_set_ui (mpz_t, unsigned long int); -void mpz_init_set (mpz_t, const mpz_t); -void mpz_init_set_d (mpz_t, double); - -size_t mpz_sizeinbase (const mpz_t, int); -char *mpz_get_str (char *, int, const mpz_t); -int mpz_set_str (mpz_t, const char *, int); -int mpz_init_set_str (mpz_t, const char *, int); - -/* This long list taken from gmp.h. */ -/* For reference, "defined(EOF)" cannot be used here. In g++ 2.95.4, - <iostream> defines EOF but not FILE. */ -#if defined (FILE) \ - || defined (H_STDIO) \ - || defined (_H_STDIO) /* AIX */ \ - || defined (_STDIO_H) /* glibc, Sun, SCO */ \ - || defined (_STDIO_H_) /* BSD, OSF */ \ - || defined (__STDIO_H) /* Borland */ \ - || defined (__STDIO_H__) /* IRIX */ \ - || defined (_STDIO_INCLUDED) /* HPUX */ \ - || defined (__dj_include_stdio_h_) /* DJGPP */ \ - || defined (_FILE_DEFINED) /* Microsoft */ \ - || defined (__STDIO__) /* Apple MPW MrC */ \ - || defined (_MSL_STDIO_H) /* Metrowerks */ \ - || defined (_STDIO_H_INCLUDED) /* QNX4 */ \ - || defined (_ISO_STDIO_ISO_H) /* Sun C++ */ \ - || defined (__STDIO_LOADED) /* VMS */ -size_t mpz_out_str (FILE *, int, const mpz_t); -#endif - -void mpz_import (mpz_t, size_t, int, size_t, int, size_t, const void *); -void *mpz_export (void *, size_t *, int, size_t, int, size_t, const mpz_t); - -#if defined (__cplusplus) -} -#endif -#endif /* __MINI_GMP_H__ */ diff --git a/src/minibuf.c b/src/minibuf.c index 552e6e022e7..949c3d989d5 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -63,7 +63,34 @@ static Lisp_Object minibuf_prompt; static ptrdiff_t minibuf_prompt_width; +static Lisp_Object nth_minibuffer (EMACS_INT depth); + +/* Return TRUE when a frame switch causes a minibuffer on the old + frame to move onto the new one. */ +static bool +minibuf_follows_frame (void) +{ + return EQ (Fdefault_toplevel_value (Qminibuffer_follows_selected_frame), + Qt); +} + +/* Return TRUE when a minibuffer always remains on the frame where it + was first invoked. */ +static bool +minibuf_stays_put (void) +{ + return NILP (Fdefault_toplevel_value (Qminibuffer_follows_selected_frame)); +} + +/* Return TRUE when opening a (recursive) minibuffer causes + minibuffers on other frames to move to the selected frame. */ +static bool +minibuf_moves_frame_when_opened (void) +{ + return !NILP (Fdefault_toplevel_value (Qminibuffer_follows_selected_frame)); +} + /* Put minibuf on currently selected frame's minibuffer. We do this whenever the user starts a new minibuffer or when a minibuffer exits. */ @@ -76,39 +103,88 @@ choose_minibuf_frame (void) && !EQ (minibuf_window, XFRAME (selected_frame)->minibuffer_window)) { struct frame *sf = XFRAME (selected_frame); - Lisp_Object buffer; - /* I don't think that any frames may validly have a null minibuffer window anymore. */ if (NILP (sf->minibuffer_window)) emacs_abort (); - /* Under X, we come here with minibuf_window being the - minibuffer window of the unused termcap window created in - init_window_once. That window doesn't have a buffer. */ - buffer = XWINDOW (minibuf_window)->contents; - if (BUFFERP (buffer)) - /* Use set_window_buffer instead of Fset_window_buffer (see - discussion of bug#11984, bug#12025, bug#12026). */ - set_window_buffer (sf->minibuffer_window, buffer, 0, 0); minibuf_window = sf->minibuffer_window; + /* If we've still got another minibuffer open, use its mini-window + instead. */ + if (minibuf_level > 1 && minibuf_stays_put ()) + { + Lisp_Object buffer = get_minibuffer (minibuf_level); + Lisp_Object tail, frame; + + FOR_EACH_FRAME (tail, frame) + if (EQ (XWINDOW (XFRAME (frame)->minibuffer_window)->contents, + buffer)) + { + minibuf_window = XFRAME (frame)->minibuffer_window; + break; + } + } } - /* Make sure no other frame has a minibuffer as its selected window, - because the text would not be displayed in it, and that would be - confusing. Only allow the selected frame to do this, - and that only if the minibuffer is active. */ + if (minibuf_moves_frame_when_opened () + && FRAMEP (selected_frame) + && FRAME_LIVE_P (XFRAME (selected_frame))) + /* Make sure no other frame has a minibuffer as its selected window, + because the text would not be displayed in it, and that would be + confusing. Only allow the selected frame to do this, + and that only if the minibuffer is active. */ { Lisp_Object tail, frame; + struct frame *of; FOR_EACH_FRAME (tail, frame) - if (MINI_WINDOW_P (XWINDOW (FRAME_SELECTED_WINDOW (XFRAME (frame)))) - && !(EQ (frame, selected_frame) - && minibuf_level > 0)) - Fset_frame_selected_window (frame, Fframe_first_window (frame), Qnil); + if (!EQ (frame, selected_frame) + && minibuf_level > 1 + /* The frame's minibuffer can be on a different frame. */ + && ! EQ (XWINDOW ((of = XFRAME (frame))->minibuffer_window)->frame, + selected_frame)) + { + if (MINI_WINDOW_P (XWINDOW (FRAME_SELECTED_WINDOW (of)))) + Fset_frame_selected_window (frame, Fframe_first_window (frame), + Qnil); + + if (!EQ (XWINDOW (of->minibuffer_window)->contents, + nth_minibuffer (0))) + set_window_buffer (of->minibuffer_window, + nth_minibuffer (0), 0, 0); + } } } +/* If `minibuffer_follows_selected_frame' is t and we have a + minibuffer, move it from its current frame to the selected frame. + This function is intended to be called from `do_switch_frame' in + frame.c. */ +void move_minibuffer_onto_frame (void) +{ + if (!minibuf_level) + return; + if (!minibuf_follows_frame ()) + return; + if (FRAMEP (selected_frame) + && FRAME_LIVE_P (XFRAME (selected_frame)) + && !EQ (minibuf_window, XFRAME (selected_frame)->minibuffer_window)) + { + EMACS_INT i; + struct frame *sf = XFRAME (selected_frame); + Lisp_Object old_frame = XWINDOW (minibuf_window)->frame; + struct frame *of = XFRAME (old_frame); + + /* Stack up all the (recursively) open minibuffers on the selected + mini_window. */ + for (i = 1; i <= minibuf_level; i++) + set_window_buffer (sf->minibuffer_window, nth_minibuffer (i), 0, 0); + minibuf_window = sf->minibuffer_window; + if (of != sf) + set_window_buffer (of->minibuffer_window, get_minibuffer (0), 0, 0); + } +} + DEFUN ("active-minibuffer-window", Factive_minibuffer_window, Sactive_minibuffer_window, 0, 0, 0, doc: /* Return the currently active minibuffer window, or nil if none. */) @@ -251,7 +327,7 @@ read_minibuf_noninteractive (Lisp_Object prompt, bool expflag, else { xfree (line); - error ("Error reading from stdin"); + xsignal1 (Qend_of_file, build_string ("Error reading from stdin")); } /* If Lisp form desired instead of string, parse it. */ @@ -261,15 +337,31 @@ read_minibuf_noninteractive (Lisp_Object prompt, bool expflag, return val; } +/* Return true when BUFFER is an active minibuffer. */ +static bool +live_minibuffer_p (Lisp_Object buffer) +{ + Lisp_Object tem; + EMACS_INT i; + + if (EQ (buffer, Fcar (Vminibuffer_list))) + /* *Minibuf-0* is never active. */ + return false; + tem = Fcdr (Vminibuffer_list); + for (i = 1; i <= minibuf_level; i++, tem = Fcdr (tem)) + if (EQ (Fcar (tem), buffer)) + return true; + return false; +} + DEFUN ("minibufferp", Fminibufferp, - Sminibufferp, 0, 1, 0, + Sminibufferp, 0, 2, 0, doc: /* Return t if BUFFER is a minibuffer. No argument or nil as argument means use current buffer as BUFFER. -BUFFER can be a buffer or a buffer name. */) - (Lisp_Object buffer) +BUFFER can be a buffer or a buffer name. If LIVE is non-nil, then +return t only if BUFFER is an active minibuffer. */) + (Lisp_Object buffer, Lisp_Object live) { - Lisp_Object tem; - if (NILP (buffer)) buffer = Fcurrent_buffer (); else if (STRINGP (buffer)) @@ -277,8 +369,67 @@ BUFFER can be a buffer or a buffer name. */) else CHECK_BUFFER (buffer); - tem = Fmemq (buffer, Vminibuffer_list); - return ! NILP (tem) ? Qt : Qnil; + return (NILP (live) + ? !NILP (Fmemq (buffer, Vminibuffer_list)) + : live_minibuffer_p (buffer)) + ? Qt : Qnil; +} + +DEFUN ("innermost-minibuffer-p", Finnermost_minibuffer_p, + Sinnermost_minibuffer_p, 0, 1, 0, + doc: /* Return t if BUFFER is the most nested active minibuffer. +No argument or nil as argument means use the current buffer as BUFFER. */) + (Lisp_Object buffer) +{ + if (NILP (buffer)) + buffer = Fcurrent_buffer (); + return EQ (buffer, (Fcar (Fnthcdr (make_fixnum (minibuf_level), + Vminibuffer_list)))) + ? Qt + : Qnil; +} + +/* Return the nesting depth of the active minibuffer BUFFER, or 0 if + BUFFER isn't such a thing. If BUFFER is nil, this means use the current + buffer. */ +EMACS_INT +this_minibuffer_depth (Lisp_Object buffer) +{ + EMACS_INT i; + Lisp_Object bufs; + + if (NILP (buffer)) + buffer = Fcurrent_buffer (); + for (i = 1, bufs = Fcdr (Vminibuffer_list); + i <= minibuf_level; + i++, bufs = Fcdr (bufs)) + if (EQ (Fcar (bufs), buffer)) + return i; + return 0; +} + +DEFUN ("abort-minibuffers", Fabort_minibuffers, Sabort_minibuffers, 0, 0, "", + doc: /* Abort the current minibuffer. +If we are not currently in the innermost minibuffer, prompt the user to +confirm the aborting of the current minibuffer and all contained ones. */) + (void) +{ + EMACS_INT minibuf_depth = this_minibuffer_depth (Qnil); + Lisp_Object array[2]; + AUTO_STRING (fmt, "Abort %s minibuffer levels? "); + + if (!minibuf_depth) + error ("Not in a minibuffer"); + if (minibuf_depth < minibuf_level) + { + array[0] = fmt; + array[1] = make_fixnum (minibuf_level - minibuf_depth + 1); + if (!NILP (Fyes_or_no_p (Fformat (2, array)))) + Fthrow (Qexit, Qt); + } + else + Fthrow (Qexit, Qt); + return Qnil; } DEFUN ("minibuffer-prompt-end", Fminibuffer_prompt_end, @@ -356,6 +507,7 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, Lisp_Object val; ptrdiff_t count = SPECPDL_INDEX (); Lisp_Object mini_frame, ambient_dir, minibuffer, input_method; + Lisp_Object calling_frame = selected_frame; Lisp_Object enable_multibyte; EMACS_INT pos = 0; /* String to add to the history. */ @@ -414,12 +566,13 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, if (!enable_recursive_minibuffers && minibuf_level > 0) { + Lisp_Object str + = build_string ("Command attempted to use minibuffer while in minibuffer"); if (EQ (selected_window, minibuf_window)) - error ("Command attempted to use minibuffer while in minibuffer"); + Fsignal (Quser_error, (list1 (str))); else /* If we're in another window, cancel the minibuffer that's active. */ - Fthrow (Qexit, - build_string ("Command attempted to use minibuffer while in minibuffer")); + Fthrow (Qexit, str); } if ((noninteractive @@ -432,6 +585,8 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, return unbind_to (count, val); } + minibuf_level++; /* Before calling choose_minibuf_frame. */ + /* Choose the minibuffer window and frame, and take action on them. */ /* Prepare for restoring the current buffer since choose_minibuf_frame @@ -439,18 +594,33 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, record_unwind_protect (restore_buffer, Fcurrent_buffer ()); choose_minibuf_frame (); + mini_frame = WINDOW_FRAME (XWINDOW (minibuf_window)); + + if (minibuf_level > 1 + && minibuf_moves_frame_when_opened () + && !minibuf_follows_frame ()) + { + EMACS_INT i; + + /* Stack up the existing minibuffers on the current mini-window */ + for (i = 1; i < minibuf_level; i++) + set_window_buffer (minibuf_window, nth_minibuffer (i), 0, 0); + } record_unwind_protect_void (choose_minibuf_frame); record_unwind_protect (restore_window_configuration, - Fcurrent_window_configuration (Qnil)); + Fcons (Qt, Fcurrent_window_configuration (Qnil))); /* If the minibuffer window is on a different frame, save that frame's configuration too. */ - mini_frame = WINDOW_FRAME (XWINDOW (minibuf_window)); if (!EQ (mini_frame, selected_frame)) record_unwind_protect (restore_window_configuration, - Fcurrent_window_configuration (mini_frame)); + Fcons (/* Arrange for the frame later to be + switched back to the calling + frame. */ + Qnil, + Fcurrent_window_configuration (mini_frame))); /* If the minibuffer is on an iconified or invisible frame, make it visible now. */ @@ -483,7 +653,6 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, = Fcons (Fthis_command_keys_vector (), minibuf_save_list); record_unwind_protect_void (read_minibuf_unwind); - minibuf_level++; /* We are exiting the minibuffer one way or the other, so run the hook. It should be run before unwinding the minibuf settings. Do it separately from read_minibuf_unwind because we need to make sure that @@ -565,8 +734,8 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, if (minibuf_level == 1 || !EQ (minibuf_window, selected_window)) minibuf_selected_window = selected_window; - /* Empty out the minibuffers of all frames other than the one - where we are going to display one now. + /* Empty out the minibuffers of all frames, except those frames + where there is an active minibuffer. Set them to point to ` *Minibuf-0*', which is always empty. */ empty_minibuf = get_minibuffer (0); @@ -574,12 +743,17 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, { Lisp_Object root_window = Fframe_root_window (frame); Lisp_Object mini_window = XWINDOW (root_window)->next; + Lisp_Object buffer; - if (! NILP (mini_window) && ! EQ (mini_window, minibuf_window) - && !NILP (Fwindow_minibuffer_p (mini_window))) - /* Use set_window_buffer instead of Fset_window_buffer (see - discussion of bug#11984, bug#12025, bug#12026). */ - set_window_buffer (mini_window, empty_minibuf, 0, 0); + if (!NILP (mini_window) && !EQ (mini_window, minibuf_window) + && !NILP (Fwindow_minibuffer_p (mini_window))) + { + buffer = XWINDOW (mini_window)->contents; + if (!live_minibuffer_p (buffer)) + /* Use set_window_buffer instead of Fset_window_buffer (see + discussion of bug#11984, bug#12025, bug#12026). */ + set_window_buffer (mini_window, empty_minibuf, 0, 0); + } } /* Display this minibuffer in the proper window. */ @@ -663,6 +837,20 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, recursive_edit_1 (); + /* We've exited the recursive edit without an error, so switch the + current window away from the expired minibuffer window. */ + { + Lisp_Object prev = Fprevious_window (minibuf_window, Qnil, Qnil); + /* PREV can be on a different frame when we have a minibuffer only + frame, the other frame's minibuffer window is MINIBUF_WINDOW, + and its "focus window" is also MINIBUF_WINDOW. */ + while (!EQ (prev, minibuf_window) + && !EQ (selected_frame, WINDOW_FRAME (XWINDOW (prev)))) + prev = Fprevious_window (prev, Qnil, Qnil); + if (!EQ (prev, minibuf_window)) + Fset_frame_selected_window (selected_frame, prev, Qnil); + } + /* If cursor is on the minibuffer line, show the user we have exited by putting it in column 0. */ if (XWINDOW (minibuf_window)->cursor.vpos >= 0 @@ -701,6 +889,12 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, in set-window-configuration. */ unbind_to (count, Qnil); + /* Switch the frame back to the calling frame. */ + if (!EQ (selected_frame, calling_frame) + && FRAMEP (calling_frame) + && FRAME_LIVE_P (XFRAME (calling_frame))) + call2 (intern ("select-frame-set-input-focus"), calling_frame, Qnil); + /* Add the value to the appropriate history list, if any. This is done after the previous buffer has been made current again, in case the history variable is buffer-local. */ @@ -714,6 +908,49 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, return val; } +/* Return true if BUF is a particular existing minibuffer. */ +bool +is_minibuffer (EMACS_INT depth, Lisp_Object buf) +{ + Lisp_Object tail = Fnthcdr (make_fixnum (depth), Vminibuffer_list); + return + !NILP (tail) + && EQ (Fcar (tail), buf); +} + +/* Return the DEPTHth minibuffer, or nil if such does not yet exist. */ +static Lisp_Object +nth_minibuffer (EMACS_INT depth) +{ + Lisp_Object tail = Fnthcdr (make_fixnum (depth), Vminibuffer_list); + return XCAR (tail); +} + +/* Set the major mode of the minibuffer BUF, depending on DEPTH, the + minibuffer depth. */ + +static void +set_minibuffer_mode (Lisp_Object buf, EMACS_INT depth) +{ + ptrdiff_t count = SPECPDL_INDEX (); + + record_unwind_current_buffer (); + Fset_buffer (buf); + if (depth > 0) + { + if (!NILP (Ffboundp (intern ("fundamental-mode")))) + call0 (intern ("fundamental-mode")); + } + else + { + if (!NILP (Ffboundp (intern ("minibuffer-inactive-mode")))) + call0 (intern ("minibuffer-inactive-mode")); + else + Fkill_all_local_variables (); + } + buf = unbind_to (count, buf); +} + /* Return a buffer to be used as the minibuffer at depth `depth'. depth = 0 is the lowest allowed argument, and that is the value used for nonrecursive minibuffer invocations. */ @@ -733,29 +970,22 @@ get_minibuffer (EMACS_INT depth) static char const name_fmt[] = " *Minibuf-%"pI"d*"; char name[sizeof name_fmt + INT_STRLEN_BOUND (EMACS_INT)]; AUTO_STRING_WITH_LEN (lname, name, sprintf (name, name_fmt, depth)); - buf = Fget_buffer_create (lname); - + buf = Fget_buffer_create (lname, Qnil); + /* Do this before set_minibuffer_mode. */ + XSETCAR (tail, buf); + set_minibuffer_mode (buf, depth); /* Although the buffer's name starts with a space, undo should be enabled in it. */ Fbuffer_enable_undo (buf); - - XSETCAR (tail, buf); } else { - ptrdiff_t count = SPECPDL_INDEX (); /* We have to empty both overlay lists. Otherwise we end up with overlays that think they belong to this buffer while the buffer doesn't know about them any more. */ delete_all_overlays (XBUFFER (buf)); reset_buffer (XBUFFER (buf)); - record_unwind_current_buffer (); - Fset_buffer (buf); - if (!NILP (Ffboundp (intern ("minibuffer-inactive-mode")))) - call0 (intern ("minibuffer-inactive-mode")); - else - Fkill_all_local_variables (); - buf = unbind_to (count, buf); + set_minibuffer_mode (buf, depth); } return buf; @@ -775,6 +1005,7 @@ read_minibuf_unwind (void) { Lisp_Object old_deactivate_mark; Lisp_Object window; + Lisp_Object future_mini_window; /* If this was a recursive minibuffer, tie the minibuffer window back to the outer level minibuffer buffer. */ @@ -809,6 +1040,7 @@ read_minibuf_unwind (void) if (FRAME_LIVE_P (XFRAME (WINDOW_FRAME (XWINDOW (temp))))) minibuf_window = temp; #endif + future_mini_window = Fcar (minibuf_save_list); minibuf_save_list = Fcdr (minibuf_save_list); /* Erase the minibuffer we were using at this level. */ @@ -825,7 +1057,8 @@ read_minibuf_unwind (void) /* When we get to the outmost level, make sure we resize the mini-window back to its normal size. */ - if (minibuf_level == 0) + if (minibuf_level == 0 + || !EQ (selected_frame, WINDOW_FRAME (XWINDOW (future_mini_window)))) resize_mini_window (XWINDOW (window), 0); /* Deal with frames that should be removed when exiting the @@ -860,6 +1093,13 @@ read_minibuf_unwind (void) } +void +barf_if_interaction_inhibited (void) +{ + if (inhibit_interaction) + xsignal0 (Qinhibited_interaction); +} + DEFUN ("read-from-minibuffer", Fread_from_minibuffer, Sread_from_minibuffer, 1, 7, 0, doc: /* Read a string from the minibuffer, prompting with string PROMPT. @@ -904,6 +1144,9 @@ If the variable `minibuffer-allow-text-properties' is non-nil, then the string which is returned includes whatever text properties were present in the minibuffer. Otherwise the value has no text properties. +If `inhibit-interaction' is non-nil, this function will signal an + `inhibited-interaction' error. + The remainder of this documentation string describes the INITIAL-CONTENTS argument in more detail. It is only relevant when studying existing code, or when HIST is a cons. If non-nil, @@ -919,6 +1162,8 @@ and some related functions, which use zero-indexing for POSITION. */) { Lisp_Object histvar, histpos, val; + barf_if_interaction_inhibited (); + CHECK_STRING (prompt); if (NILP (keymap)) keymap = Vminibuffer_local_map; @@ -992,11 +1237,17 @@ point positioned at the end, so that SPACE will accept the input. \(Actually, INITIAL can also be a cons of a string and an integer. Such values are treated as in `read-from-minibuffer', but are normally not useful in this function.) + Third arg INHERIT-INPUT-METHOD, if non-nil, means the minibuffer inherits -the current input method and the setting of`enable-multibyte-characters'. */) +the current input method and the setting of`enable-multibyte-characters'. + +If `inhibit-interaction' is non-nil, this function will signal an +`inhibited-interaction' error. */) (Lisp_Object prompt, Lisp_Object initial, Lisp_Object inherit_input_method) { CHECK_STRING (prompt); + barf_if_interaction_inhibited (); + return read_minibuf (Vminibuffer_local_ns_map, initial, prompt, 0, Qminibuffer_history, make_fixnum (0), Qnil, 0, !NILP (inherit_input_method)); @@ -1039,7 +1290,7 @@ Prompt with PROMPT. */) DEFUN ("read-variable", Fread_variable, Sread_variable, 1, 2, 0, doc: /* Read the name of a user option and return it as a symbol. Prompt with PROMPT. By default, return DEFAULT-VALUE or its first element -if it is a list. +if it is a list of strings. A user option, or customizable variable, is one for which `custom-variable-p' returns non-nil. */) (Lisp_Object prompt, Lisp_Object default_value) @@ -1212,9 +1463,6 @@ is used to further constrain the set of candidates. */) bucket = AREF (collection, idx); } - if (HASH_TABLE_P (collection)) - hash_rehash_if_needed (XHASH_TABLE (collection)); - while (1) { /* Get the next element of the alist, obarray, or hash-table. */ @@ -1914,6 +2162,8 @@ syms_of_minibuf (void) staticpro (&minibuf_prompt); staticpro (&minibuf_save_list); + DEFSYM (Qminibuffer_follows_selected_frame, + "minibuffer-follows-selected-frame"); DEFSYM (Qcompletion_ignore_case, "completion-ignore-case"); DEFSYM (Qminibuffer_default, "minibuffer-default"); Fset (Qminibuffer_default, Qnil); @@ -1935,9 +2185,6 @@ syms_of_minibuf (void) DEFSYM (Qminibuffer_setup_hook, "minibuffer-setup-hook"); DEFSYM (Qminibuffer_exit_hook, "minibuffer-exit-hook"); - /* The maximum length of a minibuffer history. */ - DEFSYM (Qhistory_length, "history-length"); - DEFSYM (Qcurrent_input_method, "current-input-method"); DEFSYM (Qactivate_input_method, "activate-input-method"); DEFSYM (Qcase_fold_search, "case-fold-search"); @@ -1957,6 +2204,16 @@ For example, `eval-expression' uses this. */); The function is called with the arguments passed to `read-buffer'. */); Vread_buffer_function = Qnil; + DEFVAR_LISP ("minibuffer-follows-selected-frame", minibuffer_follows_selected_frame, + doc: /* t means the active minibuffer always displays on the selected frame. +Nil means that a minibuffer will appear only in the frame which created it. +Any other value means the minibuffer will move onto another frame, but +only when the user starts using a minibuffer there. + +Any buffer local or dynamic binding of this variable is ignored. Only the +default top level value is used. */); + minibuffer_follows_selected_frame = Qt; + DEFVAR_BOOL ("read-buffer-completion-ignore-case", read_buffer_completion_ignore_case, doc: /* Non-nil means completion ignores case when reading a buffer name. */); @@ -2100,6 +2357,15 @@ This variable also overrides the default character that `read-passwd' uses to hide passwords. */); Vread_hide_char = Qnil; + DEFVAR_BOOL ("inhibit-interaction", + inhibit_interaction, + doc: /* Non-nil means any user interaction will signal an error. +This variable can be bound when user interaction can't be performed, +for instance when running a headless Emacs server. Functions like +`read-from-minibuffer' (and the like) will signal `inhibited-interaction' +instead. */); + inhibit_interaction = 0; + defsubr (&Sactive_minibuffer_window); defsubr (&Sset_minibuffer_window); defsubr (&Sread_from_minibuffer); @@ -2113,6 +2379,8 @@ uses to hide passwords. */); defsubr (&Sminibuffer_prompt); defsubr (&Sminibufferp); + defsubr (&Sinnermost_minibuffer_p); + defsubr (&Sabort_minibuffers); defsubr (&Sminibuffer_prompt_end); defsubr (&Sminibuffer_contents); defsubr (&Sminibuffer_contents_no_properties); diff --git a/src/module-env-25.h b/src/module-env-25.h index d8f8eb68119..97c7787da34 100644 --- a/src/module-env-25.h +++ b/src/module-env-25.h @@ -6,12 +6,10 @@ /* Memory management. */ - emacs_value (*make_global_ref) (emacs_env *env, - emacs_value any_reference) + emacs_value (*make_global_ref) (emacs_env *env, emacs_value value) EMACS_ATTRIBUTE_NONNULL(1); - void (*free_global_ref) (emacs_env *env, - emacs_value global_reference) + void (*free_global_ref) (emacs_env *env, emacs_value global_value) EMACS_ATTRIBUTE_NONNULL(1); /* Non-local exit handling. */ @@ -23,19 +21,15 @@ EMACS_ATTRIBUTE_NONNULL(1); enum emacs_funcall_exit (*non_local_exit_get) - (emacs_env *env, - emacs_value *non_local_exit_symbol_out, - emacs_value *non_local_exit_data_out) + (emacs_env *env, emacs_value *symbol, emacs_value *data) EMACS_ATTRIBUTE_NONNULL(1, 2, 3); void (*non_local_exit_signal) (emacs_env *env, - emacs_value non_local_exit_symbol, - emacs_value non_local_exit_data) + emacs_value symbol, emacs_value data) EMACS_ATTRIBUTE_NONNULL(1); void (*non_local_exit_throw) (emacs_env *env, - emacs_value tag, - emacs_value value) + emacs_value tag, emacs_value value) EMACS_ATTRIBUTE_NONNULL(1); /* Function registration. */ @@ -43,71 +37,69 @@ emacs_value (*make_function) (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity, - emacs_value (*function) (emacs_env *env, - ptrdiff_t nargs, - emacs_value args[], - void *) + emacs_value (*func) (emacs_env *env, + ptrdiff_t nargs, + emacs_value* args, + void *data) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1), - const char *documentation, + const char *docstring, void *data) EMACS_ATTRIBUTE_NONNULL(1, 4); emacs_value (*funcall) (emacs_env *env, - emacs_value function, + emacs_value func, ptrdiff_t nargs, - emacs_value args[]) + emacs_value* args) EMACS_ATTRIBUTE_NONNULL(1); - emacs_value (*intern) (emacs_env *env, - const char *symbol_name) + emacs_value (*intern) (emacs_env *env, const char *name) EMACS_ATTRIBUTE_NONNULL(1, 2); /* Type conversion. */ - emacs_value (*type_of) (emacs_env *env, - emacs_value value) + emacs_value (*type_of) (emacs_env *env, emacs_value arg) EMACS_ATTRIBUTE_NONNULL(1); - bool (*is_not_nil) (emacs_env *env, emacs_value value) + bool (*is_not_nil) (emacs_env *env, emacs_value arg) EMACS_ATTRIBUTE_NONNULL(1); bool (*eq) (emacs_env *env, emacs_value a, emacs_value b) EMACS_ATTRIBUTE_NONNULL(1); - intmax_t (*extract_integer) (emacs_env *env, emacs_value value) + intmax_t (*extract_integer) (emacs_env *env, emacs_value arg) EMACS_ATTRIBUTE_NONNULL(1); - emacs_value (*make_integer) (emacs_env *env, intmax_t value) + emacs_value (*make_integer) (emacs_env *env, intmax_t n) EMACS_ATTRIBUTE_NONNULL(1); - double (*extract_float) (emacs_env *env, emacs_value value) + double (*extract_float) (emacs_env *env, emacs_value arg) EMACS_ATTRIBUTE_NONNULL(1); - emacs_value (*make_float) (emacs_env *env, double value) + emacs_value (*make_float) (emacs_env *env, double d) EMACS_ATTRIBUTE_NONNULL(1); /* Copy the content of the Lisp string VALUE to BUFFER as an utf8 - NUL-terminated string. + null-terminated string. SIZE must point to the total size of the buffer. If BUFFER is NULL or if SIZE is not big enough, write the required buffer size to SIZE and return true. - Note that SIZE must include the last NUL byte (e.g. "abc" needs + Note that SIZE must include the last null byte (e.g. "abc" needs a buffer of size 4). Return true if the string was successfully copied. */ bool (*copy_string_contents) (emacs_env *env, emacs_value value, - char *buffer, - ptrdiff_t *size_inout) + char *buf, + ptrdiff_t *len) EMACS_ATTRIBUTE_NONNULL(1, 4); /* Create a Lisp string from a utf8 encoded string. */ emacs_value (*make_string) (emacs_env *env, - const char *contents, ptrdiff_t length) + const char *str, ptrdiff_t len) EMACS_ATTRIBUTE_NONNULL(1, 2); /* Embedded pointer type. */ @@ -116,25 +108,24 @@ void *ptr) EMACS_ATTRIBUTE_NONNULL(1); - void *(*get_user_ptr) (emacs_env *env, emacs_value uptr) + void *(*get_user_ptr) (emacs_env *env, emacs_value arg) EMACS_ATTRIBUTE_NONNULL(1); - void (*set_user_ptr) (emacs_env *env, emacs_value uptr, void *ptr) + void (*set_user_ptr) (emacs_env *env, emacs_value arg, void *ptr) EMACS_ATTRIBUTE_NONNULL(1); void (*(*get_user_finalizer) (emacs_env *env, emacs_value uptr)) (void *) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1); - void (*set_user_finalizer) (emacs_env *env, - emacs_value uptr, + void (*set_user_finalizer) (emacs_env *env, emacs_value arg, void (*fin) (void *) EMACS_NOEXCEPT) EMACS_ATTRIBUTE_NONNULL(1); /* Vector functions. */ - emacs_value (*vec_get) (emacs_env *env, emacs_value vec, ptrdiff_t i) + emacs_value (*vec_get) (emacs_env *env, emacs_value vector, ptrdiff_t index) EMACS_ATTRIBUTE_NONNULL(1); - void (*vec_set) (emacs_env *env, emacs_value vec, ptrdiff_t i, - emacs_value val) + void (*vec_set) (emacs_env *env, emacs_value vector, ptrdiff_t index, + emacs_value value) EMACS_ATTRIBUTE_NONNULL(1); - ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vec) + ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vector) EMACS_ATTRIBUTE_NONNULL(1); diff --git a/src/module-env-27.h b/src/module-env-27.h index 0fe2557d71b..9ef3c8b33bb 100644 --- a/src/module-env-27.h +++ b/src/module-env-27.h @@ -3,7 +3,7 @@ enum emacs_process_input_result (*process_input) (emacs_env *env) EMACS_ATTRIBUTE_NONNULL (1); - struct timespec (*extract_time) (emacs_env *env, emacs_value value) + struct timespec (*extract_time) (emacs_env *env, emacs_value arg) EMACS_ATTRIBUTE_NONNULL (1); emacs_value (*make_time) (emacs_env *env, struct timespec time) diff --git a/src/module-env-28.h b/src/module-env-28.h new file mode 100644 index 00000000000..f8820b0606b --- /dev/null +++ b/src/module-env-28.h @@ -0,0 +1,23 @@ + /* Add module environment functions newly added in Emacs 28 here. + Before Emacs 28 is released, remove this comment and start + module-env-29.h on the master branch. */ + + void (*(*EMACS_ATTRIBUTE_NONNULL (1) + get_function_finalizer) (emacs_env *env, + emacs_value arg)) (void *) EMACS_NOEXCEPT; + + void (*set_function_finalizer) (emacs_env *env, emacs_value arg, + void (*fin) (void *) EMACS_NOEXCEPT) + EMACS_ATTRIBUTE_NONNULL (1); + + int (*open_channel) (emacs_env *env, emacs_value pipe_process) + EMACS_ATTRIBUTE_NONNULL (1); + + void (*make_interactive) (emacs_env *env, emacs_value function, + emacs_value spec) + EMACS_ATTRIBUTE_NONNULL (1); + + /* Create a unibyte Lisp string from a string. */ + emacs_value (*make_unibyte_string) (emacs_env *env, + const char *str, ptrdiff_t len) + EMACS_ATTRIBUTE_NONNULL(1, 2); diff --git a/src/msdos.c b/src/msdos.c index c710ce1c5db..5da01c9e7ca 100644 --- a/src/msdos.c +++ b/src/msdos.c @@ -1794,7 +1794,7 @@ internal_terminal_init (void) } Vinitial_window_system = Qpc; - Vwindow_system_version = make_fixnum (27); /* RE Emacs version */ + Vwindow_system_version = make_fixnum (28); /* RE Emacs version */ tty->terminal->type = output_msdos_raw; /* If Emacs was dumped on DOS/V machine, forget the stale VRAM @@ -2905,7 +2905,7 @@ IT_menu_display (XMenu *menu, int y, int x, int pn, int *faces, int disp_help) p++; for (j = 0, q = menu->text[i]; *q; j++) { - unsigned c = STRING_CHAR_ADVANCE (q); + unsigned c = string_char_advance (&q); if (c > 26) { diff --git a/src/nsfns.m b/src/nsfns.m index 5f223669397..c7857eac731 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -255,7 +255,10 @@ ns_set_foreground_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) [col getRed: &r green: &g blue: &b alpha: &alpha]; FRAME_FOREGROUND_PIXEL (f) = - ARGB_TO_ULONG ((int)(alpha*0xff), (int)(r*0xff), (int)(g*0xff), (int)(b*0xff)); + ARGB_TO_ULONG ((unsigned long) (alpha * 0xff), + (unsigned long) (r * 0xff), + (unsigned long) (g * 0xff), + (unsigned long) (b * 0xff)); if (FRAME_NS_VIEW (f)) { @@ -284,19 +287,16 @@ ns_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) error ("Unknown color"); } - /* Clear the frame; in some instances the NS-internal GC appears not - to update, or it does update and cannot clear old text - properly. */ - if (FRAME_VISIBLE_P (f)) - ns_clear_frame (f); - [col retain]; [f->output_data.ns->background_color release]; f->output_data.ns->background_color = col; [col getRed: &r green: &g blue: &b alpha: &alpha]; FRAME_BACKGROUND_PIXEL (f) = - ARGB_TO_ULONG ((int)(alpha*0xff), (int)(r*0xff), (int)(g*0xff), (int)(b*0xff)); + ARGB_TO_ULONG ((unsigned long) (alpha * 0xff), + (unsigned long) (r * 0xff), + (unsigned long) (g * 0xff), + (unsigned long) (b * 0xff)); if (view != nil) { @@ -318,7 +318,10 @@ ns_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) } if (FRAME_VISIBLE_P (f)) - SET_FRAME_GARBAGED (f); + { + SET_FRAME_GARBAGED (f); + ns_clear_frame (f); + } } unblock_input (); } @@ -387,37 +390,25 @@ ns_set_icon_name (struct frame *f, Lisp_Object arg, Lisp_Object oldval) /* Don't change the name if it's already NAME. */ if ([[view window] miniwindowTitle] && ([[[view window] miniwindowTitle] - isEqualToString: [NSString stringWithUTF8String: - SSDATA (arg)]])) + isEqualToString: [NSString stringWithLispString:arg]])) return; [[view window] setMiniwindowTitle: - [NSString stringWithUTF8String: SSDATA (arg)]]; + [NSString stringWithLispString:arg]]; } static void ns_set_name_internal (struct frame *f, Lisp_Object name) { - Lisp_Object encoded_name, encoded_icon_name; - NSString *str; NSView *view = FRAME_NS_VIEW (f); - - - encoded_name = ENCODE_UTF_8 (name); - - str = [NSString stringWithUTF8String: SSDATA (encoded_name)]; - + NSString *str = [NSString stringWithLispString: name]; /* Don't change the name if it's already NAME. */ if (! [[[view window] title] isEqualToString: str]) [[view window] setTitle: str]; - if (!STRINGP (f->icon_name)) - encoded_icon_name = encoded_name; - else - encoded_icon_name = ENCODE_UTF_8 (f->icon_name); - - str = [NSString stringWithUTF8String: SSDATA (encoded_icon_name)]; + if (STRINGP (f->icon_name)) + str = [NSString stringWithLispString: f->icon_name]; if ([[view window] miniwindowTitle] && ! [[[view window] miniwindowTitle] isEqualToString: str]) @@ -445,7 +436,7 @@ ns_set_name (struct frame *f, Lisp_Object name, int explicit) return; if (NILP (name)) - name = build_string ([ns_app_name UTF8String]); + name = [ns_app_name lispString]; else CHECK_STRING (name); @@ -465,7 +456,7 @@ ns_set_name (struct frame *f, Lisp_Object name, int explicit) static void ns_set_represented_filename (struct frame *f) { - Lisp_Object filename, encoded_filename; + Lisp_Object filename; Lisp_Object buf = XWINDOW (f->selected_window)->contents; NSAutoreleasePool *pool; NSString *fstr; @@ -482,9 +473,7 @@ ns_set_represented_filename (struct frame *f) if (! NILP (filename)) { - encoded_filename = ENCODE_UTF_8 (filename); - - fstr = [NSString stringWithUTF8String: SSDATA (encoded_filename)]; + fstr = [NSString stringWithLispString:filename]; if (fstr == nil) fstr = @""; } else @@ -698,19 +687,31 @@ ns_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) } } +static void +ns_set_child_frame_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + int old_width = FRAME_CHILD_FRAME_BORDER_WIDTH (f); + int new_width = check_int_nonnegative (arg); + + if (new_width == old_width) + return; + f->child_frame_border_width = new_width; + + if (FRAME_NATIVE_WINDOW (f) != 0) + adjust_frame_size (f, -1, -1, 3, 0, Qchild_frame_border_width); + + SET_FRAME_GARBAGED (f); +} static void ns_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { int old_width = FRAME_INTERNAL_BORDER_WIDTH (f); + int new_width = check_int_nonnegative (arg); - CHECK_TYPE_RANGED_INTEGER (int, arg); - f->internal_border_width = XFIXNUM (arg); - if (FRAME_INTERNAL_BORDER_WIDTH (f) < 0) - f->internal_border_width = 0; - - if (FRAME_INTERNAL_BORDER_WIDTH (f) == old_width) + if (new_width == old_width) return; + f->internal_border_width = new_width; if (FRAME_NATIVE_WINDOW (f) != 0) adjust_frame_size (f, -1, -1, 3, 0, Qinternal_border_width); @@ -734,7 +735,7 @@ ns_implicitly_set_icon_type (struct frame *f) block_input (); pool = [[NSAutoreleasePool alloc] init]; if (f->output_data.ns->miniimage - && [[NSString stringWithUTF8String: SSDATA (f->name)] + && [[NSString stringWithLispString:f->name] isEqualToString: [(NSImage *)f->output_data.ns->miniimage name]]) { [pool release]; @@ -759,7 +760,7 @@ ns_implicitly_set_icon_type (struct frame *f) if (SYMBOLP (elt) && EQ (elt, Qt) && SSDATA (f->name)[0] == '/') { NSString *str - = [NSString stringWithUTF8String: SSDATA (f->name)]; + = [NSString stringWithLispString:f->name]; if ([[NSFileManager defaultManager] fileExistsAtPath: str]) image = [[[NSWorkspace sharedWorkspace] iconForFile: str] retain]; } @@ -771,8 +772,7 @@ ns_implicitly_set_icon_type (struct frame *f) image = [EmacsImage allocInitFromFile: XCDR (elt)]; if (image == nil) image = [[NSImage imageNamed: - [NSString stringWithUTF8String: - SSDATA (XCDR (elt))]] retain]; + [NSString stringWithLispString:XCDR (elt)]] retain]; } } @@ -816,8 +816,7 @@ ns_set_icon_type (struct frame *f, Lisp_Object arg, Lisp_Object oldval) image = [EmacsImage allocInitFromFile: arg]; if (image == nil) - image =[NSImage imageNamed: [NSString stringWithUTF8String: - SSDATA (arg)]]; + image =[NSImage imageNamed: [NSString stringWithLispString:arg]]; if (image == nil) { @@ -851,20 +850,18 @@ ns_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) static Lisp_Object ns_appkit_version_str (void) { - char tmp[256]; + NSString *tmp; #ifdef NS_IMPL_GNUSTEP - sprintf(tmp, "gnustep-gui-%s", Xstr(GNUSTEP_GUI_VERSION)); + tmp = [NSString stringWithFormat:@"gnustep-gui-%s", Xstr(GNUSTEP_GUI_VERSION)]; #elif defined (NS_IMPL_COCOA) - NSString *osversion - = [[NSProcessInfo processInfo] operatingSystemVersionString]; - sprintf(tmp, "appkit-%.2f %s", - NSAppKitVersionNumber, - [osversion UTF8String]); + tmp = [NSString stringWithFormat:@"appkit-%.2f %@", + NSAppKitVersionNumber, + [[NSProcessInfo processInfo] operatingSystemVersionString]]; #else - tmp = "ns-unknown"; + tmp = [NSString initWithUTF8String:@"ns-unknown"]; #endif - return build_string (tmp); + return [tmp lispString]; } @@ -930,6 +927,7 @@ frame_parm_handler ns_frame_parm_handlers[] = ns_set_foreground_color, ns_set_icon_name, ns_set_icon_type, + ns_set_child_frame_border_width, ns_set_internal_border_width, gui_set_right_divider_width, /* generic OK */ gui_set_bottom_divider_width, /* generic OK */ @@ -1168,7 +1166,7 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, be set. */ if (EQ (name, Qunbound) || NILP (name) || ! STRINGP (name)) { - fset_name (f, build_string ([ns_app_name UTF8String])); + fset_name (f, [ns_app_name lispString]); f->explicit_name = 0; } else @@ -1215,6 +1213,9 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, gui_default_parameter (f, parms, Qinternal_border_width, make_fixnum (2), "internalBorderWidth", "InternalBorderWidth", RES_TYPE_NUMBER); + gui_default_parameter (f, parms, Qchild_frame_border_width, make_fixnum (2), + "childFrameBorderWidth", "childFrameBorderWidth", + RES_TYPE_NUMBER); gui_default_parameter (f, parms, Qright_divider_width, make_fixnum (0), NULL, NULL, RES_TYPE_NUMBER); gui_default_parameter (f, parms, Qbottom_divider_width, make_fixnum (0), @@ -1271,14 +1272,20 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, #ifdef NS_IMPL_COCOA tem = gui_display_get_arg (dpyinfo, parms, Qns_appearance, NULL, NULL, RES_TYPE_SYMBOL); - FRAME_NS_APPEARANCE (f) = EQ (tem, Qdark) - ? ns_appearance_vibrant_dark : ns_appearance_aqua; - store_frame_param (f, Qns_appearance, tem); + if (EQ (tem, Qdark)) + FRAME_NS_APPEARANCE (f) = ns_appearance_vibrant_dark; + else if (EQ (tem, Qlight)) + FRAME_NS_APPEARANCE (f) = ns_appearance_aqua; + else + FRAME_NS_APPEARANCE (f) = ns_appearance_system_default; + store_frame_param (f, Qns_appearance, + (!NILP (tem) && !EQ (tem, Qunbound)) ? tem : Qnil); tem = gui_display_get_arg (dpyinfo, parms, Qns_transparent_titlebar, NULL, NULL, RES_TYPE_BOOLEAN); FRAME_NS_TRANSPARENT_TITLEBAR (f) = !NILP (tem) && !EQ (tem, Qunbound); - store_frame_param (f, Qns_transparent_titlebar, tem); + store_frame_param (f, Qns_transparent_titlebar, + FRAME_NS_TRANSPARENT_TITLEBAR (f) ? Qt : Qnil); #endif parent_frame = gui_display_get_arg (dpyinfo, parms, Qparent_frame, NULL, NULL, @@ -1497,14 +1504,13 @@ Some window managers may refuse to restack windows. */) if (FRAME_NS_VIEW (f1) && FRAME_NS_VIEW (f2)) { - NSWindow *window = [FRAME_NS_VIEW (f1) window]; - NSInteger window2 = [[FRAME_NS_VIEW (f2) window] windowNumber]; - NSWindowOrderingMode flag = NILP (above) ? NSWindowBelow : NSWindowAbove; + EmacsWindow *window = (EmacsWindow *)[FRAME_NS_VIEW (f1) window]; + NSWindow *window2 = [FRAME_NS_VIEW (f2) window]; - [window orderWindow: flag - relativeTo: window2]; - - return Qt; + if ([window restackWindow:window2 above:!NILP (above)]) + return Qt; + else + return Qnil; } else { @@ -1603,12 +1609,12 @@ Optional arg DIR_ONLY_P, if non-nil, means choose only directories. */) Lisp_Object fname = Qnil; NSString *promptS = NILP (prompt) || !STRINGP (prompt) ? nil : - [NSString stringWithUTF8String: SSDATA (prompt)]; + [NSString stringWithLispString:prompt]; NSString *dirS = NILP (dir) || !STRINGP (dir) ? - [NSString stringWithUTF8String: SSDATA (BVAR (current_buffer, directory))] : - [NSString stringWithUTF8String: SSDATA (dir)]; + [NSString stringWithLispString:BVAR (current_buffer, directory)] : + [NSString stringWithLispString:dir]; NSString *initS = NILP (init) || !STRINGP (init) ? nil : - [NSString stringWithUTF8String: SSDATA (init)]; + [NSString stringWithLispString:init]; NSEvent *nxev; check_window_system (NULL); @@ -1684,7 +1690,7 @@ Optional arg DIR_ONLY_P, if non-nil, means choose only directories. */) { NSString *str = ns_filename_from_panel (panel); if (! str) str = ns_directory_from_panel (panel); - if (str) fname = build_string ([str UTF8String]); + if (str) fname = [str lispString]; } [[FRAME_NS_VIEW (SELECTED_FRAME ()) window] makeKeyWindow]; @@ -1714,7 +1720,7 @@ If OWNER is nil, Emacs is assumed. */) check_window_system (NULL); if (NILP (owner)) - owner = build_string([ns_app_name UTF8String]); + owner = [ns_app_name lispString]; CHECK_STRING (name); value = ns_get_defaults_value (SSDATA (name)); @@ -1733,20 +1739,19 @@ If VALUE is nil, the default is removed. */) { check_window_system (NULL); if (NILP (owner)) - owner = build_string ([ns_app_name UTF8String]); + owner = [ns_app_name lispString]; CHECK_STRING (name); if (NILP (value)) { [[NSUserDefaults standardUserDefaults] removeObjectForKey: - [NSString stringWithUTF8String: SSDATA (name)]]; + [NSString stringWithLispString:name]]; } else { CHECK_STRING (value); [[NSUserDefaults standardUserDefaults] setObject: - [NSString stringWithUTF8String: SSDATA (value)] - forKey: [NSString stringWithUTF8String: - SSDATA (name)]]; + [NSString stringWithLispString:value] + forKey: [NSString stringWithLispString:name]]; } return Qnil; @@ -2038,7 +2043,7 @@ The optional argument FRAME is currently ignored. */) NSEnumerator *cnames = [[clist allKeys] reverseObjectEnumerator]; NSString *cname; while ((cname = [cnames nextObject])) - list = Fcons (build_string ([cname UTF8String]), list); + list = Fcons ([cname lispString], list); /* for (i = [[clist allKeys] count] - 1; i >= 0; i--) list = Fcons (build_string ([[[clist allKeys] objectAtIndex: i] UTF8String]), list); */ @@ -2086,13 +2091,11 @@ there was no result. */) { id pb; NSString *svcName; - char *utfStr; CHECK_STRING (service); check_window_system (NULL); - utfStr = SSDATA (service); - svcName = [NSString stringWithUTF8String: utfStr]; + svcName = [NSString stringWithLispString:service]; pb =[NSPasteboard pasteboardWithUniqueName]; ns_string_to_pasteboard (pb, send); @@ -2122,7 +2125,7 @@ ns_do_applescript (Lisp_Object script, Lisp_Object *result) NSAppleScript *scriptObject = [[NSAppleScript alloc] initWithSource: - [NSString stringWithUTF8String: SSDATA (script)]]; + [NSString stringWithLispString:script]]; returnDescriptor = [scriptObject executeAndReturnError: &errorDict]; [scriptObject release]; @@ -2145,7 +2148,7 @@ ns_do_applescript (Lisp_Object script, Lisp_Object *result) { desc = [returnDescriptor coerceToDescriptorType: typeUTF8Text]; if (desc) - *result = build_string([[desc stringValue] UTF8String]); + *result = [[desc stringValue] lispString]; } else { @@ -2323,8 +2326,8 @@ DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0, [[col colorUsingDefaultColorSpace] getRed: &red green: &green blue: &blue alpha: &alpha]; unblock_input (); - return list3i (lrint (red * 65280), lrint (green * 65280), - lrint (blue * 65280)); + return list3i (lrint (red * 65535), lrint (green * 65535), + lrint (blue * 65535)); } @@ -2947,16 +2950,16 @@ The coordinates X and Y are interpreted in pixels relative to a position if (FRAME_INITIAL_P (f) || !FRAME_NS_P (f)) return Qnil; - CHECK_TYPE_RANGED_INTEGER (int, x); - CHECK_TYPE_RANGED_INTEGER (int, y); + int xval = check_integer_range (x, INT_MIN, INT_MAX); + int yval = check_integer_range (y, INT_MIN, INT_MAX); - mouse_x = screen_frame.origin.x + XFIXNUM (x); + mouse_x = screen_frame.origin.x + xval; if (screen == primary_screen) - mouse_y = screen_frame.origin.y + XFIXNUM (y); + mouse_y = screen_frame.origin.y + yval; else mouse_y = (primary_screen_height - screen_frame.size.height - - screen_frame.origin.y) + XFIXNUM (y); + - screen_frame.origin.y) + yval; CGPoint mouse_pos = CGPointMake(mouse_x, mouse_y); CGWarpMouseCursorPosition (mouse_pos); @@ -3003,80 +3006,6 @@ DEFUN ("ns-show-character-palette", ========================================================================== */ -/* - Handle arrow/function/control keys and copy/paste/cut in file dialogs. - Return YES if handled, NO if not. - */ -static BOOL -handlePanelKeys (NSSavePanel *panel, NSEvent *theEvent) -{ - NSString *s; - int i; - BOOL ret = NO; - - if ([theEvent type] != NSEventTypeKeyDown) return NO; - s = [theEvent characters]; - - for (i = 0; i < [s length]; ++i) - { - int ch = (int) [s characterAtIndex: i]; - switch (ch) - { - case NSHomeFunctionKey: - case NSDownArrowFunctionKey: - case NSUpArrowFunctionKey: - case NSLeftArrowFunctionKey: - case NSRightArrowFunctionKey: - case NSPageUpFunctionKey: - case NSPageDownFunctionKey: - case NSEndFunctionKey: - /* Don't send command modified keys, as those are handled in the - performKeyEquivalent method of the super class. */ - if (! ([theEvent modifierFlags] & NSEventModifierFlagCommand)) - { - [panel sendEvent: theEvent]; - ret = YES; - } - break; - /* As we don't have the standard key commands for - copy/paste/cut/select-all in our edit menu, we must handle - them here. TODO: handle Emacs key bindings for copy/cut/select-all - here, paste works, because we have that in our Edit menu. - I.e. refactor out code in nsterm.m, keyDown: to figure out the - correct modifier. */ - case 'x': // Cut - case 'c': // Copy - case 'v': // Paste - case 'a': // Select all - if ([theEvent modifierFlags] & NSEventModifierFlagCommand) - { - [NSApp sendAction: - (ch == 'x' - ? @selector(cut:) - : (ch == 'c' - ? @selector(copy:) - : (ch == 'v' - ? @selector(paste:) - : @selector(selectAll:)))) - to:nil from:panel]; - ret = YES; - } - default: - // Send all control keys, as the text field supports C-a, C-f, C-e - // C-b and more. - if ([theEvent modifierFlags] & NSEventModifierFlagControl) - { - [panel sendEvent: theEvent]; - ret = YES; - } - break; - } - } - - - return ret; -} - @implementation EmacsFileDelegate /* -------------------------------------------------------------------------- Delegate methods for Open/Save panels @@ -3099,6 +3028,60 @@ handlePanelKeys (NSSavePanel *panel, NSEvent *theEvent) #endif +/* Whether N bytes at STR are in the [1,127] range. */ +static bool +all_nonzero_ascii (unsigned char *str, ptrdiff_t n) +{ + for (ptrdiff_t i = 0; i < n; i++) + if (str[i] < 1 || str[i] > 127) + return false; + return true; +} + +@implementation NSString (EmacsString) +/* Make an NSString from a Lisp string. */ ++ (NSString *)stringWithLispString:(Lisp_Object)string +{ + /* Shortcut for the common case. */ + if (all_nonzero_ascii (SDATA (string), SBYTES (string))) + return [NSString stringWithCString: SSDATA (string) + encoding: NSASCIIStringEncoding]; + string = string_to_multibyte (string); + + /* Now the string is multibyte; convert to UTF-16. */ + unichar *chars = xmalloc (4 * SCHARS (string)); + unichar *d = chars; + const unsigned char *s = SDATA (string); + const unsigned char *end = s + SBYTES (string); + while (s < end) + { + int c = string_char_advance (&s); + /* We pass unpaired surrogates through, because they are typically + handled fairly well by the NS libraries (displayed with distinct + glyphs etc). */ + if (c <= 0xffff) + *d++ = c; + else if (c <= 0x10ffff) + { + *d++ = 0xd800 + ((c - 0x10000) >> 10); + *d++ = 0xdc00 + (c & 0x3ff); + } + else + *d++ = 0xfffd; /* Not valid for UTF-16. */ + } + NSString *str = [NSString stringWithCharacters: chars + length: d - chars]; + xfree (chars); + return str; +} + +/* Make a Lisp string from an NSString. */ +- (Lisp_Object)lispString +{ + return build_string ([self UTF8String]); +} +@end + /* ========================================================================== Lisp interface declaration @@ -3112,6 +3095,7 @@ syms_of_nsfns (void) DEFSYM (Qframe_title_format, "frame-title-format"); DEFSYM (Qicon_title_format, "icon-title-format"); DEFSYM (Qdark, "dark"); + DEFSYM (Qlight, "light"); DEFVAR_LISP ("ns-icon-type-alist", Vns_icon_type_alist, doc: /* Alist of elements (REGEXP . IMAGE) for images of icons associated to frames. diff --git a/src/nsfont.m b/src/nsfont.m index 61a30a9ef75..f4f0d281674 100644 --- a/src/nsfont.m +++ b/src/nsfont.m @@ -39,9 +39,7 @@ Author: Adrian Robert (arobert@cogsci.ucsd.edu) #include "pdumper.h" /* TODO: Drop once we can assume gnustep-gui 0.17.1. */ -#ifdef NS_IMPL_GNUSTEP #import <AppKit/NSFontDescriptor.h> -#endif #define NSFONT_TRACE 0 #define LCD_SMOOTHING_MARGIN 2 @@ -237,12 +235,6 @@ ns_char_width (NSFont *sfont, int c) CGFloat w = -1.0; NSString *cstr = [NSString stringWithFormat: @"%c", c]; -#ifdef NS_IMPL_COCOA - NSGlyph glyph = [sfont glyphWithName: cstr]; - if (glyph) - w = [sfont advancementForGlyph: glyph].width; -#endif - if (w < 0.0) { NSDictionary *attrsDictionary = @@ -273,12 +265,6 @@ ns_ascii_average_width (NSFont *sfont) ascii_printable = [[NSString alloc] initWithFormat: @"%s", chars]; } -#ifdef NS_IMPL_COCOA - NSGlyph glyph = [sfont glyphWithName: ascii_printable]; - if (glyph) - w = [sfont advancementForGlyph: glyph].width; -#endif - if (w < (CGFloat) 0.0) { NSDictionary *attrsDictionary = @@ -343,7 +329,7 @@ static NSString { Lisp_Object script = assq_no_quit (XCAR (otf), Votf_script_alist); return CONSP (script) - ? [NSString stringWithUTF8String: SSDATA (SYMBOL_NAME (XCDR ((script))))] + ? [NSString stringWithLispString: SYMBOL_NAME (XCDR ((script)))] : @""; } @@ -359,7 +345,7 @@ static NSString if (!strncmp (SSDATA (r), reg, SBYTES (r))) { script = XCDR (XCAR (rts)); - return [NSString stringWithUTF8String: SSDATA (SYMBOL_NAME (script))]; + return [NSString stringWithLispString: SYMBOL_NAME (script)]; } rts = XCDR (rts); } @@ -384,8 +370,7 @@ static NSString { Lisp_Object key = XCAR (tmp), val = XCDR (tmp); if (EQ (key, QCscript) && SYMBOLP (val)) - return [NSString stringWithUTF8String: - SSDATA (SYMBOL_NAME (val))]; + return [NSString stringWithLispString: SYMBOL_NAME (val)]; if (EQ (key, QClang) && SYMBOLP (val)) return ns_lang_to_script (val); if (EQ (key, QCotf) && CONSP (val) && SYMBOLP (XCAR (val))) @@ -511,10 +496,6 @@ static NSSet } [charset release]; } -#ifdef NS_IMPL_COCOA - if ([families count] == 0) - [families addObject: @"LastResort"]; -#endif [scriptToFamilies setObject: families forKey: script]; } @@ -734,11 +715,6 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size) traits: traits & ~NSItalicFontMask weight: fixLeopardBug size: pixel_size]; } -#ifdef NS_IMPL_COCOA - /* LastResort not really a family */ - if (nsfont == nil && [@"LastResort" isEqualToString: family]) - nsfont = [NSFont fontWithName: @"LastResort" size: pixel_size]; -#endif if (nsfont == nil) { @@ -765,12 +741,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size) font_info->metrics = xzalloc (0x100 * sizeof *font_info->metrics); /* for metrics */ -#ifdef NS_IMPL_COCOA - sfont = [nsfont screenFontWithRenderingMode: - NSFontAntialiasedIntegerAdvancementsRenderingMode]; -#else sfont = [nsfont screenFont]; -#endif if (sfont == nil) sfont = nsfont; @@ -797,11 +768,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size) * intended. */ CGFloat adjusted_descender = [sfont descender] + 0.0001; -#ifdef NS_IMPL_GNUSTEP font_info->nsfont = sfont; -#else - font_info->nsfont = nsfont; -#endif [font_info->nsfont retain]; /* set up ns_font (defined in nsgui.h) */ @@ -834,32 +801,6 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size) font_info->max_bounds.rbearing = lrint (brect.size.width - (CGFloat) font_info->width); -#ifdef NS_IMPL_COCOA - /* set up synthItal and the CG font */ - font_info->synthItal = synthItal; - { - ATSFontRef atsFont = ATSFontFindFromPostScriptName - ((CFStringRef)[nsfont fontName], kATSOptionFlagsDefault); - - if (atsFont == kATSFontRefUnspecified) - { - /* see if we can get it by dropping italic (then synthesizing) */ - atsFont = ATSFontFindFromPostScriptName ((CFStringRef) - [[fontMgr convertFont: nsfont toNotHaveTrait: NSItalicFontMask] - fontName], kATSOptionFlagsDefault); - if (atsFont != kATSFontRefUnspecified) - font_info->synthItal = YES; - else - { - /* last resort fallback */ - atsFont = ATSFontFindFromPostScriptName - ((CFStringRef)@"Monaco", kATSOptionFlagsDefault); - } - } - font_info->cgfont = CGFontCreateWithPlatformFont ((void *) &atsFont); - } -#endif - /* set up metrics portion of font struct */ font->ascent = lrint([sfont ascender]); font->descent = -lrint(floor(adjusted_descender)); @@ -901,9 +842,6 @@ nsfont_close (struct font *font) xfree (font_info->glyphs); xfree (font_info->metrics); [font_info->nsfont release]; -#ifdef NS_IMPL_COCOA - CGFontRelease (font_info->cgfont); -#endif xfree (font_info->name); font_info->name = NULL; } @@ -994,7 +932,6 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, { static unsigned char cbuf[1024]; unsigned char *c = cbuf; -#ifdef NS_IMPL_GNUSTEP #if GNUSTEP_GUI_MAJOR_VERSION > 0 || GNUSTEP_GUI_MINOR_VERSION > 22 static CGFloat advances[1024]; CGFloat *adv = advances; @@ -1002,10 +939,6 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, static float advances[1024]; float *adv = advances; #endif -#else - static CGSize advances[1024]; - CGSize *adv = advances; -#endif struct face *face; NSRect r; struct nsfont_info *font; @@ -1043,7 +976,7 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, r.origin.x = s->x; if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) - r.origin.x += abs (s->face->box_line_width); + r.origin.x += max (s->face->box_vertical_line_width, 0); r.origin.y = s->y; r.size.height = FONT_HEIGHT (font); @@ -1073,11 +1006,7 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, else { cwidth = LGLYPH_WADJUST (glyph); -#ifdef NS_IMPL_GNUSTEP *(adv-1) += LGLYPH_XOFF (glyph); -#else - (*(adv-1)).width += LGLYPH_XOFF (glyph); -#endif } } } @@ -1088,12 +1017,8 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, cwidth = font->metrics[hi][lo].width; } twidth += cwidth; -#ifdef NS_IMPL_GNUSTEP *adv++ = cwidth; - CHAR_STRING_ADVANCE (*t, c); /* This converts the char to UTF-8. */ -#else - (*adv++).width = cwidth; -#endif + c += CHAR_STRING (*t, c); /* This converts the char to UTF-8. */ } len = adv - advances; r.size.width = twidth; @@ -1105,7 +1030,7 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, { NSRect br = r; int fibw = FRAME_INTERNAL_BORDER_WIDTH (s->f); - int mbox_line_width = max (s->face->box_line_width, 0); + int mbox_line_width = max (s->face->box_vertical_line_width, 0); if (s->row->full_width_p) { @@ -1129,9 +1054,10 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, } else { - int correction = abs (s->face->box_line_width)+1; + int correction = abs (s->face->box_horizontal_line_width)+1; br.origin.y += correction; br.size.height -= 2*correction; + correction = abs (s->face->box_vertical_line_width)+1; br.origin.x += correction; br.size.width -= 2*correction; } @@ -1162,7 +1088,6 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, : FRAME_BACKGROUND_COLOR (s->f))); /* render under GNUstep using DPS */ -#ifdef NS_IMPL_GNUSTEP { NSGraphicsContext *context = GSCurrentContext (); @@ -1191,61 +1116,6 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, DPSgrestore (context); } -#else /* NS_IMPL_COCOA */ - { - CGContextRef gcontext = - [[NSGraphicsContext currentContext] graphicsPort]; - static CGAffineTransform fliptf; - static BOOL firstTime = YES; - - if (firstTime) - { - firstTime = NO; - fliptf = CGAffineTransformMakeScale (1.0, -1.0); - } - - CGContextSaveGState (gcontext); - - // Used to be Fix2X (kATSItalicQDSkew), but Fix2X is deprecated - // and kATSItalicQDSkew is 0.25. - fliptf.c = font->synthItal ? 0.25 : 0.0; - - CGContextSetFont (gcontext, font->cgfont); - CGContextSetFontSize (gcontext, font->size); - if (NILP (ns_antialias_text) || font->size <= ns_antialias_threshold) - CGContextSetShouldAntialias (gcontext, 0); - else - CGContextSetShouldAntialias (gcontext, 1); - - CGContextSetTextMatrix (gcontext, fliptf); - - if (bgCol != nil) - { - /* foreground drawing; erase first to avoid overstrike */ - [bgCol set]; - CGContextSetTextDrawingMode (gcontext, kCGTextFillStroke); - CGContextSetTextPosition (gcontext, r.origin.x, r.origin.y); - CGContextShowGlyphsWithAdvances (gcontext, s->char2b, advances, len); - CGContextSetTextDrawingMode (gcontext, kCGTextFill); - } - - [col set]; - - CGContextSetTextPosition (gcontext, r.origin.x, r.origin.y); - CGContextShowGlyphsWithAdvances (gcontext, s->char2b + from, - advances, len); - - if (face->overstrike) - { - CGContextSetTextPosition (gcontext, r.origin.x+0.5, r.origin.y); - CGContextShowGlyphsWithAdvances (gcontext, s->char2b + from, - advances, len); - } - - CGContextRestoreGState (gcontext); - } -#endif /* NS_IMPL_COCOA */ - unblock_input (); return to-from; } @@ -1263,10 +1133,6 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, static void ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block) { -#ifdef NS_IMPL_COCOA - static EmacsGlyphStorage *glyphStorage; - static char firstTime = 1; -#endif unichar *unichars = xmalloc (0x101 * sizeof (unichar)); unsigned int i, g, idx; unsigned short *glyphs; @@ -1277,14 +1143,6 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block) block_input (); -#ifdef NS_IMPL_COCOA - if (firstTime) - { - firstTime = 0; - glyphStorage = [[EmacsGlyphStorage alloc] initWithCapacity: 0x100]; - } -#endif - font_info->glyphs[block] = xmalloc (0x100 * sizeof (unsigned short)); if (!unichars || !(font_info->glyphs[block])) emacs_abort (); @@ -1298,38 +1156,12 @@ ns_uni_to_glyphs (struct nsfont_info *font_info, unsigned char block) unichars[0x100] = 0; { -#ifdef NS_IMPL_COCOA - NSString *allChars = [[NSString alloc] - initWithCharactersNoCopy: unichars - length: 0x100 - freeWhenDone: NO]; - NSGlyphGenerator *glyphGenerator = [NSGlyphGenerator sharedGlyphGenerator]; - /* NSCharacterSet *coveredChars = [nsfont coveredCharacterSet]; */ - unsigned int numGlyphs = [font_info->nsfont numberOfGlyphs]; - NSUInteger gInd = 0, cInd = 0; - - [glyphStorage setString: allChars font: font_info->nsfont]; - [glyphGenerator generateGlyphsForGlyphStorage: glyphStorage - desiredNumberOfCharacters: glyphStorage->maxChar - glyphIndex: &gInd characterIndex: &cInd]; -#endif glyphs = font_info->glyphs[block]; for (i = 0; i < 0x100; i++, glyphs++) { -#ifdef NS_IMPL_GNUSTEP g = unichars[i]; -#else - g = glyphStorage->cglyphs[i]; - /* TODO: is this a good check? Maybe need to use coveredChars. */ - if (g > numGlyphs || g == NSNullGlyph) - g = INVALID_GLYPH; /* Hopefully unused... */ -#endif *glyphs = g; } - -#ifdef NS_IMPL_COCOA - [allChars release]; -#endif } unblock_input (); @@ -1351,19 +1183,12 @@ ns_glyph_metrics (struct nsfont_info *font_info, unsigned char block) fprintf (stderr, "%p\tComputing metrics for glyphs in block %d\n", font_info, block); -#ifdef NS_IMPL_GNUSTEP /* not implemented yet (as of startup 0.18), so punt */ if (numGlyphs == 0) numGlyphs = 0x10000; -#endif block_input (); -#ifdef NS_IMPL_COCOA - sfont = [font_info->nsfont screenFontWithRenderingMode: - NSFontAntialiasedIntegerAdvancementsRenderingMode]; -#else sfont = [font_info->nsfont screenFont]; -#endif font_info->metrics[block] = xzalloc (0x100 * sizeof (struct font_metrics)); if (!(font_info->metrics[block])) @@ -1396,76 +1221,6 @@ ns_glyph_metrics (struct nsfont_info *font_info, unsigned char block) } -#ifdef NS_IMPL_COCOA -/* Helper for font glyph setup. */ -@implementation EmacsGlyphStorage - -- init -{ - return [self initWithCapacity: 1024]; -} - -- initWithCapacity: (unsigned long) c -{ - self = [super init]; - maxChar = 0; - maxGlyph = 0; - dict = [NSMutableDictionary new]; - cglyphs = xmalloc (c * sizeof (CGGlyph)); - return self; -} - -- (void) dealloc -{ - if (attrStr != nil) - [attrStr release]; - [dict release]; - xfree (cglyphs); - [super dealloc]; -} - -- (void) setString: (NSString *)str font: (NSFont *)font -{ - [dict setObject: font forKey: NSFontAttributeName]; - if (attrStr != nil) - [attrStr release]; - attrStr = [[NSAttributedString alloc] initWithString: str attributes: dict]; - maxChar = [str length]; - maxGlyph = 0; -} - -/* NSGlyphStorage protocol */ -- (NSUInteger)layoutOptions -{ - return 0; -} - -- (NSAttributedString *)attributedString -{ - return attrStr; -} - -- (void)insertGlyphs: (const NSGlyph *)glyphs length: (NSUInteger)length - forStartingGlyphAtIndex: (NSUInteger)glyphIndex - characterIndex: (NSUInteger)charIndex -{ - len = glyphIndex+length; - for (i =glyphIndex; i<len; i++) - cglyphs[i] = glyphs[i-glyphIndex]; - if (len > maxGlyph) - maxGlyph = len; -} - -- (void)setIntAttribute: (NSInteger)attributeTag value: (NSInteger)val - forGlyphAtIndex: (NSUInteger)glyphIndex -{ - return; -} - -@end -#endif /* NS_IMPL_COCOA */ - - /* Debugging */ void ns_dump_glyphstring (struct glyph_string *s) diff --git a/src/nsimage.m b/src/nsimage.m index a375aa1dfcb..fa81a41a519 100644 --- a/src/nsimage.m +++ b/src/nsimage.m @@ -36,6 +36,14 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) #include "coding.h" +#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MAX_ALLOWED < 1070 +# define COLORSPACE_NAME NSCalibratedRGBColorSpace +#else +# define COLORSPACE_NAME \ + ((ns_use_srgb_colorspace && NSAppKitVersionNumber >= NSAppKitVersionNumber10_7) \ + ? NSDeviceRGBColorSpace : NSCalibratedRGBColorSpace) +#endif + /* ========================================================================== @@ -45,6 +53,55 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) ========================================================================== */ +bool +ns_can_use_native_image_api (Lisp_Object type) +{ + NSString *imageType = @"unknown"; + NSArray *types; + + NSTRACE ("ns_can_use_native_image_api"); + + if (EQ (type, Qnative_image)) + return YES; + +#ifdef NS_IMPL_COCOA + /* Work out the UTI of the image type. */ + if (EQ (type, Qjpeg)) + imageType = @"public.jpeg"; + else if (EQ (type, Qpng)) + imageType = @"public.png"; + else if (EQ (type, Qgif)) + imageType = @"com.compuserve.gif"; + else if (EQ (type, Qtiff)) + imageType = @"public.tiff"; + else if (EQ (type, Qsvg)) + imageType = @"public.svg-image"; + + /* NSImage also supports a host of other types such as PDF and BMP, + but we don't yet support these in image.c. */ + + types = [NSImage imageTypes]; +#else + /* Work out the image type. */ + if (EQ (type, Qjpeg)) + imageType = @"jpeg"; + else if (EQ (type, Qpng)) + imageType = @"png"; + else if (EQ (type, Qgif)) + imageType = @"gif"; + else if (EQ (type, Qtiff)) + imageType = @"tiff"; + + types = [NSImage imageFileTypes]; +#endif + + /* Check if the type is supported on this system. */ + if ([types indexOfObject:imageType] != NSNotFound) + return YES; + else + return NO; +} + void * ns_image_from_XBM (char *bits, int width, int height, unsigned long fg, unsigned long bg) @@ -150,6 +207,12 @@ ns_image_set_transform (void *img, double m[3][3]) [(EmacsImage *)img setTransform:m]; } +void +ns_image_set_smoothing (void *img, bool smooth) +{ + [(EmacsImage *)img setSmoothing:smooth]; +} + unsigned long ns_get_pixel (void *img, int x, int y) { @@ -172,6 +235,11 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) [(EmacsImage *)img setAlphaAtX: x Y: y to: a]; } +size_t +ns_image_size_in_bytes (void *img) +{ + return [(EmacsImage *)img sizeInBytes]; +} /* ========================================================================== @@ -194,7 +262,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) found = ENCODE_FILE (found); image = [[EmacsImage alloc] initByReferencingFile: - [NSString stringWithUTF8String: SSDATA (found)]]; + [NSString stringWithLispString: found]]; image->bmRep = nil; #ifdef NS_IMPL_COCOA @@ -210,7 +278,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) [image setSize: NSMakeSize([imgRep pixelsWide], [imgRep pixelsHigh])]; - [image setName: [NSString stringWithUTF8String: SSDATA (file)]]; + [image setName: [NSString stringWithLispString: file]]; return image; } @@ -225,6 +293,18 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) } +- (id)copyWithZone:(NSZone *)zone +{ + EmacsImage *copy = [super copyWithZone:zone]; + + copy->stippleMask = [stippleMask copyWithZone:zone]; + copy->bmRep = [bmRep copyWithZone:zone]; + copy->transform = [transform copyWithZone:zone]; + + return copy; +} + + /* Create image from monochrome bitmap. If both FG and BG are 0 (black), set the background to white and make it transparent. */ - (instancetype)initFromXBM: (unsigned char *)bits width: (int)w height: (int)h @@ -240,7 +320,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) pixelsWide: w pixelsHigh: h bitsPerSample: 8 samplesPerPixel: 4 hasAlpha: YES isPlanar: YES - colorSpaceName: NSCalibratedRGBColorSpace + colorSpaceName: COLORSPACE_NAME bytesPerRow: w bitsPerPixel: 0]; [bmRep getBitmapDataPlanes: planes]; @@ -360,7 +440,7 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) /* keep things simple for now */ bitsPerSample: 8 samplesPerPixel: 4 /*RGB+A*/ hasAlpha: YES isPlanar: YES - colorSpaceName: NSCalibratedRGBColorSpace + colorSpaceName: COLORSPACE_NAME bytesPerRow: width bitsPerPixel: 0]; [bmRep getBitmapDataPlanes: pixmapData]; @@ -407,9 +487,10 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) if (pixmapData[0] != NULL) { int loc = x + y * [self size].width; - return (pixmapData[3][loc] << 24) /* alpha */ - | (pixmapData[0][loc] << 16) | (pixmapData[1][loc] << 8) - | (pixmapData[2][loc]); + return (((unsigned long) pixmapData[3][loc] << 24) /* alpha */ + | ((unsigned long) pixmapData[0][loc] << 16) + | ((unsigned long) pixmapData[1][loc] << 8) + | (unsigned long) pixmapData[2][loc]); } else { @@ -541,4 +622,27 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) [transform setTransformStruct:tm]; } +- (void)setSmoothing: (BOOL) s +{ + smoothing = s; +} + +/* Approximate allocated size of image in bytes. */ +- (size_t) sizeInBytes +{ + size_t bytes = 0; + NSImageRep *rep; + NSEnumerator *reps = [[self representations] objectEnumerator]; + while ((rep = (NSImageRep *) [reps nextObject])) + { + if ([rep respondsToSelector: @selector (bytesPerRow)]) + { + NSBitmapImageRep *bmr = (NSBitmapImageRep *) rep; + bytes += [bmr bytesPerRow] * [bmr numberOfPlanes] * [bmr pixelsHigh]; + } + } + return bytes; +} + + @end diff --git a/src/nsmenu.m b/src/nsmenu.m index cab57821c9f..24aa5a0ac11 100644 --- a/src/nsmenu.m +++ b/src/nsmenu.m @@ -47,21 +47,11 @@ Carbon version by Yamamoto Mitsuharu. */ #endif -#if 0 -/* Include lisp -> C common menu parsing code. */ -#define ENCODE_MENU_STRING(str) ENCODE_UTF_8 (str) -#include "nsmenu_common.c" -#endif - extern long context_menu_value; EmacsMenu *svcsMenu; /* Nonzero means a menu is currently active. */ static int popup_activated_flag; -/* Nonzero means we are tracking and updating menus. */ -static int trackingMenu; - - /* NOTE: toolbar implementation is at end, following complete menu implementation. */ @@ -75,11 +65,22 @@ static int trackingMenu; /* Supposed to discard menubar and free storage. Since we share the menubar among frames and update its context for the focused window, - there is nothing to do here. */ + we do not discard the menu. We do, however, want to remove any + existing menu items. */ void free_frame_menubar (struct frame *f) { - return; + id menu = [NSApp mainMenu]; + for (int i = [menu numberOfItems] - 1 ; i >= 0; i--) + { + NSMenuItem *item = [menu itemAtIndex:i]; + NSString *title = [item title]; + + if ([ns_app_name isEqualToString:title]) + continue; + + [menu removeItemAtIndex:i]; + } } @@ -98,16 +99,18 @@ popup_activated (void) 3) deep_p, submenu = non-nil: Update contents of a single submenu. -------------------------------------------------------------------------- */ static void -ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) +ns_update_menubar (struct frame *f, bool deep_p) { - NSAutoreleasePool *pool; - id menu = [NSApp mainMenu]; - static EmacsMenu *last_submenu = nil; BOOL needsSet = NO; + id menu = [NSApp mainMenu]; bool owfi; + Lisp_Object items; widget_value *wv, *first_wv, *prev_wv = 0; int i; + int *submenu_start, *submenu_end; + bool *submenu_top_level_items; + int *submenu_n_panes; #if NSMENUPROFILE struct timeb tb; @@ -116,13 +119,12 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) NSTRACE ("ns_update_menubar"); - if (f != SELECTED_FRAME ()) + if (f != SELECTED_FRAME () || FRAME_EXTERNAL_MENU_BAR (f) == 0) return; XSETFRAME (Vmenu_updating_frame, f); /*fprintf (stderr, "ns_update_menubar: frame: %p\tdeep: %d\tsub: %p\n", f, deep_p, submenu); */ block_input (); - pool = [[NSAutoreleasePool alloc] init]; /* Menu may have been created automatically; if so, discard it. */ if ([menu isKindOfClass: [EmacsMenu class]] == NO) @@ -143,115 +145,105 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) #endif #ifdef NS_IMPL_GNUSTEP - deep_p = 1; /* until GNUstep NSMenu implements the Panther delegation model */ + deep_p = 1; /* See comment in menuNeedsUpdate. */ #endif if (deep_p) { - /* Fully parse one or more of the submenus. */ - int n = 0; - int *submenu_start, *submenu_end; - bool *submenu_top_level_items; - int *submenu_n_panes; + /* Make a widget-value tree representing the entire menu trees. */ + struct buffer *prev = current_buffer; Lisp_Object buffer; ptrdiff_t specpdl_count = SPECPDL_INDEX (); int previous_menu_items_used = f->menu_bar_items_used; Lisp_Object *previous_items = alloca (previous_menu_items_used * sizeof *previous_items); + int subitems; - /* lisp preliminaries */ buffer = XWINDOW (FRAME_SELECTED_WINDOW (f))->contents; specbind (Qinhibit_quit, Qt); + /* Don't let the debugger step into this code + because it is not reentrant. */ specbind (Qdebug_on_next_call, Qnil); + record_unwind_save_match_data (); if (NILP (Voverriding_local_map_menu_flag)) { specbind (Qoverriding_terminal_local_map, Qnil); specbind (Qoverriding_local_map, Qnil); } + set_buffer_internal_1 (XBUFFER (buffer)); - /* TODO: for some reason this is not needed in other terms, - but some menu updates call Info-extract-pointer which causes - abort-on-error if waiting-for-input. Needs further investigation. */ + /* TODO: for some reason this is not needed in other terms, but + some menu updates call Info-extract-pointer which causes + abort-on-error if waiting-for-input. Needs further + investigation. */ owfi = waiting_for_input; waiting_for_input = 0; - /* lucid hook and possible reset */ + /* Run the Lucid hook. */ safe_run_hooks (Qactivate_menubar_hook); + + /* If it has changed current-menubar from previous value, + really recompute the menubar from the value. */ if (! NILP (Vlucid_menu_bar_dirty_flag)) call0 (Qrecompute_lucid_menubar); safe_run_hooks (Qmenu_bar_update_hook); fset_menu_bar_items (f, menu_bar_items (FRAME_MENU_BAR_ITEMS (f))); - /* Now ready to go */ items = FRAME_MENU_BAR_ITEMS (f); - /* Save the frame's previous menu bar contents data */ + /* Save the frame's previous menu bar contents data. */ if (previous_menu_items_used) - memcpy (previous_items, aref_addr (f->menu_bar_vector, 0), - previous_menu_items_used * sizeof (Lisp_Object)); + memcpy (previous_items, xvector_contents (f->menu_bar_vector), + previous_menu_items_used * word_size); - /* parse stage 1: extract from lisp */ + /* Fill in menu_items with the current menu bar contents. + This can evaluate Lisp code. */ save_menu_items (); menu_items = f->menu_bar_vector; menu_items_allocated = VECTORP (menu_items) ? ASIZE (menu_items) : 0; - submenu_start = alloca (ASIZE (items) * sizeof *submenu_start); - submenu_end = alloca (ASIZE (items) * sizeof *submenu_end); - submenu_n_panes = alloca (ASIZE (items) * sizeof *submenu_n_panes); - submenu_top_level_items = alloca (ASIZE (items) + subitems = ASIZE (items) / 4; + submenu_start = alloca ((subitems + 1) * sizeof *submenu_start); + submenu_end = alloca (subitems * sizeof *submenu_end); + submenu_n_panes = alloca (subitems * sizeof *submenu_n_panes); + submenu_top_level_items = alloca (subitems * sizeof *submenu_top_level_items); init_menu_items (); - for (i = 0; i < ASIZE (items); i += 4) + for (i = 0; i < subitems; i++) { Lisp_Object key, string, maps; - key = AREF (items, i); - string = AREF (items, i + 1); - maps = AREF (items, i + 2); + key = AREF (items, 4 * i); + string = AREF (items, 4 * i + 1); + maps = AREF (items, 4 * i + 2); if (NILP (string)) break; - /* FIXME: we'd like to only parse the needed submenu, but this - was causing crashes in the _common parsing code: need to make - sure proper initialization done. */ - /* if (submenu && strcmp ([[submenu title] UTF8String], SSDATA (string))) - continue; */ - submenu_start[i] = menu_items_used; menu_items_n_panes = 0; - submenu_top_level_items[i] = parse_single_submenu (key, string, maps); + submenu_top_level_items[i] + = parse_single_submenu (key, string, maps); submenu_n_panes[i] = menu_items_n_panes; + submenu_end[i] = menu_items_used; - n++; } + submenu_start[i] = -1; finish_menu_items (); waiting_for_input = owfi; + /* Convert menu_items into widget_value trees + to display the menu. This cannot evaluate Lisp code. */ - if (submenu && n == 0) - { - /* should have found a menu for this one but didn't */ - fprintf (stderr, "ERROR: did not find lisp menu for submenu '%s'.\n", - [[submenu title] UTF8String]); - discard_menu_items (); - unbind_to (specpdl_count, Qnil); - [pool release]; - unblock_input (); - return; - } - - /* parse stage 2: insert into lucid 'widget_value' structures - [comments in other terms say not to evaluate lisp code here] */ wv = make_widget_value ("menubar", NULL, true, Qnil); wv->button_type = BUTTON_TYPE_NONE; first_wv = wv; - for (i = 0; i < 4*n; i += 4) + for (i = 0; submenu_start[i] >= 0; i++) { menu_items_n_panes = submenu_n_panes[i]; wv = digest_single_submenu (submenu_start[i], submenu_end[i], @@ -261,172 +253,79 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) else first_wv->contents = wv; /* Don't set wv->name here; GC during the loop might relocate it. */ - wv->enabled = 1; + wv->enabled = true; wv->button_type = BUTTON_TYPE_NONE; prev_wv = wv; } set_buffer_internal_1 (prev); - /* Compare the new menu items with previous, and leave off if no change. */ - /* FIXME: following other terms here, but seems like this should be - done before parse stage 2 above, since its results aren't used. */ - if (previous_menu_items_used - && (!submenu || (submenu && submenu == last_submenu)) - && menu_items_used == previous_menu_items_used) - { - for (i = 0; i < previous_menu_items_used; i++) - /* FIXME: this ALWAYS fails on Buffers menu items.. something - about their strings causes them to change every time, so we - double-check failures. */ - if (!EQ (previous_items[i], AREF (menu_items, i))) - if (!(STRINGP (previous_items[i]) - && STRINGP (AREF (menu_items, i)) - && !strcmp (SSDATA (previous_items[i]), - SSDATA (AREF (menu_items, i))))) - break; - if (i == previous_menu_items_used) - { - /* No change. */ + /* If there has been no change in the Lisp-level contents + of the menu bar, skip redisplaying it. Just exit. */ -#if NSMENUPROFILE - ftime (&tb); - t += 1000*tb.time+tb.millitm; - fprintf (stderr, "NO CHANGE! CUTTING OUT after %ld msec.\n", t); -#endif + /* Compare the new menu items with the ones computed last time. */ + for (i = 0; i < previous_menu_items_used; i++) + if (menu_items_used == i + || (!EQ (previous_items[i], AREF (menu_items, i)))) + break; + if (i == menu_items_used && i == previous_menu_items_used && i != 0) + { + /* The menu items have not changed. Don't bother updating + the menus in any form, since it would be a no-op. */ + free_menubar_widget_value_tree (first_wv); + discard_menu_items (); + unbind_to (specpdl_count, Qnil); + return; + } - free_menubar_widget_value_tree (first_wv); - discard_menu_items (); - unbind_to (specpdl_count, Qnil); - [pool release]; - unblock_input (); - return; - } - } /* The menu items are different, so store them in the frame. */ - /* FIXME: this is not correct for single-submenu case. */ fset_menu_bar_vector (f, menu_items); f->menu_bar_items_used = menu_items_used; - /* Calls restore_menu_items, etc., as they were outside. */ + /* This undoes save_menu_items. */ unbind_to (specpdl_count, Qnil); - /* Parse stage 2a: now GC cannot happen during the lifetime of the - widget_value, so it's safe to store data from a Lisp_String. */ + /* Now GC cannot happen during the lifetime of the widget_value, + so it's safe to store data from a Lisp_String. */ wv = first_wv->contents; for (i = 0; i < ASIZE (items); i += 4) { Lisp_Object string; string = AREF (items, i + 1); if (NILP (string)) - break; - - wv->name = SSDATA (string); + break; + wv->name = SSDATA (string); update_submenu_strings (wv->contents); - wv = wv->next; + wv = wv->next; } - /* Now, update the NS menu; if we have a submenu, use that, otherwise - create a new menu for each sub and fill it. */ - if (submenu) - { - const char *submenuTitle = [[submenu title] UTF8String]; - for (wv = first_wv->contents; wv; wv = wv->next) - { - if (!strcmp (submenuTitle, wv->name)) - { - [submenu fillWithWidgetValue: wv->contents]; - last_submenu = submenu; - break; - } - } - } - else - { - [menu fillWithWidgetValue: first_wv->contents frame: f]; - } - } else { - static int n_previous_strings = 0; - static char previous_strings[100][10]; - static struct frame *last_f = NULL; - int n; - Lisp_Object string; + /* Make a widget-value tree containing + just the top level menu bar strings. */ wv = make_widget_value ("menubar", NULL, true, Qnil); wv->button_type = BUTTON_TYPE_NONE; first_wv = wv; - /* Make widget-value tree with just the top level menu bar strings. */ items = FRAME_MENU_BAR_ITEMS (f); - if (NILP (items)) - { - free_menubar_widget_value_tree (first_wv); - [pool release]; - unblock_input (); - return; - } - - - /* Check if no change: this mechanism is a bit rough, but ready. */ - n = ASIZE (items) / 4; - if (f == last_f && n_previous_strings == n) - { - for (i = 0; i<n; i++) - { - string = AREF (items, 4*i+1); - - if (EQ (string, make_fixnum (0))) // FIXME: Why??? --Stef - continue; - if (NILP (string)) - { - if (previous_strings[i][0]) - break; - else - continue; - } - else if (memcmp (previous_strings[i], SDATA (string), - min (10, SBYTES (string) + 1))) - break; - } - - if (i == n) - { - free_menubar_widget_value_tree (first_wv); - [pool release]; - unblock_input (); - return; - } - } - - [menu clear]; for (i = 0; i < ASIZE (items); i += 4) { + Lisp_Object string; + string = AREF (items, i + 1); if (NILP (string)) break; - if (n < 100) - memcpy (previous_strings[i/4], SDATA (string), - min (10, SBYTES (string) + 1)); - wv = make_widget_value (SSDATA (string), NULL, true, Qnil); wv->button_type = BUTTON_TYPE_NONE; + /* This prevents lwlib from assuming this + menu item is really supposed to be empty. */ + /* The intptr_t cast avoids a warning. + This value just has to be different from small integers. */ wv->call_data = (void *) (intptr_t) (-1); -#ifdef NS_IMPL_COCOA - /* We'll update the real copy under app menu when time comes. */ - if (!strcmp ("Services", wv->name)) - { - /* But we need to make sure it will update on demand. */ - [svcsMenu setFrame: f]; - } - else -#endif - [menu addSubmenuWithTitle: wv->name forFrame: f]; - if (prev_wv) prev_wv->next = wv; else @@ -434,16 +333,59 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) prev_wv = wv; } - last_f = f; - if (n < 100) - n_previous_strings = n; + /* Forget what we thought we knew about what is in the + detailed contents of the menu bar menus. + Changing the top level always destroys the contents. */ + f->menu_bar_items_used = 0; + } + + /* Now, update the NS menu. */ + i = 0; + + /* Make sure we skip the "application" menu, which is always the + first entry in our top-level menu. */ + if (i < [menu numberOfItems]) + { + NSString *title = [[menu itemAtIndex:i] title]; + if ([ns_app_name isEqualToString:title]) + i += 1; + } + + for (wv = first_wv->contents; wv; wv = wv->next) + { + EmacsMenu *submenu; + + if (i < [menu numberOfItems]) + { + NSString *titleStr = [NSString stringWithUTF8String: wv->name]; + NSMenuItem *item = [menu itemAtIndex:i]; + submenu = (EmacsMenu*)[item submenu]; + + [item setTitle:titleStr]; + [submenu setTitle:titleStr]; + [submenu removeAllItems]; + } else - n_previous_strings = 0; + submenu = [menu addSubmenuWithTitle: wv->name]; + + if ([[submenu title] isEqualToString:@"Help"]) + [NSApp setHelpMenu:submenu]; + if (deep_p) + [submenu fillWithWidgetValue: wv->contents]; + + i += 1; + } + + while (i < [menu numberOfItems]) + { + /* Remove any extra items. */ + [menu removeItemAtIndex:i]; } - free_menubar_widget_value_tree (first_wv); + free_menubar_widget_value_tree (first_wv); + #if NSMENUPROFILE ftime (&tb); t += 1000*tb.time+tb.millitm; @@ -454,7 +396,6 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) if (needsSet) [NSApp setMainMenu: menu]; - [pool release]; unblock_input (); } @@ -464,23 +405,12 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) frame's menus have changed, and the *step representation should be updated from Lisp. */ void -set_frame_menubar (struct frame *f, bool first_time, bool deep_p) +set_frame_menubar (struct frame *f, bool deep_p) { - ns_update_menubar (f, deep_p, nil); -} - -void -ns_activate_menubar (struct frame *f) -{ -#ifdef NS_IMPL_COCOA - ns_update_menubar (f, true, nil); - ns_check_pending_open_menu (); -#endif + ns_update_menubar (f, deep_p); } - - /* ========================================================================== Menu: class implementation @@ -496,96 +426,31 @@ ns_activate_menubar (struct frame *f) /* override designated initializer */ - (instancetype)initWithTitle: (NSString *)title { - frame = 0; if ((self = [super initWithTitle: title])) [self setAutoenablesItems: NO]; - return self; -} - - -/* used for top-level */ -- (instancetype)initWithTitle: (NSString *)title frame: (struct frame *)f -{ - [self initWithTitle: title]; - frame = f; -#ifdef NS_IMPL_COCOA [self setDelegate: self]; -#endif - return self; -} + needsUpdate = YES; -- (void)setFrame: (struct frame *)f -{ - frame = f; -} - -#ifdef NS_IMPL_COCOA --(void)trackingNotification:(NSNotification *)notification -{ - /* Update menu in menuNeedsUpdate only while tracking menus. */ - trackingMenu = ([notification name] == NSMenuDidBeginTrackingNotification - ? 1 : 0); - if (! trackingMenu) ns_check_menu_open (nil); -} - -- (void)menuWillOpen:(NSMenu *)menu -{ - ++trackingMenu; - -#if MAC_OS_X_VERSION_MIN_REQUIRED < 1070 - // On 10.6 we get repeated calls, only the one for NSSystemDefined is "real". - if ( -#if MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 - NSAppKitVersionNumber < NSAppKitVersionNumber10_7 && -#endif - [[NSApp currentEvent] type] != NSEventTypeSystemDefined) - return; -#endif - - /* When dragging from one menu to another, we get willOpen followed by didClose, - i.e. trackingMenu == 3 in willOpen and then 2 after didClose. - We have updated all menus, so avoid doing it when trackingMenu == 3. */ - if (trackingMenu == 2) - ns_check_menu_open (menu); -} - -- (void)menuDidClose:(NSMenu *)menu -{ - --trackingMenu; + return self; } -#endif /* NS_IMPL_COCOA */ -/* Delegate method called when a submenu is being opened: run a 'deep' call - to set_frame_menubar. */ +/* Delegate method called when a submenu is being opened: run a 'deep' + call to ns_update_menubar. */ - (void)menuNeedsUpdate: (NSMenu *)menu { - if (!FRAME_LIVE_P (frame)) + if (!FRAME_LIVE_P (SELECTED_FRAME ())) return; - /* Cocoa/Carbon will request update on every keystroke - via IsMenuKeyEvent -> CheckMenusForKeyEvent. These are not needed - since key equivalents are handled through emacs. - On Leopard, even keystroke events generate SystemDefined event. - Third-party applications that enhance mouse / trackpad - interaction, or also VNC/Remote Desktop will send events - of type AppDefined rather than SysDefined. - Menus will fail to show up if they haven't been initialized. - AppDefined events may lack timing data. - - Thus, we rely on the didBeginTrackingNotification notification - as above to indicate the need for updates. - From 10.6 on, we could also use -[NSMenu propertiesToUpdate]: In the - key press case, NSMenuPropertyItemImage (e.g.) won't be set. - */ - if (trackingMenu == 0) - return; -/*fprintf (stderr, "Updating menu '%s'\n", [[self title] UTF8String]); NSLog (@"%@\n", event); */ -#ifdef NS_IMPL_GNUSTEP - /* Don't know how to do this for anything other than Mac OS X 10.5 and later. - This is wrong, as it might run Lisp code in the event loop. */ - ns_update_menubar (frame, true, self); +#ifdef NS_IMPL_COCOA +/* TODO: GNUstep calls this method when the menu is still being built + which results in a recursive stack overflow. One possible solution + is to use menuWillOpen instead, but the Apple docs explicitly warn + against changing the contents of the menu in it. I don't know what + the right thing to do for GNUstep is. */ + if (needsUpdate) + ns_update_menubar (SELECTED_FRAME (), true); #endif } @@ -599,33 +464,8 @@ ns_activate_menubar (struct frame *f) } -/* Parse a widget_value's key rep (examples: 's-p', 's-S', '(C-x C-s)', '<f13>') - into an accelerator string. We are only able to display a single character - for an accelerator, together with an optional modifier combination. (Under - Carbon more control was possible, but in Cocoa multi-char strings passed to - NSMenuItem get ignored. For now we try to display a super-single letter - combo, and return the others as strings to be appended to the item title. - (This is signaled by setting keyEquivModMask to 0 for now.) */ --(NSString *)parseKeyEquiv: (const char *)key -{ - const char *tpos = key; - keyEquivModMask = NSEventModifierFlagCommand; - - if (!key || !*key) - return @""; - - while (*tpos == ' ' || *tpos == '(') - tpos++; - if ((*tpos == 's') && (*(tpos+1) == '-')) - { - return [NSString stringWithFormat: @"%c", tpos[2]]; - } - keyEquivModMask = 0; /* signal */ - return [NSString stringWithUTF8String: tpos]; -} - - - (NSMenuItem *)addItemWithWidgetValue: (void *)wvptr + attributes: (NSDictionary *)attributes { NSMenuItem *item; widget_value *wv = (widget_value *)wvptr; @@ -633,36 +473,33 @@ ns_activate_menubar (struct frame *f) if (menu_separator_name_p (wv->name)) { item = [NSMenuItem separatorItem]; - [self addItem: item]; } else { - NSString *title, *keyEq; - title = [NSString stringWithUTF8String: wv->name]; + NSString *title = [NSString stringWithUTF8String: wv->name]; if (title == nil) title = @"< ? >"; /* (get out in the open so we know about it) */ - keyEq = [self parseKeyEquiv: wv->key]; -#ifdef NS_IMPL_COCOA - /* macOS mangles modifier strings longer than one character. */ - if (keyEquivModMask == 0) - { - title = [title stringByAppendingFormat: @" (%@)", keyEq]; - item = [self addItemWithTitle: (NSString *)title - action: @selector (menuDown:) - keyEquivalent: @""]; - } - else + item = [[[NSMenuItem alloc] init] autorelease]; + if (wv->key) { -#endif - item = [self addItemWithTitle: (NSString *)title - action: @selector (menuDown:) - keyEquivalent: keyEq]; + NSString *key = [NSString stringWithUTF8String: wv->key]; #ifdef NS_IMPL_COCOA - } + /* Cocoa only permits a single key (with modifiers) as + keyEquivalent, so we put them in the title string + in a tab-separated column. */ + title = [title stringByAppendingFormat: @"\t%@", key]; +#else + [item setKeyEquivalent: key]; #endif - [item setKeyEquivalentModifierMask: keyEquivModMask]; + } + NSAttributedString *atitle = [[[NSAttributedString alloc] + initWithString: title + attributes: attributes] + autorelease]; + [item setAction: @selector (menuDown:)]; + [item setAttributedTitle: atitle]; [item setEnabled: wv->enabled]; /* Draw radio buttons and tickboxes. */ @@ -675,52 +512,145 @@ ns_activate_menubar (struct frame *f) [item setTag: (NSInteger)wv->call_data]; } + [self addItem: item]; return item; } /* convenience */ --(void)clear +-(void)removeAllItems { +#ifdef NS_IMPL_COCOA + [super removeAllItems]; +#else + /* GNUstep doesn't have removeAllItems yet, so do it + manually. */ int n; for (n = [self numberOfItems]-1; n >= 0; n--) - { - NSMenuItem *item = [self itemAtIndex: n]; - NSString *title = [item title]; - if ([ns_app_name isEqualToString: title] - && ![item isSeparatorItem]) - continue; - [self removeItemAtIndex: n]; - } + [self removeItemAtIndex: n]; +#endif + + needsUpdate = YES; } -- (void)fillWithWidgetValue: (void *)wvptr +typedef struct { + const char *from, *to; +} subst_t; + +/* Standard keyboard symbols used in menus. */ +static const subst_t key_symbols[] = { + {"<backspace>", "⌫"}, + {"DEL", "⌫"}, + {"<deletechar>", "⌦"}, + {"<return>", "↩"}, + {"RET", "↩"}, + {"<left>", "←"}, + {"<right>", "→"}, + {"<up>", "↑"}, + {"<down>", "↓"}, + {"<prior>", "⇞"}, + {"<next>", "⇟"}, + {"<home>", "↖"}, + {"<end>", "↘"}, + {"<tab>", "⇥"}, + {"TAB", "⇥"}, + {"<backtab>", "⇤"}, +}; + +/* Transform the key sequence KEY into something prettier by + substituting keyboard symbols. */ +static char * +prettify_key (const char *key) { - [self fillWithWidgetValue: wvptr frame: (struct frame *)nil]; + while (*key == ' ') key++; + + int len = strlen (key); + char *buf = xmalloc (len + 1); + memcpy (buf, key, len + 1); + for (int i = 0; i < ARRAYELTS (key_symbols); i++) + { + ptrdiff_t fromlen = strlen (key_symbols[i].from); + char *p = buf; + while (p < buf + len) + { + char *match = memmem (buf, len, key_symbols[i].from, fromlen); + if (!match) + break; + ptrdiff_t tolen = strlen (key_symbols[i].to); + eassert (tolen <= fromlen); + memcpy (match, key_symbols[i].to, tolen); + memmove (match + tolen, match + fromlen, + len - (match + fromlen - buf) + 1); + len -= fromlen - tolen; + p = match + tolen; + } + } + Lisp_Object result = build_string (buf); + xfree (buf); + return SSDATA (result); } -- (void)fillWithWidgetValue: (void *)wvptr frame: (struct frame *)f +- (void)fillWithWidgetValue: (void *)wvptr { - widget_value *wv = (widget_value *)wvptr; + widget_value *first_wv = (widget_value *)wvptr; + NSFont *menuFont = [NSFont menuFontOfSize:0]; + NSDictionary *attributes = nil; + +#ifdef NS_IMPL_COCOA + /* Cocoa doesn't allow multi-key sequences in its menu display, so + work around it by using tabs to split the title into two + columns. */ + NSDictionary *font_attribs = @{NSFontAttributeName: menuFont}; + CGFloat maxNameWidth = 0; + CGFloat maxKeyWidth = 0; + + /* Determine the maximum width of all menu items. */ + for (widget_value *wv = first_wv; wv != NULL; wv = wv->next) + if (!menu_separator_name_p (wv->name)) + { + NSString *name = [NSString stringWithUTF8String: wv->name]; + NSSize nameSize = [name sizeWithAttributes: font_attribs]; + maxNameWidth = MAX(maxNameWidth, nameSize.width); + if (wv->key) + { + wv->key = prettify_key (wv->key); + NSString *key = [NSString stringWithUTF8String: wv->key]; + NSSize keySize = [key sizeWithAttributes: font_attribs]; + maxKeyWidth = MAX(maxKeyWidth, keySize.width); + } + } + + /* Put some space between the names and keys. */ + CGFloat maxWidth = maxNameWidth + maxKeyWidth + 40; + + /* Set a right-aligned tab stop at the maximum width, so that the + key will appear immediately to the left of it. */ + NSTextTab *tab = + [[[NSTextTab alloc] initWithTextAlignment: NSTextAlignmentRight + location: maxWidth + options: @{}] autorelease]; + NSMutableParagraphStyle *pstyle = [[[NSMutableParagraphStyle alloc] init] + autorelease]; + [pstyle setTabStops: @[tab]]; + attributes = @{NSParagraphStyleAttributeName: pstyle}; +#endif /* clear existing contents */ - [self clear]; + [self removeAllItems]; /* add new contents */ - for (; wv != NULL; wv = wv->next) + for (widget_value *wv = first_wv; wv != NULL; wv = wv->next) { - NSMenuItem *item = [self addItemWithWidgetValue: wv]; + NSMenuItem *item = [self addItemWithWidgetValue: wv + attributes: attributes]; if (wv->contents) { EmacsMenu *submenu; - if (f) - submenu = [[EmacsMenu alloc] initWithTitle: [item title] frame:f]; - else - submenu = [[EmacsMenu alloc] initWithTitle: [item title]]; + submenu = [[EmacsMenu alloc] initWithTitle: [item title]]; [self setSubmenu: submenu forItem: item]; [submenu fillWithWidgetValue: wv->contents]; @@ -729,6 +659,8 @@ ns_activate_menubar (struct frame *f) } } + needsUpdate = NO; + #ifdef NS_IMPL_GNUSTEP if ([[self window] isVisible]) [self sizeToFit]; @@ -737,13 +669,13 @@ ns_activate_menubar (struct frame *f) /* Adds an empty submenu and returns it. */ -- (EmacsMenu *)addSubmenuWithTitle: (const char *)title forFrame: (struct frame *)f +- (EmacsMenu *)addSubmenuWithTitle: (const char *)title { NSString *titleStr = [NSString stringWithUTF8String: title]; NSMenuItem *item = [self addItemWithTitle: titleStr action: (SEL)nil /*@selector (menuDown:) */ keyEquivalent: @""]; - EmacsMenu *submenu = [[EmacsMenu alloc] initWithTitle: titleStr frame: f]; + EmacsMenu *submenu = [[EmacsMenu alloc] initWithTitle: titleStr]; [self setSubmenu: submenu forItem: item]; [submenu release]; return submenu; @@ -976,7 +908,7 @@ ns_menu_show (struct frame *f, int x, int y, int menuflags, } pmenu = [[EmacsMenu alloc] initWithTitle: - [NSString stringWithUTF8String: SSDATA (title)]]; + [NSString stringWithLispString: title]]; [pmenu fillWithWidgetValue: first_wv->contents]; free_menubar_widget_value_tree (first_wv); unbind_to (specpdl_count, Qnil); @@ -1028,15 +960,12 @@ update_frame_tool_bar (struct frame *f) int i, k = 0; EmacsView *view = FRAME_NS_VIEW (f); EmacsToolbar *toolbar = [view toolbar]; - int oldh; NSTRACE ("update_frame_tool_bar"); if (view == nil || toolbar == nil) return; block_input (); - oldh = FRAME_TOOLBAR_HEIGHT (f); - #ifdef NS_IMPL_COCOA [toolbar clearActive]; #else @@ -1092,7 +1021,7 @@ update_frame_tool_bar (struct frame *f) continue; } - img_id = lookup_image (f, image); + img_id = lookup_image (f, image, -1); img = IMAGE_FROM_ID (f, img_id); prepare_image_for_display (f, img); @@ -1141,8 +1070,6 @@ update_frame_tool_bar (struct frame *f) } #endif - if (oldh != FRAME_TOOLBAR_HEIGHT (f)) - [view updateFrameSize:YES]; if (view->wait_for_tool_bar && FRAME_TOOLBAR_HEIGHT (f) > 0) { view->wait_for_tool_bar = NO; @@ -1868,7 +1795,7 @@ DEFUN ("ns-reset-menu", Fns_reset_menu, Sns_reset_menu, 0, 0, 0, doc: /* Cause the NS menu to be re-calculated. */) (void) { - set_frame_menubar (SELECTED_FRAME (), 1, 0); + set_frame_menubar (SELECTED_FRAME (), 0); return Qnil; } @@ -1889,12 +1816,6 @@ DEFUN ("menu-or-popup-active-p", Fmenu_or_popup_active_p, Smenu_or_popup_active_ void syms_of_nsmenu (void) { -#ifndef NS_IMPL_COCOA - /* Don't know how to keep track of this in Next/Open/GNUstep. Always - update menus there. */ - trackingMenu = 1; - PDUMPER_REMEMBER_SCALAR (trackingMenu); -#endif defsubr (&Sns_reset_menu); defsubr (&Smenu_or_popup_active_p); diff --git a/src/nsselect.m b/src/nsselect.m index abd58166b1f..5ab3ef77fec 100644 --- a/src/nsselect.m +++ b/src/nsselect.m @@ -58,7 +58,7 @@ symbol_to_nsstring (Lisp_Object sym) if (EQ (sym, QPRIMARY)) return NXPrimaryPboard; if (EQ (sym, QSECONDARY)) return NXSecondaryPboard; if (EQ (sym, QTEXT)) return NSPasteboardTypeString; - return [NSString stringWithUTF8String: SSDATA (SYMBOL_NAME (sym))]; + return [NSString stringWithLispString: SYMBOL_NAME (sym)]; } static NSPasteboard * @@ -78,7 +78,13 @@ ns_string_to_symbol (NSString *t) return QSECONDARY; if ([t isEqualToString: NSPasteboardTypeString]) return QTEXT; - if ([t isEqualToString: NSFilenamesPboardType]) + if ([t isEqualToString: +#if NS_USE_NSPasteboardTypeFileURL != 0 + NSPasteboardTypeFileURL +#else + NSFilenamesPboardType +#endif + ]) return QFILE_NAME; if ([t isEqualToString: NSPasteboardTypeTabularText]) return QTEXT; @@ -114,7 +120,7 @@ clean_local_selection_data (Lisp_Object obj) if (size == 1) return clean_local_selection_data (AREF (obj, 0)); - copy = make_uninit_vector (size); + copy = make_nil_vector (size); for (i = 0; i < size; i++) ASET (copy, i, clean_local_selection_data (AREF (obj, i))); return copy; @@ -170,17 +176,12 @@ ns_string_to_pasteboard_internal (id pb, Lisp_Object str, NSString *gtype) } else { - char *utfStr; NSString *type, *nsStr; NSEnumerator *tenum; CHECK_STRING (str); - utfStr = SSDATA (str); - nsStr = [[NSString alloc] initWithBytesNoCopy: utfStr - length: SBYTES (str) - encoding: NSUTF8StringEncoding - freeWhenDone: NO]; + nsStr = [NSString stringWithLispString: str]; // FIXME: Why those 2 different code paths? if (gtype == nil) { @@ -196,7 +197,6 @@ ns_string_to_pasteboard_internal (id pb, Lisp_Object str, NSString *gtype) eassert (gtype == NSPasteboardTypeString); [pb setString: nsStr forType: gtype]; } - [nsStr release]; ns_store_pb_change_count (pb); } } @@ -473,7 +473,12 @@ nxatoms_of_nsselect (void) [NSNumber numberWithLong:0], NXPrimaryPboard, [NSNumber numberWithLong:0], NXSecondaryPboard, [NSNumber numberWithLong:0], NSPasteboardTypeString, - [NSNumber numberWithLong:0], NSFilenamesPboardType, + [NSNumber numberWithLong:0], +#if NS_USE_NSPasteboardTypeFileURL != 0 + NSPasteboardTypeFileURL, +#else + NSFilenamesPboardType, +#endif [NSNumber numberWithLong:0], NSPasteboardTypeTabularText, nil] retain]; } diff --git a/src/nsterm.h b/src/nsterm.h index 0c431808fc2..eae1d0725ea 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -39,6 +39,15 @@ typedef CGFloat EmacsCGFloat; typedef float EmacsCGFloat; #endif +/* NSFilenamesPboardType is deprecated in macOS 10.14, but + NSPasteboardTypeFileURL is only available in 10.13 (and GNUstep + probably lacks it too). */ +#if defined NS_IMPL_COCOA && MAC_OS_X_VERSION_MIN_REQUIRED >= 101300 +#define NS_USE_NSPasteboardTypeFileURL 1 +#else +#define NS_USE_NSPasteboardTypeFileURL 0 +#endif + /* ========================================================================== Trace support @@ -339,6 +348,16 @@ typedef id instancetype; #endif +/* macOS 10.14 and above cannot draw directly "to the glass" and + therefore we draw to an offscreen buffer and swap it in when the + toolkit wants to draw the frame. GNUstep and macOS 10.7 and below + do not support this method, so we revert to drawing directly to the + glass. */ +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 101400 +#define NS_DRAW_TO_BUFFER 1 +#endif + + /* ========================================================================== NSColor, EmacsColor category. @@ -351,6 +370,12 @@ typedef id instancetype; @end + +@interface NSString (EmacsString) ++ (NSString *)stringWithLispString:(Lisp_Object)string; +- (Lisp_Object)lispString; +@end + /* ========================================================================== The Emacs application @@ -398,6 +423,7 @@ typedef id instancetype; ========================================================================== */ @class EmacsToolbar; +@class EmacsSurface; #ifdef NS_IMPL_COCOA @interface EmacsView : NSView <NSTextInput, NSWindowDelegate> @@ -417,9 +443,12 @@ typedef id instancetype; int maximized_width, maximized_height; NSWindow *nonfs_window; BOOL fs_is_native; + BOOL in_fullscreen_transition; +#ifdef NS_DRAW_TO_BUFFER + EmacsSurface *surface; +#endif @public struct frame *emacsframe; - int rows, cols; int scrollbarsNeedingUpdate; EmacsToolbar *toolbar; NSRect ns_userRect; @@ -438,16 +467,16 @@ typedef id instancetype; /* Emacs-side interface */ - (instancetype) initFrameFromEmacs: (struct frame *) f; - (void) createToolbar: (struct frame *)f; -- (void) setRows: (int) r andColumns: (int) c; - (void) setWindowClosing: (BOOL)closing; - (EmacsToolbar *) toolbar; - (void) deleteWorkingText; -- (void) updateFrameSize: (BOOL) delay; - (void) handleFS; - (void) setFSValue: (int)value; - (void) toggleFullScreen: (id) sender; - (BOOL) fsIsNative; - (BOOL) isFullscreen; +- (BOOL) inFullScreenTransition; +- (void) waitFullScreenTransition; #if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 - (void) updateCollectionBehavior; #endif @@ -457,7 +486,13 @@ typedef id instancetype; #endif - (int)fullscreenState; -/* Non-notification versions of NSView methods. Used for direct calls. */ +#ifdef NS_DRAW_TO_BUFFER +- (void)focusOnDrawingBuffer; +- (void)unfocusDrawingBuffer; +#endif +- (void)copyRect:(NSRect)srcRect to:(NSRect)dstRect; + +/* Non-notification versions of NSView methods. Used for direct calls. */ - (void)windowWillEnterFullScreen; - (void)windowDidEnterFullScreen; - (void)windowWillExitFullScreen; @@ -471,6 +506,9 @@ typedef id instancetype; { NSPoint grabOffset; } + +- (BOOL)restackWindow:(NSWindow *)win above:(BOOL)above; +- (void)setAppearance; @end @@ -486,25 +524,17 @@ typedef id instancetype; ========================================================================== */ -#ifdef NS_IMPL_COCOA @interface EmacsMenu : NSMenu <NSMenuDelegate> -#else -@interface EmacsMenu : NSMenu -#endif { - struct frame *frame; - unsigned long keyEquivModMask; + BOOL needsUpdate; } -- (instancetype)initWithTitle: (NSString *)title frame: (struct frame *)f; -- (void)setFrame: (struct frame *)f; - (void)menuNeedsUpdate: (NSMenu *)menu; /* (delegate method) */ -- (NSString *)parseKeyEquiv: (const char *)key; -- (NSMenuItem *)addItemWithWidgetValue: (void *)wvptr; +- (NSMenuItem *)addItemWithWidgetValue: (void *)wvptr + attributes: (NSDictionary *)attributes; - (void)fillWithWidgetValue: (void *)wvptr; -- (void)fillWithWidgetValue: (void *)wvptr frame: (struct frame *)f; -- (EmacsMenu *)addSubmenuWithTitle: (const char *)title forFrame: (struct frame *)f; -- (void) clear; +- (EmacsMenu *)addSubmenuWithTitle: (const char *)title; +- (void) removeAllItems; - (Lisp_Object)runMenuAt: (NSPoint)p forFrame: (struct frame *)f keymaps: (bool)keymaps; @end @@ -619,6 +649,7 @@ typedef id instancetype; unsigned long xbm_fg; @public NSAffineTransform *transform; + BOOL smoothing; } + (instancetype)allocInitFromFile: (Lisp_Object)file; - (void)dealloc; @@ -637,6 +668,8 @@ typedef id instancetype; - (Lisp_Object)getMetadata; - (BOOL)setFrame: (unsigned int) index; - (void)setTransform: (double[3][3]) m; +- (void)setSmoothing: (BOOL)s; +- (size_t)sizeInBytes; @end @@ -682,6 +715,25 @@ typedef id instancetype; + (CGFloat)scrollerWidth; @end +#ifdef NS_DRAW_TO_BUFFER +@interface EmacsSurface : NSObject +{ + NSMutableArray *cache; + NSSize size; + CGColorSpaceRef colorSpace; + IOSurfaceRef currentSurface; + IOSurfaceRef lastSurface; + CGContextRef context; +} +- (id) initWithSize: (NSSize)s ColorSpace: (CGColorSpaceRef)cs; +- (void) dealloc; +- (NSSize) getSize; +- (CGContextRef) getContext; +- (void) releaseContext; +- (IOSurfaceRef) getSurface; +@end +#endif + /* ========================================================================== @@ -689,22 +741,6 @@ typedef id instancetype; ========================================================================== */ -#ifdef NS_IMPL_COCOA -/* rendering util */ -@interface EmacsGlyphStorage : NSObject <NSGlyphStorage> -{ -@public - NSAttributedString *attrStr; - NSMutableDictionary *dict; - CGGlyph *cglyphs; - unsigned long maxChar, maxGlyph; - long i, len; -} -- (instancetype)initWithCapacity: (unsigned long) c; -- (void) setString: (NSString *)str font: (NSFont *)font; -@end -#endif /* NS_IMPL_COCOA */ - extern NSArray *ns_send_types, *ns_return_types; extern NSString *ns_app_name; extern EmacsMenu *svcsMenu; @@ -782,6 +818,7 @@ struct ns_color_table #define GREEN16_FROM_ULONG(color) (GREEN_FROM_ULONG(color) * 0x101) #define BLUE16_FROM_ULONG(color) (BLUE_FROM_ULONG(color) * 0x101) +#ifdef NS_IMPL_GNUSTEP /* this extends font backend font */ struct nsfont_info { @@ -798,14 +835,8 @@ struct nsfont_info float size; #ifdef __OBJC__ NSFont *nsfont; -#if defined (NS_IMPL_COCOA) - CGFontRef cgfont; -#else /* GNUstep */ - void *cgfont; -#endif #else /* ! OBJC */ void *nsfont; - void *cgfont; #endif char bold, ital; /* convenience flags */ char synthItal; @@ -815,7 +846,7 @@ struct nsfont_info unsigned short **glyphs; /* map Unicode index to glyph */ struct font_metrics **metrics; }; - +#endif /* Initialized in ns_initialize_display_info (). */ struct ns_display_info @@ -1054,18 +1085,6 @@ struct x_output (FRAME_SCROLL_BAR_LINES (f) * FRAME_LINE_HEIGHT (f) \ - NS_SCROLL_BAR_HEIGHT (f)) : 0) -/* Calculate system coordinates of the left and top of the parent - window or, if there is no parent window, the screen. */ -#define NS_PARENT_WINDOW_LEFT_POS(f) \ - (FRAME_PARENT_FRAME (f) != NULL \ - ? [FRAME_NS_VIEW (FRAME_PARENT_FRAME (f)) window].frame.origin.x : 0) -#define NS_PARENT_WINDOW_TOP_POS(f) \ - (FRAME_PARENT_FRAME (f) != NULL \ - ? ([FRAME_NS_VIEW (FRAME_PARENT_FRAME (f)) window].frame.origin.y \ - + [FRAME_NS_VIEW (FRAME_PARENT_FRAME (f)) window].frame.size.height \ - - FRAME_NS_TITLEBAR_HEIGHT (FRAME_PARENT_FRAME (f))) \ - : [[[NSScreen screens] objectAtIndex: 0] frame].size.height) - #define FRAME_NS_FONT_TABLE(f) (FRAME_DISPLAY_INFO (f)->font_table) #define FRAME_FONTSET(f) ((f)->output_data.ns->fontset) @@ -1090,7 +1109,7 @@ extern void ns_term_shutdown (int sig); #define NS_DUMPGLYPH_MOUSEFACE 3 - +#ifdef NS_IMPL_GNUSTEP /* In nsfont, called from fontset.c */ extern void nsfont_make_fontset_for_font (Lisp_Object name, Lisp_Object font_object); @@ -1098,6 +1117,7 @@ extern void nsfont_make_fontset_for_font (Lisp_Object name, /* In nsfont, for debugging */ struct glyph_string; void ns_dump_glyphstring (struct glyph_string *s) EXTERNALLY_VISIBLE; +#endif /* Implemented in nsterm, published in or needed from nsfns. */ extern Lisp_Object ns_list_fonts (struct frame *f, Lisp_Object pattern, @@ -1132,8 +1152,6 @@ extern int ns_lisp_to_color (Lisp_Object color, NSColor **col); extern NSColor *ns_lookup_indexed_color (unsigned long idx, struct frame *f); extern unsigned long ns_index_color (NSColor *color, struct frame *f); extern const char *ns_get_pending_menu_title (void); -extern void ns_check_menu_open (NSMenu *menu); -extern void ns_check_pending_open_menu (void); #endif /* Implemented in nsfns, published in nsterm. */ @@ -1180,6 +1198,7 @@ extern void syms_of_nsselect (void); /* From nsimage.m, needed in image.c */ struct image; +extern bool ns_can_use_native_image_api (Lisp_Object type); extern void *ns_image_from_XBM (char *bits, int width, int height, unsigned long fg, unsigned long bg); extern void *ns_image_for_XPM (int width, int height, int depth); @@ -1190,12 +1209,14 @@ extern int ns_image_width (void *img); extern int ns_image_height (void *img); extern void ns_image_set_size (void *img, int width, int height); extern void ns_image_set_transform (void *img, double m[3][3]); +extern void ns_image_set_smoothing (void *img, bool smooth); extern unsigned long ns_get_pixel (void *img, int x, int y); extern void ns_put_pixel (void *img, int x, int y, unsigned long argb); extern void ns_set_alpha (void *img, int x, int y, unsigned char a); extern int ns_display_pixel_height (struct ns_display_info *); extern int ns_display_pixel_width (struct ns_display_info *); +extern size_t ns_image_size_in_bytes (void *img); /* This in nsterm.m */ extern float ns_antialias_threshold; @@ -1255,10 +1276,24 @@ extern char gnustep_base_version[]; /* version tracking */ ? (min) : (((x)>(max)) ? (max) : (x))) #define SCREENMAXBOUND(x) (IN_BOUND (-SCREENMAX, x, SCREENMAX)) + +#ifdef NS_IMPL_COCOA +/* Add some required AppKit version numbers if they're not defined. */ +#ifndef NSAppKitVersionNumber10_7 +#define NSAppKitVersionNumber10_7 1138 +#endif + +#ifndef NSAppKitVersionNumber10_10 +#define NSAppKitVersionNumber10_10 1343 +#endif +#endif /* NS_IMPL_COCOA */ + + /* macOS 10.7 introduces some new constants. */ #if !defined (NS_IMPL_COCOA) || !defined (MAC_OS_X_VERSION_10_7) #define NSFullScreenWindowMask (1 << 14) #define NSWindowCollectionBehaviorFullScreenPrimary (1 << 7) +#define NSWindowCollectionBehaviorFullScreenAuxiliary (1 << 8) #define NSApplicationPresentationFullScreen (1 << 10) #define NSApplicationPresentationAutoHideToolbar (1 << 11) #define NSAppKitVersionNumber10_7 1138 diff --git a/src/nsterm.m b/src/nsterm.m index b8658a05daf..1b2328628ee 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -49,6 +49,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) #include "nsterm.h" #include "systime.h" #include "character.h" +#include "xwidget.h" #include "fontset.h" #include "composite.h" #include "ccl.h" @@ -71,6 +72,10 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) #include <Carbon/Carbon.h> #endif +#ifdef NS_DRAW_TO_BUFFER +#include <IOSurface/IOSurface.h> +#endif + static EmacsMenu *dockMenu; #ifdef NS_IMPL_COCOA static EmacsMenu *mainMenu; @@ -139,14 +144,9 @@ char const * nstrace_fullscreen_type_name (int fs_type) + (NSColor *)colorForEmacsRed:(CGFloat)red green:(CGFloat)green blue:(CGFloat)blue alpha:(CGFloat)alpha { -#if defined (NS_IMPL_COCOA) \ - && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 if (ns_use_srgb_colorspace -#if MAC_OS_X_VERSION_MIN_REQUIRED < 1070 - && [NSColor respondsToSelector: - @selector(colorWithSRGBRed:green:blue:alpha:)] -#endif - ) + && NSAppKitVersionNumber >= NSAppKitVersionNumber10_7) return [NSColor colorWithSRGBRed: red green: green blue: blue @@ -160,28 +160,12 @@ char const * nstrace_fullscreen_type_name (int fs_type) - (NSColor *)colorUsingDefaultColorSpace { - /* FIXME: We're checking for colorWithSRGBRed here so this will only - work in the same place as in the method above. It should really - be a check whether we're on macOS 10.7 or above. */ -#if defined (NS_IMPL_COCOA) \ - && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 -#if MAC_OS_X_VERSION_MIN_REQUIRED < 1070 - if ([NSColor respondsToSelector: - @selector(colorWithSRGBRed:green:blue:alpha:)]) -#endif - { - if (ns_use_srgb_colorspace) - return [self colorUsingColorSpace: [NSColorSpace sRGBColorSpace]]; - else - return [self colorUsingColorSpace: [NSColorSpace deviceRGBColorSpace]]; - } -#if MAC_OS_X_VERSION_MIN_REQUIRED < 1070 - else -#endif -#endif /* NS_IMPL_COCOA && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 */ -#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 1070 - return [self colorUsingColorSpaceName: NSCalibratedRGBColorSpace]; +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 + if (ns_use_srgb_colorspace + && NSAppKitVersionNumber >= NSAppKitVersionNumber10_7) + return [self colorUsingColorSpace: [NSColorSpace sRGBColorSpace]]; #endif + return [self colorUsingColorSpace: [NSColorSpace deviceRGBColorSpace]]; } @end @@ -287,7 +271,12 @@ struct ns_display_info *x_display_list; /* Chain of existing displays */ long context_menu_value = 0; /* display update */ +static struct frame *ns_updating_frame; +#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 +static NSView *focus_view = NULL; +#endif static int ns_window_num = 0; +static BOOL gsaved = NO; static BOOL ns_fake_keydown = NO; #ifdef NS_IMPL_COCOA static BOOL ns_menu_bar_is_hidden = NO; @@ -327,24 +316,6 @@ static struct { NULL, 0, 0 }; -#ifdef NS_IMPL_COCOA -/* - * State for pending menu activation: - * MENU_NONE Normal state - * MENU_PENDING A menu has been clicked on, but has been canceled so we can - * run lisp to update the menu. - * MENU_OPENING Menu is up to date, and the click event is redone so the menu - * will open. - */ -#define MENU_NONE 0 -#define MENU_PENDING 1 -#define MENU_OPENING 2 -static int menu_will_open_state = MENU_NONE; - -/* Saved position for menu click. */ -static CGPoint menu_mouse_point; -#endif - /* Convert modifiers in a NeXTstep event to emacs style modifiers. */ #define NS_FUNCTION_KEY_MASK 0x800000 #define NSLeftControlKeyMask (0x000001 | NSEventModifierFlagControl) @@ -840,6 +811,32 @@ ns_menu_bar_height (NSScreen *screen) } +/* Get the frame rect, in system coordinates, of the parent window or, + if there is no parent window, the main screen. */ +static inline NSRect +ns_parent_window_rect (struct frame *f) +{ + NSRect parentRect; + + if (FRAME_PARENT_FRAME (f) != NULL) + { + EmacsView *parentView = FRAME_NS_VIEW (FRAME_PARENT_FRAME (f)); + parentRect = [parentView convertRect:[parentView frame] + toView:nil]; + parentRect = [[parentView window] convertRectToScreen:parentRect]; + } + else + parentRect = [[[NSScreen screens] objectAtIndex:0] frame]; + + return parentRect; +} + +/* Calculate system coordinates of the left and top of the parent + window or, if there is no parent window, the main screen. */ +#define NS_PARENT_WINDOW_LEFT_POS(f) NSMinX (ns_parent_window_rect (f)) +#define NS_PARENT_WINDOW_TOP_POS(f) NSMaxY (ns_parent_window_rect (f)) + + static NSRect ns_row_rect (struct window *w, struct glyph_row *row, enum glyph_row_area area) @@ -1097,13 +1094,12 @@ ns_update_begin (struct frame *f) external (RIF) call; whole frame, called before gui_update_window_begin -------------------------------------------------------------------------- */ { -#ifdef NS_IMPL_COCOA EmacsView *view = FRAME_NS_VIEW (f); - NSTRACE_WHEN (NSTRACE_GROUP_UPDATES, "ns_update_begin"); ns_update_auto_hide_menu_bar (); +#ifdef NS_IMPL_COCOA if ([view isFullscreen] && [view fsIsNative]) { // Fix reappearing tool bar in fullscreen for Mac OS X 10.7 @@ -1113,6 +1109,28 @@ ns_update_begin (struct frame *f) [toolbar setVisible: tbar_visible]; } #endif + + ns_updating_frame = f; +#ifdef NS_DRAW_TO_BUFFER +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + if ([FRAME_NS_VIEW (f) wantsUpdateLayer]) + { +#endif + [view focusOnDrawingBuffer]; +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + } + else + { +#endif +#endif /* NS_DRAW_TO_BUFFER */ + +#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + [view lockFocus]; +#endif +#if defined (NS_DRAW_TO_BUFFER) && MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + } +#endif + } @@ -1123,57 +1141,152 @@ ns_update_end (struct frame *f) external (RIF) call; for whole frame, called after gui_update_window_end -------------------------------------------------------------------------- */ { +#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + EmacsView *view = FRAME_NS_VIEW (f); +#endif + NSTRACE_WHEN (NSTRACE_GROUP_UPDATES, "ns_update_end"); /* if (f == MOUSE_HL_INFO (f)->mouse_face_mouse_frame) */ MOUSE_HL_INFO (f)->mouse_face_defer = 0; -} +#ifdef NS_DRAW_TO_BUFFER +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + if ([FRAME_NS_VIEW (f) wantsUpdateLayer]) + { +#endif + [FRAME_NS_VIEW (f) unfocusDrawingBuffer]; +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + } + else + { +#endif +#endif /* NS_DRAW_TO_BUFFER */ -static BOOL -ns_clip_to_rect (struct frame *f, NSRect *r, int n) +#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + block_input (); + + [view unlockFocus]; + [[view window] flushWindow]; + + unblock_input (); +#endif +#if defined (NS_DRAW_TO_BUFFER) && MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + } +#endif + ns_updating_frame = NULL; +} + +static void +ns_focus (struct frame *f, NSRect *r, int n) /* -------------------------------------------------------------------------- - Clip the drawing area to rectangle r in frame f. If drawing is not - currently possible mark r as dirty and return NO, otherwise return - YES. + Internal: Focus on given frame. During small local updates this is used to + draw, however during large updates, ns_update_begin and ns_update_end are + called to wrap the whole thing, in which case these calls are stubbed out. + Except, on GNUstep, we accumulate the rectangle being drawn into, because + the back end won't do this automatically, and will just end up flushing + the entire window. -------------------------------------------------------------------------- */ { - NSTRACE_WHEN (NSTRACE_GROUP_FOCUS, "ns_clip_to_rect"); - if (r) + EmacsView *view = FRAME_NS_VIEW (f); + + NSTRACE_WHEN (NSTRACE_GROUP_FOCUS, "ns_focus"); + if (r != NULL) { NSTRACE_RECT ("r", *r); + } - if ([NSView focusView] == FRAME_NS_VIEW (f)) + if (f != ns_updating_frame) + { +#ifdef NS_DRAW_TO_BUFFER +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + if ([FRAME_NS_VIEW (f) wantsUpdateLayer]) { - [[NSGraphicsContext currentContext] saveGraphicsState]; - if (n == 2) - NSRectClipList (r, 2); - else - NSRectClip (*r); - - return YES; +#endif + [view focusOnDrawingBuffer]; +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 } else { - NSView *view = FRAME_NS_VIEW (f); - int i; - for (i = 0 ; i < n ; i++) - [view setNeedsDisplayInRect:r[i]]; +#endif +#endif /* NS_DRAW_TO_BUFFER */ + +#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + if (view != focus_view) + { + if (focus_view != NULL) + { + [focus_view unlockFocus]; + [[focus_view window] flushWindow]; + } + + if (view) + [view lockFocus]; + focus_view = view; + } +#endif +#if defined (NS_DRAW_TO_BUFFER) && MAC_OS_X_VERSION_MIN_REQUIRED < 101400 } +#endif } - return NO; + + /* clipping */ + if (r) + { + [[NSGraphicsContext currentContext] saveGraphicsState]; + if (n == 2) + NSRectClipList (r, 2); + else + NSRectClip (*r); + gsaved = YES; + } } static void -ns_reset_clipping (struct frame *f) -/* Internal: Restore the previous graphics state, unsetting any - clipping areas. */ +ns_unfocus (struct frame *f) +/* -------------------------------------------------------------------------- + Internal: Remove focus on given frame + -------------------------------------------------------------------------- */ { - NSTRACE_WHEN (NSTRACE_GROUP_FOCUS, "ns_reset_clipping"); + NSTRACE_WHEN (NSTRACE_GROUP_FOCUS, "ns_unfocus"); - [[NSGraphicsContext currentContext] restoreGraphicsState]; + if (gsaved) + { + [[NSGraphicsContext currentContext] restoreGraphicsState]; + gsaved = NO; + } + +#ifdef NS_DRAW_TO_BUFFER + #if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + if ([FRAME_NS_VIEW (f) wantsUpdateLayer]) + { +#endif + if (! ns_updating_frame) + [FRAME_NS_VIEW (f) unfocusDrawingBuffer]; + [FRAME_NS_VIEW (f) setNeedsDisplay:YES]; +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + } + else + { +#endif +#endif /* NS_DRAW_TO_BUFFER */ + +#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + if (f != ns_updating_frame) + { + if (focus_view != NULL) + { + [focus_view unlockFocus]; + [[focus_view window] flushWindow]; + focus_view = NULL; + } + } +#endif +#if defined (NS_DRAW_TO_BUFFER) && MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + } +#endif } @@ -1340,7 +1453,7 @@ ns_ring_bell (struct frame *f) } } - +#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 static void hide_bell (void) /* -------------------------------------------------------------------------- @@ -1354,6 +1467,7 @@ hide_bell (void) [bell_view remove]; } } +#endif /* ========================================================================== @@ -1513,9 +1627,12 @@ ns_make_frame_visible (struct frame *f) /* Making a new frame from a fullscreen frame will make the new frame fullscreen also. So skip handleFS as this will print an error. */ - if ([view fsIsNative] && f->want_fullscreen == FULLSCREEN_BOTH - && [view isFullscreen]) - return; + if ([view fsIsNative] && [view isFullscreen]) + { + // maybe it is not necessary to wait + [view waitFullScreenTransition]; + return; + } if (f->want_fullscreen != FULLSCREEN_NONE) { @@ -1682,61 +1799,64 @@ ns_set_offset (struct frame *f, int xoff, int yoff, int change_grav) -------------------------------------------------------------------------- */ { NSView *view = FRAME_NS_VIEW (f); - NSScreen *screen = [[view window] screen]; + NSRect windowFrame = [[view window] frame]; + NSPoint topLeft; NSTRACE ("ns_set_offset"); block_input (); - f->left_pos = xoff; - f->top_pos = yoff; + if (FRAME_PARENT_FRAME (f)) + { + /* Convert the parent frame's view rectangle into screen + coords. */ + EmacsView *parentView = FRAME_NS_VIEW (FRAME_PARENT_FRAME (f)); + NSRect parentRect = [parentView convertRect:[parentView frame] + toView:nil]; + parentRect = [[parentView window] convertRectToScreen:parentRect]; + + if (f->size_hint_flags & XNegative) + topLeft.x = NSMaxX (parentRect) - NSWidth (windowFrame) + xoff; + else + topLeft.x = NSMinX (parentRect) + xoff; - if (view != nil) + if (f->size_hint_flags & YNegative) + topLeft.y = NSMinY (parentRect) + NSHeight (windowFrame) - yoff; + else + topLeft.y = NSMaxY (parentRect) - yoff; + } + else { - if (FRAME_PARENT_FRAME (f) == NULL && screen) - { - f->left_pos = f->size_hint_flags & XNegative - ? [screen visibleFrame].size.width + f->left_pos - FRAME_PIXEL_WIDTH (f) - : f->left_pos; - /* We use visibleFrame here to take menu bar into account. - Ideally we should also adjust left/top with visibleFrame.origin. */ - - f->top_pos = f->size_hint_flags & YNegative - ? ([screen visibleFrame].size.height + f->top_pos - - FRAME_PIXEL_HEIGHT (f) - FRAME_NS_TITLEBAR_HEIGHT (f) - - FRAME_TOOLBAR_HEIGHT (f)) - : f->top_pos; -#ifdef NS_IMPL_GNUSTEP - if (f->left_pos < 100) - f->left_pos = 100; /* don't overlap menu */ -#endif - } - else if (FRAME_PARENT_FRAME (f) != NULL) - { - struct frame *parent = FRAME_PARENT_FRAME (f); + /* If there is no parent frame then just convert to screen + coordinates, UNLESS we have negative values, in which case I + think it's best to position from the bottom and right of the + current screen rather than the main screen or whole + display. */ + NSRect screenFrame = [[[view window] screen] frame]; - /* On X negative values for child frames always result in - positioning relative to the bottom right corner of the - parent frame. */ - if (f->left_pos < 0) - f->left_pos = FRAME_PIXEL_WIDTH (parent) - FRAME_PIXEL_WIDTH (f) + f->left_pos; + if (f->size_hint_flags & XNegative) + topLeft.x = NSMaxX (screenFrame) - NSWidth (windowFrame) + xoff; + else + topLeft.x = xoff; - if (f->top_pos < 0) - f->top_pos = FRAME_PIXEL_HEIGHT (parent) + FRAME_TOOLBAR_HEIGHT (parent) - - FRAME_PIXEL_HEIGHT (f) + f->top_pos; - } + if (f->size_hint_flags & YNegative) + topLeft.y = NSMinY (screenFrame) + NSHeight (windowFrame) - yoff; + else + topLeft.y = NSMaxY ([[[NSScreen screens] objectAtIndex:0] frame]) - yoff; + +#ifdef NS_IMPL_GNUSTEP + /* Don't overlap the menu. - /* Constrain the setFrameTopLeftPoint so we don't move behind the - menu bar. */ - NSPoint pt = NSMakePoint (SCREENMAXBOUND (f->left_pos - + NS_PARENT_WINDOW_LEFT_POS (f)), - SCREENMAXBOUND (NS_PARENT_WINDOW_TOP_POS (f) - - f->top_pos)); - NSTRACE_POINT ("setFrameTopLeftPoint", pt); - [[view window] setFrameTopLeftPoint: pt]; - f->size_hint_flags &= ~(XNegative|YNegative); + FIXME: Surely there's a better way than just hardcoding 100 + in here? */ + topLeft.x = 100; +#endif } + NSTRACE_POINT ("setFrameTopLeftPoint", topLeft); + [[view window] setFrameTopLeftPoint:topLeft]; + f->size_hint_flags &= ~(XNegative|YNegative); + unblock_input (); } @@ -1803,9 +1923,16 @@ ns_set_window_size (struct frame *f, make_fixnum (FRAME_NS_TITLEBAR_HEIGHT (f)), make_fixnum (FRAME_TOOLBAR_HEIGHT (f)))); - [window setFrame: wr display: YES]; + /* Usually it seems safe to delay changing the frame size, but when a + series of actions are taken with no redisplay between them then we + can end up using old values so don't delay here. */ + change_frame_size (f, + FRAME_PIXEL_TO_TEXT_WIDTH (f, pixelwidth), + FRAME_PIXEL_TO_TEXT_HEIGHT (f, pixelheight), + 0, NO, 0, 1); + + [window setFrame:wr display:NO]; - [view updateFrameSize: NO]; unblock_input (); } @@ -1854,7 +1981,6 @@ ns_set_undecorated (struct frame *f, Lisp_Object new_value, Lisp_Object old_valu so some key presses (TAB) are swallowed by the system. */ [window makeFirstResponder: view]; - [view updateFrameSize: NO]; unblock_input (); } } @@ -1903,8 +2029,16 @@ ns_set_parent_frame (struct frame *f, Lisp_Object new_value, Lisp_Object old_val block_input (); child = [FRAME_NS_VIEW (f) window]; +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 + EmacsView *view = (EmacsView *)FRAME_NS_VIEW (f); +#endif + if ([child parentWindow] != nil) { +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 + parent = [child parentWindow]; +#endif + [[child parentWindow] removeChildWindow:child]; #if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 #if MAC_OS_X_VERSION_MIN_REQUIRED < 101000 @@ -1912,10 +2046,38 @@ ns_set_parent_frame (struct frame *f, Lisp_Object new_value, Lisp_Object old_val #endif [child setAccessibilitySubrole:NSAccessibilityStandardWindowSubrole]; #endif +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 + if (NILP (new_value)) + { + NSTRACE ("child setCollectionBehavior:NSWindowCollectionBehaviorFullScreenPrimary"); + [child setCollectionBehavior:NSWindowCollectionBehaviorFullScreenPrimary]; + // if current parent in fullscreen and no new parent make child fullscreen + while (parent) { + if (([parent styleMask] & NSWindowStyleMaskFullScreen) != 0) + { + [view toggleFullScreen:child]; + break; + } + // check all parents + parent = [parent parentWindow]; + } + } +#endif } if (!NILP (new_value)) { +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 + // child frame must not be in fullscreen + if ([view fsIsNative] && [view isFullscreen]) + { + // in case child is going fullscreen + [view waitFullScreenTransition]; + [view toggleFullScreen:child]; + } + NSTRACE ("child setCollectionBehavior:NSWindowCollectionBehaviorFullScreenAuxiliary"); + [child setCollectionBehavior:NSWindowCollectionBehaviorFullScreenAuxiliary]; +#endif parent = [FRAME_NS_VIEW (p) window]; [parent addChildWindow: child @@ -2016,29 +2178,21 @@ ns_set_appearance (struct frame *f, Lisp_Object new_value, Lisp_Object old_value { #if MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 EmacsView *view = (EmacsView *)FRAME_NS_VIEW (f); - NSWindow *window = [view window]; + EmacsWindow *window = (EmacsWindow *)[view window]; NSTRACE ("ns_set_appearance"); -#ifndef NSAppKitVersionNumber10_10 -#define NSAppKitVersionNumber10_10 1343 -#endif - if (NSAppKitVersionNumber < NSAppKitVersionNumber10_10) return; if (EQ (new_value, Qdark)) - { - window.appearance = [NSAppearance - appearanceNamed: NSAppearanceNameVibrantDark]; - FRAME_NS_APPEARANCE (f) = ns_appearance_vibrant_dark; - } + FRAME_NS_APPEARANCE (f) = ns_appearance_vibrant_dark; + else if (EQ (new_value, Qlight)) + FRAME_NS_APPEARANCE (f) = ns_appearance_aqua; else - { - window.appearance = [NSAppearance - appearanceNamed: NSAppearanceNameAqua]; - FRAME_NS_APPEARANCE (f) = ns_appearance_aqua; - } + FRAME_NS_APPEARANCE (f) = ns_appearance_system_default; + + [window setAppearance]; #endif /* MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 */ } @@ -2157,9 +2311,6 @@ ns_get_color (const char *name, NSColor **col) See https://lists.gnu.org/r/emacs-devel/2009-07/msg01203.html. */ { NSColor *new = nil; - static char hex[20]; - int scaling = 0; - float r = -1.0, g, b; NSString *nsname = [NSString stringWithUTF8String: name]; NSTRACE ("ns_get_color(%s, **)", name); @@ -2202,48 +2353,31 @@ ns_get_color (const char *name, NSColor **col) } /* First, check for some sort of numeric specification. */ - hex[0] = '\0'; - - if (name[0] == '0' || name[0] == '1' || name[0] == '.') /* RGB decimal */ + unsigned short r16, g16, b16; + if (parse_color_spec (name, &r16, &g16, &b16)) { - NSScanner *scanner = [NSScanner scannerWithString: nsname]; - [scanner scanFloat: &r]; - [scanner scanFloat: &g]; - [scanner scanFloat: &b]; - } - else if (!strncmp(name, "rgb:", 4)) /* A newer X11 format -- rgb:r/g/b */ - scaling = (snprintf (hex, sizeof hex, "%s", name + 4) - 2) / 3; - else if (name[0] == '#') /* An old X11 format; convert to newer */ - { - int len = (strlen(name) - 1); - int start = (len % 3 == 0) ? 1 : len / 4 + 1; - int i; - scaling = strlen(name+start) / 3; - for (i = 0; i < 3; i++) - sprintf (hex + i * (scaling + 1), "%.*s/", scaling, - name + start + i * scaling); - hex[3 * (scaling + 1) - 1] = '\0'; + *col = [NSColor colorForEmacsRed: r16 / 65535.0 + green: g16 / 65535.0 + blue: b16 / 65535.0 + alpha: 1.0]; + unblock_input (); + return 0; } - - if (hex[0]) + else if (name[0] == '0' || name[0] == '1' || name[0] == '.') { - unsigned int rr, gg, bb; - float fscale = scaling == 4 ? 65535.0 : (scaling == 2 ? 255.0 : 15.0); - if (sscanf (hex, "%x/%x/%x", &rr, &gg, &bb)) + /* RGB decimal */ + NSScanner *scanner = [NSScanner scannerWithString: nsname]; + float r, g, b; + if ( [scanner scanFloat: &r] && r >= 0 && r <= 1 + && [scanner scanFloat: &g] && g >= 0 && g <= 1 + && [scanner scanFloat: &b] && b >= 0 && b <= 1) { - r = rr / fscale; - g = gg / fscale; - b = bb / fscale; + *col = [NSColor colorForEmacsRed: r green: g blue: b alpha: 1.0]; + unblock_input (); + return 0; } } - if (r >= 0.0F) - { - *col = [NSColor colorForEmacsRed: r green: g blue: b alpha: 1.0]; - unblock_input (); - return 0; - } - /* Otherwise, color is expected to be from a list */ { NSEnumerator *lenum, *cenum; @@ -2304,8 +2438,10 @@ ns_color_index_to_rgba(int idx, struct frame *f) EmacsCGFloat r, g, b, a; [col getRed: &r green: &g blue: &b alpha: &a]; - return ARGB_TO_ULONG((int)(a*255), - (int)(r*255), (int)(g*255), (int)(b*255)); + return ARGB_TO_ULONG((unsigned long) (a * 255), + (unsigned long) (r * 255), + (unsigned long) (g * 255), + (unsigned long) (b * 255)); } void @@ -2325,8 +2461,10 @@ ns_query_color(void *col, Emacs_Color *color_def, bool setPixel) if (setPixel == YES) color_def->pixel - = ARGB_TO_ULONG((int)(a*255), - (int)(r*255), (int)(g*255), (int)(b*255)); + = ARGB_TO_ULONG((unsigned long) (a * 255), + (unsigned long) (r * 255), + (unsigned long) (g * 255), + (unsigned long) (b * 255)); } bool @@ -2432,7 +2570,8 @@ frame_set_mouse_pixel_position (struct frame *f, int pix_x, int pix_y) } static int -ns_note_mouse_movement (struct frame *frame, CGFloat x, CGFloat y) +ns_note_mouse_movement (struct frame *frame, CGFloat x, CGFloat y, + BOOL dragging) /* ------------------------------------------------------------------------ Called by EmacsView on mouseMovement events. Passes on to emacs mainstream code if we moved off of a rect of interest @@ -2441,17 +2580,24 @@ ns_note_mouse_movement (struct frame *frame, CGFloat x, CGFloat y) { struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (frame); NSRect *r; + BOOL force_update = NO; // NSTRACE ("note_mouse_movement"); dpyinfo->last_mouse_motion_frame = frame; r = &dpyinfo->last_mouse_glyph; + /* If the last rect is too large (ex, xwidget webkit), update at + every move, or resizing by dragging modeline or vertical split is + very hard to make its way. */ + if (dragging && (r->size.width > 32 || r->size.height > 32)) + force_update = YES; + /* Note, this doesn't get called for enter/leave, since we don't have a position. Those are taken care of in the corresponding NSView methods. */ /* Has movement gone beyond last rect we were tracking? */ - if (x < r->origin.x || x >= r->origin.x + r->size.width + if (force_update || x < r->origin.x || x >= r->origin.x + r->size.width || y < r->origin.y || y >= r->origin.y + r->size.height) { ns_update_begin (frame); @@ -2735,6 +2881,8 @@ ns_get_shifted_character (NSEvent *event) ========================================================================== */ +#if 0 +/* FIXME: Remove this function. */ static void ns_redraw_scroll_bars (struct frame *f) { @@ -2749,6 +2897,7 @@ ns_redraw_scroll_bars (struct frame *f) [view display]; } } +#endif void @@ -2772,16 +2921,16 @@ ns_clear_frame (struct frame *f) r = [view bounds]; block_input (); - if (ns_clip_to_rect (f, &r, 1)) - { - [ns_lookup_indexed_color (NS_FACE_BACKGROUND - (FACE_FROM_ID (f, DEFAULT_FACE_ID)), f) set]; - NSRectFill (r); - ns_reset_clipping (f); - - /* as of 2006/11 or so this is now needed */ - ns_redraw_scroll_bars (f); - } + ns_focus (f, &r, 1); + [ns_lookup_indexed_color (NS_FACE_BACKGROUND + (FACE_FROM_ID (f, DEFAULT_FACE_ID)), f) set]; + NSRectFill (r); + ns_unfocus (f); + + /* as of 2006/11 or so this is now needed */ + /* FIXME: I don't see any reason for this and removing it makes no + difference here. Do we need it for GNUstep? */ + //ns_redraw_scroll_bars (f); unblock_input (); } @@ -2802,46 +2951,15 @@ ns_clear_frame_area (struct frame *f, int x, int y, int width, int height) NSTRACE_WHEN (NSTRACE_GROUP_UPDATES, "ns_clear_frame_area"); r = NSIntersectionRect (r, [view frame]); - if (ns_clip_to_rect (f, &r, 1)) - { - [ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), f) set]; + ns_focus (f, &r, 1); + [ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), f) set]; - NSRectFill (r); + NSRectFill (r); - ns_reset_clipping (f); - } + ns_unfocus (f); + return; } -static void -ns_copy_bits (struct frame *f, NSRect src, NSRect dest) -{ - NSSize delta = NSMakeSize (dest.origin.x - src.origin.x, - dest.origin.y - src.origin.y); - NSTRACE ("ns_copy_bits"); - - if (FRAME_NS_VIEW (f)) - { - hide_bell(); // Ensure the bell image isn't scrolled. - - /* FIXME: scrollRect:by: is deprecated in macOS 10.14. There is - no obvious replacement so we may have to come up with our own. */ - [FRAME_NS_VIEW (f) scrollRect: src by: delta]; - -#ifdef NS_IMPL_COCOA - /* As far as I can tell from the documentation, scrollRect:by:, - above, should copy the dirty rectangles from our source - rectangle to our destination, however it appears it clips the - operation to src. As a result we need to use - translateRectsNeedingDisplayInRect:by: below, and we have to - union src and dest so it can pick up the dirty rectangles, - and place them, as it also clips to the rectangle. - - FIXME: We need a GNUstep equivalent. */ - [FRAME_NS_VIEW (f) translateRectsNeedingDisplayInRect:NSUnionRect (src, dest) - by:delta]; -#endif - } -} static void ns_scroll_run (struct window *w, struct run *run) @@ -2894,8 +3012,12 @@ ns_scroll_run (struct window *w, struct run *run) { NSRect srcRect = NSMakeRect (x, from_y, width, height); NSRect dstRect = NSMakeRect (x, to_y, width, height); + EmacsView *view = FRAME_NS_VIEW (f); - ns_copy_bits (f, srcRect , dstRect); + [view copyRect:srcRect to:dstRect]; +#ifdef NS_IMPL_COCOA + [view setNeedsDisplayInRect:srcRect]; +#endif } unblock_input (); @@ -2903,6 +3025,50 @@ ns_scroll_run (struct window *w, struct run *run) static void +ns_clear_under_internal_border (struct frame *f) +{ + NSTRACE ("ns_clear_under_internal_border"); + + if (FRAME_LIVE_P (f) && FRAME_INTERNAL_BORDER_WIDTH (f) > 0) + { + int border_width = FRAME_INTERNAL_BORDER_WIDTH (f); + NSView *view = FRAME_NS_VIEW (f); + NSRect edge_rect, frame_rect = [view bounds]; + NSRectEdge edge[] = {NSMinXEdge, NSMinYEdge, NSMaxXEdge, NSMaxYEdge}; + + int face_id = + (FRAME_PARENT_FRAME (f) + ? (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, CHILD_FRAME_BORDER_FACE_ID) + : CHILD_FRAME_BORDER_FACE_ID) + : (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) + : INTERNAL_BORDER_FACE_ID)); + struct face *face = FACE_FROM_ID_OR_NULL (f, face_id); + + if (!face) + face = FRAME_DEFAULT_FACE (f); + + /* Sometimes with new frames we reach this point and have no + face. I'm not sure why we have a live frame but no face, so + just give up. */ + if (!face) + return; + + ns_focus (f, NULL, 1); + [ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), f) set]; + for (int i = 0; i < 4 ; i++) + { + NSDivideRect (frame_rect, &edge_rect, &frame_rect, border_width, edge[i]); + + NSRectFill (edge_rect); + } + ns_unfocus (f); + } +} + + +static void ns_after_update_window_line (struct window *w, struct glyph_row *desired_row) /* -------------------------------------------------------------------------- External (RIF): preparatory to fringe update after text was updated @@ -2930,12 +3096,32 @@ ns_after_update_window_line (struct window *w, struct glyph_row *desired_row) height > 0)) { int y = WINDOW_TO_FRAME_PIXEL_Y (w, max (0, desired_row->y)); + int face_id = + !NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) + : INTERNAL_BORDER_FACE_ID; + struct face *face = FACE_FROM_ID_OR_NULL (f, face_id); block_input (); - ns_clear_frame_area (f, 0, y, width, height); - ns_clear_frame_area (f, - FRAME_PIXEL_WIDTH (f) - width, - y, width, height); + if (face) + { + NSRect r = NSMakeRect (0, y, FRAME_PIXEL_WIDTH (f), height); + ns_focus (f, &r, 1); + + [ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), f) set]; + NSRectFill (NSMakeRect (0, y, width, height)); + NSRectFill (NSMakeRect (FRAME_PIXEL_WIDTH (f) - width, + y, width, height)); + + ns_unfocus (f); + } + else + { + ns_clear_frame_area (f, 0, y, width, height); + ns_clear_frame_area (f, + FRAME_PIXEL_WIDTH (f) - width, + y, width, height); + } unblock_input (); } } @@ -2949,20 +3135,12 @@ ns_shift_glyphs_for_insert (struct frame *f, External (RIF): copy an area horizontally, don't worry about clearing src -------------------------------------------------------------------------- */ { - //NSRect srcRect = NSMakeRect (x, y, width, height); + NSRect srcRect = NSMakeRect (x, y, width, height); NSRect dstRect = NSMakeRect (x+shift_by, y, width, height); NSTRACE ("ns_shift_glyphs_for_insert"); - /* This doesn't work now as we copy the "bits" before we've had a - chance to actually draw any changes to the screen. This means in - certain circumstances we end up with copies of the cursor all - over the place. Just mark the area dirty so it is redrawn later. - - FIXME: Work out how to do this properly. */ - // ns_copy_bits (f, srcRect, dstRect); - - [FRAME_NS_VIEW (f) setNeedsDisplayInRect:dstRect]; + [FRAME_NS_VIEW (f) copyRect:srcRect to:dstRect]; } @@ -2998,10 +3176,12 @@ ns_compute_glyph_string_overhangs (struct glyph_string *s) else { s->left_overhang = 0; +#ifdef NS_IMPL_GNUSTEP if (EQ (font->driver->type, Qns)) s->right_overhang = ((struct nsfont_info *)font)->ital ? FONT_HEIGHT (font) * 0.2 : 0; else +#endif s->right_overhang = 0; } } @@ -3082,66 +3262,64 @@ ns_draw_fringe_bitmap (struct window *w, struct glyph_row *row, /* The visible portion of imageRect will always be contained within clearRect. */ - if (ns_clip_to_rect (f, &clearRect, 1)) + ns_focus (f, &clearRect, 1); + if (! NSIsEmptyRect (clearRect)) { - if (! NSIsEmptyRect (clearRect)) - { - NSTRACE_RECT ("clearRect", clearRect); + NSTRACE_RECT ("clearRect", clearRect); - [ns_lookup_indexed_color(face->background, f) set]; - NSRectFill (clearRect); - } + [ns_lookup_indexed_color(face->background, f) set]; + NSRectFill (clearRect); + } - if (p->which) - { - EmacsImage *img = bimgs[p->which - 1]; + if (p->which) + { + EmacsImage *img = bimgs[p->which - 1]; - if (!img) - { - // Note: For "periodic" images, allocate one EmacsImage for - // the base image, and use it for all dh:s. - unsigned short *bits = p->bits; - int full_height = p->h + p->dh; - int i; - unsigned char *cbits = xmalloc (full_height); - - for (i = 0; i < full_height; i++) - cbits[i] = bits[i]; - img = [[EmacsImage alloc] initFromXBM: cbits width: 8 - height: full_height - fg: 0 bg: 0 - reverseBytes: NO]; - bimgs[p->which - 1] = img; - xfree (cbits); - } + if (!img) + { + // Note: For "periodic" images, allocate one EmacsImage for + // the base image, and use it for all dh:s. + unsigned short *bits = p->bits; + int full_height = p->h + p->dh; + int i; + unsigned char *cbits = xmalloc (full_height); + + for (i = 0; i < full_height; i++) + cbits[i] = bits[i]; + img = [[EmacsImage alloc] initFromXBM: cbits width: 8 + height: full_height + fg: 0 bg: 0 + reverseBytes: NO]; + bimgs[p->which - 1] = img; + xfree (cbits); + } - { - NSColor *bm_color; - if (!p->cursor_p) - bm_color = ns_lookup_indexed_color(face->foreground, f); - else if (p->overlay_p) - bm_color = ns_lookup_indexed_color(face->background, f); - else - bm_color = f->output_data.ns->cursor_color; - [img setXBMColor: bm_color]; - } + { + NSColor *bm_color; + if (!p->cursor_p) + bm_color = ns_lookup_indexed_color(face->foreground, f); + else if (p->overlay_p) + bm_color = ns_lookup_indexed_color(face->background, f); + else + bm_color = f->output_data.ns->cursor_color; + [img setXBMColor: bm_color]; + } - // Note: For periodic images, the full image height is "h + hd". - // By using the height h, a suitable part of the image is used. - NSRect fromRect = NSMakeRect(0, 0, p->wd, p->h); + // Note: For periodic images, the full image height is "h + hd". + // By using the height h, a suitable part of the image is used. + NSRect fromRect = NSMakeRect(0, 0, p->wd, p->h); - NSTRACE_RECT ("fromRect", fromRect); + NSTRACE_RECT ("fromRect", fromRect); - [img drawInRect: imageRect - fromRect: fromRect - operation: NSCompositingOperationSourceOver - fraction: 1.0 - respectFlipped: YES - hints: nil]; - } - ns_reset_clipping (f); + [img drawInRect: imageRect + fromRect: fromRect + operation: NSCompositingOperationSourceOver + fraction: 1.0 + respectFlipped: YES + hints: nil]; } + ns_unfocus (f); } @@ -3226,60 +3404,52 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row, /* Prevent the cursor from being drawn outside the text area. */ r = NSIntersectionRect (r, ns_row_rect (w, glyph_row, TEXT_AREA)); - if (ns_clip_to_rect (f, &r, 1)) - { - face = FACE_FROM_ID_OR_NULL (f, phys_cursor_glyph->face_id); - if (face && NS_FACE_BACKGROUND (face) - == ns_index_color (FRAME_CURSOR_COLOR (f), f)) - { - [ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), f) set]; - hollow_color = FRAME_CURSOR_COLOR (f); - } - else - [FRAME_CURSOR_COLOR (f) set]; - - switch (cursor_type) - { - case DEFAULT_CURSOR: - case NO_CURSOR: - break; - case FILLED_BOX_CURSOR: - NSRectFill (r); - break; - case HOLLOW_BOX_CURSOR: - NSRectFill (r); - [hollow_color set]; - NSRectFill (NSInsetRect (r, 1, 1)); - [FRAME_CURSOR_COLOR (f) set]; - break; - case HBAR_CURSOR: - NSRectFill (r); - break; - case BAR_CURSOR: - s = r; - /* If the character under cursor is R2L, draw the bar cursor - on the right of its glyph, rather than on the left. */ - cursor_glyph = get_phys_cursor_glyph (w); - if ((cursor_glyph->resolved_level & 1) != 0) - s.origin.x += cursor_glyph->pixel_width - s.size.width; - - NSRectFill (s); - break; - } + ns_focus (f, &r, 1); - /* Draw the character under the cursor. Other terms only draw - the character on top of box cursors, so do the same here. */ - if (cursor_type == FILLED_BOX_CURSOR || cursor_type == HOLLOW_BOX_CURSOR) - draw_phys_cursor_glyph (w, glyph_row, DRAW_CURSOR); - - ns_reset_clipping (f); + face = FACE_FROM_ID_OR_NULL (f, phys_cursor_glyph->face_id); + if (face && NS_FACE_BACKGROUND (face) + == ns_index_color (FRAME_CURSOR_COLOR (f), f)) + { + [ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), f) set]; + hollow_color = FRAME_CURSOR_COLOR (f); } - else if (! redisplaying_p) + else + [FRAME_CURSOR_COLOR (f) set]; + + switch (cursor_type) { - /* If this function is called outside redisplay, it probably - means we need an immediate update. */ - [FRAME_NS_VIEW (f) display]; + case DEFAULT_CURSOR: + case NO_CURSOR: + break; + case FILLED_BOX_CURSOR: + NSRectFill (r); + break; + case HOLLOW_BOX_CURSOR: + NSRectFill (r); + [hollow_color set]; + NSRectFill (NSInsetRect (r, 1, 1)); + [FRAME_CURSOR_COLOR (f) set]; + break; + case HBAR_CURSOR: + NSRectFill (r); + break; + case BAR_CURSOR: + s = r; + /* If the character under cursor is R2L, draw the bar cursor + on the right of its glyph, rather than on the left. */ + cursor_glyph = get_phys_cursor_glyph (w); + if ((cursor_glyph->resolved_level & 1) != 0) + s.origin.x += cursor_glyph->pixel_width - s.size.width; + + NSRectFill (s); + break; } + ns_unfocus (f); + + /* Draw the character under the cursor. Other terms only draw + the character on top of box cursors, so do the same here. */ + if (cursor_type == FILLED_BOX_CURSOR || cursor_type == HOLLOW_BOX_CURSOR) + draw_phys_cursor_glyph (w, glyph_row, DRAW_CURSOR); } @@ -3297,14 +3467,12 @@ ns_draw_vertical_window_border (struct window *w, int x, int y0, int y1) face = FACE_FROM_ID_OR_NULL (f, VERTICAL_BORDER_FACE_ID); - if (ns_clip_to_rect (f, &r, 1)) - { - if (face) - [ns_lookup_indexed_color(face->foreground, f) set]; + ns_focus (f, &r, 1); + if (face) + [ns_lookup_indexed_color(face->foreground, f) set]; - NSRectFill(r); - ns_reset_clipping (f); - } + NSRectFill(r); + ns_unfocus (f); } @@ -3331,42 +3499,42 @@ ns_draw_window_divider (struct window *w, int x0, int x1, int y0, int y1) NSTRACE ("ns_draw_window_divider"); - if (ns_clip_to_rect (f, ÷r, 1)) - { - if ((y1 - y0 > x1 - x0) && (x1 - x0 >= 3)) - /* A vertical divider, at least three pixels wide: Draw first and - last pixels differently. */ - { - [ns_lookup_indexed_color(color_first, f) set]; - NSRectFill(NSMakeRect (x0, y0, 1, y1 - y0)); - [ns_lookup_indexed_color(color, f) set]; - NSRectFill(NSMakeRect (x0 + 1, y0, x1 - x0 - 2, y1 - y0)); - [ns_lookup_indexed_color(color_last, f) set]; - NSRectFill(NSMakeRect (x1 - 1, y0, 1, y1 - y0)); - } - else if ((x1 - x0 > y1 - y0) && (y1 - y0 >= 3)) - /* A horizontal divider, at least three pixels high: Draw first and - last pixels differently. */ - { - [ns_lookup_indexed_color(color_first, f) set]; - NSRectFill(NSMakeRect (x0, y0, x1 - x0, 1)); - [ns_lookup_indexed_color(color, f) set]; - NSRectFill(NSMakeRect (x0, y0 + 1, x1 - x0, y1 - y0 - 2)); - [ns_lookup_indexed_color(color_last, f) set]; - NSRectFill(NSMakeRect (x0, y1 - 1, x1 - x0, 1)); - } - else - { - /* In any other case do not draw the first and last pixels - differently. */ - [ns_lookup_indexed_color(color, f) set]; - NSRectFill(divider); - } + ns_focus (f, ÷r, 1); - ns_reset_clipping (f); + if ((y1 - y0 > x1 - x0) && (x1 - x0 >= 3)) + /* A vertical divider, at least three pixels wide: Draw first and + last pixels differently. */ + { + [ns_lookup_indexed_color(color_first, f) set]; + NSRectFill(NSMakeRect (x0, y0, 1, y1 - y0)); + [ns_lookup_indexed_color(color, f) set]; + NSRectFill(NSMakeRect (x0 + 1, y0, x1 - x0 - 2, y1 - y0)); + [ns_lookup_indexed_color(color_last, f) set]; + NSRectFill(NSMakeRect (x1 - 1, y0, 1, y1 - y0)); + } + else if ((x1 - x0 > y1 - y0) && (y1 - y0 >= 3)) + /* A horizontal divider, at least three pixels high: Draw first and + last pixels differently. */ + { + [ns_lookup_indexed_color(color_first, f) set]; + NSRectFill(NSMakeRect (x0, y0, x1 - x0, 1)); + [ns_lookup_indexed_color(color, f) set]; + NSRectFill(NSMakeRect (x0, y0 + 1, x1 - x0, y1 - y0 - 2)); + [ns_lookup_indexed_color(color_last, f) set]; + NSRectFill(NSMakeRect (x0, y1 - 1, x1 - x0, 1)); } + else + { + /* In any other case do not draw the first and last pixels + differently. */ + [ns_lookup_indexed_color(color, f) set]; + NSRectFill(divider); + } + + ns_unfocus (f); } + static void ns_show_hourglass (struct frame *f) { @@ -3591,8 +3759,8 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face, } static void -ns_draw_box (NSRect r, CGFloat thickness, NSColor *col, - char left_p, char right_p) +ns_draw_box (NSRect r, CGFloat hthickness, CGFloat vthickness, + NSColor *col, char left_p, char right_p) /* -------------------------------------------------------------------------- Draw an unfilled rect inside r, optionally leaving left and/or right open. Note we can't just use an NSDrawRect command, because of the possibility @@ -3603,28 +3771,28 @@ ns_draw_box (NSRect r, CGFloat thickness, NSColor *col, [col set]; /* top, bottom */ - s.size.height = thickness; + s.size.height = hthickness; NSRectFill (s); - s.origin.y += r.size.height - thickness; + s.origin.y += r.size.height - hthickness; NSRectFill (s); s.size.height = r.size.height; s.origin.y = r.origin.y; /* left, right (optional) */ - s.size.width = thickness; + s.size.width = vthickness; if (left_p) NSRectFill (s); if (right_p) { - s.origin.x += r.size.width - thickness; + s.origin.x += r.size.width - vthickness; NSRectFill (s); } } static void -ns_draw_relief (NSRect r, int thickness, char raised_p, +ns_draw_relief (NSRect r, int hthickness, int vthickness, char raised_p, char top_p, char bottom_p, char left_p, char right_p, struct glyph_string *s) /* -------------------------------------------------------------------------- @@ -3674,27 +3842,27 @@ ns_draw_relief (NSRect r, int thickness, char raised_p, /* TODO: mitering. Using NSBezierPath doesn't work because of color switch. */ /* top */ - sr.size.height = thickness; + sr.size.height = hthickness; if (top_p) NSRectFill (sr); /* left */ sr.size.height = r.size.height; - sr.size.width = thickness; + sr.size.width = vthickness; if (left_p) NSRectFill (sr); [(raised_p ? darkCol : lightCol) set]; /* bottom */ sr.size.width = r.size.width; - sr.size.height = thickness; - sr.origin.y += r.size.height - thickness; + sr.size.height = hthickness; + sr.origin.y += r.size.height - hthickness; if (bottom_p) NSRectFill (sr); /* right */ sr.size.height = r.size.height; sr.origin.y = r.origin.y; - sr.size.width = thickness; - sr.origin.x += r.size.width - thickness; + sr.size.width = vthickness; + sr.origin.x += r.size.width - vthickness; if (right_p) NSRectFill (sr); } @@ -3710,7 +3878,7 @@ ns_dumpglyphs_box_or_relief (struct glyph_string *s) char left_p, right_p; struct glyph *last_glyph; NSRect r; - int thickness; + int hthickness, vthickness; struct face *face; if (s->hl == DRAW_MOUSE_FACE) @@ -3723,15 +3891,29 @@ ns_dumpglyphs_box_or_relief (struct glyph_string *s) else face = s->face; - thickness = face->box_line_width; + vthickness = face->box_vertical_line_width; + hthickness = face->box_horizontal_line_width; NSTRACE ("ns_dumpglyphs_box_or_relief"); last_x = ((s->row->full_width_p && !s->w->pseudo_window_p) ? WINDOW_RIGHT_EDGE_X (s->w) : window_box_right (s->w, s->area)); - last_glyph = (s->cmp || s->img - ? s->first_glyph : s->first_glyph + s->nchars-1); + if (s->cmp || s->img) + last_glyph = s->first_glyph; + else if (s->first_glyph->type == COMPOSITE_GLYPH + && s->first_glyph->u.cmp.automatic) + { + struct glyph *end = s->row->glyphs[s->area] + s->row->used[s->area]; + struct glyph *g = s->first_glyph; + for (last_glyph = g++; + g < end && g->u.cmp.automatic && g->u.cmp.id == s->cmp_id + && g->slice.cmp.to < s->cmp_to; + last_glyph = g++) + ; + } + else + last_glyph = s->first_glyph + s->nchars - 1; right_x = ((s->row->full_width_p && s->extends_to_end_of_line_p ? last_x - 1 : min (last_x, s->x + s->background_width) - 1)); @@ -3748,14 +3930,15 @@ ns_dumpglyphs_box_or_relief (struct glyph_string *s) /* TODO: Sometimes box_color is 0 and this seems wrong; should investigate. */ if (s->face->box == FACE_SIMPLE_BOX && s->face->box_color) { - ns_draw_box (r, abs (thickness), + ns_draw_box (r, abs (hthickness), abs (vthickness), ns_lookup_indexed_color (face->box_color, s->f), - left_p, right_p); + left_p, right_p); } else { - ns_draw_relief (r, abs (thickness), s->face->box == FACE_RAISED_BOX, - 1, 1, left_p, right_p, s); + ns_draw_relief (r, abs (hthickness), abs (vthickness), + s->face->box == FACE_RAISED_BOX, + 1, 1, left_p, right_p, s); } } @@ -3771,7 +3954,7 @@ ns_maybe_dumpglyphs_background (struct glyph_string *s, char force_p) if (!s->background_filled_p/* || s->hl == DRAW_MOUSE_FACE*/) { - int box_line_width = max (s->face->box_line_width, 0); + int box_line_width = max (s->face->box_horizontal_line_width, 0); if (FONT_HEIGHT (s->font) < s->height - 2 * box_line_width /* When xdisp.c ignores FONT_HEIGHT, we cannot trust font dimensions, since the actual glyphs might be much @@ -3822,7 +4005,7 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) -------------------------------------------------------------------------- */ { EmacsImage *img = s->img->pixmap; - int box_line_vwidth = max (s->face->box_line_width, 0); + int box_line_vwidth = max (s->face->box_horizontal_line_width, 0); int x = s->x, y = s->ybase - image_ascent (s->img, s->face, &s->slice); int bg_x, bg_y, bg_height; int th; @@ -3835,7 +4018,7 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p && s->slice.x == 0) - x += abs (s->face->box_line_width); + x += max (s->face->box_vertical_line_width, 0); bg_x = x; bg_y = s->slice.y == 0 ? s->y : s->y + box_line_vwidth; @@ -3890,20 +4073,39 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) [[NSGraphicsContext currentContext] saveGraphicsState]; - /* Because of the transforms it's far too difficult to work out - what portion of the original, untransformed, image will be - drawn, so the clipping area will ensure we draw only the - correct bit. */ + /* Because of the transforms it's difficult to work out what + portion of the original, untransformed, image will be drawn, + so the clipping area will ensure we draw only the correct + bit. */ NSRectClip (dr); [setOrigin translateXBy:x - s->slice.x yBy:y - s->slice.y]; [setOrigin concat]; - [img->transform concat]; + + NSAffineTransform *doTransform = [NSAffineTransform transform]; + + /* ImageMagick images don't have transforms. */ + if (img->transform) + [doTransform appendTransform:img->transform]; + + [doTransform concat]; + + /* Smoothing is the default, so if we don't want smoothing we + have to turn it off. */ + if (! img->smoothing) + [[NSGraphicsContext currentContext] + setImageInterpolation:NSImageInterpolationNone]; [img drawInRect:ir fromRect:ir operation:NSCompositingOperationSourceOver fraction:1.0 respectFlipped:YES hints:nil]; + /* Apparently image interpolation is not reset with + restoreGraphicsState, so we have to manually reset it. */ + if (! img->smoothing) + [[NSGraphicsContext currentContext] + setImageInterpolation:NSImageInterpolationDefault]; + [[NSGraphicsContext currentContext] restoreGraphicsState]; } @@ -3948,7 +4150,7 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) r.origin.y = y - th; r.size.width = s->slice.width + 2*th-1; r.size.height = s->slice.height + 2*th-1; - ns_draw_relief (r, th, raised_p, + ns_draw_relief (r, th, th, raised_p, s->slice.y == 0, s->slice.y + s->slice.height == s->img->height, s->slice.x == 0, @@ -3962,7 +4164,7 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) { int thickness = abs (s->img->relief); if (thickness == 0) thickness = 1; - ns_draw_box (br, thickness, FRAME_CURSOR_COLOR (s->f), 1, 1); + ns_draw_box (br, thickness, thickness, FRAME_CURSOR_COLOR (s->f), 1, 1); } } @@ -3971,89 +4173,65 @@ static void ns_dumpglyphs_stretch (struct glyph_string *s) { NSRect r[2]; - int n, i; + NSRect glyphRect; + int n; struct face *face; NSColor *fgCol, *bgCol; if (!s->background_filled_p) { n = ns_get_glyph_string_clip_rect (s, r); + ns_focus (s->f, r, n); - if (ns_clip_to_rect (s->f, r, n)) + if (s->hl == DRAW_MOUSE_FACE) { - /* FIXME: Why are we reusing the clipping rectangles? The - other terms don't appear to do anything like this. */ - *r = NSMakeRect (s->x, s->y, s->background_width, s->height); + face = FACE_FROM_ID_OR_NULL (s->f, + MOUSE_HL_INFO (s->f)->mouse_face_face_id); + if (!face) + face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); + } + else + face = FACE_FROM_ID (s->f, s->first_glyph->face_id); - if (s->hl == DRAW_MOUSE_FACE) - { - face = FACE_FROM_ID_OR_NULL (s->f, - MOUSE_HL_INFO (s->f)->mouse_face_face_id); - if (!face) - face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); - } - else - face = FACE_FROM_ID (s->f, s->first_glyph->face_id); + bgCol = ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f); + fgCol = ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), s->f); - bgCol = ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f); - fgCol = ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), s->f); + glyphRect = NSMakeRect (s->x, s->y, s->background_width, s->height); - for (i = 0; i < n; ++i) - { - if (!s->row->full_width_p) - { - int overrun, leftoverrun; - - /* truncate to avoid overwriting fringe and/or scrollbar */ - overrun = max (0, (s->x + s->background_width) - - (WINDOW_BOX_RIGHT_EDGE_X (s->w) - - WINDOW_RIGHT_FRINGE_WIDTH (s->w))); - r[i].size.width -= overrun; - - /* truncate to avoid overwriting to left of the window box */ - leftoverrun = (WINDOW_BOX_LEFT_EDGE_X (s->w) - + WINDOW_LEFT_FRINGE_WIDTH (s->w)) - s->x; - - if (leftoverrun > 0) - { - r[i].origin.x += leftoverrun; - r[i].size.width -= leftoverrun; - } - } + [bgCol set]; - [bgCol set]; + /* NOTE: under NS this is NOT used to draw cursors, but we must avoid + overwriting cursor (usually when cursor on a tab) */ + if (s->hl == DRAW_CURSOR) + { + CGFloat x, width; - /* NOTE: under NS this is NOT used to draw cursors, but we must avoid - overwriting cursor (usually when cursor on a tab). */ - if (s->hl == DRAW_CURSOR) - { - CGFloat x, width; + /* FIXME: This looks like it will only work for left to + right languages. */ + x = NSMinX (glyphRect); + width = s->w->phys_cursor_width; + glyphRect.size.width -= width; + glyphRect.origin.x += width; - x = r[i].origin.x; - width = s->w->phys_cursor_width; - r[i].size.width -= width; - r[i].origin.x += width; + NSRectFill (glyphRect); - NSRectFill (r[i]); + /* Draw overlining, etc. on the cursor. */ + if (s->w->phys_cursor_type == FILLED_BOX_CURSOR) + ns_draw_text_decoration (s, face, bgCol, width, x); + else + ns_draw_text_decoration (s, face, fgCol, width, x); + } + else + { + NSRectFill (glyphRect); + } - /* Draw overlining, etc. on the cursor. */ - if (s->w->phys_cursor_type == FILLED_BOX_CURSOR) - ns_draw_text_decoration (s, face, bgCol, width, x); - else - ns_draw_text_decoration (s, face, fgCol, width, x); - } - else - { - NSRectFill (r[i]); - } + /* Draw overlining, etc. on the stretch glyph (or the part + of the stretch glyph after the cursor). */ + ns_draw_text_decoration (s, face, fgCol, NSWidth (glyphRect), + NSMinX (glyphRect)); - /* Draw overlining, etc. on the stretch glyph (or the part - of the stretch glyph after the cursor). */ - ns_draw_text_decoration (s, face, fgCol, r[i].size.width, - r[i].origin.x); - } - ns_reset_clipping (s->f); - } + ns_unfocus (s->f); s->background_filled_p = 1; } } @@ -4069,7 +4247,7 @@ ns_draw_glyph_string_foreground (struct glyph_string *s) of S to the right of that box line. */ if (s->face && s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) - x = s->x + eabs (s->face->box_line_width); + x = s->x + max (s->face->box_vertical_line_width, 0); else x = s->x; @@ -4095,7 +4273,7 @@ ns_draw_composite_glyph_string_foreground (struct glyph_string *s) of S to the right of that box line. */ if (s->face && s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) - x = s->x + eabs (s->face->box_line_width); + x = s->x + max (s->face->box_vertical_line_width, 0); else x = s->x; @@ -4111,7 +4289,7 @@ ns_draw_composite_glyph_string_foreground (struct glyph_string *s) if (s->cmp_from == 0) { NSRect r = NSMakeRect (s->x, s->y, s->width-1, s->height -1); - ns_draw_box (r, 1, FRAME_CURSOR_COLOR (s->f), 1, 1); + ns_draw_box (r, 1, 1, FRAME_CURSOR_COLOR (s->f), 1, 1); } } else if (! s->first_glyph->u.cmp.automatic) @@ -4203,11 +4381,9 @@ ns_draw_glyph_string (struct glyph_string *s) if (next->first_glyph->type != STRETCH_GLYPH) { n = ns_get_glyph_string_clip_rect (s->next, r); - if (ns_clip_to_rect (s->f, r, n)) - { - ns_maybe_dumpglyphs_background (s->next, 1); - ns_reset_clipping (s->f); - } + ns_focus (s->f, r, n); + ns_maybe_dumpglyphs_background (s->next, 1); + ns_unfocus (s->f); } else { @@ -4222,12 +4398,10 @@ ns_draw_glyph_string (struct glyph_string *s) || s->first_glyph->type == COMPOSITE_GLYPH)) { n = ns_get_glyph_string_clip_rect (s, r); - if (ns_clip_to_rect (s->f, r, n)) - { - ns_maybe_dumpglyphs_background (s, 1); - ns_dumpglyphs_box_or_relief (s); - ns_reset_clipping (s->f); - } + ns_focus (s->f, r, n); + ns_maybe_dumpglyphs_background (s, 1); + ns_dumpglyphs_box_or_relief (s); + ns_unfocus (s->f); box_drawn_p = 1; } @@ -4236,11 +4410,13 @@ ns_draw_glyph_string (struct glyph_string *s) case IMAGE_GLYPH: n = ns_get_glyph_string_clip_rect (s, r); - if (ns_clip_to_rect (s->f, r, n)) - { - ns_dumpglyphs_image (s, r[0]); - ns_reset_clipping (s->f); - } + ns_focus (s->f, r, n); + ns_dumpglyphs_image (s, r[0]); + ns_unfocus (s->f); + break; + + case XWIDGET_GLYPH: + x_draw_xwidget_glyph_string (s); break; case STRETCH_GLYPH: @@ -4250,68 +4426,66 @@ ns_draw_glyph_string (struct glyph_string *s) case CHAR_GLYPH: case COMPOSITE_GLYPH: n = ns_get_glyph_string_clip_rect (s, r); - if (ns_clip_to_rect (s->f, r, n)) - { - if (s->for_overlaps || (s->cmp_from > 0 - && ! s->first_glyph->u.cmp.automatic)) - s->background_filled_p = 1; - else - ns_maybe_dumpglyphs_background - (s, s->first_glyph->type == COMPOSITE_GLYPH); + ns_focus (s->f, r, n); - if (s->hl == DRAW_CURSOR && s->w->phys_cursor_type == FILLED_BOX_CURSOR) - { - unsigned long tmp = NS_FACE_BACKGROUND (s->face); - NS_FACE_BACKGROUND (s->face) = NS_FACE_FOREGROUND (s->face); - NS_FACE_FOREGROUND (s->face) = tmp; - } + if (s->for_overlaps || (s->cmp_from > 0 + && ! s->first_glyph->u.cmp.automatic)) + s->background_filled_p = 1; + else + ns_maybe_dumpglyphs_background + (s, s->first_glyph->type == COMPOSITE_GLYPH); - { - BOOL isComposite = s->first_glyph->type == COMPOSITE_GLYPH; + if (s->hl == DRAW_CURSOR && s->w->phys_cursor_type == FILLED_BOX_CURSOR) + { + unsigned long tmp = NS_FACE_BACKGROUND (s->face); + NS_FACE_BACKGROUND (s->face) = NS_FACE_FOREGROUND (s->face); + NS_FACE_FOREGROUND (s->face) = tmp; + } - if (isComposite) - ns_draw_composite_glyph_string_foreground (s); - else - ns_draw_glyph_string_foreground (s); - } + { + BOOL isComposite = s->first_glyph->type == COMPOSITE_GLYPH; - { - NSColor *col = (NS_FACE_FOREGROUND (s->face) != 0 - ? ns_lookup_indexed_color (NS_FACE_FOREGROUND (s->face), - s->f) - : FRAME_FOREGROUND_COLOR (s->f)); - [col set]; - - /* Draw underline, overline, strike-through. */ - ns_draw_text_decoration (s, s->face, col, s->width, s->x); - } + if (isComposite) + ns_draw_composite_glyph_string_foreground (s); + else + ns_draw_glyph_string_foreground (s); + } - if (s->hl == DRAW_CURSOR && s->w->phys_cursor_type == FILLED_BOX_CURSOR) - { - unsigned long tmp = NS_FACE_BACKGROUND (s->face); - NS_FACE_BACKGROUND (s->face) = NS_FACE_FOREGROUND (s->face); - NS_FACE_FOREGROUND (s->face) = tmp; - } + { + NSColor *col = (NS_FACE_FOREGROUND (s->face) != 0 + ? ns_lookup_indexed_color (NS_FACE_FOREGROUND (s->face), + s->f) + : FRAME_FOREGROUND_COLOR (s->f)); + [col set]; + + /* Draw underline, overline, strike-through. */ + ns_draw_text_decoration (s, s->face, col, s->width, s->x); + } - ns_reset_clipping (s->f); + if (s->hl == DRAW_CURSOR && s->w->phys_cursor_type == FILLED_BOX_CURSOR) + { + unsigned long tmp = NS_FACE_BACKGROUND (s->face); + NS_FACE_BACKGROUND (s->face) = NS_FACE_FOREGROUND (s->face); + NS_FACE_FOREGROUND (s->face) = tmp; } + + ns_unfocus (s->f); break; case GLYPHLESS_GLYPH: n = ns_get_glyph_string_clip_rect (s, r); - if (ns_clip_to_rect (s->f, r, n)) - { - if (s->for_overlaps || (s->cmp_from > 0 - && ! s->first_glyph->u.cmp.automatic)) - s->background_filled_p = 1; - else - ns_maybe_dumpglyphs_background - (s, s->first_glyph->type == COMPOSITE_GLYPH); - /* ... */ - /* Not yet implemented. */ - /* ... */ - ns_reset_clipping (s->f); - } + ns_focus (s->f, r, n); + + if (s->for_overlaps || (s->cmp_from > 0 + && ! s->first_glyph->u.cmp.automatic)) + s->background_filled_p = 1; + else + ns_maybe_dumpglyphs_background + (s, s->first_glyph->type == COMPOSITE_GLYPH); + /* ... */ + /* Not yet implemented. */ + /* ... */ + ns_unfocus (s->f); break; default: @@ -4322,11 +4496,9 @@ ns_draw_glyph_string (struct glyph_string *s) if (!s->for_overlaps && !box_drawn_p && s->face->box != FACE_NO_BOX) { n = ns_get_glyph_string_clip_rect (s, r); - if (ns_clip_to_rect (s->f, r, n)) - { - ns_dumpglyphs_box_or_relief (s); - ns_reset_clipping (s->f); - } + ns_focus (s->f, r, n); + ns_dumpglyphs_box_or_relief (s); + ns_unfocus (s->f); } s->num_clips = 0; @@ -4435,79 +4607,6 @@ check_native_fs () } #endif -/* GNUstep does not have cancelTracking. */ -#ifdef NS_IMPL_COCOA -/* Check if menu open should be canceled or continued as normal. */ -void -ns_check_menu_open (NSMenu *menu) -{ - /* Click in menu bar? */ - NSArray *a = [[NSApp mainMenu] itemArray]; - int i; - BOOL found = NO; - - if (menu == nil) // Menu tracking ended. - { - if (menu_will_open_state == MENU_OPENING) - menu_will_open_state = MENU_NONE; - return; - } - - for (i = 0; ! found && i < [a count]; i++) - found = menu == [[a objectAtIndex:i] submenu]; - if (found) - { - if (menu_will_open_state == MENU_NONE && emacs_event) - { - NSEvent *theEvent = [NSApp currentEvent]; - struct frame *emacsframe = SELECTED_FRAME (); - - /* On macOS, the following can cause an event loop when the - Spotlight for Help search field is populated. Avoid this by - not postponing mouse drag and non-user-generated mouse down - events (Bug#31371). */ - if (([theEvent type] == NSEventTypeLeftMouseDown) - && [theEvent eventNumber]) - { - [menu cancelTracking]; - menu_will_open_state = MENU_PENDING; - emacs_event->kind = MENU_BAR_ACTIVATE_EVENT; - EV_TRAILER (theEvent); - - CGEventRef ourEvent = CGEventCreate (NULL); - menu_mouse_point = CGEventGetLocation (ourEvent); - CFRelease (ourEvent); - } - } - else if (menu_will_open_state == MENU_OPENING) - { - menu_will_open_state = MENU_NONE; - } - } -} - -/* Redo saved menu click if state is MENU_PENDING. */ -void -ns_check_pending_open_menu () -{ - if (menu_will_open_state == MENU_PENDING) - { - CGEventSourceRef source - = CGEventSourceCreate (kCGEventSourceStateHIDSystemState); - - CGEventRef event = CGEventCreateMouseEvent (source, - kCGEventLeftMouseDown, - menu_mouse_point, - kCGMouseButtonLeft); - CGEventSetType (event, kCGEventLeftMouseDown); - CGEventPost (kCGHIDEventTap, event); - CFRelease (event); - CFRelease (source); - - menu_will_open_state = MENU_OPENING; - } -} -#endif /* NS_IMPL_COCOA */ static int ns_read_socket (struct terminal *terminal, struct input_event *hold_quit) @@ -4616,7 +4715,8 @@ ns_select (int nfds, fd_set *readfds, fd_set *writefds, return -1; } - for (k = 0; k < nfds+1; k++) + eassert (nfds <= FD_SETSIZE); + for (k = 0; k < nfds; k++) { if (readfds && FD_ISSET(k, readfds)) ++nr; if (writefds && FD_ISSET(k, writefds)) ++nr; @@ -4633,8 +4733,22 @@ ns_select (int nfds, fd_set *readfds, fd_set *writefds, thread_select(pselect, 0, NULL, NULL, NULL, &t, sigmask); } - [outerpool release]; - outerpool = [[NSAutoreleasePool alloc] init]; + /* FIXME: This draining of outerpool causes a crash when a buffer + running over tramp is displayed and the user tries to use the + menus. I believe some other autorelease pool's lifetime + straddles this call causing a violation of autorelease pool + nesting. There's no good reason to keep these here since the + pool will be drained some other time anyway, but removing them + leaves the menus sometimes not opening until the user moves their + mouse pointer, but that's better than a crash. + + There must be something about running external processes like + tramp that interferes with the modal menu code. + + See bugs 24472, 37557, 37922. */ + + // [outerpool release]; + // outerpool = [[NSAutoreleasePool alloc] init]; send_appdefined = YES; @@ -4814,8 +4928,8 @@ ns_set_vertical_scroll_bar (struct window *window, [bar removeFromSuperview]; wset_vertical_scroll_bar (window, Qnil); [bar release]; + ns_clear_frame_area (f, left, top, width, height); } - ns_clear_frame_area (f, left, top, width, height); unblock_input (); return; } @@ -4837,7 +4951,7 @@ ns_set_vertical_scroll_bar (struct window *window, r.size.width = oldRect.size.width; if (FRAME_LIVE_P (f) && !NSEqualRects (oldRect, r)) { - if (oldRect.origin.x != r.origin.x) + if (! NSEqualRects (oldRect, r)) ns_clear_frame_area (f, left, top, width, height); [bar setFrame: r]; } @@ -4915,8 +5029,7 @@ ns_set_horizontal_scroll_bar (struct window *window, oldRect = [bar frame]; if (FRAME_LIVE_P (f) && !NSEqualRects (oldRect, r)) { - if (oldRect.origin.y != r.origin.y) - ns_clear_frame_area (f, left, top, width, height); + ns_clear_frame_area (f, left, top, width, height); [bar setFrame: r]; update_p = YES; } @@ -4993,19 +5106,14 @@ ns_judge_scroll_bars (struct frame *f) id view; EmacsView *eview = FRAME_NS_VIEW (f); NSArray *subviews = [[eview superview] subviews]; - BOOL removed = NO; NSTRACE ("ns_judge_scroll_bars"); for (i = [subviews count]-1; i >= 0; --i) { view = [subviews objectAtIndex: i]; if (![view isKindOfClass: [EmacsScroller class]]) continue; - if ([view judge]) - removed = YES; + [view judge]; } - - if (removed) - [eview updateFrameSize: NO]; } /* ========================================================================== @@ -5170,7 +5278,7 @@ static struct redisplay_interface ns_redisplay_interface = ns_draw_glyph_string, ns_define_frame_cursor, ns_clear_frame_area, - 0, /* clear_under_internal_border */ + ns_clear_under_internal_border, /* clear_under_internal_border */ ns_draw_window_cursor, ns_draw_vertical_window_border, ns_draw_window_divider, @@ -5248,7 +5356,6 @@ ns_create_terminal (struct ns_display_info *dpyinfo) terminal->set_new_font_hook = ns_new_font; terminal->implicit_set_name_hook = ns_implicitly_set_name; terminal->menu_show_hook = ns_menu_show; - terminal->activate_menubar_hook = ns_activate_menubar; terminal->popup_dialog_hook = ns_popup_dialog; terminal->set_vertical_scroll_bar_hook = ns_set_vertical_scroll_bar; terminal->set_horizontal_scroll_bar_hook = ns_set_horizontal_scroll_bar; @@ -5370,11 +5477,11 @@ ns_term_init (Lisp_Object display_name) { NSColorList *cl = [NSColorList colorListNamed: @"Emacs"]; - if ( cl == nil ) + /* There are 752 colors defined in rgb.txt. */ + if ( cl == nil || [[cl allKeys] count] < 752) { - Lisp_Object color_file, color_map, color; + Lisp_Object color_file, color_map, color, name; unsigned long c; - char *name; color_file = Fexpand_file_name (build_string ("rgb.txt"), Fsymbol_value (intern ("data-directory"))); @@ -5387,18 +5494,18 @@ ns_term_init (Lisp_Object display_name) for ( ; CONSP (color_map); color_map = XCDR (color_map)) { color = XCAR (color_map); - name = SSDATA (XCAR (color)); + name = XCAR (color); c = XFIXNUM (XCDR (color)); [cl setColor: [NSColor colorForEmacsRed: RED_FROM_ULONG (c) / 255.0 green: GREEN_FROM_ULONG (c) / 255.0 blue: BLUE_FROM_ULONG (c) / 255.0 alpha: 1.0] - forKey: [NSString stringWithUTF8String: name]]; + forKey: [NSString stringWithLispString: name]]; } /* FIXME: Report any errors writing the color file below. */ -#if MAC_OS_X_VERSION_MAX_ALLOWED >= 101100 +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 101100 #if MAC_OS_X_VERSION_MIN_REQUIRED < 101100 if ([cl respondsToSelector:@selector(writeToURL:error:)]) #endif @@ -5493,15 +5600,6 @@ ns_term_init (Lisp_Object display_name) [NSApp setServicesMenu: svcsMenu]; /* Needed at least on Cocoa, to get dock menu to show windows */ [NSApp setWindowsMenu: [[NSMenu alloc] init]]; - - [[NSNotificationCenter defaultCenter] - addObserver: mainMenu - selector: @selector (trackingNotification:) - name: NSMenuDidBeginTrackingNotification object: mainMenu]; - [[NSNotificationCenter defaultCenter] - addObserver: mainMenu - selector: @selector (trackingNotification:) - name: NSMenuDidEndTrackingNotification object: mainMenu]; } #endif /* macOS menu setup */ @@ -5516,7 +5614,11 @@ ns_term_init (Lisp_Object display_name) ns_drag_types = [[NSArray arrayWithObjects: NSPasteboardTypeString, NSPasteboardTypeTabularText, +#if NS_USE_NSPasteboardTypeFileURL != 0 + NSPasteboardTypeFileURL, +#else NSFilenamesPboardType, +#endif NSPasteboardTypeURL, nil] retain]; /* If fullscreen is in init/default-frame-alist, focus isn't set @@ -5777,7 +5879,7 @@ ns_term_shutdown (int sig) emacs_event->kind = NS_NONKEY_EVENT; emacs_event->code = KEY_NS_OPEN_FILE_LINE; - ns_input_file = append2 (ns_input_file, build_string ([fileName UTF8String])); + ns_input_file = append2 (ns_input_file, [fileName lispString]); ns_input_line = Qnil; /* can be start or cons start,end */ emacs_event->modifiers =0; EV_TRAILER (theEvent); @@ -6141,8 +6243,7 @@ not_in_argv (NSString *arg) error: (NSString **)error { [ns_pending_service_names addObject: userData]; - [ns_pending_service_args addObject: [NSString stringWithUTF8String: - SSDATA (ns_string_from_pasteboard (pboard))]]; + [ns_pending_service_args addObject: [NSString stringWithLispString:ns_string_from_pasteboard (pboard)]]; } @@ -6159,8 +6260,8 @@ not_in_argv (NSString *arg) emacs_event->kind = NS_NONKEY_EVENT; emacs_event->code = KEY_NS_SPI_SERVICE_CALL; - ns_input_spi_name = build_string ([name UTF8String]); - ns_input_spi_arg = build_string ([arg UTF8String]); + ns_input_spi_name = [name lispString]; + ns_input_spi_arg = [arg lispString]; emacs_event->modifiers = EV_MODIFIERS (theEvent); EV_TRAILER (theEvent); @@ -6192,6 +6293,17 @@ not_in_argv (NSString *arg) - (void)dealloc { NSTRACE ("[EmacsView dealloc]"); + + /* Clear the view resize notification. */ + [[NSNotificationCenter defaultCenter] + removeObserver:self + name:NSViewFrameDidChangeNotification + object:nil]; + +#ifdef NS_DRAW_TO_BUFFER + [surface release]; +#endif + [toolbar release]; if (fs_state == FULLSCREEN_BOTH) [nonfs_window release]; @@ -6231,7 +6343,7 @@ not_in_argv (NSString *arg) size = [newFont pointSize]; ns_input_fontsize = make_fixnum (lrint (size)); - ns_input_font = build_string ([[newFont familyName] UTF8String]); + ns_input_font = [[newFont familyName] lispString]; EV_TRAILER (e); } } @@ -6307,7 +6419,7 @@ not_in_argv (NSString *arg) if (nsEvArray == nil) nsEvArray = [[NSMutableArray alloc] initWithCapacity: 1]; - [NSCursor setHiddenUntilMouseMoves: YES]; + [NSCursor setHiddenUntilMouseMoves:! NILP (Vmake_pointer_invisible)]; if (hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight)) { @@ -6539,7 +6651,7 @@ not_in_argv (NSString *arg) processingCompose = YES; [workingText release]; workingText = [str copy]; - ns_working_text = build_string ([workingText UTF8String]); + ns_working_text = [workingText lispString]; emacs_event->kind = NS_TEXT_EVENT; emacs_event->code = KEY_NS_PUT_WORKING_TEXT; @@ -6605,13 +6717,18 @@ not_in_argv (NSString *arg) { NSRect rect; NSPoint pt; - struct window *win = XWINDOW (FRAME_SELECTED_WINDOW (emacsframe)); + struct window *win; NSTRACE ("[EmacsView firstRectForCharacterRange:]"); if (NS_KEYLOG) NSLog (@"firstRectForCharRange request"); + if (WINDOWP (echo_area_window) && ! NILP (call0 (intern ("ns-in-echo-area")))) + win = XWINDOW (echo_area_window); + else + win = XWINDOW (FRAME_SELECTED_WINDOW (emacsframe)); + rect.size.width = theRange.length * FRAME_COLUMN_WIDTH (emacsframe); rect.size.height = FRAME_LINE_HEIGHT (emacsframe); pt.x = WINDOW_TEXT_TO_FRAME_PIXEL_X (win, win->phys_cursor.x); @@ -6718,8 +6835,6 @@ not_in_argv (NSString *arg) NSTRACE ("[EmacsView mouseDown:]"); - [self deleteWorkingText]; - if (!emacs_event) return; @@ -6929,6 +7044,7 @@ not_in_argv (NSString *arg) struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (emacsframe); Lisp_Object frame; NSPoint pt; + BOOL dragging; NSTRACE_WHEN (NSTRACE_GROUP_EVENTS, "[EmacsView mouseMoved:]"); @@ -6971,7 +7087,8 @@ not_in_argv (NSString *arg) last_mouse_window = window; } - if (!ns_note_mouse_movement (emacsframe, pt.x, pt.y)) + dragging = (e.type == NSEventTypeLeftMouseDragged); + if (!ns_note_mouse_movement (emacsframe, pt.x, pt.y, dragging)) help_echo_string = previous_help_echo_string; XSETFRAME (frame, emacsframe); @@ -7027,105 +7144,12 @@ not_in_argv (NSString *arg) return NO; } -- (void) updateFrameSize: (BOOL) delay -{ - NSWindow *window = [self window]; - NSRect wr = [window frame]; - int extra = 0; - int oldc = cols, oldr = rows; - int oldw = FRAME_PIXEL_WIDTH (emacsframe); - int oldh = FRAME_PIXEL_HEIGHT (emacsframe); - int neww, newh; - - NSTRACE ("[EmacsView updateFrameSize:]"); - NSTRACE_SIZE ("Original size", NSMakeSize (oldw, oldh)); - NSTRACE_RECT ("Original frame", wr); - NSTRACE_MSG ("Original columns: %d", cols); - NSTRACE_MSG ("Original rows: %d", rows); - - if (! [self isFullscreen]) - { - int toolbar_height; -#ifdef NS_IMPL_GNUSTEP - // GNUstep does not always update the tool bar height. Force it. - if (toolbar && [toolbar isVisible]) - update_frame_tool_bar (emacsframe); -#endif - - toolbar_height = FRAME_TOOLBAR_HEIGHT (emacsframe); - if (toolbar_height < 0) - toolbar_height = 35; - - extra = FRAME_NS_TITLEBAR_HEIGHT (emacsframe) - + toolbar_height; - } - - if (wait_for_tool_bar) - { - /* The toolbar height is always 0 in fullscreen and undecorated - frames, so don't wait for it to become available. */ - if (FRAME_TOOLBAR_HEIGHT (emacsframe) == 0 - && FRAME_UNDECORATED (emacsframe) == false - && ! [self isFullscreen]) - { - NSTRACE_MSG ("Waiting for toolbar"); - return; - } - wait_for_tool_bar = NO; - } - - neww = (int)wr.size.width - emacsframe->border_width; - newh = (int)wr.size.height - extra; - - NSTRACE_SIZE ("New size", NSMakeSize (neww, newh)); - NSTRACE_MSG ("FRAME_TOOLBAR_HEIGHT: %d", FRAME_TOOLBAR_HEIGHT (emacsframe)); - NSTRACE_MSG ("FRAME_NS_TITLEBAR_HEIGHT: %d", FRAME_NS_TITLEBAR_HEIGHT (emacsframe)); - - cols = FRAME_PIXEL_WIDTH_TO_TEXT_COLS (emacsframe, neww); - rows = FRAME_PIXEL_HEIGHT_TO_TEXT_LINES (emacsframe, newh); - - if (cols < MINWIDTH) - cols = MINWIDTH; - - if (rows < MINHEIGHT) - rows = MINHEIGHT; - - NSTRACE_MSG ("New columns: %d", cols); - NSTRACE_MSG ("New rows: %d", rows); - - if (oldr != rows || oldc != cols || neww != oldw || newh != oldh) - { - NSView *view = FRAME_NS_VIEW (emacsframe); - - change_frame_size (emacsframe, - FRAME_PIXEL_TO_TEXT_WIDTH (emacsframe, neww), - FRAME_PIXEL_TO_TEXT_HEIGHT (emacsframe, newh), - 0, delay, 0, 1); - SET_FRAME_GARBAGED (emacsframe); - cancel_mouse_face (emacsframe); - - /* The next two lines set the frame to the same size as we've - already set above. We need to do this when we switch back - from non-native fullscreen, in other circumstances it appears - to be a noop. (bug#28872) */ - wr = NSMakeRect (0, 0, neww, newh); - [view setFrame: wr]; - - // To do: consider using [NSNotificationCenter postNotificationName:]. - [self windowDidMove: // Update top/left. - [NSNotification notificationWithName:NSWindowDidMoveNotification - object:[view window]]]; - } - else - { - NSTRACE_MSG ("No change"); - } -} - (NSSize)windowWillResize: (NSWindow *)sender toSize: (NSSize)frameSize /* Normalize frame to gridded text size. */ { int extra = 0; + int cols, rows; NSTRACE ("[EmacsView windowWillResize:toSize: " NSTRACE_FMT_SIZE "]", NSTRACE_ARG_SIZE (frameSize)); @@ -7189,8 +7213,9 @@ not_in_argv (NSString *arg) old_title = t; } size_title = xmalloc (strlen (old_title) + 40); - esprintf (size_title, "%s — (%d x %d)", old_title, cols, rows); + esprintf (size_title, "%s — (%d × %d)", old_title, cols, rows); [window setTitle: [NSString stringWithUTF8String: size_title]]; + [window display]; xfree (size_title); } } @@ -7261,11 +7286,6 @@ not_in_argv (NSString *arg) sz = [self windowWillResize: theWindow toSize: sz]; #endif /* NS_IMPL_GNUSTEP */ - if (cols > 0 && rows > 0) - { - [self updateFrameSize: YES]; - } - ns_send_appdefined (-1); } @@ -7286,6 +7306,56 @@ not_in_argv (NSString *arg) #endif /* NS_IMPL_COCOA */ +- (void)viewDidResize:(NSNotification *)notification +{ + NSRect frame = [self frame]; + int neww, newh; + + if (! FRAME_LIVE_P (emacsframe)) + return; + + NSTRACE ("[EmacsView viewDidResize]"); + + neww = (int)NSWidth (frame); + newh = (int)NSHeight (frame); + NSTRACE_SIZE ("New size", NSMakeSize (neww, newh)); + +#ifdef NS_DRAW_TO_BUFFER + if ([self wantsUpdateLayer]) + { + CGFloat scale = [[self window] backingScaleFactor]; + NSSize size = [surface getSize]; + int oldw = size.width / scale; + int oldh = size.height / scale; + + NSTRACE_SIZE ("Original size", NSMakeSize (oldw, oldh)); + + /* Don't want to do anything when the view size hasn't changed. */ + if ((oldh == newh && oldw == neww)) + { + NSTRACE_MSG ("No change"); + return; + } + + [surface release]; + surface = nil; + } +#endif + + /* I'm not sure if it's safe to call this every time the view + changes size, as Emacs may already know about the change. + Unfortunately there doesn't seem to be a bullet-proof method of + determining whether we need to call it or not. */ + change_frame_size (emacsframe, + FRAME_PIXEL_TO_TEXT_WIDTH (emacsframe, neww), + FRAME_PIXEL_TO_TEXT_HEIGHT (emacsframe, newh), + 0, YES, 0, 1); + + SET_FRAME_GARBAGED (emacsframe); + cancel_mouse_face (emacsframe); +} + + - (void)windowDidBecomeKey: (NSNotification *)notification /* cf. x_detect_focus_change(), x_focus_changed(), x_new_focus_frame() */ { @@ -7344,7 +7414,6 @@ not_in_argv (NSString *arg) if (emacs_event && is_focus_frame) { - [self deleteWorkingText]; emacs_event->kind = FOCUS_OUT_EVENT; EV_TRAILER ((id)nil); } @@ -7410,7 +7479,7 @@ not_in_argv (NSString *arg) { NSRect r, wr; Lisp_Object tem; - NSWindow *win; + EmacsWindow *win; NSColor *col; NSString *name; @@ -7430,6 +7499,7 @@ not_in_argv (NSString *arg) #endif fs_is_native = ns_use_native_fullscreen; #endif + in_fullscreen_transition = NO; maximized_width = maximized_height = -1; nonfs_window = nil; @@ -7459,7 +7529,10 @@ not_in_argv (NSString *arg) #if MAC_OS_X_VERSION_MIN_REQUIRED < 1070 if (NSAppKitVersionNumber >= NSAppKitVersionNumber10_7) #endif - [win setCollectionBehavior:NSWindowCollectionBehaviorFullScreenPrimary]; + if (FRAME_PARENT_FRAME (f)) + [win setCollectionBehavior:NSWindowCollectionBehaviorFullScreenAuxiliary]; + else + [win setCollectionBehavior:NSWindowCollectionBehaviorFullScreenPrimary]; #endif wr = [win frame]; @@ -7480,24 +7553,15 @@ not_in_argv (NSString *arg) [self registerForDraggedTypes: ns_drag_types]; tem = f->name; - name = [NSString stringWithUTF8String: - NILP (tem) ? "Emacs" : SSDATA (tem)]; + name = NILP (tem) ? @"Emacs" : [NSString stringWithLispString:tem]; [win setTitle: name]; /* toolbar support */ if (! FRAME_UNDECORATED (f)) [self createToolbar: f]; -#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 -#ifndef NSAppKitVersionNumber10_10 -#define NSAppKitVersionNumber10_10 1343 -#endif - if (NSAppKitVersionNumber >= NSAppKitVersionNumber10_10 - && FRAME_NS_APPEARANCE (f) != ns_appearance_aqua) - win.appearance = [NSAppearance - appearanceNamed: NSAppearanceNameVibrantDark]; -#endif + [win setAppearance]; #if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 if ([win respondsToSelector: @selector(titlebarAppearsTransparent)]) @@ -7507,7 +7571,7 @@ not_in_argv (NSString *arg) tem = f->icon_name; if (!NILP (tem)) [win setMiniwindowTitle: - [NSString stringWithUTF8String: SSDATA (tem)]]; + [NSString stringWithLispString:tem]]; if (FRAME_PARENT_FRAME (f) != NULL) { @@ -7557,14 +7621,18 @@ not_in_argv (NSString *arg) [NSApp registerServicesMenuSendTypes: ns_send_types returnTypes: [NSArray array]]; + /* Set up view resize notifications. */ + [self setPostsFrameChangedNotifications:YES]; + [[NSNotificationCenter defaultCenter] + addObserver:self + selector:@selector (viewDidResize:) + name:NSViewFrameDidChangeNotification object:nil]; + /* macOS Sierra automatically enables tabbed windows. We can't allow this to be enabled until it's available on a Free system. Currently it only happens by accident and is buggy anyway. */ -#if defined (NS_IMPL_COCOA) \ - && MAC_OS_X_VERSION_MAX_ALLOWED >= 101200 -#if MAC_OS_X_VERSION_MIN_REQUIRED < 101200 +#ifdef NS_IMPL_COCOA if ([win respondsToSelector: @selector(setTabbingMode:)]) -#endif [win setTabbingMode: NSWindowTabbingModeDisallowed]; #endif @@ -7586,15 +7654,15 @@ not_in_argv (NSString *arg) return; if (screen != nil) { - emacsframe->left_pos = r.origin.x - NS_PARENT_WINDOW_LEFT_POS (emacsframe); - emacsframe->top_pos = - NS_PARENT_WINDOW_TOP_POS (emacsframe) - (r.origin.y + r.size.height); + emacsframe->left_pos = NSMinX (r) - NS_PARENT_WINDOW_LEFT_POS (emacsframe); + emacsframe->top_pos = NS_PARENT_WINDOW_TOP_POS (emacsframe) - NSMaxY (r); - if (emacs_event) - { - emacs_event->kind = MOVE_FRAME_EVENT; - EV_TRAILER ((id)nil); - } + // FIXME: after event part below didExitFullScreen is not received + // if (emacs_event) + // { + // emacs_event->kind = MOVE_FRAME_EVENT; + // EV_TRAILER ((id)nil); + // } } } @@ -7794,6 +7862,7 @@ not_in_argv (NSString *arg) - (void)windowWillEnterFullScreen:(NSNotification *)notification { NSTRACE ("[EmacsView windowWillEnterFullScreen:]"); + in_fullscreen_transition = YES; [self windowWillEnterFullScreen]; } - (void)windowWillEnterFullScreen /* provided for direct calls */ @@ -7806,6 +7875,7 @@ not_in_argv (NSString *arg) { NSTRACE ("[EmacsView windowDidEnterFullScreen:]"); [self windowDidEnterFullScreen]; + in_fullscreen_transition = NO; } - (void)windowDidEnterFullScreen /* provided for direct calls */ @@ -7844,6 +7914,7 @@ not_in_argv (NSString *arg) - (void)windowWillExitFullScreen:(NSNotification *)notification { NSTRACE ("[EmacsView windowWillExitFullScreen:]"); + in_fullscreen_transition = YES; [self windowWillExitFullScreen]; } @@ -7863,6 +7934,7 @@ not_in_argv (NSString *arg) { NSTRACE ("[EmacsView windowDidExitFullScreen:]"); [self windowDidExitFullScreen]; + in_fullscreen_transition = NO; } - (void)windowDidExitFullScreen /* provided for direct calls */ @@ -7882,7 +7954,6 @@ not_in_argv (NSString *arg) { [toolbar setVisible:YES]; update_frame_tool_bar (emacsframe); - [self updateFrameSize:YES]; [[self window] display]; } else @@ -7892,6 +7963,22 @@ not_in_argv (NSString *arg) [[self window] performZoom:self]; } +- (BOOL)inFullScreenTransition +{ + return in_fullscreen_transition; +} + +- (void)waitFullScreenTransition +{ +#if MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 + while ([self inFullScreenTransition]) + { + NSTRACE ("wait for fullscreen"); + wait_reading_process_output (0, 300000000, 0, 1, Qnil, NULL, 0); + } +#endif +} + - (BOOL)fsIsNative { return fs_is_native; @@ -7930,9 +8017,22 @@ not_in_argv (NSString *arg) NSWindow *win = [self window]; NSWindowCollectionBehavior b = [win collectionBehavior]; if (ns_use_native_fullscreen) - b |= NSWindowCollectionBehaviorFullScreenPrimary; + { + if ([win parentWindow]) + { + b &= ~NSWindowCollectionBehaviorFullScreenPrimary; + b |= NSWindowCollectionBehaviorFullScreenAuxiliary; + } + else + { + b |= NSWindowCollectionBehaviorFullScreenPrimary; + b &= ~NSWindowCollectionBehaviorFullScreenAuxiliary; + } + } else - b &= ~NSWindowCollectionBehaviorFullScreenPrimary; + { + b &= ~NSWindowCollectionBehaviorFullScreenPrimary; + } [win setCollectionBehavior: b]; #if MAC_OS_X_VERSION_MIN_REQUIRED < 1070 @@ -7958,8 +8058,14 @@ not_in_argv (NSString *arg) #if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 #if MAC_OS_X_VERSION_MIN_REQUIRED < 1070 if ([[self window] respondsToSelector: @selector(toggleFullScreen:)]) + { +#endif + [[self window] toggleFullScreen:sender]; + // wait for fullscreen animation complete (bug#28496) + [self waitFullScreenTransition]; +#if MAC_OS_X_VERSION_MIN_REQUIRED < 1070 + } #endif - [[self window] toggleFullScreen:sender]; #endif return; } @@ -8060,11 +8166,11 @@ not_in_argv (NSString *arg) // send notifications. [self windowWillExitFullScreen]; - [fw setFrame: [w frame] display:YES animate:ns_use_fullscreen_animation]; + [fw setFrame:[[w contentView] frame] + display:YES animate:ns_use_fullscreen_animation]; [fw close]; [w makeKeyAndOrderFront:NSApp]; [self windowDidExitFullScreen]; - [self updateFrameSize:YES]; } } @@ -8208,13 +8314,8 @@ not_in_argv (NSString *arg) if (!emacs_event) return self; - /* Send first event (for some reason two needed). */ theEvent = [[self window] currentEvent]; emacs_event->kind = TOOL_BAR_EVENT; - XSETFRAME (emacs_event->arg, emacsframe); - EV_TRAILER (theEvent); - - emacs_event->kind = TOOL_BAR_EVENT; /* XSETINT (emacs_event->code, 0); */ emacs_event->arg = AREF (emacsframe->tool_bar_items, idx + TOOL_BAR_ITEM_KEY); @@ -8238,55 +8339,161 @@ not_in_argv (NSString *arg) } -- (void)viewWillDraw +#ifdef NS_DRAW_TO_BUFFER +- (void)focusOnDrawingBuffer { - /* If the frame has been garbaged there's no point in redrawing - anything. */ - if (FRAME_GARBAGED_P (emacsframe)) - [self setNeedsDisplay:NO]; + CGFloat scale = [[self window] backingScaleFactor]; + + NSTRACE ("[EmacsView focusOnDrawingBuffer]"); + + if (! surface) + { + NSRect frame = [self frame]; + NSSize s = NSMakeSize (NSWidth (frame) * scale, NSHeight (frame) * scale); + + surface = [[EmacsSurface alloc] initWithSize:s + ColorSpace:[[[self window] colorSpace] + CGColorSpace]]; + } + + CGContextRef context = [surface getContext]; + + CGContextTranslateCTM(context, 0, [surface getSize].height); + CGContextScaleCTM(context, scale, -scale); + + [NSGraphicsContext + setCurrentContext:[NSGraphicsContext + graphicsContextWithCGContext:context + flipped:YES]]; } -- (void)drawRect: (NSRect)rect + +- (void)unfocusDrawingBuffer { - const NSRect *rectList; - NSInteger numRects; + NSTRACE ("[EmacsView unfocusDrawingBuffer]"); - NSTRACE ("[EmacsView drawRect:" NSTRACE_FMT_RECT "]", - NSTRACE_ARG_RECT(rect)); + [NSGraphicsContext setCurrentContext:nil]; + [surface releaseContext]; + [self setNeedsDisplay:YES]; +} - if (!emacsframe || !emacsframe->output_data.ns) - return; - block_input (); +- (void)windowDidChangeBackingProperties:(NSNotification *)notification + /* Update the drawing buffer when the backing properties change. */ +{ + NSTRACE ("EmacsView windowDidChangeBackingProperties:]"); - /* Get only the precise dirty rectangles to avoid redrawing - potentially large areas of the frame that haven't changed. + NSRect frame = [self frame]; - I'm not sure this actually provides much of a performance benefit - as it's hard to benchmark, but it certainly doesn't seem to - hurt. */ - [self getRectsBeingDrawn:&rectList count:&numRects]; - for (int i = 0 ; i < numRects ; i++) + [surface release]; + surface = nil; + + ns_clear_frame (emacsframe); + expose_frame (emacsframe, 0, 0, NSWidth (frame), NSHeight (frame)); +} +#endif /* NS_DRAW_TO_BUFFER */ + + +- (void)copyRect:(NSRect)srcRect to:(NSRect)dstRect +{ + NSTRACE ("[EmacsView copyRect:To:]"); + NSTRACE_RECT ("Source", srcRect); + NSTRACE_RECT ("Destination", dstRect); + +#ifdef NS_DRAW_TO_BUFFER +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + if ([self wantsUpdateLayer]) + { +#endif + double scale = [[self window] backingScaleFactor]; + CGContextRef context = [[NSGraphicsContext currentContext] CGContext]; + int bpp = CGBitmapContextGetBitsPerPixel (context) / 8; + void *pixels = CGBitmapContextGetData (context); + int rowSize = CGBitmapContextGetBytesPerRow (context); + int srcRowSize = NSWidth (srcRect) * scale * bpp; + void *srcPixels = (char *) pixels + + (int) (NSMinY (srcRect) * scale * rowSize + + NSMinX (srcRect) * scale * bpp); + void *dstPixels = (char *) pixels + + (int) (NSMinY (dstRect) * scale * rowSize + + NSMinX (dstRect) * scale * bpp); + + if (NSIntersectsRect (srcRect, dstRect) + && NSMinY (srcRect) < NSMinY (dstRect)) + for (int y = NSHeight (srcRect) * scale - 1 ; y >= 0 ; y--) + memmove ((char *) dstPixels + y * rowSize, + (char *) srcPixels + y * rowSize, + srcRowSize); + else + for (int y = 0 ; y < NSHeight (srcRect) * scale ; y++) + memmove ((char *) dstPixels + y * rowSize, + (char *) srcPixels + y * rowSize, + srcRowSize); + +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + } + else { - NSRect r = rectList[i]; +#endif +#endif /* NS_DRAW_TO_BUFFER */ - NSTRACE_RECT ("r", r); +#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + hide_bell(); // Ensure the bell image isn't scrolled. - expose_frame (emacsframe, - NSMinX (r), NSMinY (r), - NSWidth (r), NSHeight (r)); + ns_focus (emacsframe, &dstRect, 1); + [self scrollRect: srcRect + by: NSMakeSize (dstRect.origin.x - srcRect.origin.x, + dstRect.origin.y - srcRect.origin.y)]; + ns_unfocus (emacsframe); +#endif +#if defined (NS_DRAW_TO_BUFFER) && MAC_OS_X_VERSION_MIN_REQUIRED < 101400 } +#endif +} - unblock_input (); - /* - drawRect: may be called (at least in Mac OS X 10.5) for invisible - views as well for some reason. Thus, do not infer visibility - here. +#ifdef NS_DRAW_TO_BUFFER +- (BOOL)wantsUpdateLayer +{ +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + if (NSAppKitVersionNumber < 1671) + return NO; +#endif + + /* Running on macOS 10.14 or above. */ + return YES; +} + + +- (void)updateLayer +{ + NSTRACE ("[EmacsView updateLayer]"); + + /* This can fail to update the screen if the same surface is + provided twice in a row, even if its contents have changed. + There's a private method, -[CALayer setContentsChanged], that we + could use to force it, but we shouldn't often get the same + surface twice in a row. */ + [[self layer] setContents:(id)[surface getSurface]]; +} +#endif + + +- (void)drawRect: (NSRect)rect +{ + NSTRACE ("[EmacsView drawRect:" NSTRACE_FMT_RECT "]", + NSTRACE_ARG_RECT(rect)); + + if (!emacsframe || !emacsframe->output_data.ns) + return; + + int x = NSMinX (rect), y = NSMinY (rect); + int width = NSWidth (rect), height = NSHeight (rect); - emacsframe->async_visible = 1; - emacsframe->async_iconified = 0; - */ + ns_clear_frame_area (emacsframe, x, y, width, height); + block_input (); + expose_frame (emacsframe, x, y, width, height); + unblock_input (); } @@ -8344,9 +8551,19 @@ not_in_argv (NSString *arg) { return NO; } - /* FIXME: NSFilenamesPboardType is deprecated in 10.14, but the - NSURL method can only handle one file at a time. Stick with the - existing code at the moment. */ +#if NS_USE_NSPasteboardTypeFileURL != 0 + else if ([type isEqualToString: NSPasteboardTypeFileURL]) + { + type_sym = Qfile; + + NSArray *urls = [pb readObjectsForClasses: @[[NSURL self]] + options: nil]; + NSEnumerator *uenum = [urls objectEnumerator]; + NSURL *url; + while ((url = [uenum nextObject])) + strings = Fcons ([[url path] lispString], strings); + } +#else // !NS_USE_NSPasteboardTypeFileURL else if ([type isEqualToString: NSFilenamesPboardType]) { NSArray *files; @@ -8360,8 +8577,9 @@ not_in_argv (NSString *arg) fenum = [files objectEnumerator]; while ( (file = [fenum nextObject]) ) - strings = Fcons (build_string ([file UTF8String]), strings); + strings = Fcons ([file lispString], strings); } +#endif // !NS_USE_NSPasteboardTypeFileURL else if ([type isEqualToString: NSPasteboardTypeURL]) { NSURL *url = [NSURL URLFromPasteboard: pb]; @@ -8369,7 +8587,7 @@ not_in_argv (NSString *arg) type_sym = Qurl; - strings = list1 (build_string ([[url absoluteString] UTF8String])); + strings = list1 ([[url absoluteString] lispString]); } else if ([type isEqualToString: NSPasteboardTypeString] || [type isEqualToString: NSPasteboardTypeTabularText]) @@ -8381,7 +8599,7 @@ not_in_argv (NSString *arg) type_sym = Qnil; - strings = list1 (build_string ([data UTF8String])); + strings = list1 ([data lispString]); } else { @@ -8487,13 +8705,6 @@ not_in_argv (NSString *arg) } -- (void) setRows: (int) r andColumns: (int) c -{ - NSTRACE ("[EmacsView setRows:%d andColumns:%d]", r, c); - rows = r; - cols = c; -} - - (int) fullscreenState { return fs_state; @@ -8511,6 +8722,113 @@ not_in_argv (NSString *arg) @implementation EmacsWindow +/* It seems the only way to reorder child frames is by removing them + from the parent and then reattaching them in the correct order. */ + +- (void)orderFront:(id)sender +{ + NSTRACE ("[EmacsWindow orderFront:]"); + + NSWindow *parent = [self parentWindow]; + if (parent) + { + [parent removeChildWindow:self]; + [parent addChildWindow:self ordered:NSWindowAbove]; + } + else + [super orderFront:sender]; +} + +- (void)makeKeyAndOrderFront:(id)sender +{ + NSTRACE ("[EmacsWindow makeKeyAndOrderFront:]"); + + if ([self parentWindow]) + { + [self orderFront:sender]; + [self makeKeyWindow]; + } + else + [super makeKeyAndOrderFront:sender]; +} + + +/* The array returned by [NSWindow parentWindow] may already be + sorted, but the documentation doesn't tell us whether or not it is, + so to be safe we'll sort it. */ +static NSInteger +nswindow_orderedIndex_sort (id w1, id w2, void *c) +{ + NSInteger i1 = [w1 orderedIndex]; + NSInteger i2 = [w2 orderedIndex]; + + if (i1 > i2) + return NSOrderedAscending; + if (i1 < i2) + return NSOrderedDescending; + + return NSOrderedSame; +} + +- (void)orderBack:(id)sender +{ + NSTRACE ("[EmacsWindow orderBack:]"); + + NSWindow *parent = [self parentWindow]; + if (parent) + { + NSArray *children = [[parent childWindows] + sortedArrayUsingFunction:nswindow_orderedIndex_sort + context:nil]; + [parent removeChildWindow:self]; + [parent addChildWindow:self ordered:NSWindowAbove]; + + for (NSWindow *win in children) + { + if (win != self) + { + [parent removeChildWindow:win]; + [parent addChildWindow:win ordered:NSWindowAbove]; + } + } + } + else + [super orderBack:sender]; +} + +- (BOOL)restackWindow:(NSWindow *)win above:(BOOL)above +{ + NSTRACE ("[EmacsWindow restackWindow:above:]"); + + /* If parent windows don't match we can't restack these frames + without changing the parents. */ + if ([self parentWindow] != [win parentWindow]) + return NO; + else if (![self parentWindow]) + [self orderWindow:(above ? NSWindowAbove : NSWindowBelow) + relativeTo:[win windowNumber]]; + else + { + NSInteger index; + NSWindow *parent = [self parentWindow]; + NSMutableArray *children = [[[parent childWindows] + sortedArrayUsingFunction:nswindow_orderedIndex_sort + context:nil] + mutableCopy]; + [children removeObject:self]; + index = [children indexOfObject:win]; + [children insertObject:self atIndex:(above ? index+1 : index)]; + + for (NSWindow *w in children) + { + [parent removeChildWindow:w]; + [parent addChildWindow:w ordered:NSWindowAbove]; + } + } + + return YES; +} + #ifdef NS_IMPL_COCOA - (id)accessibilityAttributeValue:(NSString *)attribute { @@ -8560,9 +8878,7 @@ not_in_argv (NSString *arg) } if (STRINGP (str)) { - const char *utfStr = SSDATA (str); - NSString *nsStr = [NSString stringWithUTF8String: utfStr]; - return nsStr; + return [NSString stringWithLispString:str]; } } @@ -8747,6 +9063,32 @@ not_in_argv (NSString *arg) #endif } +- (void)setAppearance +{ +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 + struct frame *f = ((EmacsView *)[self delegate])->emacsframe; + NSAppearance *appearance = nil; + + NSTRACE ("[EmacsWindow setAppearance]"); + +#ifndef NSAppKitVersionNumber10_10 +#define NSAppKitVersionNumber10_10 1343 +#endif + + if (NSAppKitVersionNumber < NSAppKitVersionNumber10_10) + return; + + if (FRAME_NS_APPEARANCE (f) == ns_appearance_vibrant_dark) + appearance = + [NSAppearance appearanceNamed:NSAppearanceNameVibrantDark]; + else if (FRAME_NS_APPEARANCE (f) == ns_appearance_aqua) + appearance = + [NSAppearance appearanceNamed:NSAppearanceNameAqua]; + + [self setAppearance:appearance]; +#endif /* MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 */ +} + - (void)setFrame:(NSRect)windowFrame display:(BOOL)displayViews { @@ -9293,6 +9635,210 @@ not_in_argv (NSString *arg) @end /* EmacsScroller */ +#ifdef NS_DRAW_TO_BUFFER + +/* ========================================================================== + + A class to handle the screen buffer. + + ========================================================================== */ + +@implementation EmacsSurface + + +/* An IOSurface is a pixel buffer that is efficiently copied to VRAM + for display. In order to use an IOSurface we must first lock it, + write to it, then unlock it. At this point it is transferred to + VRAM and if we modify it during this transfer we may see corruption + of the output. To avoid this problem we can check if the surface + is "in use", and if it is then avoid using it. Unfortunately to + avoid writing to a surface that's in use, but still maintain the + ability to draw to the screen at any time, we need to keep a cache + of multiple surfaces that we can use at will. + + The EmacsSurface class maintains this cache of surfaces, and + handles the conversion to a CGGraphicsContext that AppKit can use + to draw on. + + The cache is simple: if a free surface is found it is removed from + the cache and set as the "current" surface. Once Emacs is done + with drawing to the current surface, the previous surface that was + drawn to is added to the cache for reuse, and the current one is + set as the last surface. If no free surfaces are found in the + cache then a new one is created. + + When AppKit wants to update the screen, we provide it with the last + surface, as that has the most recent data. + + FIXME: It is possible for the cache to grow if Emacs draws faster + than the surfaces can be drawn to the screen, so there should + probably be some sort of pruning job that removes excess + surfaces. */ + + +- (id) initWithSize: (NSSize)s + ColorSpace: (CGColorSpaceRef)cs +{ + NSTRACE ("[EmacsSurface initWithSize:ColorSpace:]"); + + [super init]; + + cache = [[NSMutableArray arrayWithCapacity:3] retain]; + size = s; + colorSpace = cs; + + return self; +} + + +- (void) dealloc +{ + if (context) + CGContextRelease (context); + + if (currentSurface) + CFRelease (currentSurface); + if (lastSurface) + CFRelease (lastSurface); + + for (id object in cache) + CFRelease ((IOSurfaceRef)object); + + [cache removeAllObjects]; + + [super dealloc]; +} + + +/* Return the size values our cached data is using. */ +- (NSSize) getSize +{ + return size; +} + + +/* Return a CGContextRef that can be used for drawing to the screen. + This must ALWAYS be paired with a call to releaseContext, and the + calls cannot be nested. */ +- (CGContextRef) getContext +{ + IOSurfaceRef surface = NULL; + + NSTRACE ("[EmacsSurface getContextWithSize:]"); + NSTRACE_MSG (@"IOSurface count: %lu", [cache count] + (lastSurface ? 1 : 0)); + + for (id object in cache) + { + if (!IOSurfaceIsInUse ((IOSurfaceRef)object)) + { + surface = (IOSurfaceRef)object; + [cache removeObject:object]; + break; + } + } + + if (!surface) + { + int bytesPerRow = IOSurfaceAlignProperty (kIOSurfaceBytesPerRow, + size.width * 4); + + surface = IOSurfaceCreate + ((CFDictionaryRef)@{(id)kIOSurfaceWidth:[NSNumber numberWithInt:size.width], + (id)kIOSurfaceHeight:[NSNumber numberWithInt:size.height], + (id)kIOSurfaceBytesPerRow:[NSNumber numberWithInt:bytesPerRow], + (id)kIOSurfaceBytesPerElement:[NSNumber numberWithInt:4], + (id)kIOSurfacePixelFormat:[NSNumber numberWithUnsignedInt:'BGRA']}); + } + + IOReturn lockStatus = IOSurfaceLock (surface, 0, nil); + if (lockStatus != kIOReturnSuccess) + NSLog (@"Failed to lock surface: %x", lockStatus); + + [self copyContentsTo:surface]; + + currentSurface = surface; + + context = CGBitmapContextCreate (IOSurfaceGetBaseAddress (currentSurface), + IOSurfaceGetWidth (currentSurface), + IOSurfaceGetHeight (currentSurface), + 8, + IOSurfaceGetBytesPerRow (currentSurface), + colorSpace, + (kCGImageAlphaPremultipliedFirst + | kCGBitmapByteOrder32Host)); + return context; +} + + +/* Releases the CGGraphicsContext and unlocks the associated + IOSurface, so it will be sent to VRAM. */ +- (void) releaseContext +{ + NSTRACE ("[EmacsSurface releaseContextAndGetSurface]"); + + CGContextRelease (context); + context = NULL; + + IOReturn lockStatus = IOSurfaceUnlock (currentSurface, 0, nil); + if (lockStatus != kIOReturnSuccess) + NSLog (@"Failed to unlock surface: %x", lockStatus); + + /* Put lastSurface back on the end of the cache. It may not have + been displayed on the screen yet, but we probably want the new + data and not some stale data anyway. */ + if (lastSurface) + [cache addObject:(id)lastSurface]; + lastSurface = currentSurface; + currentSurface = NULL; +} + + +/* Get the IOSurface that we want to draw to the screen. */ +- (IOSurfaceRef) getSurface +{ + /* lastSurface always contains the most up-to-date and complete data. */ + return lastSurface; +} + + +/* Copy the contents of lastSurface to DESTINATION. This is required + every time we want to use an IOSurface as its contents are probably + blanks (if it's new), or stale. */ +- (void) copyContentsTo: (IOSurfaceRef) destination +{ + IOReturn lockStatus; + void *sourceData, *destinationData; + int numBytes = IOSurfaceGetAllocSize (destination); + + NSTRACE ("[EmacsSurface copyContentsTo:]"); + + if (! lastSurface) + return; + + lockStatus = IOSurfaceLock (lastSurface, kIOSurfaceLockReadOnly, nil); + if (lockStatus != kIOReturnSuccess) + NSLog (@"Failed to lock source surface: %x", lockStatus); + + sourceData = IOSurfaceGetBaseAddress (lastSurface); + destinationData = IOSurfaceGetBaseAddress (destination); + + /* Since every IOSurface should have the exact same settings, a + memcpy seems like the fastest way to copy the data from one to + the other. */ + memcpy (destinationData, sourceData, numBytes); + + lockStatus = IOSurfaceUnlock (lastSurface, kIOSurfaceLockReadOnly, nil); + if (lockStatus != kIOReturnSuccess) + NSLog (@"Failed to unlock source surface: %x", lockStatus); +} + + +@end /* EmacsSurface */ + + +#endif + + #ifdef NS_IMPL_GNUSTEP /* Dummy class to get rid of startup warnings. */ @implementation EmacsDocument diff --git a/src/nsxwidget.h b/src/nsxwidget.h new file mode 100644 index 00000000000..9cc90b0d09a --- /dev/null +++ b/src/nsxwidget.h @@ -0,0 +1,80 @@ +/* Header for NS Cocoa part of xwidget and webkit widget. + +Copyright (C) 2019-2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ + +#ifndef NSXWIDGET_H_INCLUDED +#define NSXWIDGET_H_INCLUDED + +/* This file can be included from non-objc files through 'xwidget.h'. */ +#ifdef __OBJC__ +#import <AppKit/NSView.h> +#endif + +#include "dispextern.h" +#include "lisp.h" +#include "xwidget.h" + +/* Functions for xwidget webkit. */ + +bool nsxwidget_is_web_view (struct xwidget *xw); +Lisp_Object nsxwidget_webkit_uri (struct xwidget *xw); +Lisp_Object nsxwidget_webkit_title (struct xwidget *xw); +void nsxwidget_webkit_goto_uri (struct xwidget *xw, const char *uri); +void nsxwidget_webkit_goto_history (struct xwidget *xw, int rel_pos); +void nsxwidget_webkit_zoom (struct xwidget *xw, double zoom_change); +void nsxwidget_webkit_execute_script (struct xwidget *xw, const char *script, + Lisp_Object fun); + +/* Functions for xwidget model. */ + +#ifdef __OBJC__ +@interface XwWindow : NSView +@property struct xwidget *xw; +@end +#endif + +void nsxwidget_init (struct xwidget *xw); +void nsxwidget_kill (struct xwidget *xw); +void nsxwidget_resize (struct xwidget *xw); +Lisp_Object nsxwidget_get_size (struct xwidget *xw); + +/* Functions for xwidget view. */ + +#ifdef __OBJC__ +@interface XvWindow : NSView +@property struct xwidget *xw; +@property struct xwidget_view *xv; +@end +#endif + +void nsxwidget_init_view (struct xwidget_view *xv, + struct xwidget *xww, + struct glyph_string *s, + int x, int y); +void nsxwidget_delete_view (struct xwidget_view *xv); + +void nsxwidget_show_view (struct xwidget_view *xv); +void nsxwidget_hide_view (struct xwidget_view *xv); +void nsxwidget_resize_view (struct xwidget_view *xv, + int widget, int height); + +void nsxwidget_move_view (struct xwidget_view *xv, int x, int y); +void nsxwidget_move_widget_in_view (struct xwidget_view *xv, int x, int y); +void nsxwidget_set_needsdisplay (struct xwidget_view *xv); + +#endif /* NSXWIDGET_H_INCLUDED */ diff --git a/src/nsxwidget.m b/src/nsxwidget.m new file mode 100644 index 00000000000..eff5f0a9ce8 --- /dev/null +++ b/src/nsxwidget.m @@ -0,0 +1,590 @@ +/* NS Cocoa part implementation of xwidget and webkit widget. + +Copyright (C) 2019-2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#include "lisp.h" +#include "blockinput.h" +#include "dispextern.h" +#include "buffer.h" +#include "frame.h" +#include "nsterm.h" +#include "xwidget.h" + +#import <AppKit/AppKit.h> +#import <WebKit/WebKit.h> + +/* Thoughts on NS Cocoa xwidget and webkit2: + + Webkit2 process architecture seems to be very hostile for offscreen + rendering techniques, which is used by GTK xwidget implementation; + Specifically NSView level view sharing / copying is not working. + + *** So only one view can be associated with a model. *** + + With this decision, implementation is plain and can expect best out + of webkit2's rationale. But process and session structures will + diverge from GTK xwidget. Though, cosmetically similar usages can + be presented and will be preferred, if agreeable. + + For other widget types, OSR seems possible, but will not care for a + while. */ + +/* Xwidget webkit. */ + +@interface XwWebView : WKWebView +<WKNavigationDelegate, WKUIDelegate, WKScriptMessageHandler> +@property struct xwidget *xw; +/* Map url to whether javascript is blocked by + 'Content-Security-Policy' sandbox without allow-scripts. */ +@property(retain) NSMutableDictionary *urlScriptBlocked; +@end +@implementation XwWebView : WKWebView + +- (id)initWithFrame:(CGRect)frame + configuration:(WKWebViewConfiguration *)configuration + xwidget:(struct xwidget *)xw +{ + /* Script controller to add script message handler and user script. */ + WKUserContentController *scriptor = [[WKUserContentController alloc] init]; + configuration.userContentController = scriptor; + + /* Enable inspect element context menu item for debugging. */ + [configuration.preferences setValue:@YES + forKey:@"developerExtrasEnabled"]; + + Lisp_Object enablePlugins = + Fintern (build_string ("xwidget-webkit-enable-plugins"), Qnil); + if (!EQ (Fsymbol_value (enablePlugins), Qnil)) + configuration.preferences.plugInsEnabled = YES; + + self = [super initWithFrame:frame configuration:configuration]; + if (self) + { + self.xw = xw; + self.urlScriptBlocked = [[NSMutableDictionary alloc] init]; + self.navigationDelegate = self; + self.UIDelegate = self; + self.customUserAgent = + @"Mozilla/5.0 (Macintosh; Intel Mac OS X 10_12_6)" + @" AppleWebKit/603.3.8 (KHTML, like Gecko)" + @" Version/11.0.1 Safari/603.3.8"; + [scriptor addScriptMessageHandler:self name:@"keyDown"]; + [scriptor addUserScript:[[WKUserScript alloc] + initWithSource:xwScript + injectionTime: + WKUserScriptInjectionTimeAtDocumentStart + forMainFrameOnly:NO]]; + } + return self; +} + +- (void)webView:(WKWebView *)webView +didFinishNavigation:(WKNavigation *)navigation +{ + if (EQ (Fbuffer_live_p (self.xw->buffer), Qt)) + store_xwidget_event_string (self.xw, "load-changed", ""); +} + +- (void)webView:(WKWebView *)webView +decidePolicyForNavigationAction:(WKNavigationAction *)navigationAction +decisionHandler:(void (^)(WKNavigationActionPolicy))decisionHandler +{ + switch (navigationAction.navigationType) { + case WKNavigationTypeLinkActivated: + decisionHandler (WKNavigationActionPolicyAllow); + break; + default: + // decisionHandler (WKNavigationActionPolicyCancel); + decisionHandler (WKNavigationActionPolicyAllow); + break; + } +} + +- (void)webView:(WKWebView *)webView +decidePolicyForNavigationResponse:(WKNavigationResponse *)navigationResponse +decisionHandler:(void (^)(WKNavigationResponsePolicy))decisionHandler +{ + if (!navigationResponse.canShowMIMEType) + { + NSString *url = navigationResponse.response.URL.absoluteString; + NSString *mimetype = navigationResponse.response.MIMEType; + NSString *filename = navigationResponse.response.suggestedFilename; + decisionHandler (WKNavigationResponsePolicyCancel); + store_xwidget_download_callback_event (self.xw, + url.UTF8String, + mimetype.UTF8String, + filename.UTF8String); + return; + } + decisionHandler (WKNavigationResponsePolicyAllow); + + self.urlScriptBlocked[navigationResponse.response.URL] = + [NSNumber numberWithBool:NO]; + if ([navigationResponse.response isKindOfClass:[NSHTTPURLResponse class]]) + { + NSDictionary *headers = + ((NSHTTPURLResponse *) navigationResponse.response).allHeaderFields; + NSString *value = headers[@"Content-Security-Policy"]; + if (value) + { + /* TODO: Sloppy parsing of 'Content-Security-Policy' value. */ + NSRange sandbox = [value rangeOfString:@"sandbox"]; + if (sandbox.location != NSNotFound + && (sandbox.location == 0 + || [value characterAtIndex:(sandbox.location - 1)] == ' ' + || [value characterAtIndex:(sandbox.location - 1)] == ';')) + { + NSRange allowScripts = [value rangeOfString:@"allow-scripts"]; + if (allowScripts.location == NSNotFound + || allowScripts.location < sandbox.location) + self.urlScriptBlocked[navigationResponse.response.URL] = + [NSNumber numberWithBool:YES]; + } + } + } +} + +/* No additional new webview or emacs window will be created + for <a ... target="_blank">. */ +- (WKWebView *)webView:(WKWebView *)webView +createWebViewWithConfiguration:(WKWebViewConfiguration *)configuration + forNavigationAction:(WKNavigationAction *)navigationAction + windowFeatures:(WKWindowFeatures *)windowFeatures +{ + if (!navigationAction.targetFrame.isMainFrame) + [webView loadRequest:navigationAction.request]; + return nil; +} + +/* Open panel for file upload. */ +- (void)webView:(WKWebView *)webView +runOpenPanelWithParameters:(WKOpenPanelParameters *)parameters +initiatedByFrame:(WKFrameInfo *)frame +completionHandler:(void (^)(NSArray<NSURL *> *URLs))completionHandler +{ + NSOpenPanel *openPanel = [NSOpenPanel openPanel]; + openPanel.canChooseFiles = YES; + openPanel.canChooseDirectories = NO; + openPanel.allowsMultipleSelection = parameters.allowsMultipleSelection; + if ([openPanel runModal] == NSModalResponseOK) + completionHandler (openPanel.URLs); + else + completionHandler (nil); +} + +/* By forwarding mouse events to emacs view (frame) + - Mouse click in webview selects the window contains the webview. + - Correct mouse hand/arrow/I-beam is displayed (TODO: not perfect yet). +*/ + +- (void)mouseDown:(NSEvent *)event +{ + [self.xw->xv->emacswindow mouseDown:event]; + [super mouseDown:event]; +} + +- (void)mouseUp:(NSEvent *)event +{ + [self.xw->xv->emacswindow mouseUp:event]; + [super mouseUp:event]; +} + +/* Basically we want keyboard events handled by emacs unless an input + element has focus. Especially, while incremental search, we set + emacs as first responder to avoid focus held in an input element + with matching text. */ + +- (void)keyDown:(NSEvent *)event +{ + Lisp_Object var = Fintern (build_string ("isearch-mode"), Qnil); + Lisp_Object val = buffer_local_value (var, Fcurrent_buffer ()); + if (!EQ (val, Qunbound) && !EQ (val, Qnil)) + { + [self.window makeFirstResponder:self.xw->xv->emacswindow]; + [self.xw->xv->emacswindow keyDown:event]; + return; + } + + /* Emacs handles keyboard events when javascript is blocked. */ + if ([self.urlScriptBlocked[self.URL] boolValue]) + { + [self.xw->xv->emacswindow keyDown:event]; + return; + } + + [self evaluateJavaScript:@"xwHasFocus()" + completionHandler:^(id result, NSError *error) { + if (error) + { + NSLog (@"xwHasFocus: %@", error); + [self.xw->xv->emacswindow keyDown:event]; + } + else if (result) + { + NSNumber *hasFocus = result; /* __NSCFBoolean */ + if (!hasFocus.boolValue) + [self.xw->xv->emacswindow keyDown:event]; + else + [super keyDown:event]; + } + }]; +} + +- (void)interpretKeyEvents:(NSArray<NSEvent *> *)eventArray +{ + /* We should do nothing and do not forward (default implementation + if we not override here) to let emacs collect key events and ask + interpretKeyEvents to its superclass. */ +} + +static NSString *xwScript; ++ (void)initialize +{ + /* Find out if an input element has focus. + Message to script message handler when 'C-g' key down. */ + if (!xwScript) + xwScript = + @"function xwHasFocus() {" + @" var ae = document.activeElement;" + @" if (ae) {" + @" var name = ae.nodeName;" + @" return name == 'INPUT' || name == 'TEXTAREA';" + @" } else {" + @" return false;" + @" }" + @"}" + @"function xwKeyDown(event) {" + @" if (event.ctrlKey && event.key == 'g') {" + @" window.webkit.messageHandlers.keyDown.postMessage('C-g');" + @" }" + @"}" + @"document.addEventListener('keydown', xwKeyDown);" + ; +} + +/* Confirming to WKScriptMessageHandler, listens concerning keyDown in + webkit. Currently 'C-g'. */ +- (void)userContentController:(WKUserContentController *)userContentController + didReceiveScriptMessage:(WKScriptMessage *)message +{ + if ([message.body isEqualToString:@"C-g"]) + { + /* Just give up focus, no relay "C-g" to emacs, another "C-g" + follows will be handled by emacs. */ + [self.window makeFirstResponder:self.xw->xv->emacswindow]; + } +} + +@end + +/* Xwidget webkit commands. */ + +bool +nsxwidget_is_web_view (struct xwidget *xw) +{ + return xw->xwWidget != NULL && + [xw->xwWidget isKindOfClass:WKWebView.class]; +} + +Lisp_Object +nsxwidget_webkit_uri (struct xwidget *xw) +{ + XwWebView *xwWebView = (XwWebView *) xw->xwWidget; + return [xwWebView.URL.absoluteString lispString]; +} + +Lisp_Object +nsxwidget_webkit_title (struct xwidget *xw) +{ + XwWebView *xwWebView = (XwWebView *) xw->xwWidget; + return [xwWebView.title lispString]; +} + +/* @Note ATS - Need application transport security in 'Info.plist' or + remote pages will not loaded. */ +void +nsxwidget_webkit_goto_uri (struct xwidget *xw, const char *uri) +{ + XwWebView *xwWebView = (XwWebView *) xw->xwWidget; + NSString *urlString = [NSString stringWithUTF8String:uri]; + NSURL *url = [NSURL URLWithString:urlString]; + NSURLRequest *urlRequest = [NSURLRequest requestWithURL:url]; + [xwWebView loadRequest:urlRequest]; +} + +void +nsxwidget_webkit_goto_history (struct xwidget *xw, int rel_pos) +{ + XwWebView *xwWebView = (XwWebView *) xw->xwWidget; + switch (rel_pos) { + case -1: [xwWebView goBack]; break; + case 0: [xwWebView reload]; break; + case 1: [xwWebView goForward]; break; + } +} + +void +nsxwidget_webkit_zoom (struct xwidget *xw, double zoom_change) +{ + XwWebView *xwWebView = (XwWebView *) xw->xwWidget; + xwWebView.magnification += zoom_change; + /* TODO: setMagnification:centeredAtPoint. */ +} + +/* Recursively convert an objc native type JavaScript value to a Lisp + value. Mostly copied from GTK xwidget 'webkit_js_to_lisp'. */ +static Lisp_Object +js_to_lisp (id value) +{ + if (value == nil || [value isKindOfClass:NSNull.class]) + return Qnil; + else if ([value isKindOfClass:NSString.class]) + return [(NSString *) value lispString]; + else if ([value isKindOfClass:NSNumber.class]) + { + NSNumber *nsnum = (NSNumber *) value; + char type = nsnum.objCType[0]; + if (type == 'c') /* __NSCFBoolean has type character 'c'. */ + return nsnum.boolValue? Qt : Qnil; + else + { + if (type == 'i' || type == 'l') + return make_int (nsnum.longValue); + else if (type == 'f' || type == 'd') + return make_float (nsnum.doubleValue); + /* else fall through. */ + } + } + else if ([value isKindOfClass:NSArray.class]) + { + NSArray *nsarr = (NSArray *) value; + EMACS_INT n = nsarr.count; + Lisp_Object obj; + struct Lisp_Vector *p = allocate_nil_vector (n); + + for (ptrdiff_t i = 0; i < n; ++i) + p->contents[i] = js_to_lisp ([nsarr objectAtIndex:i]); + XSETVECTOR (obj, p); + return obj; + } + else if ([value isKindOfClass:NSDictionary.class]) + { + NSDictionary *nsdict = (NSDictionary *) value; + NSArray *keys = nsdict.allKeys; + ptrdiff_t n = keys.count; + Lisp_Object obj; + struct Lisp_Vector *p = allocate_nil_vector (n); + + for (ptrdiff_t i = 0; i < n; ++i) + { + NSString *prop_key = (NSString *) [keys objectAtIndex:i]; + id prop_value = [nsdict valueForKey:prop_key]; + p->contents[i] = Fcons ([prop_key lispString], + js_to_lisp (prop_value)); + } + XSETVECTOR (obj, p); + return obj; + } + NSLog (@"Unhandled type in javascript result"); + return Qnil; +} + +void +nsxwidget_webkit_execute_script (struct xwidget *xw, const char *script, + Lisp_Object fun) +{ + XwWebView *xwWebView = (XwWebView *) xw->xwWidget; + if ([xwWebView.urlScriptBlocked[xwWebView.URL] boolValue]) + { + message ("Javascript is blocked by 'CSP: sandbox'."); + return; + } + + NSString *javascriptString = [NSString stringWithUTF8String:script]; + [xwWebView evaluateJavaScript:javascriptString + completionHandler:^(id result, NSError *error) { + if (error) + { + NSLog (@"evaluateJavaScript error : %@", error.localizedDescription); + NSLog (@"error script=%@", javascriptString); + } + else if (result && FUNCTIONP (fun)) + { + // NSLog (@"result=%@, type=%@", result, [result class]); + Lisp_Object lisp_value = js_to_lisp (result); + store_xwidget_js_callback_event (xw, fun, lisp_value); + } + }]; +} + +/* Window containing an xwidget. */ + +@implementation XwWindow +- (BOOL)isFlipped { return YES; } +@end + +/* Xwidget model, macOS Cocoa part. */ + +void +nsxwidget_init(struct xwidget *xw) +{ + block_input (); + NSRect rect = NSMakeRect (0, 0, xw->width, xw->height); + xw->xwWidget = [[XwWebView alloc] + initWithFrame:rect + configuration:[[WKWebViewConfiguration alloc] init] + xwidget:xw]; + xw->xwWindow = [[XwWindow alloc] + initWithFrame:rect]; + [xw->xwWindow addSubview:xw->xwWidget]; + xw->xv = NULL; /* for 1 to 1 relationship of webkit2. */ + unblock_input (); +} + +void +nsxwidget_kill (struct xwidget *xw) +{ + if (xw) + { + WKUserContentController *scriptor = + ((XwWebView *) xw->xwWidget).configuration.userContentController; + [scriptor removeAllUserScripts]; + [scriptor removeScriptMessageHandlerForName:@"keyDown"]; + [scriptor release]; + if (xw->xv) + xw->xv->model = Qnil; /* Make sure related view stale. */ + + /* This stops playing audio when a xwidget-webkit buffer is + killed. I could not find other solution. */ + nsxwidget_webkit_goto_uri (xw, "about:blank"); + + [((XwWebView *) xw->xwWidget).urlScriptBlocked release]; + [xw->xwWidget removeFromSuperviewWithoutNeedingDisplay]; + [xw->xwWidget release]; + [xw->xwWindow removeFromSuperviewWithoutNeedingDisplay]; + [xw->xwWindow release]; + xw->xwWidget = nil; + } +} + +void +nsxwidget_resize (struct xwidget *xw) +{ + if (xw->xwWidget) + { + [xw->xwWindow setFrameSize:NSMakeSize(xw->width, xw->height)]; + [xw->xwWidget setFrameSize:NSMakeSize(xw->width, xw->height)]; + } +} + +Lisp_Object +nsxwidget_get_size (struct xwidget *xw) +{ + return list2i (xw->xwWidget.frame.size.width, + xw->xwWidget.frame.size.height); +} + +/* Xwidget view, macOS Cocoa part. */ + +@implementation XvWindow : NSView +- (BOOL)isFlipped { return YES; } +@end + +void +nsxwidget_init_view (struct xwidget_view *xv, + struct xwidget *xw, + struct glyph_string *s, + int x, int y) +{ + /* 'x_draw_xwidget_glyph_string' will calculate correct position and + size of clip to draw in emacs buffer window. Thus, just begin at + origin with no crop. */ + xv->x = x; + xv->y = y; + xv->clip_left = 0; + xv->clip_right = xw->width; + xv->clip_top = 0; + xv->clip_bottom = xw->height; + + xv->xvWindow = [[XvWindow alloc] + initWithFrame:NSMakeRect (x, y, xw->width, xw->height)]; + xv->xvWindow.xw = xw; + xv->xvWindow.xv = xv; + + xw->xv = xv; /* For 1 to 1 relationship of webkit2. */ + [xv->xvWindow addSubview:xw->xwWindow]; + + xv->emacswindow = FRAME_NS_VIEW (s->f); + [xv->emacswindow addSubview:xv->xvWindow]; +} + +void +nsxwidget_delete_view (struct xwidget_view *xv) +{ + if (!EQ (xv->model, Qnil)) + { + struct xwidget *xw = XXWIDGET (xv->model); + [xw->xwWindow removeFromSuperviewWithoutNeedingDisplay]; + xw->xv = NULL; /* Now model has no view. */ + } + [xv->xvWindow removeFromSuperviewWithoutNeedingDisplay]; + [xv->xvWindow release]; +} + +void +nsxwidget_show_view (struct xwidget_view *xv) +{ + xv->hidden = NO; + [xv->xvWindow setFrameOrigin:NSMakePoint(xv->x + xv->clip_left, + xv->y + xv->clip_top)]; +} + +void +nsxwidget_hide_view (struct xwidget_view *xv) +{ + xv->hidden = YES; + [xv->xvWindow setFrameOrigin:NSMakePoint(10000, 10000)]; +} + +void +nsxwidget_resize_view (struct xwidget_view *xv, int width, int height) +{ + [xv->xvWindow setFrameSize:NSMakeSize(width, height)]; +} + +void +nsxwidget_move_view (struct xwidget_view *xv, int x, int y) +{ + [xv->xvWindow setFrameOrigin:NSMakePoint (x, y)]; +} + +/* Move model window in container (view window). */ +void +nsxwidget_move_widget_in_view (struct xwidget_view *xv, int x, int y) +{ + struct xwidget *xww = xv->xvWindow.xw; + [xww->xwWindow setFrameOrigin:NSMakePoint (x, y)]; +} + +void +nsxwidget_set_needsdisplay (struct xwidget_view *xv) +{ + xv->xvWindow.needsDisplay = YES; +} diff --git a/src/pdumper.c b/src/pdumper.c index 96f9c13b068..c1388ebbb37 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -71,17 +71,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #ifdef HAVE_PDUMPER #if GNUC_PREREQ (4, 7, 0) -# pragma GCC diagnostic error "-Wconversion" -# pragma GCC diagnostic ignored "-Wsign-conversion" # pragma GCC diagnostic error "-Wshadow" -# define ALLOW_IMPLICIT_CONVERSION \ - _Pragma ("GCC diagnostic push") \ - _Pragma ("GCC diagnostic ignored \"-Wconversion\"") -# define DISALLOW_IMPLICIT_CONVERSION \ - _Pragma ("GCC diagnostic pop") -#else -# define ALLOW_IMPLICIT_CONVERSION ((void) 0) -# define DISALLOW_IMPLICIT_CONVERSION ((void) 0) #endif #define VM_POSIX 1 @@ -105,17 +95,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ # define VM_SUPPORTED 0 #endif -/* PDUMPER_CHECK_REHASHING being true causes the portable dumper to - check, for each hash table it dumps, that the hash table means the - same thing after rehashing. */ -#ifndef PDUMPER_CHECK_REHASHING -# if ENABLE_CHECKING -# define PDUMPER_CHECK_REHASHING 1 -# else -# define PDUMPER_CHECK_REHASHING 0 -# endif -#endif - /* Require an architecture in which pointers, ptrdiff_t and intptr_t are the same size and have the same layout, and where bytes have eight bits --- that is, a general-purpose computer made after 1990. @@ -152,8 +131,11 @@ static int nr_remembered_data = 0; typedef int_least32_t dump_off; #define DUMP_OFF_MIN INT_LEAST32_MIN #define DUMP_OFF_MAX INT_LEAST32_MAX +#define PRIdDUMP_OFF PRIdLEAST32 + +enum { EMACS_INT_XDIGITS = (EMACS_INT_WIDTH + 3) / 4 }; -static void ATTRIBUTE_FORMAT ((printf, 1, 2)) +static void ATTRIBUTE_FORMAT_PRINTF (1, 2) dump_trace (const char *fmt, ...) { if (0) @@ -324,9 +306,7 @@ static void dump_reloc_set_offset (struct dump_reloc *reloc, dump_off offset) { eassert (offset >= 0); - ALLOW_IMPLICIT_CONVERSION; reloc->raw_offset = offset >> DUMP_RELOC_ALIGNMENT_BITS; - DISALLOW_IMPLICIT_CONVERSION; if (dump_reloc_get_offset (*reloc) != offset) error ("dump relocation out of range"); } @@ -401,6 +381,9 @@ struct dump_header The start of the cold region is always aligned on a page boundary. */ dump_off cold_start; + + /* Offset of a vector of the dumped hash tables. */ + dump_off hash_list; }; /* Double-ended singly linked list. */ @@ -558,8 +541,11 @@ struct dump_context heap objects. */ Lisp_Object bignum_data; - unsigned number_hot_relocations; - unsigned number_discardable_relocations; + /* List of hash tables that have been dumped. */ + Lisp_Object hash_tables; + + dump_off number_hot_relocations; + dump_off number_discardable_relocations; }; /* These special values for use as offsets in dump_remember_object and @@ -746,9 +732,7 @@ dump_off_from_lisp (Lisp_Object value) { intmax_t n = intmax_t_from_lisp (value); eassert (DUMP_OFF_MIN <= n && n <= DUMP_OFF_MAX); - ALLOW_IMPLICIT_CONVERSION; return n; - DISALLOW_IMPLICIT_CONVERSION; } static Lisp_Object @@ -965,11 +949,9 @@ dump_queue_init (struct dump_queue *dump_queue) static bool dump_queue_empty_p (struct dump_queue *dump_queue) { - bool is_empty = - EQ (Fhash_table_count (dump_queue->sequence_numbers), - make_fixnum (0)); - eassert (EQ (Fhash_table_count (dump_queue->sequence_numbers), - Fhash_table_count (dump_queue->link_weights))); + ptrdiff_t count = XHASH_TABLE (dump_queue->sequence_numbers)->count; + bool is_empty = count == 0; + eassert (count == XFIXNAT (Fhash_table_count (dump_queue->link_weights))); if (!is_empty) { eassert (!dump_tailq_empty_p (&dump_queue->zero_weight_objects) @@ -1011,9 +993,9 @@ dump_queue_enqueue (struct dump_queue *dump_queue, if (NILP (weights)) { /* Object is new. */ - dump_trace ("new object %016x weight=%u\n", - (unsigned) XLI (object), - (unsigned) weight.value); + EMACS_UINT uobj = XLI (object); + dump_trace ("new object %0*"pI"x weight=%d\n", EMACS_INT_XDIGITS, uobj, + weight.value); if (weight.value == WEIGHT_NONE.value) { @@ -1228,17 +1210,15 @@ dump_queue_dequeue (struct dump_queue *dump_queue, dump_off basis) + dump_tailq_length (&dump_queue->one_weight_normal_objects) + dump_tailq_length (&dump_queue->one_weight_strong_objects))); - bool dump_object_counts = true; - if (dump_object_counts) - dump_trace - ("dump_queue_dequeue basis=%d fancy=%u zero=%u " - "normal=%u strong=%u hash=%u\n", - basis, - (unsigned) dump_tailq_length (&dump_queue->fancy_weight_objects), - (unsigned) dump_tailq_length (&dump_queue->zero_weight_objects), - (unsigned) dump_tailq_length (&dump_queue->one_weight_normal_objects), - (unsigned) dump_tailq_length (&dump_queue->one_weight_strong_objects), - (unsigned) XFIXNUM (Fhash_table_count (dump_queue->link_weights))); + dump_trace + (("dump_queue_dequeue basis=%"PRIdDUMP_OFF" fancy=%"PRIdPTR + " zero=%"PRIdPTR" normal=%"PRIdPTR" strong=%"PRIdPTR" hash=%td\n"), + basis, + dump_tailq_length (&dump_queue->fancy_weight_objects), + dump_tailq_length (&dump_queue->zero_weight_objects), + dump_tailq_length (&dump_queue->one_weight_normal_objects), + dump_tailq_length (&dump_queue->one_weight_strong_objects), + XHASH_TABLE (dump_queue->link_weights)->count); static const int nr_candidates = 3; struct candidate @@ -1311,10 +1291,10 @@ dump_queue_dequeue (struct dump_queue *dump_queue, dump_off basis) else emacs_abort (); - dump_trace (" result score=%f src=%s object=%016x\n", + EMACS_UINT uresult = XLI (result); + dump_trace (" result score=%f src=%s object=%0*"pI"x\n", best < 0 ? -1.0 : (double) candidates[best].score, - src, - (unsigned) XLI (result)); + src, EMACS_INT_XDIGITS, uresult); { Lisp_Object weights = Fgethash (result, dump_queue->link_weights, Qnil); @@ -1837,7 +1817,7 @@ dump_field_lv_or_rawptr (struct dump_context *ctx, /* Now value is the Lisp_Object to which we want to point whether or not the field is a raw pointer (in which case we just synthesized - the Lisp_Object outselves) or a Lisp_Object (in which case we + the Lisp_Object ourselves) or a Lisp_Object (in which case we just copied the thing). Add a fixup or relocation. */ intptr_t out_value; @@ -1928,7 +1908,7 @@ dump_field_fixup_later (struct dump_context *ctx, (void) field_relpos (in_start, in_field); } -/* Mark an output object field, which is as wide as a poiner, as being +/* Mark an output object field, which is as wide as a pointer, as being fixed up to point to a specific offset in the dump. */ static void dump_field_ptr_to_dump_offset (struct dump_context *ctx, @@ -1999,11 +1979,7 @@ static dump_off finish_dump_pvec (struct dump_context *ctx, union vectorlike_header *out_hdr) { - ALLOW_IMPLICIT_CONVERSION; - dump_off result = dump_object_finish (ctx, out_hdr, - vectorlike_nbytes (out_hdr)); - DISALLOW_IMPLICIT_CONVERSION; - return result; + return dump_object_finish (ctx, out_hdr, vectorlike_nbytes (out_hdr)); } static void @@ -2082,7 +2058,7 @@ dump_interval_tree (struct dump_context *ctx, static dump_off dump_string (struct dump_context *ctx, const struct Lisp_String *string) { -#if CHECK_STRUCTS && !defined (HASH_Lisp_String_86FEA6EC7C) +#if CHECK_STRUCTS && !defined (HASH_Lisp_String_348C2B2FDB) # error "Lisp_String changed. See CHECK_STRUCTS comment in config.h." #endif /* If we have text properties, write them _after_ the string so that @@ -2239,7 +2215,7 @@ dump_bignum (struct dump_context *ctx, Lisp_Object object) static dump_off dump_float (struct dump_context *ctx, const struct Lisp_Float *lfloat) { -#if CHECK_STRUCTS && !defined (HASH_Lisp_Float_50A7B216D9) +#if CHECK_STRUCTS && !defined (HASH_Lisp_Float_7E7D284C02) # error "Lisp_Float changed. See CHECK_STRUCTS comment in config.h." #endif eassert (ctx->header.cold_start); @@ -2603,7 +2579,7 @@ dump_vectorlike_generic (struct dump_context *ctx, Lisp_Object out; const Lisp_Object *vslot = &v->contents[i]; /* In the wide case, we're always misaligned. */ -#ifndef WIDE_EMACS_INT +#if INTPTR_MAX == EMACS_INT_MAX eassert (ctx->offset % sizeof (out) == 0); #endif dump_object_start (ctx, &out, sizeof (out)); @@ -2615,78 +2591,65 @@ dump_vectorlike_generic (struct dump_context *ctx, return offset; } -/* Determine whether the hash table's hash order is stable - across dump and load. If it is, we don't have to trigger - a rehash on access. */ -static bool -dump_hash_table_stable_p (const struct Lisp_Hash_Table *hash) +/* Return a vector of KEY, VALUE pairs in the given hash table H. The + first H->count pairs are valid, and the rest are unbound. */ +static Lisp_Object +hash_table_contents (struct Lisp_Hash_Table *h) { - if (hash->test.hashfn == hashfn_user_defined) + if (h->test.hashfn == hashfn_user_defined) error ("cannot dump hash tables with user-defined tests"); /* Bug#36769 */ - bool is_eql = hash->test.hashfn == hashfn_eql; - bool is_equal = hash->test.hashfn == hashfn_equal; - ptrdiff_t size = HASH_TABLE_SIZE (hash); - for (ptrdiff_t i = 0; i < size; ++i) + + ptrdiff_t size = HASH_TABLE_SIZE (h); + Lisp_Object key_and_value = make_uninit_vector (2 * size); + ptrdiff_t n = 0; + + /* Make sure key_and_value ends up in the same order; charset.c + relies on it by expecting hash table indices to stay constant + across the dump. */ + for (ptrdiff_t i = 0; i < size; i++) + if (!NILP (HASH_HASH (h, i))) + { + ASET (key_and_value, n++, HASH_KEY (h, i)); + ASET (key_and_value, n++, HASH_VALUE (h, i)); + } + + while (n < 2 * size) { - Lisp_Object key = HASH_KEY (hash, i); - if (!EQ (key, Qunbound)) - { - bool key_stable = (dump_builtin_symbol_p (key) - || FIXNUMP (key) - || (is_equal - && (STRINGP (key) || BOOL_VECTOR_P (key))) - || ((is_equal || is_eql) - && (FLOATP (key) || BIGNUMP (key)))); - if (!key_stable) - return false; - } + ASET (key_and_value, n++, Qunbound); + ASET (key_and_value, n++, Qnil); } - return true; + return key_and_value; } -/* Return a list of (KEY . VALUE) pairs in the given hash table. */ -static Lisp_Object -hash_table_contents (Lisp_Object table) +static dump_off +dump_hash_table_list (struct dump_context *ctx) { - Lisp_Object contents = Qnil; - struct Lisp_Hash_Table *h = XHASH_TABLE (table); - for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) - { - Lisp_Object key = HASH_KEY (h, i); - if (!EQ (key, Qunbound)) - dump_push (&contents, Fcons (key, HASH_VALUE (h, i))); - } - return Fnreverse (contents); + if (!NILP (ctx->hash_tables)) + return dump_object (ctx, CALLN (Fapply, Qvector, ctx->hash_tables)); + else + return 0; } -/* Copy the given hash table, rehash it, and make sure that we can - look up all the values in the original. */ static void -check_hash_table_rehash (Lisp_Object table_orig) -{ - ptrdiff_t count = XHASH_TABLE (table_orig)->count; - hash_rehash_if_needed (XHASH_TABLE (table_orig)); - Lisp_Object table_rehashed = Fcopy_hash_table (table_orig); - eassert (!hash_rehash_needed_p (XHASH_TABLE (table_rehashed))); - XHASH_TABLE (table_rehashed)->hash = Qnil; - eassert (count == 0 || hash_rehash_needed_p (XHASH_TABLE (table_rehashed))); - hash_rehash_if_needed (XHASH_TABLE (table_rehashed)); - eassert (!hash_rehash_needed_p (XHASH_TABLE (table_rehashed))); - Lisp_Object expected_contents = hash_table_contents (table_orig); - while (!NILP (expected_contents)) - { - Lisp_Object key_value_pair = dump_pop (&expected_contents); - Lisp_Object key = XCAR (key_value_pair); - Lisp_Object expected_value = XCDR (key_value_pair); - Lisp_Object arbitrary = Qdump_emacs_portable__sort_predicate_copied; - Lisp_Object found_value = Fgethash (key, table_rehashed, arbitrary); - eassert (EQ (expected_value, found_value)); - Fremhash (key, table_rehashed); - } +hash_table_freeze (struct Lisp_Hash_Table *h) +{ + ptrdiff_t npairs = ASIZE (h->key_and_value) / 2; + h->key_and_value = hash_table_contents (h); + h->next = h->hash = make_fixnum (npairs); + h->index = make_fixnum (ASIZE (h->index)); + h->next_free = (npairs == h->count ? -1 : h->count); +} + +static void +hash_table_thaw (Lisp_Object hash) +{ + struct Lisp_Hash_Table *h = XHASH_TABLE (hash); + h->hash = make_nil_vector (XFIXNUM (h->hash)); + h->next = Fmake_vector (h->next, make_fixnum (-1)); + h->index = Fmake_vector (h->index, make_fixnum (-1)); - eassert (EQ (Fhash_table_count (table_rehashed), - make_fixnum (0))); + hash_table_rehash (hash); } static dump_off @@ -2694,55 +2657,15 @@ dump_hash_table (struct dump_context *ctx, Lisp_Object object, dump_off offset) { -#if CHECK_STRUCTS && !defined HASH_Lisp_Hash_Table_12AFBF47AF +#if CHECK_STRUCTS && !defined HASH_Lisp_Hash_Table_6D63EDB618 # error "Lisp_Hash_Table changed. See CHECK_STRUCTS comment in config.h." #endif const struct Lisp_Hash_Table *hash_in = XHASH_TABLE (object); - bool is_stable = dump_hash_table_stable_p (hash_in); - /* If the hash table is likely to be modified in memory (either - because we need to rehash, and thus toggle hash->count, or - because we need to assemble a list of weak tables) punt the hash - table to the end of the dump, where we can lump all such hash - tables together. */ - if (!(is_stable || !NILP (hash_in->weak)) - && ctx->flags.defer_hash_tables) - { - if (offset != DUMP_OBJECT_ON_HASH_TABLE_QUEUE) - { - eassert (offset == DUMP_OBJECT_ON_NORMAL_QUEUE - || offset == DUMP_OBJECT_NOT_SEEN); - /* We still want to dump the actual keys and values now. */ - dump_enqueue_object (ctx, hash_in->key_and_value, WEIGHT_NONE); - /* We'll get to the rest later. */ - offset = DUMP_OBJECT_ON_HASH_TABLE_QUEUE; - dump_remember_object (ctx, object, offset); - dump_push (&ctx->deferred_hash_tables, object); - } - return offset; - } - - if (PDUMPER_CHECK_REHASHING) - check_hash_table_rehash (make_lisp_ptr ((void *) hash_in, Lisp_Vectorlike)); - struct Lisp_Hash_Table hash_munged = *hash_in; struct Lisp_Hash_Table *hash = &hash_munged; - /* Remember to rehash this hash table on first access. After a - dump reload, the hash table values will have changed, so we'll - need to rebuild the index. - - TODO: for EQ and EQL hash tables, it should be possible to rehash - here using the preferred load address of the dump, eliminating - the need to rehash-on-access if we can load the dump where we - want. */ - if (hash->count > 0 && !is_stable) - /* Hash codes will have to be recomputed anyway, so let's not dump them. - Also set `hash` to nil for hash_rehash_needed_p. - We could also refrain from dumping the `next' and `index' vectors, - except that `next' is currently used for HASH_TABLE_SIZE and - we'd have to rebuild the next_free list as well as adjust - sweep_weak_hash_table for the case where there's no `index'. */ - hash->hash = Qnil; + hash_table_freeze (hash); + dump_push (&ctx->hash_tables, object); START_DUMP_PVEC (ctx, &hash->header, struct Lisp_Hash_Table, out); dump_pseudovector_lisp_fields (ctx, &out->header, &hash->header); @@ -2769,7 +2692,7 @@ dump_hash_table (struct dump_context *ctx, static dump_off dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer) { -#if CHECK_STRUCTS && !defined HASH_buffer_375A10F5E5 +#if CHECK_STRUCTS && !defined HASH_buffer_99D642C1CB # error "buffer changed. See CHECK_STRUCTS comment in config.h." #endif struct buffer munged_buffer = *in_buffer; @@ -2845,8 +2768,6 @@ dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer) ctx->obj_offset + dump_offsetof (struct buffer, text), base_offset + dump_offsetof (struct buffer, own_text)); - dump_field_lv_rawptr (ctx, out, buffer, &buffer->next, - Lisp_Vectorlike, WEIGHT_NORMAL); DUMP_FIELD_COPY (out, buffer, pt); DUMP_FIELD_COPY (out, buffer, pt_byte); DUMP_FIELD_COPY (out, buffer, begv); @@ -2961,7 +2882,7 @@ dump_vectorlike (struct dump_context *ctx, Lisp_Object lv, dump_off offset) { -#if CHECK_STRUCTS && !defined HASH_pvec_type_E55BD36F8E +#if CHECK_STRUCTS && !defined HASH_pvec_type_A4A6E9984D # error "pvec_type changed. See CHECK_STRUCTS comment in config.h." #endif const struct Lisp_Vector *v = XVECTOR (lv); @@ -3069,7 +2990,7 @@ dump_vectorlike (struct dump_context *ctx, static dump_off dump_object (struct dump_context *ctx, Lisp_Object object) { -#if CHECK_STRUCTS && !defined (HASH_Lisp_Type_E2AD97D3F7) +#if CHECK_STRUCTS && !defined (HASH_Lisp_Type_45F0582FD7) # error "Lisp_Type changed. See CHECK_STRUCTS comment in config.h." #endif eassert (!EQ (object, dead_object ())); @@ -3356,9 +3277,7 @@ static void dump_cold_charset (struct dump_context *ctx, Lisp_Object data) { /* Dump charset lookup tables. */ - ALLOW_IMPLICIT_CONVERSION; int cs_i = XFIXNUM (XCAR (data)); - DISALLOW_IMPLICIT_CONVERSION; dump_off cs_dump_offset = dump_off_from_lisp (XCDR (data)); dump_remember_fixup_ptr_raw (ctx, @@ -3604,14 +3523,12 @@ dump_unwind_cleanup (void *data) Vprocess_environment = ctx->old_process_environment; } -/* Return DUMP_OFFSET, making sure it is within the heap. */ -static dump_off +/* Check that DUMP_OFFSET is within the heap. */ +static void dump_check_dump_off (struct dump_context *ctx, dump_off dump_offset) { eassert (dump_offset > 0); - if (ctx) - eassert (dump_offset < ctx->end_heap); - return dump_offset; + eassert (!ctx || dump_offset < ctx->end_heap); } static void @@ -3668,9 +3585,7 @@ static struct emacs_reloc decode_emacs_reloc (struct dump_context *ctx, Lisp_Object lreloc) { struct emacs_reloc reloc = {0}; - ALLOW_IMPLICIT_CONVERSION; int type = XFIXNUM (dump_pop (&lreloc)); - DISALLOW_IMPLICIT_CONVERSION; reloc.emacs_offset = dump_off_from_lisp (dump_pop (&lreloc)); dump_check_emacs_off (reloc.emacs_offset); switch (type) @@ -3681,9 +3596,7 @@ decode_emacs_reloc (struct dump_context *ctx, Lisp_Object lreloc) reloc.u.dump_offset = dump_off_from_lisp (dump_pop (&lreloc)); dump_check_dump_off (ctx, reloc.u.dump_offset); dump_off length = dump_off_from_lisp (dump_pop (&lreloc)); - ALLOW_IMPLICIT_CONVERSION; reloc.length = length; - DISALLOW_IMPLICIT_CONVERSION; if (reloc.length != length) error ("relocation copy length too large"); } @@ -3694,9 +3607,7 @@ decode_emacs_reloc (struct dump_context *ctx, Lisp_Object lreloc) intmax_t value = intmax_t_from_lisp (dump_pop (&lreloc)); dump_off size = dump_off_from_lisp (dump_pop (&lreloc)); reloc.u.immediate = value; - ALLOW_IMPLICIT_CONVERSION; reloc.length = size; - DISALLOW_IMPLICIT_CONVERSION; eassert (reloc.length == size); } break; @@ -3721,9 +3632,7 @@ decode_emacs_reloc (struct dump_context *ctx, Lisp_Object lreloc) RELOC_EMACS_IMMEDIATE relocation instead. */ eassert (!dump_object_self_representing_p (target_value)); int tag_type = XTYPE (target_value); - ALLOW_IMPLICIT_CONVERSION; reloc.length = tag_type; - DISALLOW_IMPLICIT_CONVERSION; eassert (reloc.length == tag_type); if (type == RELOC_EMACS_EMACS_LV) @@ -3734,6 +3643,7 @@ decode_emacs_reloc (struct dump_context *ctx, Lisp_Object lreloc) } else { + eassume (ctx); /* Pacify GCC 9.2.1 -O3 -Wnull-dereference. */ eassert (!dump_object_emacs_ptr (target_value)); reloc.u.dump_offset = dump_recall_object (ctx, target_value); if (reloc.u.dump_offset <= 0) @@ -3797,9 +3707,7 @@ dump_merge_emacs_relocs (Lisp_Object lreloc_a, Lisp_Object lreloc_b) return Qnil; dump_off new_length = reloc_a.length + reloc_b.length; - ALLOW_IMPLICIT_CONVERSION; reloc_a.length = new_length; - DISALLOW_IMPLICIT_CONVERSION; if (reloc_a.length != new_length) return Qnil; /* Overflow */ @@ -4116,7 +4024,7 @@ types. */) ctx->header.fingerprint[i] = fingerprint[i]; const dump_off header_start = ctx->offset; - dump_fingerprint ("dumping fingerprint", ctx->header.fingerprint); + dump_fingerprint ("Dumping fingerprint", ctx->header.fingerprint); dump_write (ctx, &ctx->header, sizeof (ctx->header)); const dump_off header_end = ctx->offset; @@ -4153,6 +4061,19 @@ types. */) || !NILP (ctx->deferred_hash_tables) || !NILP (ctx->deferred_symbols)); + ctx->header.hash_list = ctx->offset; + dump_hash_table_list (ctx); + + do + { + dump_drain_deferred_hash_tables (ctx); + dump_drain_deferred_symbols (ctx); + dump_drain_normal_queue (ctx); + } + while (!dump_queue_empty_p (&ctx->dump_queue) + || !NILP (ctx->deferred_hash_tables) + || !NILP (ctx->deferred_symbols)); + dump_sort_copied_objects (ctx); /* While we copy built-in symbols into the Emacs image, these @@ -4212,9 +4133,9 @@ types. */) of the dump. */ drain_reloc_list (ctx, dump_emit_dump_reloc, emacs_reloc_merger, &ctx->dump_relocs, &ctx->header.dump_relocs); - unsigned number_hot_relocations = ctx->number_hot_relocations; + dump_off number_hot_relocations = ctx->number_hot_relocations; ctx->number_hot_relocations = 0; - unsigned number_discardable_relocations = ctx->number_discardable_relocations; + dump_off number_discardable_relocations = ctx->number_discardable_relocations; ctx->number_discardable_relocations = 0; drain_reloc_list (ctx, dump_emit_dump_reloc, emacs_reloc_merger, &ctx->object_starts, &ctx->header.object_starts); @@ -4238,14 +4159,17 @@ types. */) dump_seek (ctx, 0); dump_write (ctx, &ctx->header, sizeof (ctx->header)); + dump_off + header_bytes = header_end - header_start, + hot_bytes = hot_end - hot_start, + discardable_bytes = discardable_end - ctx->header.discardable_start, + cold_bytes = cold_end - ctx->header.cold_start; fprintf (stderr, ("Dump complete\n" - "Byte counts: header=%lu hot=%lu discardable=%lu cold=%lu\n" - "Reloc counts: hot=%u discardable=%u\n"), - (unsigned long) (header_end - header_start), - (unsigned long) (hot_end - hot_start), - (unsigned long) (discardable_end - ctx->header.discardable_start), - (unsigned long) (cold_end - ctx->header.cold_start), + "Byte counts: header=%"PRIdDUMP_OFF" hot=%"PRIdDUMP_OFF + " discardable=%"PRIdDUMP_OFF" cold=%"PRIdDUMP_OFF"\n" + "Reloc counts: hot=%"PRIdDUMP_OFF" discardable=%"PRIdDUMP_OFF"\n"), + header_bytes, hot_bytes, discardable_bytes, cold_bytes, number_hot_relocations, number_discardable_relocations); @@ -4682,15 +4606,15 @@ dump_mmap_contiguous_heap (struct dump_memory_map *maps, int nr_maps, Beware: the simple patch 2019-03-11T15:20:54Z!eggert@cs.ucla.edu is worse, as it sometimes frees this storage twice. */ struct dump_memory_map_heap_control_block *cb = calloc (1, sizeof (*cb)); - - char *mem; if (!cb) goto out; + __lsan_ignore_object (cb); + cb->refcount = 1; cb->mem = malloc (total_size); if (!cb->mem) goto out; - mem = cb->mem; + char *mem = cb->mem; for (int i = 0; i < nr_maps; ++i) { struct dump_memory_map *map = &maps[i]; @@ -4878,14 +4802,19 @@ struct dump_bitset }; static bool -dump_bitset_init (struct dump_bitset *bitset, size_t number_bits) +dump_bitsets_init (struct dump_bitset bitset[2], size_t number_bits) { - int xword_size = sizeof (bitset->bits[0]); + int xword_size = sizeof (bitset[0].bits[0]); int bits_per_word = xword_size * CHAR_BIT; ptrdiff_t words_needed = divide_round_up (number_bits, bits_per_word); - bitset->number_words = words_needed; - bitset->bits = calloc (words_needed, xword_size); - return bitset->bits != NULL; + dump_bitset_word *bits = calloc (words_needed, 2 * xword_size); + if (!bits) + return false; + bitset[0].bits = bits; + bitset[0].number_words = bitset[1].number_words = words_needed; + bitset[1].bits = memset (bits + words_needed, UCHAR_MAX, + words_needed * xword_size); + return true; } static dump_bitset_word * @@ -4946,7 +4875,7 @@ struct pdumper_loaded_dump_private /* Copy of the header we read from the dump. */ struct dump_header header; /* Mark bits for objects in the dump; used during GC. */ - struct dump_bitset mark_bits; + struct dump_bitset mark_bits, last_mark_bits; /* Time taken to load the dump. */ double load_time; /* Dump file name. */ @@ -5069,6 +4998,10 @@ pdumper_find_object_type_impl (const void *obj) dump_off offset = ptrdiff_t_to_dump_off ((uintptr_t) obj - dump_public.start); if (offset % DUMP_ALIGNMENT != 0) return PDUMPER_NO_OBJECT; + ptrdiff_t bitno = offset / DUMP_ALIGNMENT; + if (offset < dump_private.header.discardable_start + && !dump_bitset_bit_set_p (&dump_private.last_mark_bits, bitno)) + return PDUMPER_NO_OBJECT; const struct dump_reloc *reloc = dump_find_relocation (&dump_private.header.object_starts, offset); return (reloc != NULL && dump_reloc_get_offset (*reloc) == offset) @@ -5097,12 +5030,16 @@ pdumper_set_marked_impl (const void *obj) eassert (offset < dump_private.header.cold_start); eassert (offset < dump_private.header.discardable_start); ptrdiff_t bitno = offset / DUMP_ALIGNMENT; + eassert (dump_bitset_bit_set_p (&dump_private.last_mark_bits, bitno)); dump_bitset_set_bit (&dump_private.mark_bits, bitno); } void pdumper_clear_marks_impl (void) { + dump_bitset_word *swap = dump_private.last_mark_bits.bits; + dump_private.last_mark_bits.bits = dump_private.mark_bits.bits; + dump_private.mark_bits.bits = swap; dump_bitset_clear (&dump_private.mark_bits); } @@ -5111,14 +5048,13 @@ dump_read_all (int fd, void *buf, size_t bytes_to_read) { /* We don't want to use emacs_read, since that relies on the lisp world, and we're not in the lisp world yet. */ - eassert (bytes_to_read <= SSIZE_MAX); size_t bytes_read = 0; while (bytes_read < bytes_to_read) { - /* Some platforms accept only int-sized values to read. */ - unsigned chunk_to_read = INT_MAX; - if (bytes_to_read - bytes_read < chunk_to_read) - chunk_to_read = (unsigned) (bytes_to_read - bytes_read); + /* Some platforms accept only int-sized values to read. + Round this down to a page size (see MAX_RW_COUNT in sysdep.c). */ + int max_rw_count = INT_MAX >> 18 << 18; + int chunk_to_read = min (bytes_to_read - bytes_read, max_rw_count); ssize_t chunk = read (fd, (char *) buf + bytes_read, chunk_to_read); if (chunk < 0) return chunk; @@ -5304,6 +5240,9 @@ enum dump_section NUMBER_DUMP_SECTIONS, }; +/* Pointer to a stack variable to avoid having to staticpro it. */ +static Lisp_Object *pdumper_hashes = &zero_vector; + /* Load a dump from DUMP_FILENAME. Return an error code. N.B. We run very early in initialization, so we can't use lisp, @@ -5317,7 +5256,7 @@ pdumper_load (const char *dump_filename) int dump_page_size; dump_off adj_discardable_start; - struct dump_bitset mark_bits; + struct dump_bitset mark_bits[2]; size_t mark_bits_needed; struct dump_header header_buf = { 0 }; @@ -5334,7 +5273,7 @@ pdumper_load (const char *dump_filename) eassert (!dump_loaded_p ()); int err; - int dump_fd = emacs_open (dump_filename, O_RDONLY, 0); + int dump_fd = emacs_open_noquit (dump_filename, O_RDONLY, 0); if (dump_fd < 0) { err = (errno == ENOENT || errno == ENOTDIR @@ -5431,7 +5370,7 @@ pdumper_load (const char *dump_filename) err = PDUMPER_LOAD_ERROR; mark_bits_needed = divide_round_up (header->discardable_start, DUMP_ALIGNMENT); - if (!dump_bitset_init (&mark_bits, mark_bits_needed)) + if (!dump_bitsets_init (mark_bits, mark_bits_needed)) goto out; /* Point of no return. */ @@ -5439,7 +5378,8 @@ pdumper_load (const char *dump_filename) dump_base = (uintptr_t) sections[DS_HOT].mapping; gflags.dumped_with_pdumper_ = true; dump_private.header = *header; - dump_private.mark_bits = mark_bits; + dump_private.mark_bits = mark_bits[0]; + dump_private.last_mark_bits = mark_bits[1]; dump_public.start = dump_base; dump_public.end = dump_public.start + dump_size; @@ -5450,6 +5390,15 @@ pdumper_load (const char *dump_filename) for (int i = 0; i < ARRAYELTS (sections); ++i) dump_mmap_reset (§ions[i]); + Lisp_Object hashes = zero_vector; + if (header->hash_list) + { + struct Lisp_Vector *hash_tables = + (struct Lisp_Vector *) (dump_base + header->hash_list); + hashes = make_lisp_ptr (hash_tables, Lisp_Vectorlike); + } + + pdumper_hashes = &hashes; /* Run the functions Emacs registered for doing post-dump-load initialization. */ for (int i = 0; i < nr_dump_hooks; ++i) @@ -5520,6 +5469,19 @@ Value is nil if this session was not started using a dump file.*/) #endif /* HAVE_PDUMPER */ +static void +thaw_hash_tables (void) +{ + Lisp_Object hash_tables = *pdumper_hashes; + for (ptrdiff_t i = 0; i < ASIZE (hash_tables); i++) + hash_table_thaw (AREF (hash_tables, i)); +} + +void +init_pdumper_once (void) +{ + pdumper_do_now_and_after_load (thaw_hash_tables); +} void syms_of_pdumper (void) diff --git a/src/pdumper.h b/src/pdumper.h index d36bc766e74..ed665ac6c2f 100644 --- a/src/pdumper.h +++ b/src/pdumper.h @@ -256,6 +256,7 @@ pdumper_clear_marks (void) file was loaded. */ extern void pdumper_record_wd (const char *); +void init_pdumper_once (void); void syms_of_pdumper (void); INLINE_HEADER_END diff --git a/src/print.c b/src/print.c index f61155ea263..14af9195475 100644 --- a/src/print.c +++ b/src/print.c @@ -368,8 +368,8 @@ strout (const char *ptr, ptrdiff_t size, ptrdiff_t size_byte, int len; for (ptrdiff_t i = 0; i < size_byte; i += len) { - int ch = STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr + i, - len); + int ch = string_char_and_length ((const unsigned char *) ptr + i, + &len); printchar_to_stream (ch, stdout); } } @@ -400,8 +400,8 @@ strout (const char *ptr, ptrdiff_t size, ptrdiff_t size_byte, int len; for (i = 0; i < size_byte; i += len) { - int ch = STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr + i, - len); + int ch = string_char_and_length ((const unsigned char *) ptr + i, + &len); insert_char (ch); } } @@ -426,9 +426,8 @@ strout (const char *ptr, ptrdiff_t size, ptrdiff_t size_byte, /* Here, we must convert each multi-byte form to the corresponding character code before handing it to PRINTCHAR. */ - int len; - int ch = STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr + i, - len); + int len, ch = (string_char_and_length + ((const unsigned char *) ptr + i, &len)); printchar (ch, printcharfun); i += len; } @@ -510,8 +509,7 @@ print_string (Lisp_Object string, Lisp_Object printcharfun) { /* Here, we must convert each multi-byte form to the corresponding character code before handing it to PRINTCHAR. */ - int len; - int ch = STRING_CHAR_AND_LENGTH (SDATA (string) + i, len); + int len, ch = string_char_and_length (SDATA (string) + i, &len); printchar (ch, printcharfun); i += len; } @@ -564,7 +562,7 @@ temp_output_buffer_setup (const char *bufname) record_unwind_current_buffer (); - Fset_buffer (Fget_buffer_create (build_string (bufname))); + Fset_buffer (Fget_buffer_create (build_string (bufname), Qnil)); Fkill_all_local_variables (); delete_all_overlays (current_buffer); @@ -943,7 +941,7 @@ print_error_message (Lisp_Object data, Lisp_Object stream, const char *context, else { Lisp_Object error_conditions = Fget (errname, Qerror_conditions); - errmsg = Fsubstitute_command_keys (Fget (errname, Qerror_message)); + errmsg = call1 (Qsubstitute_command_keys, Fget (errname, Qerror_message)); file_error = Fmemq (Qfile_error, error_conditions); } @@ -1307,15 +1305,13 @@ print_check_string_charset_prop (INTERVAL interval, Lisp_Object string) } if (! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND)) { - int i, c; ptrdiff_t charpos = interval->position; ptrdiff_t bytepos = string_char_to_byte (string, charpos); - Lisp_Object charset; + Lisp_Object charset = XCAR (XCDR (val)); - charset = XCAR (XCDR (val)); - for (i = 0; i < LENGTH (interval); i++) + for (ptrdiff_t i = 0; i < LENGTH (interval); i++) { - FETCH_STRING_CHAR_ADVANCE (c, string, charpos, bytepos); + int c = fetch_string_char_advance (string, &charpos, &bytepos); if (! ASCII_CHAR_P (c) && ! EQ (CHARSET_NAME (CHAR_CHARSET (c)), charset)) { @@ -1365,6 +1361,22 @@ data_from_funcptr (void (*funcptr) (void)) interchangeably, so it's OK to assume that here too. */ return (void const *) funcptr; } + +/* Print the value of the pointer PTR. */ + +static void +print_pointer (Lisp_Object printcharfun, char *buf, const char *prefix, + const void *ptr) +{ + uintptr_t ui = (uintptr_t) ptr; + + /* In theory this assignment could lose info on pre-C99 hosts, but + in practice it doesn't. */ + uintmax_t up = ui; + + int len = sprintf (buf, "%s 0x%" PRIxMAX, prefix, up); + strout (buf, len, len, printcharfun); +} #endif static bool @@ -1545,7 +1557,8 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, /* Implement a readable output, e.g.: #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */ /* Always print the size. */ - int len = sprintf (buf, "#s(hash-table size %"pD"d", ASIZE (h->next)); + int len = sprintf (buf, "#s(hash-table size %"pD"d", + HASH_TABLE_SIZE (h)); strout (buf, len, len, printcharfun); if (!NILP (h->test.name)) @@ -1578,27 +1591,34 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, /* Print the data here as a plist. */ ptrdiff_t real_size = HASH_TABLE_SIZE (h); - ptrdiff_t size = real_size; + ptrdiff_t size = h->count; /* Don't print more elements than the specified maximum. */ if (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size) size = XFIXNAT (Vprint_length); printchar ('(', printcharfun); - for (ptrdiff_t i = 0; i < size; i++) + ptrdiff_t j = 0; + for (ptrdiff_t i = 0; i < real_size; i++) { Lisp_Object key = HASH_KEY (h, i); if (!EQ (key, Qunbound)) { - if (i) printchar (' ', printcharfun); + if (j++) printchar (' ', printcharfun); print_object (key, printcharfun, escapeflag); printchar (' ', printcharfun); print_object (HASH_VALUE (h, i), printcharfun, escapeflag); + if (j == size) + break; } } - if (size < real_size) - print_c_string (" ...", printcharfun); + if (j < h->count) + { + if (j) + printchar (' ', printcharfun); + print_c_string ("...", printcharfun); + } print_c_string ("))", printcharfun); } @@ -1796,26 +1816,22 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, case PVEC_MODULE_FUNCTION: { print_c_string ("#<module function ", printcharfun); - module_funcptr ptr = module_function_address (XMODULE_FUNCTION (obj)); + const struct Lisp_Module_Function *function = XMODULE_FUNCTION (obj); + module_funcptr ptr = module_function_address (function); char const *file; char const *symbol; dynlib_addr (ptr, &file, &symbol); if (symbol == NULL) - { - uintptr_t ui = (uintptr_t) data_from_funcptr (ptr); - - /* In theory this assignment could lose info on pre-C99 - hosts, but in practice it doesn't. */ - uintmax_t up = ui; - - int len = sprintf (buf, "at 0x%"PRIxMAX, up); - strout (buf, len, len, printcharfun); - } - else + print_pointer (printcharfun, buf, "at", data_from_funcptr (ptr)); + else print_c_string (symbol, printcharfun); - if (file != NULL) + void *data = module_function_data (function); + if (data != NULL) + print_pointer (printcharfun, buf, " with data", data); + + if (file != NULL) { print_c_string (" from ", printcharfun); print_c_string (file, printcharfun); @@ -1833,12 +1849,30 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, return true; } +static char +named_escape (int i) +{ + switch (i) + { + case '\b': return 'b'; + case '\t': return 't'; + case '\n': return 'n'; + case '\f': return 'f'; + case '\r': return 'r'; + case ' ': return 's'; + /* \a, \v, \e and \d are excluded from printing as escapes since + they are somewhat rare as characters and more likely to be + plain integers. */ + } + return 0; +} + static void print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { char buf[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT), max (sizeof " . #" + INT_STRLEN_BOUND (intmax_t), - max ((sizeof "at 0x" + max ((sizeof " with data 0x" + (sizeof (uintmax_t) * CHAR_BIT + 4 - 1) / 4), 40)))]; current_thread->stack_top = buf; @@ -1893,8 +1927,32 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { case_Lisp_Int: { - int len = sprintf (buf, "%"pI"d", XFIXNUM (obj)); - strout (buf, len, len, printcharfun); + EMACS_INT i = XFIXNUM (obj); + char escaped_name; + + if (print_integers_as_characters && i >= 0 && i <= MAX_UNICODE_CHAR + && ((escaped_name = named_escape (i)) + || graphic_base_p (i))) + { + printchar ('?', printcharfun); + if (escaped_name) + { + printchar ('\\', printcharfun); + i = escaped_name; + } + else if (escapeflag + && (i == ';' || i == '\"' || i == '\'' || i == '\\' + || i == '(' || i == ')' + || i == '{' || i == '}' + || i == '[' || i == ']')) + printchar ('\\', printcharfun); + printchar (i, printcharfun); + } + else + { + int len = sprintf (buf, "%"pI"d", i); + strout (buf, len, len, printcharfun); + } } break; @@ -1914,7 +1972,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) ptrdiff_t i, i_byte; ptrdiff_t size_byte; /* True means we must ensure that the next character we output - cannot be taken as part of a hex character escape. */ + cannot be taken as part of a hex character escape. */ bool need_nonhex = false; bool multibyte = STRING_MULTIBYTE (obj); @@ -1931,9 +1989,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { /* Here, we must convert each multi-byte form to the corresponding character code before handing it to printchar. */ - int c; - - FETCH_STRING_CHAR_ADVANCE (c, obj, i, i_byte); + int c = fetch_string_char_advance (obj, &i, &i_byte); maybe_quit (); @@ -1963,25 +2019,29 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) /* If we just had a hex escape, and this character could be taken as part of it, output `\ ' to prevent that. */ - if (c_isxdigit (c)) - { - if (need_nonhex) - print_c_string ("\\ ", printcharfun); - printchar (c, printcharfun); - } - else if (c == '\n' && print_escape_newlines - ? (c = 'n', true) - : c == '\f' && print_escape_newlines - ? (c = 'f', true) - : c == '\"' || c == '\\') - { - printchar ('\\', printcharfun); - printchar (c, printcharfun); - } - else if (print_escape_control_characters && c_iscntrl (c)) + if (c_isxdigit (c)) + { + if (need_nonhex) + print_c_string ("\\ ", printcharfun); + printchar (c, printcharfun); + } + else if (c == '\n' && print_escape_newlines + ? (c = 'n', true) + : c == '\f' && print_escape_newlines + ? (c = 'f', true) + : c == '\"' || c == '\\') + { + printchar ('\\', printcharfun); + printchar (c, printcharfun); + } + else if (print_escape_control_characters && c_iscntrl (c)) octalout (c, SDATA (obj), i_byte, size_byte, printcharfun); - else - printchar (c, printcharfun); + else if (!multibyte + && SINGLE_BYTE_CHAR_P (c) + && !ASCII_CHAR_P (c)) + printchar (BYTE8_TO_CHAR (c), printcharfun); + else + printchar (c, printcharfun); need_nonhex = false; } } @@ -2011,7 +2071,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) && len == size_byte); if (! NILP (Vprint_gensym) - && !SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (obj)) + && !SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (obj)) print_c_string ("#:", printcharfun); else if (size_byte == 0) { @@ -2024,8 +2084,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { /* Here, we must convert each multi-byte form to the corresponding character code before handing it to PRINTCHAR. */ - int c; - FETCH_STRING_CHAR_ADVANCE (c, name, i, i_byte); + int c = fetch_string_char_advance (name, &i, &i_byte); maybe_quit (); if (escapeflag) @@ -2035,7 +2094,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) || c == ',' || c == '.' || c == '`' || c == '[' || c == ']' || c == '?' || c <= 040 || c == NO_BREAK_SPACE - || confusing) + || confusing) { printchar ('\\', printcharfun); confusing = false; @@ -2100,7 +2159,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) if (!NILP (Vprint_circle)) { - /* With the print-circle feature. */ + /* With the print-circle feature. */ Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil); if (FIXNUMP (num)) @@ -2152,7 +2211,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { int len; /* We're in trouble if this happens! - Probably should just emacs_abort (). */ + Probably should just emacs_abort (). */ print_c_string ("#<EMACS BUG: INVALID DATATYPE ", printcharfun); if (VECTORLIKEP (obj)) len = sprintf (buf, "(PVEC 0x%08zx)", (size_t) ASIZE (obj)); @@ -2231,6 +2290,14 @@ A value of nil means to use the shortest notation that represents the number without losing information. */); Vfloat_output_format = Qnil; + DEFVAR_BOOL ("print-integers-as-characters", print_integers_as_characters, + doc: /* Non-nil means integers are printed using characters syntax. +Only independent graphic characters, and control characters with named +escape sequences such as newline, are printed this way. Other +integers, including those corresponding to raw bytes, are printed +as numbers the usual way. */); + print_integers_as_characters = false; + DEFVAR_LISP ("print-length", Vprint_length, doc: /* Maximum length of list to print before abbreviating. A value of nil means no limit. See also `eval-expression-print-length'. */); diff --git a/src/process.c b/src/process.c index 1bfbf38f6ba..3beb9cf7146 100644 --- a/src/process.c +++ b/src/process.c @@ -80,15 +80,6 @@ static struct rlimit nofile_limit; #endif -#ifdef NEED_BSDTTY -#include <bsdtty.h> -#endif - -#ifdef USG5_4 -# include <sys/stream.h> -# include <sys/stropts.h> -#endif - #ifdef HAVE_UTIL_H #include <util.h> #endif @@ -292,6 +283,18 @@ static int max_desc; the file descriptor of a socket that is already bound. */ static int external_sock_fd; +/* File descriptor that becomes readable when we receive SIGCHLD. */ +static int child_signal_read_fd = -1; +/* The write end thereof. The SIGCHLD handler writes to this file + descriptor to notify `wait_reading_process_output' of process + status changes. */ +static int child_signal_write_fd = -1; +static void child_signal_init (void); +#ifndef WINDOWSNT +static void child_signal_read (int, void *); +#endif +static void child_signal_notify (void); + /* Indexed by descriptor, gives the process (if any) for that descriptor. */ static Lisp_Object chan_process[FD_SETSIZE]; static void wait_for_socket_fds (Lisp_Object, char const *); @@ -465,6 +468,7 @@ add_read_fd (int fd, fd_callback func, void *data) { add_keyboard_wait_descriptor (fd); + eassert (0 <= fd && fd < FD_SETSIZE); fd_callback_info[fd].func = func; fd_callback_info[fd].data = data; } @@ -485,6 +489,7 @@ static void add_process_read_fd (int fd) { add_non_keyboard_read_fd (fd); + eassert (0 <= fd && fd < FD_SETSIZE); fd_callback_info[fd].flags |= PROCESS_FD; } @@ -495,6 +500,7 @@ delete_read_fd (int fd) { delete_keyboard_wait_descriptor (fd); + eassert (0 <= fd && fd < FD_SETSIZE); if (fd_callback_info[fd].flags == 0) { fd_callback_info[fd].func = 0; @@ -534,6 +540,7 @@ recompute_max_desc (void) { int fd; + eassert (max_desc < FD_SETSIZE); for (fd = max_desc; fd >= 0; --fd) { if (fd_callback_info[fd].flags != 0) @@ -542,6 +549,7 @@ recompute_max_desc (void) break; } } + eassert (max_desc < FD_SETSIZE); } /* Stop monitoring file descriptor FD for when write is possible. */ @@ -549,6 +557,7 @@ recompute_max_desc (void) void delete_write_fd (int fd) { + eassert (0 <= fd && fd < FD_SETSIZE); if ((fd_callback_info[fd].flags & NON_BLOCKING_CONNECT_FD) != 0) { if (--num_pending_connects < 0) @@ -571,6 +580,7 @@ compute_input_wait_mask (fd_set *mask) int fd; FD_ZERO (mask); + eassert (max_desc < FD_SETSIZE); for (fd = 0; fd <= max_desc; ++fd) { if (fd_callback_info[fd].thread != NULL @@ -593,6 +603,7 @@ compute_non_process_wait_mask (fd_set *mask) int fd; FD_ZERO (mask); + eassert (max_desc < FD_SETSIZE); for (fd = 0; fd <= max_desc; ++fd) { if (fd_callback_info[fd].thread != NULL @@ -616,6 +627,7 @@ compute_non_keyboard_wait_mask (fd_set *mask) int fd; FD_ZERO (mask); + eassert (max_desc < FD_SETSIZE); for (fd = 0; fd <= max_desc; ++fd) { if (fd_callback_info[fd].thread != NULL @@ -639,6 +651,7 @@ compute_write_mask (fd_set *mask) int fd; FD_ZERO (mask); + eassert (max_desc < FD_SETSIZE); for (fd = 0; fd <= max_desc; ++fd) { if (fd_callback_info[fd].thread != NULL @@ -660,6 +673,7 @@ clear_waiting_thread_info (void) { int fd; + eassert (max_desc < FD_SETSIZE); for (fd = 0; fd <= max_desc; ++fd) { if (fd_callback_info[fd].waiting_thread == current_thread) @@ -690,8 +704,7 @@ status_convert (int w) if (WIFSTOPPED (w)) return Fcons (Qstop, Fcons (make_fixnum (WSTOPSIG (w)), Qnil)); else if (WIFEXITED (w)) - return Fcons (Qexit, Fcons (make_fixnum (WEXITSTATUS (w)), - WCOREDUMP (w) ? Qt : Qnil)); + return Fcons (Qexit, Fcons (make_fixnum (WEXITSTATUS (w)), Qnil)); else if (WIFSIGNALED (w)) return Fcons (Qsignal, Fcons (make_fixnum (WTERMSIG (w)), WCOREDUMP (w) ? Qt : Qnil)); @@ -936,8 +949,10 @@ update_processes_for_thread_death (Lisp_Object dying_thread) struct Lisp_Process *proc = XPROCESS (process); pset_thread (proc, Qnil); + eassert (proc->infd < FD_SETSIZE); if (proc->infd >= 0) fd_callback_info[proc->infd].thread = NULL; + eassert (proc->outfd < FD_SETSIZE); if (proc->outfd >= 0) fd_callback_info[proc->outfd].thread = NULL; } @@ -1205,6 +1220,16 @@ not the name of the pty that Emacs uses to talk with that terminal. */) return XPROCESS (process)->tty_name; } +static void +update_process_mark (struct Lisp_Process *p) +{ + Lisp_Object buffer = p->buffer; + if (BUFFERP (buffer)) + set_marker_both (p->mark, buffer, + BUF_ZV (XBUFFER (buffer)), + BUF_ZV_BYTE (XBUFFER (buffer))); +} + DEFUN ("set-process-buffer", Fset_process_buffer, Sset_process_buffer, 2, 2, 0, doc: /* Set buffer associated with PROCESS to BUFFER (a buffer, or nil). @@ -1217,7 +1242,11 @@ Return BUFFER. */) if (!NILP (buffer)) CHECK_BUFFER (buffer); p = XPROCESS (process); - pset_buffer (p, buffer); + if (!EQ (p->buffer, buffer)) + { + pset_buffer (p, buffer); + update_process_mark (p); + } if (NETCONN1_P (p) || SERIALCONN1_P (p) || PIPECONN1_P (p)) pset_childp (p, Fplist_put (p->childp, QCbuffer, buffer)); setup_process_coding_systems (process); @@ -1364,8 +1393,10 @@ If THREAD is nil, the process is unlocked. */) proc = XPROCESS (process); pset_thread (proc, thread); + eassert (proc->infd < FD_SETSIZE); if (proc->infd >= 0) fd_callback_info[proc->infd].thread = tstate; + eassert (proc->outfd < FD_SETSIZE); if (proc->outfd >= 0) fd_callback_info[proc->outfd].thread = tstate; @@ -1392,14 +1423,12 @@ nil otherwise. */) CHECK_PROCESS (process); /* All known platforms store window sizes as 'unsigned short'. */ - CHECK_RANGED_INTEGER (height, 0, USHRT_MAX); - CHECK_RANGED_INTEGER (width, 0, USHRT_MAX); + unsigned short h = check_uinteger_max (height, USHRT_MAX); + unsigned short w = check_uinteger_max (width, USHRT_MAX); if (NETCONN_P (process) || XPROCESS (process)->infd < 0 - || (set_window_size (XPROCESS (process)->infd, - XFIXNUM (height), XFIXNUM (width)) - < 0)) + || set_window_size (XPROCESS (process)->infd, h, w) < 0) return Qnil; else return Qt; @@ -1639,6 +1668,7 @@ DEFUN ("process-list", Fprocess_list, Sprocess_list, 0, 0, 0, return Fmapcar (Qcdr, Vprocess_alist); } + /* Starting asynchronous inferior processes. */ DEFUN ("make-process", Fmake_process, Smake_process, 0, MANY, 0, @@ -1656,7 +1686,10 @@ you specify a filter function to handle the output. BUFFER may be also nil, meaning that this process is not associated with any buffer. :command COMMAND -- COMMAND is a list starting with the program file -name, followed by strings to give to the program as arguments. +name, followed by strings to give to the program as arguments. If the +program file name is not an absolute file name, `make-process' will +look for the program file name in `exec-path' (which is a list of +directories). :coding CODING -- If CODING is a symbol, it specifies the coding system used for both reading and writing for this process. If CODING @@ -1715,7 +1748,7 @@ usage: (make-process &rest ARGS) */) buffer = Fplist_get (contact, QCbuffer); if (!NILP (buffer)) - buffer = Fget_buffer_create (buffer); + buffer = Fget_buffer_create (buffer, Qnil); /* Make sure that the child will be able to chdir to the current buffer's current directory, or its unhandled equivalent. We @@ -1752,7 +1785,7 @@ usage: (make-process &rest ARGS) */) QCname, concat2 (name, build_string (" stderr")), QCbuffer, - Fget_buffer_create (xstderr), + Fget_buffer_create (xstderr, Qnil), QCnoquery, query_on_exit ? Qnil : Qt); } @@ -1804,10 +1837,7 @@ usage: (make-process &rest ARGS) */) : EQ (Vprocess_adaptive_read_buffering, Qt) ? 1 : 2); /* Make the process marker point into the process buffer (if any). */ - if (BUFFERP (buffer)) - set_marker_both (XPROCESS (proc)->mark, buffer, - BUF_ZV (XBUFFER (buffer)), - BUF_ZV_BYTE (XBUFFER (buffer))); + update_process_mark (XPROCESS (proc)); USE_SAFE_ALLOCA; @@ -2034,7 +2064,7 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) { struct Lisp_Process *p = XPROCESS (process); int inchannel, outchannel; - pid_t pid; + pid_t pid = -1; int vfork_errno; int forkin, forkout, forkerr = -1; bool pty_flag = 0; @@ -2042,6 +2072,10 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) Lisp_Object lisp_pty_name = Qnil; sigset_t oldset; + /* Ensure that the SIGCHLD handler can notify + `wait_reading_process_output'. */ + child_signal_init (); + inchannel = outchannel = -1; if (p->pty_flag) @@ -2087,6 +2121,9 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) } } + if (FD_SETSIZE <= inchannel || FD_SETSIZE <= outchannel) + report_file_errno ("Creating pipe", Qnil, EMFILE); + #ifndef WINDOWSNT if (emacs_pipe (p->open_fd + READ_FROM_EXEC_MONITOR) != 0) report_file_error ("Creating pipe", Qnil); @@ -2096,6 +2133,7 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) fcntl (outchannel, F_SETFL, O_NONBLOCK); /* Record this as an active process, with its channels. */ + eassert (0 <= inchannel && inchannel < FD_SETSIZE); chan_process[inchannel] = process; p->infd = inchannel; p->outfd = outchannel; @@ -2111,145 +2149,25 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) if (!EQ (p->command, Qt)) add_process_read_fd (inchannel); + ptrdiff_t count = SPECPDL_INDEX (); + /* This may signal an error. */ setup_process_coding_systems (process); + char **env = make_environment_block (current_dir); block_input (); block_child_signal (&oldset); -#ifndef WINDOWSNT - /* vfork, and prevent local vars from being clobbered by the vfork. */ - Lisp_Object volatile current_dir_volatile = current_dir; - Lisp_Object volatile lisp_pty_name_volatile = lisp_pty_name; - char **volatile new_argv_volatile = new_argv; - int volatile forkin_volatile = forkin; - int volatile forkout_volatile = forkout; - int volatile forkerr_volatile = forkerr; - struct Lisp_Process *p_volatile = p; - -#ifdef DARWIN_OS - /* Darwin doesn't let us run setsid after a vfork, so use fork when - necessary. Also, reset SIGCHLD handling after a vfork, as - apparently macOS can mistakenly deliver SIGCHLD to the child. */ - if (pty_flag) - pid = fork (); - else - { - pid = vfork (); - if (pid == 0) - signal (SIGCHLD, SIG_DFL); - } -#else - pid = vfork (); -#endif - - current_dir = current_dir_volatile; - lisp_pty_name = lisp_pty_name_volatile; - new_argv = new_argv_volatile; - forkin = forkin_volatile; - forkout = forkout_volatile; - forkerr = forkerr_volatile; - p = p_volatile; - pty_flag = p->pty_flag; + eassert (pty_flag == ! NILP (lisp_pty_name)); - if (pid == 0) -#endif /* not WINDOWSNT */ - { - /* Make the pty be the controlling terminal of the process. */ -#ifdef HAVE_PTYS - dissociate_controlling_tty (); - - /* Make the pty's terminal the controlling terminal. */ - if (pty_flag && forkin >= 0) - { -#ifdef TIOCSCTTY - /* We ignore the return value - because faith@cs.unc.edu says that is necessary on Linux. */ - ioctl (forkin, TIOCSCTTY, 0); -#endif - } -#if defined (LDISC1) - if (pty_flag && forkin >= 0) - { - struct termios t; - tcgetattr (forkin, &t); - t.c_lflag = LDISC1; - if (tcsetattr (forkin, TCSANOW, &t) < 0) - emacs_perror ("create_process/tcsetattr LDISC1"); - } -#else -#if defined (NTTYDISC) && defined (TIOCSETD) - if (pty_flag && forkin >= 0) - { - /* Use new line discipline. */ - int ldisc = NTTYDISC; - ioctl (forkin, TIOCSETD, &ldisc); - } -#endif -#endif - -#if !defined (DONT_REOPEN_PTY) -/*** There is a suggestion that this ought to be a - conditional on TIOCSPGRP, or !defined TIOCSCTTY. - Trying the latter gave the wrong results on Debian GNU/Linux 1.1; - that system does seem to need this code, even though - both TIOCSCTTY is defined. */ - /* Now close the pty (if we had it open) and reopen it. - This makes the pty the controlling terminal of the subprocess. */ - if (pty_flag) - { - - /* I wonder if emacs_close (emacs_open (SSDATA (lisp_pty_name), ...)) - would work? */ - if (forkin >= 0) - emacs_close (forkin); - forkout = forkin = emacs_open (SSDATA (lisp_pty_name), O_RDWR, 0); - - if (forkin < 0) - { - emacs_perror (SSDATA (lisp_pty_name)); - _exit (EXIT_CANCELED); - } - - } -#endif /* not DONT_REOPEN_PTY */ - -#ifdef SETUP_SLAVE_PTY - if (pty_flag) - { - SETUP_SLAVE_PTY; - } -#endif /* SETUP_SLAVE_PTY */ -#endif /* HAVE_PTYS */ - - signal (SIGINT, SIG_DFL); - signal (SIGQUIT, SIG_DFL); -#ifdef SIGPROF - signal (SIGPROF, SIG_DFL); -#endif - - /* Emacs ignores SIGPIPE, but the child should not. */ - signal (SIGPIPE, SIG_DFL); - - /* Stop blocking SIGCHLD in the child. */ - unblock_child_signal (&oldset); - - if (pty_flag) - child_setup_tty (forkout); + vfork_errno + = emacs_spawn (&pid, forkin, forkout, forkerr, new_argv, env, + SSDATA (current_dir), + pty_flag ? SSDATA (lisp_pty_name) : NULL, &oldset); - if (forkerr < 0) - forkerr = forkout; -#ifdef WINDOWSNT - pid = child_setup (forkin, forkout, forkerr, new_argv, 1, current_dir); -#else /* not WINDOWSNT */ - child_setup (forkin, forkout, forkerr, new_argv, 1, current_dir); -#endif /* not WINDOWSNT */ - } + eassert ((vfork_errno == 0) == (0 < pid)); - /* Back in the parent process. */ - - vfork_errno = errno; p->pid = pid; if (pid >= 0) p->alive = 1; @@ -2258,6 +2176,9 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) unblock_child_signal (&oldset); unblock_input (); + /* Environment block no longer needed. */ + unbind_to (count, Qnil); + if (pid < 0) report_file_errno (CHILD_SETUP_ERROR_DESC, Qnil, vfork_errno); else @@ -2306,6 +2227,8 @@ create_pty (Lisp_Object process) if (pty_fd >= 0) { p->open_fd[SUBPROCESS_STDIN] = pty_fd; + if (FD_SETSIZE <= pty_fd) + report_file_errno ("Opening pty", Qnil, EMFILE); #if ! defined (USG) || defined (USG_SUBTTY_WORKS) /* On most USG systems it does not work to open the pty's tty here, then close it and reopen it in the child. */ @@ -2327,6 +2250,7 @@ create_pty (Lisp_Object process) /* Record this as an active process, with its channels. As a result, child_setup will close Emacs's side of the pipes. */ + eassert (0 <= pty_fd && pty_fd < FD_SETSIZE); chan_process[pty_fd] = process; p->infd = pty_fd; p->outfd = pty_fd; @@ -2412,6 +2336,9 @@ usage: (make-pipe-process &rest ARGS) */) outchannel = p->open_fd[WRITE_TO_SUBPROCESS]; inchannel = p->open_fd[READ_FROM_SUBPROCESS]; + if (FD_SETSIZE <= inchannel || FD_SETSIZE <= outchannel) + report_file_errno ("Creating pipe", Qnil, EMFILE); + fcntl (inchannel, F_SETFL, O_NONBLOCK); fcntl (outchannel, F_SETFL, O_NONBLOCK); @@ -2420,6 +2347,7 @@ usage: (make-pipe-process &rest ARGS) */) #endif /* Record this as an active process, with its channels. */ + eassert (0 <= inchannel && inchannel < FD_SETSIZE); chan_process[inchannel] = proc; p->infd = inchannel; p->outfd = outchannel; @@ -2430,7 +2358,7 @@ usage: (make-pipe-process &rest ARGS) */) buffer = Fplist_get (contact, QCbuffer); if (NILP (buffer)) buffer = name; - buffer = Fget_buffer_create (buffer); + buffer = Fget_buffer_create (buffer, Qnil); pset_buffer (p, buffer); pset_childp (p, contact); @@ -2452,10 +2380,7 @@ usage: (make-pipe-process &rest ARGS) */) : EQ (Vprocess_adaptive_read_buffering, Qt) ? 1 : 2); /* Make the process marker point into the process buffer (if any). */ - if (BUFFERP (buffer)) - set_marker_both (p->mark, buffer, - BUF_ZV (XBUFFER (buffer)), - BUF_ZV_BYTE (XBUFFER (buffer))); + update_process_mark (p); { /* Setup coding systems for communicating with the network stream. */ @@ -2752,6 +2677,7 @@ set up yet, this function will block until socket setup has completed. */) return Qnil; channel = XPROCESS (process)->infd; + eassert (0 <= channel && channel < FD_SETSIZE); return conv_sockaddr_to_lisp (datagram_address[channel].sa, datagram_address[channel].len); } @@ -2780,6 +2706,7 @@ set up yet, this function will block until socket setup has completed. */) channel = XPROCESS (process)->infd; len = get_lisp_to_sockaddr_size (address, &family); + eassert (0 <= channel && channel < FD_SETSIZE); if (len == 0 || datagram_address[channel].len != len) return Qnil; conv_lisp_to_sockaddr (family, address, datagram_address[channel].sa, len); @@ -3154,16 +3081,19 @@ usage: (make-serial-process &rest ARGS) */) fd = serial_open (port); p->open_fd[SUBPROCESS_STDIN] = fd; + if (FD_SETSIZE <= fd) + report_file_errno ("Opening serial port", port, EMFILE); p->infd = fd; p->outfd = fd; if (fd > max_desc) max_desc = fd; + eassert (0 <= fd && fd < FD_SETSIZE); chan_process[fd] = proc; buffer = Fplist_get (contact, QCbuffer); if (NILP (buffer)) buffer = name; - buffer = Fget_buffer_create (buffer); + buffer = Fget_buffer_create (buffer, Qnil); pset_buffer (p, buffer); pset_childp (p, contact); @@ -3181,21 +3111,14 @@ usage: (make-serial-process &rest ARGS) */) if (!EQ (p->command, Qt)) add_process_read_fd (fd); - if (BUFFERP (buffer)) - { - set_marker_both (p->mark, buffer, - BUF_ZV (XBUFFER (buffer)), - BUF_ZV_BYTE (XBUFFER (buffer))); - } + update_process_mark (p); - tem = Fplist_member (contact, QCcoding); - if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem)))) - tem = Qnil; + tem = Fplist_get (contact, QCcoding); val = Qnil; if (!NILP (tem)) { - val = XCAR (XCDR (tem)); + val = tem; if (CONSP (val)) val = XCAR (val); } @@ -3209,7 +3132,7 @@ usage: (make-serial-process &rest ARGS) */) val = Qnil; if (!NILP (tem)) { - val = XCAR (XCDR (tem)); + val = tem; if (CONSP (val)) val = XCDR (val); } @@ -3244,16 +3167,14 @@ set_network_socket_coding_system (Lisp_Object proc, Lisp_Object host, Lisp_Object coding_systems = Qt; Lisp_Object val; - tem = Fplist_member (contact, QCcoding); - if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem)))) - tem = Qnil; /* No error message (too late!). */ + tem = Fplist_get (contact, QCcoding); /* Setup coding systems for communicating with the network stream. */ /* Qt denotes we have not yet called Ffind_operation_coding_system. */ if (!NILP (tem)) { - val = XCAR (XCDR (tem)); + val = tem; if (CONSP (val)) val = XCAR (val); } @@ -3287,7 +3208,7 @@ set_network_socket_coding_system (Lisp_Object proc, Lisp_Object host, if (!NILP (tem)) { - val = XCAR (XCDR (tem)); + val = tem; if (CONSP (val)) val = XCDR (val); } @@ -3337,6 +3258,7 @@ finish_after_tls_connection (Lisp_Object proc) Fplist_get (contact, QChost), Fplist_get (contact, QCservice)); + eassert (p->outfd < FD_SETSIZE); if (NILP (result)) { pset_status (p, list2 (Qfailed, @@ -3382,6 +3304,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, if (!NILP (use_external_socket_p)) { socket_to_use = external_sock_fd; + eassert (socket_to_use < FD_SETSIZE); /* Ensure we don't consume the external socket twice. */ external_sock_fd = -1; @@ -3423,6 +3346,14 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, xerrno = errno; continue; } + /* Reject file descriptors that would be too large. */ + if (FD_SETSIZE <= s) + { + emacs_close (s); + s = -1; + xerrno = EMFILE; + continue; + } } if (p->is_non_blocking_client && ! (SOCK_NONBLOCK && socket_to_use < 0)) @@ -3587,6 +3518,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, #ifdef DATAGRAM_SOCKETS if (p->socktype == SOCK_DGRAM) { + eassert (0 <= s && s < FD_SETSIZE); if (datagram_address[s].sa) emacs_abort (); @@ -3651,6 +3583,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, inch = s; outch = s; + eassert (0 <= inch && inch < FD_SETSIZE); chan_process[inch] = proc; fcntl (inch, F_SETFL, O_NONBLOCK); @@ -3667,10 +3600,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, pset_status (p, Qlisten); /* Make the process marker point into the process buffer (if any). */ - if (BUFFERP (p->buffer)) - set_marker_both (p->mark, p->buffer, - BUF_ZV (XBUFFER (p->buffer)), - BUF_ZV_BYTE (XBUFFER (p->buffer))); + update_process_mark (p); if (p->is_non_blocking_client) { @@ -3680,6 +3610,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, if (! (connecting_status (p->status) && EQ (XCDR (p->status), addrinfos))) pset_status (p, Fcons (Qconnect, addrinfos)); + eassert (0 <= inch && inch < FD_SETSIZE); if ((fd_callback_info[inch].flags & NON_BLOCKING_CONNECT_FD) == 0) add_non_blocking_write_fd (inch); } @@ -4190,7 +4121,7 @@ usage: (make-network-process &rest ARGS) */) open_socket: if (!NILP (buffer)) - buffer = Fget_buffer_create (buffer); + buffer = Fget_buffer_create (buffer, Qnil); /* Unwind bind_polling_period. */ unbind_to (count, Qnil); @@ -4639,6 +4570,12 @@ network_lookup_address_info_1 (Lisp_Object host, const char *service, if (STRING_MULTIBYTE (host) && SBYTES (host) != SCHARS (host)) error ("Non-ASCII hostname %s detected, please use puny-encode-domain", SSDATA (host)); + +#ifdef WINDOWSNT + /* Ensure socket support is loaded if available. */ + init_winsock (TRUE); +#endif + ret = getaddrinfo (SSDATA (host), service, hints, res); if (ret) { @@ -4742,6 +4679,7 @@ deactivate_process (Lisp_Object proc) close_process_fd (&p->open_fd[i]); inchannel = p->infd; + eassert (inchannel < FD_SETSIZE); if (inchannel >= 0) { p->infd = -1; @@ -4878,6 +4816,13 @@ server_accept_connection (Lisp_Object server, int channel) s = accept4 (channel, &saddr.sa, &len, SOCK_CLOEXEC); + if (FD_SETSIZE <= s) + { + emacs_close (s); + s = -1; + errno = EMFILE; + } + if (s < 0) { int code = errno; @@ -4964,7 +4909,7 @@ server_accept_connection (Lisp_Object server, int channel) if (!NILP (buffer)) { args[1] = buffer; - buffer = Fget_buffer_create (Fformat (nargs, args)); + buffer = Fget_buffer_create (Fformat (nargs, args), Qnil); } } @@ -4975,6 +4920,7 @@ server_accept_connection (Lisp_Object server, int channel) Lisp_Object name = Fformat (nargs, args); Lisp_Object proc = make_process (name); + eassert (0 <= s && s < FD_SETSIZE); chan_process[s] = proc; fcntl (s, F_SETFL, O_NONBLOCK); @@ -5254,6 +5200,8 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (! NILP (wait_for_cell) && ! NILP (XCAR (wait_for_cell))) break; + eassert (max_desc < FD_SETSIZE); + #if defined HAVE_GETADDRINFO_A || defined HAVE_GNUTLS { Lisp_Object process_list_head, aproc; @@ -5331,19 +5279,9 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, do { unsigned old_timers_run = timers_run; - struct buffer *old_buffer = current_buffer; - Lisp_Object old_window = selected_window; timer_delay = timer_check (); - /* If a timer has run, this might have changed buffers - an alike. Make read_key_sequence aware of that. */ - if (timers_run != old_timers_run - && (old_buffer != current_buffer - || !EQ (old_window, selected_window)) - && waiting_for_user_input_p == -1) - record_asynch_buffer_change (); - if (timers_run != old_timers_run && do_display) /* We must retry, since a timer may have requeued itself and that could alter the time_delay. */ @@ -5387,6 +5325,15 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, compute_input_wait_mask (&Atemp); compute_write_mask (&Ctemp); + /* If a process status has changed, the child signal pipe + will likely be readable. We want to ignore it for now, + because otherwise we wouldn't run into a timeout + below. */ + int fd = child_signal_read_fd; + eassert (fd < FD_SETSIZE); + if (0 <= fd) + FD_CLR (fd, &Atemp); + timeout = make_timespec (0, 0); if ((thread_select (pselect, max_desc + 1, &Atemp, @@ -5417,14 +5364,16 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, /* If data can be read from the process, do so until exhausted. */ if (wait_proc->infd >= 0) { + unsigned int count = 0; XSETPROCESS (proc, wait_proc); while (true) { int nread = read_process_output (proc, wait_proc->infd); + rarely_quit (++count); if (nread < 0) { - if (errno == EIO || would_block (errno)) + if (errno != EINTR) break; } else @@ -5471,6 +5420,14 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, check_write = true; } + /* We have to be informed when we receive a SIGCHLD signal for + an asynchronous process. Otherwise this might deadlock if we + receive a SIGCHLD during `pselect'. */ + int child_fd = child_signal_read_fd; + eassert (child_fd < FD_SETSIZE); + if (0 <= child_fd) + FD_SET (child_fd, &Available); + /* If frame size has changed or the window is newly mapped, redisplay now, before we start to wait. There is a race condition here; if a SIGIO arrives between now and the select @@ -5498,6 +5455,10 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, } else { +#ifdef HAVE_GNUTLS + int tls_nfds; + fd_set tls_available; +#endif /* Set the timeout for adaptive read buffering if any process has non-zero read_output_skip and non-zero read_output_delay, and we are not reading output for a @@ -5567,7 +5528,36 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, } #endif -/* Non-macOS HAVE_GLIB builds call thread_select in xgselect.c. */ +#ifdef HAVE_GNUTLS + /* GnuTLS buffers data internally. We need to check if some + data is available in the buffers manually before the select. + And if so, we need to skip the select which could block. */ + FD_ZERO (&tls_available); + tls_nfds = 0; + for (channel = 0; channel < FD_SETSIZE; ++channel) + if (! NILP (chan_process[channel]) + && FD_ISSET (channel, &Available)) + { + struct Lisp_Process *p = XPROCESS (chan_process[channel]); + if (p + && p->gnutls_p && p->gnutls_state + && emacs_gnutls_record_check_pending (p->gnutls_state) > 0) + { + tls_nfds++; + eassert (p->infd == channel); + FD_SET (p->infd, &tls_available); + } + } + /* If wait_proc is somebody else, we have to wait in select + as usual. Otherwise, clobber the timeout. */ + if (tls_nfds > 0 + && (!wait_proc || + (wait_proc->infd >= 0 + && FD_ISSET (wait_proc->infd, &tls_available)))) + timeout = make_timespec (0, 0); +#endif + + /* Non-macOS HAVE_GLIB builds call thread_select in xgselect.c. */ #if defined HAVE_GLIB && !defined HAVE_NS nfds = xg_select (max_desc + 1, &Available, (check_write ? &Writeok : 0), @@ -5585,59 +5575,21 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, #endif /* !HAVE_GLIB */ #ifdef HAVE_GNUTLS - /* GnuTLS buffers data internally. In lowat mode it leaves - some data in the TCP buffers so that select works, but - with custom pull/push functions we need to check if some - data is available in the buffers manually. */ - if (nfds == 0) + /* Merge tls_available into Available. */ + if (tls_nfds > 0) { - fd_set tls_available; - int set = 0; - - FD_ZERO (&tls_available); - if (! wait_proc) + if (nfds == 0 || (nfds < 0 && errno == EINTR)) { - /* We're not waiting on a specific process, so loop - through all the channels and check for data. - This is a workaround needed for some versions of - the gnutls library -- 2.12.14 has been confirmed - to need it. */ - for (channel = 0; channel < FD_SETSIZE; ++channel) - if (! NILP (chan_process[channel])) - { - struct Lisp_Process *p = - XPROCESS (chan_process[channel]); - if (p && p->gnutls_p && p->gnutls_state - && ((emacs_gnutls_record_check_pending - (p->gnutls_state)) - > 0)) - { - nfds++; - eassert (p->infd == channel); - FD_SET (p->infd, &tls_available); - set++; - } - } + /* Fast path, just copy. */ + nfds = tls_nfds; + Available = tls_available; } - else - { - /* Check this specific channel. */ - if (wait_proc->gnutls_p /* Check for valid process. */ - && wait_proc->gnutls_state - /* Do we have pending data? */ - && ((emacs_gnutls_record_check_pending - (wait_proc->gnutls_state)) - > 0)) - { - nfds = 1; - eassert (0 <= wait_proc->infd); - /* Set to Available. */ - FD_SET (wait_proc->infd, &tls_available); - set++; - } - } - if (set) - Available = tls_available; + else if (nfds > 0) + /* Slow path, merge one by one. Note: nfds does not need + to be accurate, just positive is enough. */ + for (channel = 0; channel < FD_SETSIZE; ++channel) + if (FD_ISSET(channel, &tls_available)) + FD_SET(channel, &Available); } #endif } @@ -5700,9 +5652,6 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, if (read_kbd != 0) { - unsigned old_timers_run = timers_run; - struct buffer *old_buffer = current_buffer; - Lisp_Object old_window = selected_window; bool leave = false; if (detect_input_pending_run_timers (do_display)) @@ -5712,14 +5661,6 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, leave = true; } - /* If a timer has run, this might have changed buffers - an alike. Make read_key_sequence aware of that. */ - if (timers_run != old_timers_run - && waiting_for_user_input_p == -1 - && (old_buffer != current_buffer - || !EQ (old_window, selected_window))) - record_asynch_buffer_change (); - if (leave) break; } @@ -6021,6 +5962,7 @@ read_process_output (Lisp_Object proc, int channel) { ssize_t nbytes; struct Lisp_Process *p = XPROCESS (proc); + eassert (0 <= channel && channel < FD_SETSIZE); struct coding_system *coding = proc_decode_coding_system[channel]; int carryover = p->decoding_carryover; ptrdiff_t readmax = clip_to_bounds (1, read_process_output_max, PTRDIFF_MAX); @@ -6185,6 +6127,7 @@ read_and_dispose_of_process_output (struct Lisp_Process *p, char *chars, proc_encode_coding_system[p->outfd] surely points to a valid memory because p->outfd will be changed once EOF is sent to the process. */ + eassert (p->outfd < FD_SETSIZE); if (NILP (p->encode_coding_system) && p->outfd >= 0 && proc_encode_coding_system[p->outfd]) { @@ -6219,18 +6162,6 @@ read_and_dispose_of_process_output (struct Lisp_Process *p, char *chars, /* Restore waiting_for_user_input_p as it was when we were called, in case the filter clobbered it. */ waiting_for_user_input_p = waiting; - -#if 0 /* Call record_asynch_buffer_change unconditionally, - because we might have changed minor modes or other things - that affect key bindings. */ - if (! EQ (Fcurrent_buffer (), obuffer) - || ! EQ (current_buffer->keymap, okeymap)) -#endif - /* But do it only if the caller is actually going to read events. - Otherwise there's no need to make him wake up, and it could - cause trouble (for example it would make sit_for return). */ - if (waiting_for_user_input_p == -1) - record_asynch_buffer_change (); } DEFUN ("internal-default-process-filter", Finternal_default_process_filter, @@ -6436,6 +6367,7 @@ send_process (Lisp_Object proc, const char *buf, ptrdiff_t len, if (p->outfd < 0) error ("Output file descriptor of %s is closed", SDATA (p->name)); + eassert (p->outfd < FD_SETSIZE); coding = proc_encode_coding_system[p->outfd]; Vlast_coding_system_used = CODING_ID_NAME (coding->id); @@ -6545,6 +6477,7 @@ send_process (Lisp_Object proc, const char *buf, ptrdiff_t len, /* Send this batch, using one or more write calls. */ ptrdiff_t written = 0; int outfd = p->outfd; + eassert (0 <= outfd && outfd < FD_SETSIZE); #ifdef DATAGRAM_SOCKETS if (DATAGRAM_CHAN_P (outfd)) { @@ -6995,6 +6928,7 @@ traffic. */) struct Lisp_Process *p; p = XPROCESS (process); + eassert (p->infd < FD_SETSIZE); if (EQ (p->command, Qt) && p->infd >= 0 && (!EQ (p->filter, Qt) || EQ (p->status, Qlisten))) @@ -7080,10 +7014,7 @@ SIGCODE may be an integer, or a symbol whose name is a signal name. */) } if (FIXNUMP (sigcode)) - { - CHECK_TYPE_RANGED_INTEGER (int, sigcode); - signo = XFIXNUM (sigcode); - } + signo = check_integer_range (sigcode, INT_MIN, INT_MAX); else { char *name; @@ -7125,6 +7056,7 @@ process has been transmitted to the serial port. */) outfd = XPROCESS (proc)->outfd; + eassert (outfd < FD_SETSIZE); if (outfd >= 0) coding = proc_encode_coding_system[outfd]; @@ -7172,11 +7104,13 @@ process has been transmitted to the serial port. */) p->open_fd[WRITE_TO_SUBPROCESS] = new_outfd; p->outfd = new_outfd; + eassert (0 <= new_outfd && new_outfd < FD_SETSIZE); if (!proc_encode_coding_system[new_outfd]) proc_encode_coding_system[new_outfd] = xmalloc (sizeof (struct coding_system)); if (old_outfd >= 0) { + eassert (old_outfd < FD_SETSIZE); *proc_encode_coding_system[new_outfd] = *proc_encode_coding_system[old_outfd]; memset (proc_encode_coding_system[old_outfd], 0, @@ -7213,7 +7147,95 @@ process has been transmitted to the serial port. */) subprocesses which the main thread should not reap. For example, if the main thread attempted to reap an already-reaped child, it might inadvertently reap a GTK-created process that happened to - have the same process ID. */ + have the same process ID. + + To avoid a deadlock when receiving SIGCHLD while + 'wait_reading_process_output' is in 'pselect', the SIGCHLD handler + will notify the `pselect' using a self-pipe. The deadlock could + occur if SIGCHLD is delivered outside of the 'pselect' call, in + which case 'pselect' will not be interrupted by the signal, and + will therefore wait on the process's output descriptor for the + output that will never come. + + WINDOWSNT doesn't need this facility because its 'pselect' + emulation (see 'sys_select' in w32proc.c) waits on a subprocess + handle, which becomes signaled when the process exits, and also + because that emulation delays the delivery of the simulated SIGCHLD + until all the output from the subprocess has been consumed. */ + +/* FIXME: On Unix-like systems that have a proper 'pselect' + (HAVE_PSELECT), we should block SIGCHLD in + 'wait_reading_process_output' and pass a non-NULL signal mask to + 'pselect' to avoid the need for the self-pipe. */ + +/* Set up `child_signal_read_fd' and `child_signal_write_fd'. */ + +static void +child_signal_init (void) +{ + /* Either both are initialized, or both are uninitialized. */ + eassert ((child_signal_read_fd < 0) == (child_signal_write_fd < 0)); + +#ifndef WINDOWSNT + if (0 <= child_signal_read_fd) + return; /* already done */ + + int fds[2]; + if (emacs_pipe (fds) < 0) + report_file_error ("Creating pipe for child signal", Qnil); + if (FD_SETSIZE <= fds[0]) + { + /* Since we need to `pselect' on the read end, it has to fit + into an `fd_set'. */ + emacs_close (fds[0]); + emacs_close (fds[1]); + report_file_errno ("Creating pipe for child signal", Qnil, + EMFILE); + } + + /* We leave the file descriptors open until the Emacs process + exits. */ + eassert (0 <= fds[0]); + eassert (0 <= fds[1]); + if (fcntl (fds[0], F_SETFL, O_NONBLOCK) != 0) + emacs_perror ("fcntl"); + if (fcntl (fds[1], F_SETFL, O_NONBLOCK) != 0) + emacs_perror ("fcntl"); + add_read_fd (fds[0], child_signal_read, NULL); + fd_callback_info[fds[0]].flags &= ~KEYBOARD_FD; + child_signal_read_fd = fds[0]; + child_signal_write_fd = fds[1]; +#endif /* !WINDOWSNT */ +} + +#ifndef WINDOWSNT +/* Consume a process status change. */ + +static void +child_signal_read (int fd, void *data) +{ + eassert (0 <= fd); + eassert (fd == child_signal_read_fd); + char dummy; + if (emacs_read (fd, &dummy, 1) < 0 && errno != EAGAIN) + emacs_perror ("reading from child signal FD"); +} +#endif /* !WINDOWSNT */ + +/* Notify `wait_reading_process_output' of a process status + change. */ + +static void +child_signal_notify (void) +{ +#ifndef WINDOWSNT + int fd = child_signal_write_fd; + eassert (0 <= fd); + char dummy = 0; + if (emacs_write (fd, &dummy, 1) != 1) + emacs_perror ("writing to child signal FD"); +#endif +} /* LIB_CHILD_HANDLER is a SIGCHLD handler that Emacs calls while doing its own SIGCHLD handling. On POSIXish systems, glib needs this to @@ -7251,6 +7273,7 @@ static void handle_child_signal (int sig) { Lisp_Object tail, proc; + bool changed = false; /* Find the process that signaled us, and record its status. */ @@ -7273,6 +7296,7 @@ handle_child_signal (int sig) eassert (ok); if (child_status_changed (deleted_pid, 0, 0)) { + changed = true; if (STRINGP (XCDR (head))) unlink (SSDATA (XCDR (head))); XSETCAR (tail, Qnil); @@ -7290,6 +7314,7 @@ handle_child_signal (int sig) && child_status_changed (p->pid, &status, WUNTRACED | WCONTINUED)) { /* Change the status of the process that was found. */ + changed = true; p->tick = ++process_tick; p->raw_status = status; p->raw_status_new = 1; @@ -7309,6 +7334,10 @@ handle_child_signal (int sig) } } + if (changed) + /* Wake up `wait_reading_process_output'. */ + child_signal_notify (); + lib_child_handler (sig); #ifdef NS_IMPL_GNUSTEP /* NSTask in GNUstep sets its child handler each time it is called. @@ -7399,16 +7428,6 @@ exec_sentinel (Lisp_Object proc, Lisp_Object reason) when we were called, in case the filter clobbered it. */ waiting_for_user_input_p = waiting; -#if 0 - if (! EQ (Fcurrent_buffer (), obuffer) - || ! EQ (current_buffer->keymap, okeymap)) -#endif - /* But do it only if the caller is actually going to read events. - Otherwise there's no need to make him wake up, and it could - cause trouble (for example it would make sit_for return). */ - if (waiting_for_user_input_p == -1) - record_asynch_buffer_change (); - unbind_to (count, Qnil); } @@ -7635,6 +7654,7 @@ DEFUN ("process-filter-multibyte-p", Fprocess_filter_multibyte_p, struct Lisp_Process *p = XPROCESS (process); if (p->infd < 0) return Qnil; + eassert (p->infd < FD_SETSIZE); struct coding_system *coding = proc_decode_coding_system[p->infd]; return (CODING_FOR_UNIBYTE (coding) ? Qnil : Qt); } @@ -7668,6 +7688,7 @@ keyboard_bit_set (fd_set *mask) { int fd; + eassert (max_desc < FD_SETSIZE); for (fd = 0; fd <= max_desc; fd++) if (FD_ISSET (fd, mask) && ((fd_callback_info[fd].flags & (FOR_READ | KEYBOARD_FD)) @@ -7915,6 +7936,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, void add_timer_wait_descriptor (int fd) { + eassert (0 <= fd && fd < FD_SETSIZE); add_read_fd (fd, timerfd_callback, NULL); fd_callback_info[fd].flags &= ~KEYBOARD_FD; } @@ -7977,6 +7999,7 @@ setup_process_coding_systems (Lisp_Object process) if (inch < 0 || outch < 0) return; + eassert (0 <= inch && inch < FD_SETSIZE); if (!proc_decode_coding_system[inch]) proc_decode_coding_system[inch] = xmalloc (sizeof (struct coding_system)); coding_system = p->decode_coding_system; @@ -7988,6 +8011,7 @@ setup_process_coding_systems (Lisp_Object process) } setup_coding_system (coding_system, proc_decode_coding_system[inch]); + eassert (0 <= outch && outch < FD_SETSIZE); if (!proc_encode_coding_system[outch]) proc_encode_coding_system[outch] = xmalloc (sizeof (struct coding_system)); setup_coding_system (p->encode_coding_system, @@ -8201,6 +8225,17 @@ restore_nofile_limit (void) #endif } +int +open_channel_for_module (Lisp_Object process) +{ + CHECK_PROCESS (process); + CHECK_TYPE (PIPECONN_P (process), Qpipe_process_p, process); + int fd = dup (XPROCESS (process)->open_fd[SUBPROCESS_STDOUT]); + if (fd == -1) + report_file_error ("Cannot duplicate file descriptor", Qnil); + return fd; +} + /* This is not called "init_process" because that is the name of a Mach system call, so it would cause problems on Darwin systems. */ @@ -8215,13 +8250,29 @@ init_process_emacs (int sockfd) if (!will_dump_with_unexec_p ()) { #if defined HAVE_GLIB && !defined WINDOWSNT - /* Tickle glib's child-handling code. Ask glib to wait for Emacs itself; - this should always fail, but is enough to initialize glib's + /* Tickle glib's child-handling code. Ask glib to install a + watch source for Emacs itself which will initialize glib's private SIGCHLD handler, allowing catch_child_signal to copy - it into lib_child_handler. */ - g_source_unref (g_child_watch_source_new (getpid ())); -#endif + it into lib_child_handler. + + Unfortunatly in glib commit 2e471acf, the behavior changed to + always install a signal handler when g_child_watch_source_new + is called and not just the first time it's called. Glib also + now resets signal handlers to SIG_DFL when it no longer has a + watcher on that signal. This is a hackey work around to get + glib's g_unix_signal_handler into lib_child_handler. */ + GSource *source = g_child_watch_source_new (getpid ()); + catch_child_signal (); + g_source_unref (source); + + eassert (lib_child_handler != dummy_handler); + signal_handler_t lib_child_handler_glib = lib_child_handler; + catch_child_signal (); + eassert (lib_child_handler == dummy_handler); + lib_child_handler = lib_child_handler_glib; +#else catch_child_signal (); +#endif } #ifdef HAVE_SETRLIMIT @@ -8278,19 +8329,6 @@ init_process_emacs (int sockfd) memset (datagram_address, 0, sizeof datagram_address); #endif -#if defined (DARWIN_OS) - /* PTYs are broken on Darwin < 6, but are sometimes useful for interactive - processes. As such, we only change the default value. */ - if (initialized) - { - char const *release = (STRINGP (Voperating_system_release) - ? SSDATA (Voperating_system_release) - : 0); - if (!release || !release[0] || (release[0] < '7' && release[1] == '.')) { - Vprocess_connection_type = Qnil; - } - } -#endif #endif /* subprocesses */ kbd_is_on_hold = 0; } @@ -8460,6 +8498,7 @@ amounts of data in one go. */); DEFSYM (Qinterrupt_process_functions, "interrupt-process-functions"); DEFSYM (Qnull, "null"); + DEFSYM (Qpipe_process_p, "pipe-process-p"); defsubr (&Sprocessp); defsubr (&Sget_process); diff --git a/src/process.h b/src/process.h index 1d3797cab4f..d041ada5867 100644 --- a/src/process.h +++ b/src/process.h @@ -300,6 +300,8 @@ extern Lisp_Object remove_slash_colon (Lisp_Object); extern void update_processes_for_thread_death (Lisp_Object); extern void dissociate_controlling_tty (void); +extern int open_channel_for_module (Lisp_Object); + INLINE_HEADER_END #endif /* EMACS_PROCESS_H */ diff --git a/src/ptr-bounds.h b/src/ptr-bounds.h deleted file mode 100644 index db887242d7b..00000000000 --- a/src/ptr-bounds.h +++ /dev/null @@ -1,79 +0,0 @@ -/* Pointer bounds checking for GNU Emacs - -Copyright 2017-2021 Free Software Foundation, Inc. - -This file is part of GNU Emacs. - -GNU Emacs is free software: you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation, either version 3 of the License, or (at -your option) any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ - -/* Pointer bounds checking is a no-op unless running on hardware - supporting Intel MPX (Intel Skylake or better). Also, it requires - GCC 5 and Linux kernel 3.19, or later. Configure with - CFLAGS='-fcheck-pointer-bounds -mmpx', perhaps with - -fchkp-first-field-has-own-bounds thrown in. - - Although pointer bounds checking can help during debugging, it is - disabled by default because it hurts performance significantly. - The checking does not detect all pointer errors. For example, a - dumped Emacs might not detect a bounds violation of a pointer that - was created before Emacs was dumped. */ - -#ifndef PTR_BOUNDS_H -#define PTR_BOUNDS_H - -#include <stddef.h> - -/* When not checking pointer bounds, the following macros simply - return their first argument. These macros return either void *, or - the same type as their first argument. */ - -INLINE_HEADER_BEGIN - -/* Return a copy of P, with bounds narrowed to [P, P + N). */ -#ifdef __CHKP__ -INLINE void * -ptr_bounds_clip (void const *p, size_t n) -{ - return __builtin___bnd_narrow_ptr_bounds (p, p, n); -} -#else -# define ptr_bounds_clip(p, n) ((void) (size_t) {n}, p) -#endif - -/* Return a copy of P, but with the bounds of Q. */ -#ifdef __CHKP__ -# define ptr_bounds_copy(p, q) __builtin___bnd_copy_ptr_bounds (p, q) -#else -# define ptr_bounds_copy(p, q) ((void) (void const *) {q}, p) -#endif - -/* Return a copy of P, but with infinite bounds. - This is a loophole in pointer bounds checking. */ -#ifdef __CHKP__ -# define ptr_bounds_init(p) __builtin___bnd_init_ptr_bounds (p) -#else -# define ptr_bounds_init(p) (p) -#endif - -/* Return a copy of P, but with bounds [P, P + N). - This is a loophole in pointer bounds checking. */ -#ifdef __CHKP__ -# define ptr_bounds_set(p, n) __builtin___bnd_set_ptr_bounds (p, n) -#else -# define ptr_bounds_set(p, n) ((void) (size_t) {n}, p) -#endif - -INLINE_HEADER_END - -#endif /* PTR_BOUNDS_H */ diff --git a/src/regex-emacs.c b/src/regex-emacs.c index 6129d2c854b..8350e54b54a 100644 --- a/src/regex-emacs.c +++ b/src/regex-emacs.c @@ -58,7 +58,7 @@ #define RE_STRING_CHAR(p, multibyte) \ (multibyte ? STRING_CHAR (p) : *(p)) #define RE_STRING_CHAR_AND_LENGTH(p, len, multibyte) \ - (multibyte ? STRING_CHAR_AND_LENGTH (p, len) : ((len) = 1, *(p))) + (multibyte ? string_char_and_length (p, &(len)) : ((len) = 1, *(p))) #define RE_CHAR_TO_MULTIBYTE(c) UNIBYTE_TO_CHAR (c) @@ -89,7 +89,7 @@ #define GET_CHAR_AFTER(c, p, len) \ do { \ if (target_multibyte) \ - (c) = STRING_CHAR_AND_LENGTH (p, len); \ + (c) = string_char_and_length (p, &(len)); \ else \ { \ (c) = *p; \ @@ -929,7 +929,7 @@ typedef struct ? 0 \ : ((fail_stack).stack \ = REGEX_REALLOCATE ((fail_stack).stack, \ - (fail_stack).size * sizeof (fail_stack_elt_t), \ + (fail_stack).avail * sizeof (fail_stack_elt_t), \ min (emacs_re_max_failures * TYPICAL_FAILURE_SIZE, \ ((fail_stack).size * FAIL_STACK_GROWTH_FACTOR)) \ * sizeof (fail_stack_elt_t)), \ @@ -969,7 +969,11 @@ typedef struct #define ENSURE_FAIL_STACK(space) \ while (REMAINING_AVAIL_SLOTS <= space) { \ if (!GROW_FAIL_STACK (fail_stack)) \ - return -2; \ + { \ + unbind_to (count, Qnil); \ + SAFE_FREE (); \ + return -2; \ + } \ DEBUG_PRINT ("\n Doubled stack; size now: %td\n", fail_stack.size); \ DEBUG_PRINT (" slots available: %td\n", REMAINING_AVAIL_SLOTS);\ } @@ -979,6 +983,8 @@ while (REMAINING_AVAIL_SLOTS <= space) { \ do { \ char *destination; \ intptr_t n = num; \ + eassert (0 < n && n < num_regs); \ + eassert (REG_UNSET (regstart[n]) <= REG_UNSET (regend[n])); \ ENSURE_FAIL_STACK(3); \ DEBUG_PRINT (" Push reg %"PRIdPTR" (spanning %p -> %p)\n", \ n, regstart[n], regend[n]); \ @@ -1017,8 +1023,10 @@ do { \ } \ else \ { \ + eassert (0 < pfreg && pfreg < num_regs); \ regend[pfreg] = POP_FAILURE_POINTER (); \ regstart[pfreg] = POP_FAILURE_POINTER (); \ + eassert (REG_UNSET (regstart[pfreg]) <= REG_UNSET (regend[pfreg])); \ DEBUG_PRINT (" Pop reg %ld (spanning %p -> %p)\n", \ pfreg, regstart[pfreg], regend[pfreg]); \ } \ @@ -1757,6 +1765,7 @@ regex_compile (re_char *pattern, ptrdiff_t size, /* Initialize the compile stack. */ compile_stack.stack = xmalloc (INIT_COMPILE_STACK_SIZE * sizeof *compile_stack.stack); + __lsan_ignore_object (compile_stack.stack); compile_stack.size = INIT_COMPILE_STACK_SIZE; compile_stack.avail = 0; @@ -2113,17 +2122,20 @@ regex_compile (re_char *pattern, ptrdiff_t size, if (CHAR_BYTE8_P (c1)) c = BYTE8_TO_CHAR (128); } - if (CHAR_BYTE8_P (c)) - { - c = CHAR_TO_BYTE8 (c); - c1 = CHAR_TO_BYTE8 (c1); - for (; c <= c1; c++) - SET_LIST_BIT (c); - } - else if (multibyte) - SETUP_MULTIBYTE_RANGE (range_table_work, c, c1); - else - SETUP_UNIBYTE_RANGE (range_table_work, c, c1); + if (c <= c1) + { + if (CHAR_BYTE8_P (c)) + { + c = CHAR_TO_BYTE8 (c); + c1 = CHAR_TO_BYTE8 (c1); + for (; c <= c1; c++) + SET_LIST_BIT (c); + } + else if (multibyte) + SETUP_MULTIBYTE_RANGE (range_table_work, c, c1); + else + SETUP_UNIBYTE_RANGE (range_table_work, c, c1); + } } } @@ -3164,10 +3176,6 @@ re_search (struct re_pattern_buffer *bufp, const char *string, ptrdiff_t size, regs, size); } -/* Head address of virtual concatenation of string. */ -#define HEAD_ADDR_VSTRING(P) \ - (((P) >= size1 ? string2 : string1)) - /* Address of POS in the concatenation of virtual string. */ #define POS_ADDR_VSTRING(POS) \ (((POS) >= size1 ? string2 - size1 : string1) + (POS)) @@ -3297,7 +3305,7 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, ptrdiff_t size1, { int buf_charlen; - buf_ch = STRING_CHAR_AND_LENGTH (d, buf_charlen); + buf_ch = string_char_and_length (d, &buf_charlen); buf_ch = RE_TRANSLATE (translate, buf_ch); if (fastmap[CHAR_LEADING_CODE (buf_ch)]) break; @@ -3327,7 +3335,7 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, ptrdiff_t size1, { int buf_charlen; - buf_ch = STRING_CHAR_AND_LENGTH (d, buf_charlen); + buf_ch = string_char_and_length (d, &buf_charlen); if (fastmap[CHAR_LEADING_CODE (buf_ch)]) break; range -= buf_charlen; @@ -3410,16 +3418,12 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, ptrdiff_t size1, if (multibyte) { re_char *p = POS_ADDR_VSTRING (startpos) + 1; - re_char *p0 = p; - re_char *phead = HEAD_ADDR_VSTRING (startpos); + int len = raw_prev_char_len (p); - /* Find the head of multibyte form. */ - PREV_CHAR_BOUNDARY (p, phead); - range += p0 - 1 - p; + range += len - 1; if (range > 0) break; - - startpos -= p0 - 1 - p; + startpos -= len - 1; } } } @@ -3571,9 +3575,11 @@ skip_noops (re_char *p, re_char *pend) opcode. When the function finishes, *PP will be advanced past that opcode. C is character to test (possibly after translations) and CORIG is original character (i.e. without any translations). UNIBYTE denotes whether c is - unibyte or multibyte character. */ + unibyte or multibyte character. + CANON_TABLE is the canonicalisation table for case folding or Qnil. */ static bool -execute_charset (re_char **pp, int c, int corig, bool unibyte) +execute_charset (re_char **pp, int c, int corig, bool unibyte, + Lisp_Object canon_table) { eassume (0 <= c && 0 <= corig); re_char *p = *pp, *rtp = NULL; @@ -3613,11 +3619,9 @@ execute_charset (re_char **pp, int c, int corig, bool unibyte) (class_bits & BIT_BLANK && ISBLANK (c)) || (class_bits & BIT_WORD && ISWORD (c)) || ((class_bits & BIT_UPPER) && - (ISUPPER (c) || (corig != c && - c == downcase (corig) && ISLOWER (c)))) || + (ISUPPER (corig) || (!NILP (canon_table) && ISLOWER (corig)))) || ((class_bits & BIT_LOWER) && - (ISLOWER (c) || (corig != c && - c == upcase (corig) && ISUPPER(c)))) || + (ISLOWER (corig) || (!NILP (canon_table) && ISUPPER (corig)))) || (class_bits & BIT_PUNCT && ISPUNCT (c)) || (class_bits & BIT_GRAPH && ISGRAPH (c)) || (class_bits & BIT_PRINT && ISPRINT (c))) @@ -3692,7 +3696,8 @@ mutually_exclusive_p (struct re_pattern_buffer *bufp, re_char *p1, else if ((re_opcode_t) *p1 == charset || (re_opcode_t) *p1 == charset_not) { - if (!execute_charset (&p1, c, c, !multibyte || ASCII_CHAR_P (c))) + if (!execute_charset (&p1, c, c, !multibyte || ASCII_CHAR_P (c), + Qnil)) { DEBUG_PRINT (" No match => fast loop.\n"); return true; @@ -3868,6 +3873,10 @@ re_match_2_internal (struct re_pattern_buffer *bufp, re_char *string2, ptrdiff_t size2, ptrdiff_t pos, struct re_registers *regs, ptrdiff_t stop) { + eassume (0 <= size1); + eassume (0 <= size2); + eassume (0 <= pos && pos <= stop && stop <= size1 + size2); + /* General temporaries. */ int mcnt; @@ -3923,8 +3932,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, attempt) by a subexpression part of the pattern, that is, the regnum-th regstart pointer points to where in the pattern we began matching and the regnum-th regend points to right after where we - stopped matching the regnum-th subexpression. (The zeroth register - keeps track of what the whole pattern matches.) */ + stopped matching the regnum-th subexpression. */ re_char **regstart UNINIT, **regend UNINIT; /* The following record the register info as found in the above @@ -3973,29 +3981,22 @@ re_match_2_internal (struct re_pattern_buffer *bufp, /* Do not bother to initialize all the register variables if there are no groups in the pattern, as it takes a fair amount of time. If there are groups, we include space for register 0 (the whole - pattern), even though we never use it, since it simplifies the - array indexing. We should fix this. */ - if (bufp->re_nsub) + pattern) in REGSTART[0], even though we never use it, to avoid + the undefined behavior of subtracting 1 from REGSTART. */ + ptrdiff_t re_nsub = num_regs - 1; + if (0 < re_nsub) { - regstart = SAFE_ALLOCA (num_regs * 4 * sizeof *regstart); + regstart = SAFE_ALLOCA ((re_nsub * 4 + 1) * sizeof *regstart); regend = regstart + num_regs; - best_regstart = regend + num_regs; - best_regend = best_regstart + num_regs; - } + best_regstart = regend + re_nsub; + best_regend = best_regstart + re_nsub; - /* The starting position is bogus. */ - if (pos < 0 || pos > size1 + size2) - { - unbind_to (count, Qnil); - SAFE_FREE (); - return -1; + /* Initialize subexpression text positions to unset, to mark ones + that no start_memory/stop_memory has been seen for. */ + for (re_char **apos = regstart + 1; apos < best_regstart + 1; apos++) + *apos = NULL; } - /* Initialize subexpression text positions to -1 to mark ones that no - start_memory/stop_memory has been seen for. */ - for (ptrdiff_t reg = 1; reg < num_regs; reg++) - regstart[reg] = regend[reg] = NULL; - /* We move 'string1' into 'string2' if the latter's empty -- but not if 'string1' is null. */ if (size2 == 0 && string1 != NULL) @@ -4130,6 +4131,8 @@ re_match_2_internal (struct re_pattern_buffer *bufp, { regstart[reg] = best_regstart[reg]; regend[reg] = best_regend[reg]; + eassert (REG_UNSET (regstart[reg]) + <= REG_UNSET (regend[reg])); } } } /* d != end_match_2 */ @@ -4177,7 +4180,9 @@ re_match_2_internal (struct re_pattern_buffer *bufp, for (ptrdiff_t reg = 1; reg < num_regs; reg++) { - if (REG_UNSET (regstart[reg]) || REG_UNSET (regend[reg])) + eassert (REG_UNSET (regstart[reg]) + <= REG_UNSET (regend[reg])); + if (REG_UNSET (regend[reg])) regs->start[reg] = regs->end[reg] = -1; else { @@ -4238,13 +4243,13 @@ re_match_2_internal (struct re_pattern_buffer *bufp, PREFETCH (); if (multibyte) - pat_ch = STRING_CHAR_AND_LENGTH (p, pat_charlen); + pat_ch = string_char_and_length (p, &pat_charlen); else { pat_ch = RE_CHAR_TO_MULTIBYTE (*p); pat_charlen = 1; } - buf_ch = STRING_CHAR_AND_LENGTH (d, buf_charlen); + buf_ch = string_char_and_length (d, &buf_charlen); if (TRANSLATE (buf_ch) != pat_ch) { @@ -4266,7 +4271,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, PREFETCH (); if (multibyte) { - pat_ch = STRING_CHAR_AND_LENGTH (p, pat_charlen); + pat_ch = string_char_and_length (p, &pat_charlen); pat_ch = RE_CHAR_TO_UNIBYTE (pat_ch); } else @@ -4363,7 +4368,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, } p -= 1; - if (!execute_charset (&p, c, corig, unibyte_char)) + if (!execute_charset (&p, c, corig, unibyte_char, translate)) goto fail; d += len; @@ -4377,12 +4382,12 @@ re_match_2_internal (struct re_pattern_buffer *bufp, registers data structure) under the register number. */ case start_memory: DEBUG_PRINT ("EXECUTING start_memory %d:\n", *p); + eassert (0 < *p && *p < num_regs); /* In case we need to undo this operation (via backtracking). */ PUSH_FAILURE_REG (*p); regstart[*p] = d; - regend[*p] = NULL; /* probably unnecessary. -sm */ DEBUG_PRINT (" regstart: %td\n", POINTER_TO_OFFSET (regstart[*p])); /* Move past the register number and inner group count. */ @@ -4395,6 +4400,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, case stop_memory: DEBUG_PRINT ("EXECUTING stop_memory %d:\n", *p); + eassert (0 < *p && *p < num_regs); eassert (!REG_UNSET (regstart[*p])); /* Strictly speaking, there should be code such as: @@ -4427,7 +4433,9 @@ re_match_2_internal (struct re_pattern_buffer *bufp, DEBUG_PRINT ("EXECUTING duplicate %d.\n", regno); /* Can't back reference a group which we've never matched. */ - if (REG_UNSET (regstart[regno]) || REG_UNSET (regend[regno])) + eassert (0 < regno && regno < num_regs); + eassert (REG_UNSET (regstart[regno]) <= REG_UNSET (regend[regno])); + if (REG_UNSET (regend[regno])) goto fail; /* Where in input to try to start matching. */ diff --git a/src/search.c b/src/search.c index 483d9d867a6..c757bf3d1f2 100644 --- a/src/search.c +++ b/src/search.c @@ -353,8 +353,8 @@ data if you want to preserve them. */) } DEFUN ("posix-looking-at", Fposix_looking_at, Sposix_looking_at, 1, 1, 0, - doc: /* Return t if text after point matches regular expression REGEXP. -Find the longest match, in accord with Posix regular expression rules. + doc: /* Return t if text after point matches REGEXP according to Posix rules. +Find the longest match, in accordance with Posix regular expression rules. This function modifies the match data that `match-beginning', `match-end' and `match-data' access; save and restore the match data if you want to preserve them. */) @@ -449,7 +449,7 @@ matched by the parenthesis constructions in REGEXP. */) } DEFUN ("posix-string-match", Fposix_string_match, Sposix_string_match, 2, 3, 0, - doc: /* Return index of start of first match for REGEXP in STRING, or nil. + doc: /* Return index of start of first match for Posix REGEXP in STRING, or nil. Find the longest match, in accord with Posix regular expression rules. Case is ignored if `case-fold-search' is non-nil in the current buffer. If third arg START is non-nil, start search at that index in STRING. @@ -613,7 +613,10 @@ newline_cache_on_off (struct buffer *buf) { /* It should be on. */ if (base_buf->newline_cache == 0) - base_buf->newline_cache = new_region_cache (); + { + base_buf->newline_cache = new_region_cache (); + __lsan_ignore_object (base_buf->newline_cache); + } } return base_buf->newline_cache; } @@ -994,7 +997,7 @@ find_before_next_newline (ptrdiff_t from, ptrdiff_t to, if (counted == cnt) { if (bytepos) - DEC_BOTH (pos, *bytepos); + dec_both (&pos, &*bytepos); else pos--; } @@ -1028,8 +1031,7 @@ search_command (Lisp_Object string, Lisp_Object bound, Lisp_Object noerror, } else { - CHECK_FIXNUM_COERCE_MARKER (bound); - lim = XFIXNUM (bound); + lim = fix_position (bound); if (n > 0 ? lim < PT : lim > PT) error ("Invalid search bound (wrong side of point)"); if (lim > ZV) @@ -1354,8 +1356,8 @@ search_buffer_non_re (Lisp_Object string, ptrdiff_t pos, while (--len >= 0) { unsigned char str_base[MAX_MULTIBYTE_LENGTH], *str; - int c, translated, inverse; - int in_charlen, charlen; + int translated, inverse; + int charlen; /* If we got here and the RE flag is set, it's because we're dealing with a regexp known to be trivial, so the backslash @@ -1368,7 +1370,7 @@ search_buffer_non_re (Lisp_Object string, ptrdiff_t pos, base_pat++; } - c = STRING_CHAR_AND_LENGTH (base_pat, in_charlen); + int in_charlen, c = string_char_and_length (base_pat, &in_charlen); if (NILP (trt)) { @@ -1551,12 +1553,10 @@ simple_search (EMACS_INT n, unsigned char *pat, while (this_len > 0) { - int charlen, buf_charlen; - int pat_ch, buf_ch; - - pat_ch = STRING_CHAR_AND_LENGTH (p, charlen); - buf_ch = STRING_CHAR_AND_LENGTH (BYTE_POS_ADDR (this_pos_byte), - buf_charlen); + int charlen, pat_ch = string_char_and_length (p, &charlen); + int buf_charlen, buf_ch + = string_char_and_length (BYTE_POS_ADDR (this_pos_byte), + &buf_charlen); TRANSLATE (buf_ch, trt, buf_ch); if (buf_ch != pat_ch) @@ -1577,7 +1577,7 @@ simple_search (EMACS_INT n, unsigned char *pat, break; } - INC_BOTH (pos, pos_byte); + inc_both (&pos, &pos_byte); } n--; @@ -1639,8 +1639,8 @@ simple_search (EMACS_INT n, unsigned char *pat, { int pat_ch, buf_ch; - DEC_BOTH (this_pos, this_pos_byte); - PREV_CHAR_BOUNDARY (p, pat); + dec_both (&this_pos, &this_pos_byte); + p -= raw_prev_char_len (p); pat_ch = STRING_CHAR (p); buf_ch = STRING_CHAR (BYTE_POS_ADDR (this_pos_byte)); TRANSLATE (buf_ch, trt, buf_ch); @@ -1659,7 +1659,7 @@ simple_search (EMACS_INT n, unsigned char *pat, break; } - DEC_BOTH (pos, pos_byte); + dec_both (&pos, &pos_byte); } n++; @@ -2279,7 +2279,7 @@ and `replace-match'. */) DEFUN ("posix-search-backward", Fposix_search_backward, Sposix_search_backward, 1, 4, "sPosix search backward: ", - doc: /* Search backward from point for match for regular expression REGEXP. + doc: /* Search backward from point for match for REGEXP according to Posix rules. Find the longest match in accord with Posix regular expression rules. Set point to the beginning of the occurrence found, and return point. An optional second argument bounds the search; it is a buffer position. @@ -2307,7 +2307,7 @@ and `replace-match'. */) DEFUN ("posix-search-forward", Fposix_search_forward, Sposix_search_forward, 1, 4, "sPosix search: ", - doc: /* Search forward from point for regular expression REGEXP. + doc: /* Search forward from point for REGEXP according to Posix rules. Find the longest match in accord with Posix regular expression rules. Set point to the end of the occurrence found, and return point. An optional second argument bounds the search; it is a buffer position. @@ -2393,14 +2393,7 @@ since only regular expressions have distinguished subexpressions. */) if (num_regs <= 0) error ("`replace-match' called before any match found"); - if (NILP (subexp)) - sub = 0; - else - { - CHECK_RANGED_INTEGER (subexp, 0, num_regs - 1); - sub = XFIXNUM (subexp); - } - + sub = !NILP (subexp) ? check_integer_range (subexp, 0, num_regs - 1) : 0; ptrdiff_t sub_start = search_regs.start[sub]; ptrdiff_t sub_end = search_regs.end[sub]; eassert (sub_start <= sub_end); @@ -2445,10 +2438,11 @@ since only regular expressions have distinguished subexpressions. */) if (NILP (string)) { c = FETCH_CHAR_AS_MULTIBYTE (pos_byte); - INC_BOTH (pos, pos_byte); + inc_both (&pos, &pos_byte); } else - FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c, string, pos, pos_byte); + c = fetch_string_char_as_multibyte_advance (string, + &pos, &pos_byte); if (lowercasep (c)) { @@ -2521,11 +2515,11 @@ since only regular expressions have distinguished subexpressions. */) ptrdiff_t subend = 0; bool delbackslash = 0; - FETCH_STRING_CHAR_ADVANCE (c, newtext, pos, pos_byte); + c = fetch_string_char_advance (newtext, &pos, &pos_byte); if (c == '\\') { - FETCH_STRING_CHAR_ADVANCE (c, newtext, pos, pos_byte); + c = fetch_string_char_advance (newtext, &pos, &pos_byte); if (c == '&') { @@ -2633,7 +2627,8 @@ since only regular expressions have distinguished subexpressions. */) if (str_multibyte) { - FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, newtext, pos, pos_byte); + c = fetch_string_char_advance_no_check (newtext, + &pos, &pos_byte); if (!buf_multibyte) c = CHAR_TO_BYTE8 (c); } @@ -2642,7 +2637,7 @@ since only regular expressions have distinguished subexpressions. */) /* Note that we don't have to increment POS. */ c = SREF (newtext, pos_byte++); if (buf_multibyte) - MAKE_CHAR_MULTIBYTE (c); + c = make_char_multibyte (c); } /* Either set ADD_STUFF and ADD_LEN to the text to put in SUBSTED, @@ -2655,8 +2650,8 @@ since only regular expressions have distinguished subexpressions. */) if (str_multibyte) { - FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, newtext, - pos, pos_byte); + c = fetch_string_char_advance_no_check (newtext, + &pos, &pos_byte); if (!buf_multibyte && !ASCII_CHAR_P (c)) c = CHAR_TO_BYTE8 (c); } @@ -2664,7 +2659,7 @@ since only regular expressions have distinguished subexpressions. */) { c = SREF (newtext, pos_byte++); if (buf_multibyte) - MAKE_CHAR_MULTIBYTE (c); + c = make_char_multibyte (c); } if (c == '&') @@ -2753,7 +2748,7 @@ since only regular expressions have distinguished subexpressions. */) /* Put point back where it was in the text, if possible. */ TEMP_SET_PT (clip_to_bounds (BEGV, opoint + (opoint <= 0 ? ZV : 0), ZV)); - /* Now move point "officially" to the start of the inserted replacement. */ + /* Now move point "officially" to the end of the inserted replacement. */ move_if_not_intangible (newpoint); return Qnil; @@ -3036,6 +3031,23 @@ If optional arg RESEAT is non-nil, make markers on LIST point nowhere. */) return Qnil; } +DEFUN ("match-data--translate", Fmatch_data__translate, Smatch_data__translate, + 1, 1, 0, + doc: /* Add N to all positions in the match data. Internal. */) + (Lisp_Object n) +{ + CHECK_FIXNUM (n); + EMACS_INT delta = XFIXNUM (n); + if (!NILP (last_thing_searched)) + for (ptrdiff_t i = 0; i < search_regs.num_regs; i++) + if (search_regs.start[i] >= 0) + { + search_regs.start[i] = max (0, search_regs.start[i] + delta); + search_regs.end[i] = max (0, search_regs.end[i] + delta); + } + return Qnil; +} + /* Called from Flooking_at, Fstring_match, search_buffer, Fstore_match_data if asynchronous code (filter or sentinel) is running. */ static void @@ -3276,7 +3288,7 @@ the buffer. If the buffer doesn't have a cache, the value is nil. */) TYPE_MAXIMUM (ptrdiff_t), &nl_count_cache, NULL, true); /* Create vector and populate it. */ - cache_newlines = make_uninit_vector (nl_count_cache); + cache_newlines = make_vector (nl_count_cache, make_fixnum (-1)); if (nl_count_cache) { @@ -3290,15 +3302,12 @@ the buffer. If the buffer doesn't have a cache, the value is nil. */) break; ASET (cache_newlines, i, make_fixnum (found - 1)); } - /* Fill the rest of slots with an invalid position. */ - for ( ; i < nl_count_cache; i++) - ASET (cache_newlines, i, make_fixnum (-1)); } /* Now do the same, but without using the cache. */ find_newline1 (BEGV, BEGV_BYTE, ZV, ZV_BYTE, TYPE_MAXIMUM (ptrdiff_t), &nl_count_buf, NULL, true); - buf_newlines = make_uninit_vector (nl_count_buf); + buf_newlines = make_vector (nl_count_buf, make_fixnum (-1)); if (nl_count_buf) { for (from = BEGV, found = from, i = 0; from < ZV; from = found, i++) @@ -3311,14 +3320,10 @@ the buffer. If the buffer doesn't have a cache, the value is nil. */) break; ASET (buf_newlines, i, make_fixnum (found - 1)); } - for ( ; i < nl_count_buf; i++) - ASET (buf_newlines, i, make_fixnum (-1)); } /* Construct the value and return it. */ - val = make_uninit_vector (2); - ASET (val, 0, cache_newlines); - ASET (val, 1, buf_newlines); + val = CALLN (Fvector, cache_newlines, buf_newlines); if (old != NULL) set_buffer_internal_1 (old); @@ -3400,6 +3405,7 @@ is to bind it with `let' around a small expression. */); defsubr (&Smatch_end); defsubr (&Smatch_data); defsubr (&Sset_match_data); + defsubr (&Smatch_data__translate); defsubr (&Sregexp_quote); defsubr (&Snewline_cache_check); diff --git a/src/syntax.c b/src/syntax.c index 848468891ab..9fbf88535f3 100644 --- a/src/syntax.c +++ b/src/syntax.c @@ -535,7 +535,7 @@ char_quoted (ptrdiff_t charpos, ptrdiff_t bytepos) while (charpos > beg) { int c; - DEC_BOTH (charpos, bytepos); + dec_both (&charpos, &bytepos); UPDATE_SYNTAX_TABLE_BACKWARD (charpos); c = FETCH_CHAR_AS_MULTIBYTE (bytepos); @@ -556,11 +556,9 @@ char_quoted (ptrdiff_t charpos, ptrdiff_t bytepos) static ptrdiff_t dec_bytepos (ptrdiff_t bytepos) { - if (NILP (BVAR (current_buffer, enable_multibyte_characters))) - return bytepos - 1; - - DEC_POS (bytepos); - return bytepos; + return (bytepos + - (!NILP (BVAR (current_buffer, enable_multibyte_characters)) + ? prev_char_len (bytepos) : 1)); } /* Return a defun-start position before POS and not too far before. @@ -667,7 +665,7 @@ prev_char_comend_first (ptrdiff_t pos, ptrdiff_t pos_byte) int c; bool val; - DEC_BOTH (pos, pos_byte); + dec_both (&pos, &pos_byte); UPDATE_SYNTAX_TABLE_BACKWARD (pos); c = FETCH_CHAR (pos_byte); val = SYNTAX_COMEND_FIRST (c); @@ -738,7 +736,7 @@ back_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, bool com2start, com2end, comstart; /* Move back and examine a character. */ - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from); prev_syntax = syntax; @@ -773,7 +771,7 @@ back_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, { ptrdiff_t next = from, next_byte = from_byte; int next_c, next_syntax; - DEC_BOTH (next, next_byte); + dec_both (&next, &next_byte); UPDATE_SYNTAX_TABLE_BACKWARD (next); next_c = FETCH_CHAR_AS_MULTIBYTE (next_byte); next_syntax = SYNTAX_WITH_FLAGS (next_c); @@ -809,7 +807,7 @@ back_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, /* Ignore escaped characters, except comment-enders which cannot be escaped. */ - if ((Vcomment_end_can_be_escaped || code != Sendcomment) + if ((comment_end_can_be_escaped || code != Sendcomment) && char_quoted (from, from_byte)) continue; @@ -1150,8 +1148,7 @@ the value of a `syntax-table' text property. */) if (*p) { - int len; - int character = STRING_CHAR_AND_LENGTH (p, len); + int len, character = string_char_and_length (p, &len); XSETINT (match, character); if (XFIXNAT (match) == ' ') match = Qnil; @@ -1424,7 +1421,7 @@ DEFUN ("internal-describe-syntax-value", Finternal_describe_syntax_value, { AUTO_STRING (prefixdoc, ",\n\t is a prefix character for `backward-prefix-chars'"); - insert1 (Fsubstitute_command_keys (prefixdoc)); + insert1 (call1 (Qsubstitute_command_keys, prefixdoc)); } return syntax; @@ -1444,7 +1441,7 @@ scan_words (ptrdiff_t from, EMACS_INT count) int ch0, ch1; Lisp_Object func, pos; - SETUP_SYNTAX_TABLE (from, count); + SETUP_SYNTAX_TABLE (from, clip_to_bounds (PTRDIFF_MIN, count, PTRDIFF_MAX)); while (count > 0) { @@ -1455,7 +1452,7 @@ scan_words (ptrdiff_t from, EMACS_INT count) UPDATE_SYNTAX_TABLE_FORWARD (from); ch0 = FETCH_CHAR_AS_MULTIBYTE (from_byte); code = SYNTAX (ch0); - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); if (words_include_escapes && (code == Sescape || code == Scharquote)) break; @@ -1488,7 +1485,7 @@ scan_words (ptrdiff_t from, EMACS_INT count) || (code != Sescape && code != Scharquote))) || word_boundary_p (ch0, ch1)) break; - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); ch0 = ch1; rarely_quit (from); } @@ -1501,7 +1498,7 @@ scan_words (ptrdiff_t from, EMACS_INT count) { if (from == beg) return 0; - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from); ch1 = FETCH_CHAR_AS_MULTIBYTE (from_byte); code = SYNTAX (ch1); @@ -1530,7 +1527,7 @@ scan_words (ptrdiff_t from, EMACS_INT count) { if (from == beg) break; - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from); ch0 = FETCH_CHAR_AS_MULTIBYTE (from_byte); code = SYNTAX (ch0); @@ -1539,7 +1536,7 @@ scan_words (ptrdiff_t from, EMACS_INT count) || (code != Sescape && code != Scharquote))) || word_boundary_p (ch0, ch1)) { - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); break; } ch1 = ch0; @@ -1818,7 +1815,7 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, leading_code = str[i_byte]; } - c = STRING_CHAR_AND_LENGTH (str + i_byte, len); + c = string_char_and_length (str + i_byte, &len); i_byte += len; @@ -1834,14 +1831,14 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, /* Get the end of the range. */ leading_code2 = str[i_byte]; - c2 = STRING_CHAR_AND_LENGTH (str + i_byte, len); + c2 = string_char_and_length (str + i_byte, &len); i_byte += len; if (c2 == '\\' && i_byte < size_byte) { leading_code2 = str[i_byte]; - c2 = STRING_CHAR_AND_LENGTH (str + i_byte, len); + c2 = string_char_and_length (str + i_byte, &len); i_byte += len; } @@ -1953,7 +1950,7 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, p = GAP_END_ADDR; stop = endp; } - c = STRING_CHAR_AND_LENGTH (p, nbytes); + c = string_char_and_length (p, &nbytes); if (! NILP (iso_classes) && in_classes (c, iso_classes)) { if (negate) @@ -2175,7 +2172,7 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim) stop = endp; } if (multibyte) - c = STRING_CHAR_AND_LENGTH (p, nbytes); + c = string_char_and_length (p, &nbytes); else c = *p, nbytes = 1; if (! fastmap[SYNTAX (c)]) @@ -2339,7 +2336,7 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, && SYNTAX_FLAGS_COMMENT_STYLE (syntax, 0) == style && (SYNTAX_FLAGS_COMMENT_NESTED (syntax) ? (nesting > 0 && --nesting == 0) : nesting < 0) - && !(Vcomment_end_can_be_escaped && char_quoted (from, from_byte))) + && !(comment_end_can_be_escaped && char_quoted (from, from_byte))) /* We have encountered a comment end of the same style as the comment sequence which began this comment section. */ @@ -2357,7 +2354,14 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, /* We have encountered a nested comment of the same style as the comment sequence which began this comment section. */ nesting++; - INC_BOTH (from, from_byte); + if (comment_end_can_be_escaped + && (code == Sescape || code == Scharquote)) + { + inc_both (&from, &from_byte); + UPDATE_SYNTAX_TABLE_FORWARD (from); + if (from == stop) continue; /* Failure */ + } + inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); forw_incomment: @@ -2378,7 +2382,7 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, break; else { - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); } } @@ -2395,7 +2399,7 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, as the comment sequence which began this comment section. */ { syntax = Smax; /* So that "#|#" isn't also a comment ender. */ - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); nesting++; } @@ -2437,7 +2441,7 @@ between them, return t; otherwise return nil. */) from = PT; from_byte = PT_BYTE; - SETUP_SYNTAX_TABLE (from, count1); + SETUP_SYNTAX_TABLE (from, clip_to_bounds (PTRDIFF_MIN, count1, PTRDIFF_MAX)); while (count1 > 0) { do @@ -2456,7 +2460,7 @@ between them, return t; otherwise return nil. */) comstart_first = SYNTAX_FLAGS_COMSTART_FIRST (syntax); comnested = SYNTAX_FLAGS_COMMENT_NESTED (syntax); comstyle = SYNTAX_FLAGS_COMMENT_STYLE (syntax, 0); - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); if (from < stop && comstart_first && (c1 = FETCH_CHAR_AS_MULTIBYTE (from_byte), @@ -2471,7 +2475,7 @@ between them, return t; otherwise return nil. */) code = Scomment; comstyle = SYNTAX_FLAGS_COMMENT_STYLE (other_syntax, syntax); comnested |= SYNTAX_FLAGS_COMMENT_NESTED (other_syntax); - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); } rarely_quit (++quit_count); @@ -2482,7 +2486,7 @@ between them, return t; otherwise return nil. */) comstyle = ST_COMMENT_STYLE; else if (code != Scomment) { - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); SET_PT_BOTH (from, from_byte); return Qnil; } @@ -2495,7 +2499,7 @@ between them, return t; otherwise return nil. */) SET_PT_BOTH (from, from_byte); return Qnil; } - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); /* We have skipped one comment. */ count1--; @@ -2511,7 +2515,7 @@ between them, return t; otherwise return nil. */) return Qnil; } - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); /* char_quoted does UPDATE_SYNTAX_TABLE_BACKWARD (from). */ bool quoted = char_quoted (from, from_byte); c = FETCH_CHAR_AS_MULTIBYTE (from_byte); @@ -2529,7 +2533,7 @@ between them, return t; otherwise return nil. */) /* We must record the comment style encountered so that later, we can match only the proper comment begin sequence of the same style. */ - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); code = Sendcomment; /* Calling char_quoted, above, set up global syntax position at the new value of FROM. */ @@ -2549,7 +2553,7 @@ between them, return t; otherwise return nil. */) { while (1) { - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from); c = FETCH_CHAR_AS_MULTIBYTE (from_byte); if (SYNTAX (c) == Scomment_fence @@ -2575,8 +2579,9 @@ between them, return t; otherwise return nil. */) } else if (code == Sendcomment) { - found = back_comment (from, from_byte, stop, comnested, comstyle, - &out_charpos, &out_bytepos); + found = (!quoted || !comment_end_can_be_escaped) + && back_comment (from, from_byte, stop, comnested, comstyle, + &out_charpos, &out_bytepos); if (!found) { if (c == '\n') @@ -2590,7 +2595,7 @@ between them, return t; otherwise return nil. */) not-quite-endcomment. */ if (SYNTAX (c) != code) /* It was a two-char Sendcomment. */ - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); goto leave; } } @@ -2604,7 +2609,7 @@ between them, return t; otherwise return nil. */) else if (code != Swhitespace || quoted) { leave: - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); SET_PT_BOTH (from, from_byte); return Qnil; } @@ -2629,7 +2634,7 @@ syntax_multibyte (int c, bool multibyte_symbol_p) } static Lisp_Object -scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) +scan_lists (EMACS_INT from0, EMACS_INT count, EMACS_INT depth, bool sexpflag) { Lisp_Object val; ptrdiff_t stop = count > 0 ? ZV : BEGV; @@ -2642,7 +2647,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) int comstyle = 0; /* Style of comment encountered. */ bool comnested = 0; /* Whether the comment is nestable or not. */ ptrdiff_t temp_pos; - EMACS_INT last_good = from; + EMACS_INT last_good = from0; bool found; ptrdiff_t from_byte; ptrdiff_t out_bytepos, out_charpos; @@ -2653,14 +2658,13 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) if (depth > 0) min_depth = 0; - if (from > ZV) from = ZV; - if (from < BEGV) from = BEGV; + ptrdiff_t from = clip_to_bounds (BEGV, from0, ZV); from_byte = CHAR_TO_BYTE (from); maybe_quit (); - SETUP_SYNTAX_TABLE (from, count); + SETUP_SYNTAX_TABLE (from, clip_to_bounds (PTRDIFF_MIN, count, PTRDIFF_MAX)); while (count > 0) { while (from < stop) @@ -2678,7 +2682,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) prefix = SYNTAX_FLAGS_PREFIX (syntax); if (depth == min_depth) last_good = from; - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); if (from < stop && comstart_first && (c = FETCH_CHAR_AS_MULTIBYTE (from_byte), @@ -2694,7 +2698,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) code = Scomment; comstyle = SYNTAX_FLAGS_COMMENT_STYLE (other_syntax, syntax); comnested |= SYNTAX_FLAGS_COMMENT_NESTED (other_syntax); - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); } @@ -2707,7 +2711,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) case Scharquote: if (from == stop) goto lose; - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); /* Treat following character as a word constituent. */ FALLTHROUGH; case Sword: @@ -2723,7 +2727,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) { case Scharquote: case Sescape: - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); if (from == stop) goto lose; break; @@ -2734,7 +2738,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) default: goto done; } - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); rarely_quit (++quit_count); } goto done; @@ -2756,7 +2760,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) goto done; goto lose; } - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); break; @@ -2765,7 +2769,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) break; if (from != stop && c == FETCH_CHAR_AS_MULTIBYTE (from_byte)) { - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); } if (mathexit) { @@ -2805,11 +2809,11 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) break; if (c_code == Scharquote || c_code == Sescape) - INC_BOTH (from, from_byte); - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); + inc_both (&from, &from_byte); rarely_quit (++quit_count); } - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); if (!depth && sexpflag) goto done; break; default: @@ -2834,7 +2838,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) while (from > stop) { rarely_quit (++quit_count); - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from); c = FETCH_CHAR_AS_MULTIBYTE (from_byte); int syntax = SYNTAX_WITH_FLAGS (c); @@ -2853,7 +2857,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) later, we can match only the proper comment begin sequence of the same style. */ int c2, other_syntax; - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from); code = Sendcomment; c2 = FETCH_CHAR_AS_MULTIBYTE (from_byte); @@ -2867,7 +2871,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) if we decremented FROM in the if-statement above. */ if (code != Sendcomment && char_quoted (from, from_byte)) { - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); code = Sword; } else if (SYNTAX_FLAGS_PREFIX (syntax)) @@ -2884,11 +2888,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) after passing it. */ while (from > stop) { - temp_pos = from_byte; - if (! NILP (BVAR (current_buffer, enable_multibyte_characters))) - DEC_POS (temp_pos); - else - temp_pos--; + temp_pos = dec_bytepos (from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from - 1); c1 = FETCH_CHAR_AS_MULTIBYTE (temp_pos); /* Don't allow comment-end to be quoted. */ @@ -2897,7 +2897,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) quoted = char_quoted (from - 1, temp_pos); if (quoted) { - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); temp_pos = dec_bytepos (temp_pos); UPDATE_SYNTAX_TABLE_BACKWARD (from - 1); } @@ -2908,7 +2908,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) case Sword: case Ssymbol: case Squote: break; default: goto done2; } - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); rarely_quit (++quit_count); } goto done2; @@ -2921,7 +2921,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) temp_pos = dec_bytepos (from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from - 1); if (from != stop && c == FETCH_CHAR_AS_MULTIBYTE (temp_pos)) - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); } if (mathexit) { @@ -2964,7 +2964,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) { if (from == stop) goto lose; - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from); if (!char_quoted (from, from_byte)) { @@ -2983,7 +2983,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) { if (from == stop) goto lose; - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from); if (!char_quoted (from, from_byte)) { @@ -3093,7 +3093,7 @@ the prefix syntax flag (p). */) SETUP_SYNTAX_TABLE (pos, -1); - DEC_BOTH (pos, pos_byte); + dec_both (&pos, &pos_byte); while (!char_quoted (pos, pos_byte) /* Previous statement updates syntax table. */ @@ -3105,7 +3105,7 @@ the prefix syntax flag (p). */) if (pos <= beg) break; - DEC_BOTH (pos, pos_byte); + dec_both (&pos, &pos_byte); rarely_quit (pos); } @@ -3182,7 +3182,7 @@ scan_sexps_forward (struct lisp_parse_state *state, prev_from = from; prev_from_byte = from_byte; if (from != BEGV) - DEC_BOTH (prev_from, prev_from_byte); + dec_both (&prev_from, &prev_from_byte); /* Use this macro instead of `from++'. */ #define INC_FROM \ @@ -3191,7 +3191,7 @@ do { prev_from = from; \ temp = FETCH_CHAR_AS_MULTIBYTE (prev_from_byte); \ prev_prev_from_syntax = prev_from_syntax; \ prev_from_syntax = SYNTAX_WITH_FLAGS (temp); \ - INC_BOTH (from, from_byte); \ + inc_both (&from, &from_byte); \ if (from < end) \ UPDATE_SYNTAX_TABLE_FORWARD (from); \ } while (0) @@ -3627,9 +3627,9 @@ init_syntax_once (void) DEFSYM (Qsyntax_table, "syntax-table"); /* Create objects which can be shared among syntax tables. */ - Vsyntax_code_object = make_uninit_vector (Smax); + Vsyntax_code_object = make_nil_vector (Smax); for (i = 0; i < Smax; i++) - ASET (Vsyntax_code_object, i, Fcons (make_fixnum (i), Qnil)); + ASET (Vsyntax_code_object, i, list1 (make_fixnum (i))); /* Now we are ready to set up this property, so we can create syntax tables. */ @@ -3770,9 +3770,9 @@ character of that word. In both cases, LIMIT bounds the search. */); Vfind_word_boundary_function_table = Fmake_char_table (Qnil, Qnil); - DEFVAR_BOOL ("comment-end-can-be-escaped", Vcomment_end_can_be_escaped, + DEFVAR_BOOL ("comment-end-can-be-escaped", comment_end_can_be_escaped, doc: /* Non-nil means an escaped ender inside a comment doesn't end the comment. */); - Vcomment_end_can_be_escaped = 0; + comment_end_can_be_escaped = false; DEFSYM (Qcomment_end_can_be_escaped, "comment-end-can-be-escaped"); Fmake_variable_buffer_local (Qcomment_end_can_be_escaped); diff --git a/src/sysdep.c b/src/sysdep.c index d100a5cb50b..941b4e2fa24 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -27,6 +27,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #endif /* HAVE_PWD_H */ #include <limits.h> #include <stdlib.h> +#include <sys/random.h> #include <unistd.h> #include <c-ctype.h> @@ -48,10 +49,18 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ # include <cygwin/fs.h> #endif -#if defined DARWIN_OS || defined __FreeBSD__ +#if defined DARWIN_OS || defined __FreeBSD__ || defined __OpenBSD__ # include <sys/sysctl.h> #endif +#if defined __OpenBSD__ +# include <sys/proc.h> +#endif + +#ifdef DARWIN_OS +# include <libproc.h> +#endif + #ifdef __FreeBSD__ /* Sparc/ARM machine/frame.h has 'struct frame' which conflicts with Emacs's 'struct frame', so rename it. */ @@ -115,16 +124,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "process.h" #include "cm.h" -#include "gnutls.h" -/* MS-Windows loads GnuTLS at run time, if available; we don't want to - do that during startup just to call gnutls_rnd. */ -#if defined HAVE_GNUTLS && !defined WINDOWSNT -# include <gnutls/crypto.h> -#else -# define emacs_gnutls_global_init() Qnil -# define gnutls_rnd(level, data, len) (-1) -#endif - #ifdef WINDOWSNT # include <direct.h> /* In process.h which conflicts with the local copy. */ @@ -135,11 +134,6 @@ int _cdecl _spawnlp (int, const char *, const char *, ...); # include <sys/socket.h> #endif -/* ULLONG_MAX is missing on Red Hat Linux 7.3; see Bug#11781. */ -#ifndef ULLONG_MAX -#define ULLONG_MAX TYPE_MAXIMUM (unsigned long long int) -#endif - /* Declare here, including term.h is problematic on some systems. */ extern void tputs (const char *, int, int (*)(int)); @@ -204,6 +198,7 @@ maybe_disable_address_randomization (int argc, char **argv) } #endif +#ifndef WINDOWSNT /* Execute the program in FILE, with argument vector ARGV and environ ENVP. Return an error number if unsuccessful. This is like execve except it reenables ASLR in the executed program if necessary, and @@ -220,6 +215,8 @@ emacs_exec_file (char const *file, char *const *argv, char *const *envp) return errno; } +#endif /* !WINDOWSNT */ + /* If FD is not already open, arrange for it to be open with FLAGS. */ static void force_open (int fd, int flags) @@ -274,12 +271,12 @@ get_current_dir_name_or_unreachable (void) char *pwd; - /* The maximum size of a directory name, including the terminating NUL. + /* The maximum size of a directory name, including the terminating null. Leave room so that the caller can append a trailing slash. */ ptrdiff_t dirsize_max = min (PTRDIFF_MAX, SIZE_MAX) - 1; /* The maximum size of a buffer for a file name, including the - terminating NUL. This is bounded by PATH_MAX, if available. */ + terminating null. This is bounded by PATH_MAX, if available. */ ptrdiff_t bufsize_max = dirsize_max; #ifdef PATH_MAX bufsize_max = min (bufsize_max, PATH_MAX); @@ -317,37 +314,25 @@ get_current_dir_name_or_unreachable (void) if (pwd && (pwdlen = strnlen (pwd, bufsize_max)) < bufsize_max && IS_DIRECTORY_SEP (pwd[pwdlen && IS_DEVICE_SEP (pwd[1]) ? 2 : 0]) - && stat (pwd, &pwdstat) == 0 - && stat (".", &dotstat) == 0 + && emacs_fstatat (AT_FDCWD, pwd, &pwdstat, 0) == 0 + && emacs_fstatat (AT_FDCWD, ".", &dotstat, 0) == 0 && dotstat.st_ino == pwdstat.st_ino && dotstat.st_dev == pwdstat.st_dev) - { - char *buf = malloc (pwdlen + 1); - if (!buf) - return NULL; - return memcpy (buf, pwd, pwdlen + 1); - } + return strdup (pwd); else { ptrdiff_t buf_size = min (bufsize_max, 1024); - char *buf = malloc (buf_size); - if (!buf) - return NULL; for (;;) { + char *buf = malloc (buf_size); + if (!buf) + return NULL; if (getcwd (buf, buf_size) == buf) return buf; - int getcwd_errno = errno; - if (getcwd_errno != ERANGE || buf_size == bufsize_max) - { - free (buf); - errno = getcwd_errno; - return NULL; - } + free (buf); + if (errno != ERANGE || buf_size == bufsize_max) + return NULL; buf_size = buf_size <= bufsize_max / 2 ? 2 * buf_size : bufsize_max; - buf = realloc (buf, buf_size); - if (!buf) - return NULL; } } } @@ -1770,24 +1755,6 @@ deliver_thread_signal (int sig, signal_handler_t handler) errno = old_errno; } -#if !HAVE_DECL_SYS_SIGLIST -# undef sys_siglist -# ifdef _sys_siglist -# define sys_siglist _sys_siglist -# elif HAVE_DECL___SYS_SIGLIST -# define sys_siglist __sys_siglist -# else -# define sys_siglist my_sys_siglist -static char const *sys_siglist[NSIG]; -# endif -#endif - -#ifdef _sys_nsig -# define sys_siglist_entries _sys_nsig -#else -# define sys_siglist_entries NSIG -#endif - /* Handle bus errors, invalid instruction, etc. */ static void handle_fatal_signal (int sig) @@ -1979,144 +1946,6 @@ init_signals (void) main_thread_id = pthread_self (); #endif -#if !HAVE_DECL_SYS_SIGLIST && !defined _sys_siglist - if (! initialized - || dumped_with_pdumper_p ()) - { - sys_siglist[SIGABRT] = "Aborted"; -# ifdef SIGAIO - sys_siglist[SIGAIO] = "LAN I/O interrupt"; -# endif - sys_siglist[SIGALRM] = "Alarm clock"; -# ifdef SIGBUS - sys_siglist[SIGBUS] = "Bus error"; -# endif -# ifdef SIGCHLD - sys_siglist[SIGCHLD] = "Child status changed"; -# endif -# ifdef SIGCONT - sys_siglist[SIGCONT] = "Continued"; -# endif -# ifdef SIGDANGER - sys_siglist[SIGDANGER] = "Swap space dangerously low"; -# endif -# ifdef SIGDGNOTIFY - sys_siglist[SIGDGNOTIFY] = "Notification message in queue"; -# endif -# ifdef SIGEMT - sys_siglist[SIGEMT] = "Emulation trap"; -# endif - sys_siglist[SIGFPE] = "Arithmetic exception"; -# ifdef SIGFREEZE - sys_siglist[SIGFREEZE] = "SIGFREEZE"; -# endif -# ifdef SIGGRANT - sys_siglist[SIGGRANT] = "Monitor mode granted"; -# endif - sys_siglist[SIGHUP] = "Hangup"; - sys_siglist[SIGILL] = "Illegal instruction"; - sys_siglist[SIGINT] = "Interrupt"; -# ifdef SIGIO - sys_siglist[SIGIO] = "I/O possible"; -# endif -# ifdef SIGIOINT - sys_siglist[SIGIOINT] = "I/O intervention required"; -# endif -# ifdef SIGIOT - sys_siglist[SIGIOT] = "IOT trap"; -# endif - sys_siglist[SIGKILL] = "Killed"; -# ifdef SIGLOST - sys_siglist[SIGLOST] = "Resource lost"; -# endif -# ifdef SIGLWP - sys_siglist[SIGLWP] = "SIGLWP"; -# endif -# ifdef SIGMSG - sys_siglist[SIGMSG] = "Monitor mode data available"; -# endif -# ifdef SIGPHONE - sys_siglist[SIGWIND] = "SIGPHONE"; -# endif - sys_siglist[SIGPIPE] = "Broken pipe"; -# ifdef SIGPOLL - sys_siglist[SIGPOLL] = "Pollable event occurred"; -# endif -# ifdef SIGPROF - sys_siglist[SIGPROF] = "Profiling timer expired"; -# endif -# ifdef SIGPTY - sys_siglist[SIGPTY] = "PTY I/O interrupt"; -# endif -# ifdef SIGPWR - sys_siglist[SIGPWR] = "Power-fail restart"; -# endif - sys_siglist[SIGQUIT] = "Quit"; -# ifdef SIGRETRACT - sys_siglist[SIGRETRACT] = "Need to relinquish monitor mode"; -# endif -# ifdef SIGSAK - sys_siglist[SIGSAK] = "Secure attention"; -# endif - sys_siglist[SIGSEGV] = "Segmentation violation"; -# ifdef SIGSOUND - sys_siglist[SIGSOUND] = "Sound completed"; -# endif -# ifdef SIGSTOP - sys_siglist[SIGSTOP] = "Stopped (signal)"; -# endif -# ifdef SIGSTP - sys_siglist[SIGSTP] = "Stopped (user)"; -# endif -# ifdef SIGSYS - sys_siglist[SIGSYS] = "Bad argument to system call"; -# endif - sys_siglist[SIGTERM] = "Terminated"; -# ifdef SIGTHAW - sys_siglist[SIGTHAW] = "SIGTHAW"; -# endif -# ifdef SIGTRAP - sys_siglist[SIGTRAP] = "Trace/breakpoint trap"; -# endif -# ifdef SIGTSTP - sys_siglist[SIGTSTP] = "Stopped (user)"; -# endif -# ifdef SIGTTIN - sys_siglist[SIGTTIN] = "Stopped (tty input)"; -# endif -# ifdef SIGTTOU - sys_siglist[SIGTTOU] = "Stopped (tty output)"; -# endif -# ifdef SIGURG - sys_siglist[SIGURG] = "Urgent I/O condition"; -# endif -# ifdef SIGUSR1 - sys_siglist[SIGUSR1] = "User defined signal 1"; -# endif -# ifdef SIGUSR2 - sys_siglist[SIGUSR2] = "User defined signal 2"; -# endif -# ifdef SIGVTALRM - sys_siglist[SIGVTALRM] = "Virtual timer expired"; -# endif -# ifdef SIGWAITING - sys_siglist[SIGWAITING] = "Process's LWPs are blocked"; -# endif -# ifdef SIGWINCH - sys_siglist[SIGWINCH] = "Window size changed"; -# endif -# ifdef SIGWIND - sys_siglist[SIGWIND] = "SIGWIND"; -# endif -# ifdef SIGXCPU - sys_siglist[SIGXCPU] = "CPU time limit exceeded"; -# endif -# ifdef SIGXFSZ - sys_siglist[SIGXFSZ] = "File size limit exceeded"; -# endif - } -#endif /* !HAVE_DECL_SYS_SIGLIST && !_sys_siglist */ - /* Don't alter signal handlers if dumping. On some machines, changing signal handlers sets static data that would make signals fail to work right when the dumped Emacs is run. */ @@ -2283,9 +2112,7 @@ init_signals (void) typedef unsigned int random_seed; static void set_random_seed (random_seed arg) { srandom (arg); } #elif defined HAVE_LRAND48 -/* Although srand48 uses a long seed, this is unsigned long to avoid - undefined behavior on signed integer overflow in init_random. */ -typedef unsigned long int random_seed; +typedef long int random_seed; static void set_random_seed (random_seed arg) { srand48 (arg); } #else typedef unsigned int random_seed; @@ -2312,23 +2139,14 @@ init_random (void) /* First, try seeding the PRNG from the operating system's entropy source. This approach is both fast and secure. */ #ifdef WINDOWSNT + /* FIXME: Perhaps getrandom can be used here too? */ success = w32_init_random (&v, sizeof v) == 0; #else - int fd = emacs_open ("/dev/urandom", O_RDONLY, 0); - if (0 <= fd) - { - success = emacs_read (fd, &v, sizeof v) == sizeof v; - close (fd); - } + verify (sizeof v <= 256); + success = getrandom (&v, sizeof v, 0) == sizeof v; #endif - /* If that didn't work, try using GnuTLS, which is secure, but on - some systems, can be somewhat slow. */ - if (!success) - success = EQ (emacs_gnutls_global_init (), Qt) - && gnutls_rnd (GNUTLS_RND_NONCE, &v, sizeof v) == 0; - - /* If _that_ didn't work, just use the current time value and PID. + /* If that didn't work, just use the current time value and PID. It's at least better than XKCD 221. */ if (!success) { @@ -2457,7 +2275,27 @@ emacs_abort (void) } #endif -/* Open FILE for Emacs use, using open flags OFLAG and mode MODE. +/* Assuming the directory DIRFD, store information about FILENAME into *ST, + using FLAGS to control how the status is obtained. + Do not fail merely because fetching info was interrupted by a signal. + Allow the user to quit. + + The type of ST is void * instead of struct stat * because the + latter type would be problematic in lisp.h. Some platforms may + play tricks like "#define stat stat64" in <sys/stat.h>, and lisp.h + does not include <sys/stat.h>. */ + +int +emacs_fstatat (int dirfd, char const *filename, void *st, int flags) +{ + int r; + while ((r = fstatat (dirfd, filename, st, flags)) != 0 && errno == EINTR) + maybe_quit (); + return r; +} + +/* Assuming the directory DIRFD, open FILE for Emacs use, + using open flags OFLAGS and mode MODE. Use binary I/O on systems that care about text vs binary I/O. Arrange for subprograms to not inherit the file descriptor. Prefer a method that is multithread-safe, if available. @@ -2465,17 +2303,45 @@ emacs_abort (void) Allow the user to quit. */ int -emacs_open (const char *file, int oflags, int mode) +emacs_openat (int dirfd, char const *file, int oflags, int mode) { int fd; if (! (oflags & O_TEXT)) oflags |= O_BINARY; oflags |= O_CLOEXEC; - while ((fd = open (file, oflags, mode)) < 0 && errno == EINTR) + while ((fd = openat (dirfd, file, oflags, mode)) < 0 && errno == EINTR) maybe_quit (); return fd; } +int +emacs_open (char const *file, int oflags, int mode) +{ + return emacs_openat (AT_FDCWD, file, oflags, mode); +} + +/* Same as above, but doesn't allow the user to quit. */ + +static int +emacs_openat_noquit (int dirfd, const char *file, int oflags, + int mode) +{ + int fd; + if (! (oflags & O_TEXT)) + oflags |= O_BINARY; + oflags |= O_CLOEXEC; + do + fd = openat (dirfd, file, oflags, mode); + while (fd < 0 && errno == EINTR); + return fd; +} + +int +emacs_open_noquit (char const *file, int oflags, int mode) +{ + return emacs_openat_noquit (AT_FDCWD, file, oflags, mode); +} + /* Open FILE as a stream for Emacs use, with mode MODE. Act like emacs_open with respect to threads, signals, and quits. */ @@ -2734,21 +2600,6 @@ emacs_perror (char const *message) errno = err; } -/* Set the access and modification time stamps of FD (a.k.a. FILE) to be - ATIME and MTIME, respectively. - FD must be either negative -- in which case it is ignored -- - or a file descriptor that is open on FILE. - If FD is nonnegative, then FILE can be NULL. */ -int -set_file_times (int fd, const char *filename, - struct timespec atime, struct timespec mtime) -{ - struct timespec timespec[2]; - timespec[0] = atime; - timespec[1] = mtime; - return fdutimens (fd, filename, timespec); -} - /* Rename directory SRCFD's entry SRC to directory DSTFD's entry DST. This is like renameat except that it fails if DST already exists, or if this operation is not supported atomically. Return 0 if @@ -2772,15 +2623,13 @@ renameat_noreplace (int srcfd, char const *src, int dstfd, char const *dst) #endif } -/* Like strsignal, except async-signal-safe, and this function typically +/* Like strsignal, except async-signal-safe, and this function returns a string in the C locale rather than the current locale. */ char const * safe_strsignal (int code) { - char const *signame = 0; + char const *signame = sigdescr_np (code); - if (0 <= code && code < sys_siglist_entries) - signame = sys_siglist[code]; if (! signame) signame = "Unknown signal"; @@ -3059,7 +2908,8 @@ list_system_processes (void) process. */ procdir = build_string ("/proc"); match = build_string ("[0-9]+"); - proclist = directory_files_internal (procdir, Qnil, match, Qt, false, Qnil); + proclist = directory_files_internal (procdir, Qnil, match, Qt, + false, Qnil, Qnil); /* `proclist' gives process IDs as strings. Destructively convert each string into a number. */ @@ -3075,37 +2925,43 @@ list_system_processes (void) return proclist; } -#elif defined DARWIN_OS || defined __FreeBSD__ +#elif defined DARWIN_OS || defined __FreeBSD__ || defined __OpenBSD__ Lisp_Object list_system_processes (void) { #ifdef DARWIN_OS int mib[] = {CTL_KERN, KERN_PROC, KERN_PROC_ALL}; +#elif defined __OpenBSD__ + int mib[] = {CTL_KERN, KERN_PROC, KERN_PROC_ALL, 0, + sizeof (struct kinfo_proc), 4096}; #else int mib[] = {CTL_KERN, KERN_PROC, KERN_PROC_PROC}; #endif size_t len; + size_t mibsize = sizeof mib / sizeof mib[0]; struct kinfo_proc *procs; size_t i; Lisp_Object proclist = Qnil; - if (sysctl (mib, 3, NULL, &len, NULL, 0) != 0 || len == 0) + if (sysctl (mib, mibsize, NULL, &len, NULL, 0) != 0 || len == 0) return proclist; procs = xmalloc (len); - if (sysctl (mib, 3, procs, &len, NULL, 0) != 0 || len == 0) + if (sysctl (mib, mibsize, procs, &len, NULL, 0) != 0 || len == 0) { xfree (procs); return proclist; } - len /= sizeof (struct kinfo_proc); + len /= sizeof procs[0]; for (i = 0; i < len; i++) { #ifdef DARWIN_OS proclist = Fcons (INT_TO_INTEGER (procs[i].kp_proc.p_pid), proclist); +#elif defined __OpenBSD__ + proclist = Fcons (INT_TO_INTEGER (procs[i].p_pid), proclist); #else proclist = Fcons (INT_TO_INTEGER (procs[i].ki_pid), proclist); #endif @@ -3142,9 +2998,17 @@ make_lisp_timeval (struct timeval t) return make_lisp_time (timeval_to_timespec (t)); } +#elif defined __OpenBSD__ + +static Lisp_Object +make_lisp_timeval (long sec, long usec) +{ + return make_lisp_time(make_timespec(sec, usec * 1000)); +} + #endif -#if defined GNU_LINUX && defined HAVE_LONG_LONG_INT +#ifdef GNU_LINUX static struct timespec time_from_jiffies (unsigned long long tval, long hz) { @@ -3492,7 +3356,7 @@ system_process_attributes (Lisp_Object pid) if (nread) { - /* We don't want trailing NUL characters. */ + /* We don't want trailing null characters. */ for (p = cmdline + nread; cmdline < p && !p[-1]; p--) continue; @@ -3831,6 +3695,189 @@ system_process_attributes (Lisp_Object pid) return attrs; } +#elif defined __OpenBSD__ + +Lisp_Object +system_process_attributes (Lisp_Object pid) +{ + int proc_id, nentries, fscale, i; + int pagesize = getpagesize (); + int mib[6]; + size_t len; + double pct; + char *ttyname, args[ARG_MAX]; + struct kinfo_proc proc; + struct passwd *pw; + struct group *gr; + struct timespec t; + struct uvmexp uvmexp; + + Lisp_Object attrs = Qnil; + Lisp_Object decoded_comm; + + CHECK_NUMBER (pid); + CONS_TO_INTEGER (pid, int, proc_id); + + len = sizeof proc; + mib[0] = CTL_KERN; + mib[1] = KERN_PROC; + mib[2] = KERN_PROC_PID; + mib[3] = proc_id; + mib[4] = len; + mib[5] = 1; + if (sysctl (mib, 6, &proc, &len, NULL, 0) != 0) + return attrs; + + attrs = Fcons (Fcons (Qeuid, INT_TO_INTEGER (proc.p_uid)), attrs); + + block_input (); + pw = getpwuid (proc.p_uid); + unblock_input (); + if (pw) + attrs = Fcons (Fcons (Quser, build_string(pw->pw_name)), attrs); + + attrs = Fcons (Fcons (Qegid, INT_TO_INTEGER(proc.p_svgid)), attrs); + + block_input (); + gr = getgrgid (proc.p_svgid); + unblock_input (); + if (gr) + attrs = Fcons (Fcons (Qgroup, build_string (gr->gr_name)), attrs); + + AUTO_STRING (comm, proc.p_comm); + decoded_comm = code_convert_string_norecord (comm, Vlocale_coding_system, 0); + attrs = Fcons (Fcons (Qcomm, decoded_comm), attrs); + + { + char state[2] = {'\0', '\0'}; + switch (proc.p_stat) { + case SIDL: + state[0] = 'I'; + break; + case SRUN: + state[0] = 'R'; + break; + case SSLEEP: + state[0] = 'S'; + break; + case SSTOP: + state[0] = 'T'; + break; + case SZOMB: + state[0] = 'Z'; + break; + case SDEAD: + state[0] = 'D'; + break; + } + attrs = Fcons (Fcons (Qstate, build_string (state)), attrs); + } + + attrs = Fcons (Fcons (Qppid, INT_TO_INTEGER (proc.p_ppid)), attrs); + attrs = Fcons (Fcons (Qpgrp, INT_TO_INTEGER (proc.p_gid)), attrs); + attrs = Fcons (Fcons (Qsess, INT_TO_INTEGER (proc.p_sid)), attrs); + + block_input (); + ttyname = proc.p_tdev == NODEV ? NULL : devname (proc.p_tdev, S_IFCHR); + unblock_input (); + if (ttyname) + attrs = Fcons (Fcons (Qttname, build_string (ttyname)), attrs); + + attrs = Fcons (Fcons (Qtpgid, INT_TO_INTEGER (proc.p_tpgid)), attrs); + attrs = Fcons (Fcons (Qminflt, INT_TO_INTEGER (proc.p_uru_minflt)), + attrs); + attrs = Fcons (Fcons (Qmajflt, INT_TO_INTEGER (proc.p_uru_majflt)), + attrs); + + /* FIXME: missing cminflt, cmajflt. */ + + attrs = Fcons (Fcons (Qutime, make_lisp_timeval (proc.p_uutime_sec, + proc.p_uutime_usec)), + attrs); + attrs = Fcons (Fcons (Qstime, make_lisp_timeval (proc.p_ustime_sec, + proc.p_ustime_usec)), + attrs); + t = timespec_add (make_timespec (proc.p_uutime_sec, + proc.p_uutime_usec * 1000), + make_timespec (proc.p_ustime_sec, + proc.p_ustime_usec * 1000)); + attrs = Fcons (Fcons (Qtime, make_lisp_time (t)), attrs); + + attrs = Fcons (Fcons (Qcutime, make_lisp_timeval (proc.p_uctime_sec, + proc.p_uctime_usec)), + attrs); + + /* FIXME: missing cstime and thus ctime. */ + + attrs = Fcons (Fcons (Qpri, make_fixnum (proc.p_priority)), attrs); + attrs = Fcons (Fcons (Qnice, make_fixnum (proc.p_nice)), attrs); + + /* FIXME: missing thcount (thread count) */ + + attrs = Fcons (Fcons (Qstart, make_lisp_timeval (proc.p_ustart_sec, + proc.p_ustart_usec)), + attrs); + + len = (proc.p_vm_tsize + proc.p_vm_dsize + proc.p_vm_ssize) * pagesize >> 10; + attrs = Fcons (Fcons (Qvsize, make_fixnum (len)), attrs); + + attrs = Fcons (Fcons (Qrss, make_fixnum (proc.p_vm_rssize * pagesize >> 10)), + attrs); + + t = make_timespec (proc.p_ustart_sec, + proc.p_ustart_usec * 1000); + t = timespec_sub (current_timespec (), t); + attrs = Fcons (Fcons (Qetime, make_lisp_time (t)), attrs); + + len = sizeof (fscale); + mib[0] = CTL_KERN; + mib[1] = KERN_FSCALE; + if (sysctl (mib, 2, &fscale, &len, NULL, 0) != -1) + { + pct = (double)proc.p_pctcpu / fscale * 100.0; + attrs = Fcons (Fcons (Qpcpu, make_float (pct)), attrs); + } + + len = sizeof (uvmexp); + mib[0] = CTL_VM; + mib[1] = VM_UVMEXP; + if (sysctl (mib, 2, &uvmexp, &len, NULL, 0) != -1) + { + pct = (100.0 * (double)proc.p_vm_rssize / uvmexp.npages); + attrs = Fcons (Fcons (Qpmem, make_float (pct)), attrs); + } + + len = sizeof args; + mib[0] = CTL_KERN; + mib[1] = KERN_PROC_ARGS; + mib[2] = proc_id; + mib[3] = KERN_PROC_ARGV; + if (sysctl (mib, 4, &args, &len, NULL, 0) == 0 && len != 0) + { + char **argv = (char**)args; + + /* concatenate argv reusing the existing storage storage. + sysctl(8) guarantees that "the buffer pointed to by oldp is + filled with an array of char pointers followed by the strings + themselves." */ + for (i = 0; argv[i] != NULL; ++i) + { + if (argv[i+1] != NULL) + { + len = strlen (argv[i]); + argv[i][len] = ' '; + } + } + + AUTO_STRING (comm, *argv); + decoded_comm = code_convert_string_norecord (comm, + Vlocale_coding_system, 0); + attrs = Fcons (Fcons (Qargs, decoded_comm), attrs); + } + + return attrs; +} + #elif defined DARWIN_OS Lisp_Object @@ -3879,8 +3926,21 @@ system_process_attributes (Lisp_Object pid) if (gr) attrs = Fcons (Fcons (Qgroup, build_string (gr->gr_name)), attrs); + char pathbuf[PROC_PIDPATHINFO_MAXSIZE]; + char *comm; + + if (proc_pidpath (proc_id, pathbuf, sizeof(pathbuf)) > 0) + { + if ((comm = strrchr (pathbuf, '/'))) + comm++; + else + comm = pathbuf; + } + else + comm = proc.kp_proc.p_comm; + decoded_comm = (code_convert_string_norecord - (build_unibyte_string (proc.kp_proc.p_comm), + (build_unibyte_string (comm), Vlocale_coding_system, 0)); attrs = Fcons (Fcons (Qcomm, decoded_comm), attrs); @@ -4130,14 +4190,20 @@ str_collate (Lisp_Object s1, Lisp_Object s2, len = SCHARS (s1); i = i_byte = 0; SAFE_NALLOCA (p1, 1, len + 1); while (i < len) - FETCH_STRING_CHAR_ADVANCE (*(p1+i-1), s1, i, i_byte); - *(p1+len) = 0; + { + wchar_t *p = &p1[i]; + *p = fetch_string_char_advance (s1, &i, &i_byte); + } + p1[len] = 0; len = SCHARS (s2); i = i_byte = 0; SAFE_NALLOCA (p2, 1, len + 1); while (i < len) - FETCH_STRING_CHAR_ADVANCE (*(p2+i-1), s2, i, i_byte); - *(p2+len) = 0; + { + wchar_t *p = &p2[i]; + *p = fetch_string_char_advance (s2, &i, &i_byte); + } + p2[len] = 0; if (STRINGP (locale)) { diff --git a/src/systhread.c b/src/systhread.c index 95d1c6fddd9..c68853cacac 100644 --- a/src/systhread.c +++ b/src/systhread.c @@ -26,6 +26,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "nsterm.h" #endif +#ifdef HAVE_PTHREAD_SET_NAME_NP +#include <pthread_np.h> +#endif + #ifndef THREADS_ENABLED void @@ -221,6 +225,10 @@ sys_thread_set_name (const char *name) # else pthread_setname_np (pthread_self (), p_name); # endif +#elif HAVE_PTHREAD_SET_NAME_NP + /* The name will automatically be truncated if it exceeds a + system-specific length. */ + pthread_set_name_np (pthread_self (), name); #endif } diff --git a/src/systhread.h b/src/systhread.h index 23da5daa44d..0f47d7c1a8a 100644 --- a/src/systhread.h +++ b/src/systhread.h @@ -21,12 +21,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <stdbool.h> -#if __has_attribute (warn_unused_result) -# define ATTRIBUTE_WARN_UNUSED_RESULT __attribute__ ((warn_unused_result)) -#else -# define ATTRIBUTE_WARN_UNUSED_RESULT -#endif - #ifdef THREADS_ENABLED #ifdef HAVE_PTHREAD @@ -108,13 +102,13 @@ extern void sys_cond_broadcast (sys_cond_t *); extern void sys_cond_destroy (sys_cond_t *); extern sys_thread_t sys_thread_self (void) - ATTRIBUTE_WARN_UNUSED_RESULT; + NODISCARD; extern bool sys_thread_equal (sys_thread_t, sys_thread_t) - ATTRIBUTE_WARN_UNUSED_RESULT; + NODISCARD; extern bool sys_thread_create (sys_thread_t *, thread_creation_function *, void *) - ATTRIBUTE_WARN_UNUSED_RESULT; + NODISCARD; extern void sys_thread_yield (void); extern void sys_thread_set_name (const char *); diff --git a/src/systime.h b/src/systime.h index 5f40ff6831e..08ab5bdde33 100644 --- a/src/systime.h +++ b/src/systime.h @@ -67,9 +67,6 @@ timespec_valid_p (struct timespec t) return t.tv_nsec >= 0; } -/* defined in sysdep.c */ -extern int set_file_times (int, const char *, struct timespec, struct timespec); - /* defined in keyboard.c */ extern void set_waiting_for_input (struct timespec *); diff --git a/src/term.c b/src/term.c index 9d1359385ca..1059b0669a7 100644 --- a/src/term.c +++ b/src/term.c @@ -105,14 +105,14 @@ struct tty_display_info *tty_list; enum no_color_bit { - NC_STANDOUT = 1 << 0, - NC_UNDERLINE = 1 << 1, - NC_REVERSE = 1 << 2, - NC_ITALIC = 1 << 3, - NC_DIM = 1 << 4, - NC_BOLD = 1 << 5, - NC_INVIS = 1 << 6, - NC_PROTECT = 1 << 7 + NC_STANDOUT = 1 << 0, + NC_UNDERLINE = 1 << 1, + NC_REVERSE = 1 << 2, + NC_ITALIC = 1 << 3, + NC_DIM = 1 << 4, + NC_BOLD = 1 << 5, + NC_STRIKE_THROUGH = 1 << 6, + NC_PROTECT = 1 << 7 }; /* internal state */ @@ -790,7 +790,7 @@ tty_write_glyphs (struct frame *f, struct glyph *string, int len) cmcheckmagic (tty); } -#ifdef HAVE_GPM /* Only used by GPM code. */ +#ifndef DOS_NT static void tty_write_glyphs_with_face (register struct frame *f, register struct glyph *string, @@ -847,6 +847,7 @@ tty_write_glyphs_with_face (register struct frame *f, register struct glyph *str cmcheckmagic (tty); } + #endif /* An implementation of insert_glyphs for termcap frames. */ @@ -1931,6 +1932,10 @@ turn_on_face (struct frame *f, int face_id) if (face->tty_underline_p && MAY_USE_WITH_COLORS_P (tty, NC_UNDERLINE)) OUTPUT1_IF (tty, tty->TS_enter_underline_mode); + if (face->tty_strike_through_p + && MAY_USE_WITH_COLORS_P (tty, NC_STRIKE_THROUGH)) + OUTPUT1_IF (tty, tty->TS_enter_strike_through_mode); + if (tty->TN_max_colors > 0) { const char *ts; @@ -1971,7 +1976,8 @@ turn_off_face (struct frame *f, int face_id) if (face->tty_bold_p || face->tty_italic_p || face->tty_reverse_p - || face->tty_underline_p) + || face->tty_underline_p + || face->tty_strike_through_p) { OUTPUT1_IF (tty, tty->TS_exit_attribute_mode); if (strcmp (tty->TS_exit_attribute_mode, tty->TS_end_standout_mode) == 0) @@ -2006,11 +2012,20 @@ tty_capable_p (struct tty_display_info *tty, unsigned int caps) if ((caps & (cap)) && (!(TS) || !MAY_USE_WITH_COLORS_P(tty, NC_bit))) \ return 0; - TTY_CAPABLE_P_TRY (tty, TTY_CAP_INVERSE, tty->TS_standout_mode, NC_REVERSE); - TTY_CAPABLE_P_TRY (tty, TTY_CAP_UNDERLINE, tty->TS_enter_underline_mode, NC_UNDERLINE); - TTY_CAPABLE_P_TRY (tty, TTY_CAP_BOLD, tty->TS_enter_bold_mode, NC_BOLD); - TTY_CAPABLE_P_TRY (tty, TTY_CAP_DIM, tty->TS_enter_dim_mode, NC_DIM); - TTY_CAPABLE_P_TRY (tty, TTY_CAP_ITALIC, tty->TS_enter_italic_mode, NC_ITALIC); + TTY_CAPABLE_P_TRY (tty, + TTY_CAP_INVERSE, tty->TS_standout_mode, NC_REVERSE); + TTY_CAPABLE_P_TRY (tty, + TTY_CAP_UNDERLINE, tty->TS_enter_underline_mode, + NC_UNDERLINE); + TTY_CAPABLE_P_TRY (tty, + TTY_CAP_BOLD, tty->TS_enter_bold_mode, NC_BOLD); + TTY_CAPABLE_P_TRY (tty, + TTY_CAP_DIM, tty->TS_enter_dim_mode, NC_DIM); + TTY_CAPABLE_P_TRY (tty, + TTY_CAP_ITALIC, tty->TS_enter_italic_mode, NC_ITALIC); + TTY_CAPABLE_P_TRY (tty, + TTY_CAP_STRIKE_THROUGH, tty->TS_enter_strike_through_mode, + NC_STRIKE_THROUGH); /* We can do it! */ return 1; @@ -2366,25 +2381,9 @@ frame's terminal). */) Mouse ***********************************************************************/ -#ifdef HAVE_GPM - -#ifndef HAVE_WINDOW_SYSTEM -void -term_mouse_moveto (int x, int y) -{ - /* TODO: how to set mouse position? - const char *name; - int fd; - name = (const char *) ttyname (0); - fd = emacs_open (name, O_WRONLY, 0); - SOME_FUNCTION (x, y, fd); - emacs_close (fd); - last_mouse_x = x; - last_mouse_y = y; */ -} -#endif /* HAVE_WINDOW_SYSTEM */ +#ifndef DOS_NT -/* Implementation of draw_row_with_mouse_face for TTY/GPM. */ +/* Implementation of draw_row_with_mouse_face for TTY/GPM and macOS. */ void tty_draw_row_with_mouse_face (struct window *w, struct glyph_row *row, int start_hpos, int end_hpos, @@ -2402,7 +2401,7 @@ tty_draw_row_with_mouse_face (struct window *w, struct glyph_row *row, pos_y = row->y + WINDOW_TOP_EDGE_Y (w); pos_x = row->used[LEFT_MARGIN_AREA] + start_hpos + WINDOW_LEFT_EDGE_X (w); - /* Save current cursor co-ordinates. */ + /* Save current cursor coordinates. */ save_y = curY (tty); save_x = curX (tty); cursor_to (f, pos_y, pos_x); @@ -2416,20 +2415,22 @@ tty_draw_row_with_mouse_face (struct window *w, struct glyph_row *row, cursor_to (f, save_y, save_x); } -static bool -term_mouse_movement (struct frame *frame, Gpm_Event *event) +#endif + +#ifdef HAVE_GPM + +void +term_mouse_moveto (int x, int y) { - /* Has the mouse moved off the glyph it was on at the last sighting? */ - if (event->x != last_mouse_x || event->y != last_mouse_y) - { - frame->mouse_moved = 1; - note_mouse_highlight (frame, event->x, event->y); - /* Remember which glyph we're now on. */ - last_mouse_x = event->x; - last_mouse_y = event->y; - return 1; - } - return 0; + /* TODO: how to set mouse position? + const char *name; + int fd; + name = (const char *) ttyname (0); + fd = emacs_open (name, O_WRONLY, 0); + SOME_FUNCTION (x, y, fd); + emacs_close (fd); + last_mouse_x = x; + last_mouse_y = y; */ } /* Return the current time, as a Time value. Wrap around on overflow. */ @@ -2483,7 +2484,7 @@ term_mouse_click (struct input_event *result, Gpm_Event *event, { int i, j; - result->kind = GPM_CLICK_EVENT; + result->kind = MOUSE_CLICK_EVENT; for (i = 0, j = GPM_B_LEFT; i < 3; i++, j >>= 1 ) { if (event->buttons & j) { @@ -2536,67 +2537,55 @@ term_mouse_click (struct input_event *result, Gpm_Event *event, } int -handle_one_term_event (struct tty_display_info *tty, Gpm_Event *event, - struct input_event *hold_quit) +handle_one_term_event (struct tty_display_info *tty, Gpm_Event *event) { struct frame *f = XFRAME (tty->top_frame); struct input_event ie; - bool do_help = 0; int count = 0; EVENT_INIT (ie); ie.kind = NO_EVENT; ie.arg = Qnil; - if (event->type & (GPM_MOVE | GPM_DRAG)) { - previous_help_echo_string = help_echo_string; - help_echo_string = Qnil; - - Gpm_DrawPointer (event->x, event->y, fileno (tty->output)); - - if (!term_mouse_movement (f, event)) - help_echo_string = previous_help_echo_string; - - /* If the contents of the global variable help_echo_string - has changed, generate a HELP_EVENT. */ - if (!NILP (help_echo_string) - || !NILP (previous_help_echo_string)) - do_help = 1; - - goto done; - } - else { - f->mouse_moved = 0; - term_mouse_click (&ie, event, f); - if (tty_handle_tab_bar_click (f, event->x, event->y, - (ie.modifiers & down_modifier) != 0, &ie)) - { - /* tty_handle_tab_bar_click stores 2 events in the event - queue, so we are done here. */ - count += 2; - return count; - } - } - - done: - if (ie.kind != NO_EVENT) + if (event->type & (GPM_MOVE | GPM_DRAG)) { - kbd_buffer_store_event_hold (&ie, hold_quit); - count++; - } + Gpm_DrawPointer (event->x, event->y, fileno (tty->output)); - if (do_help - && !(hold_quit && hold_quit->kind != NO_EVENT)) + /* Has the mouse moved off the glyph it was on at the last + sighting? */ + if (event->x != last_mouse_x || event->y != last_mouse_y) + { + /* FIXME: These three lines can not be moved into + update_mouse_position unless xterm-mouse gets updated to + generate mouse events via C code. See + https://lists.gnu.org/archive/html/emacs-devel/2020-11/msg00163.html */ + last_mouse_x = event->x; + last_mouse_y = event->y; + f->mouse_moved = 1; + + count += update_mouse_position (f, event->x, event->y); + } + } + else { - Lisp_Object frame; - - if (f) - XSETFRAME (frame, f); - else - frame = Qnil; - - gen_help_event (help_echo_string, frame, help_echo_window, - help_echo_object, help_echo_pos); + f->mouse_moved = 0; + term_mouse_click (&ie, event, f); + /* eassert (ie.kind == MOUSE_CLICK_EVENT); */ + if (tty_handle_tab_bar_click (f, event->x, event->y, + (ie.modifiers & down_modifier) != 0, &ie)) + { + /* eassert (ie.kind == MOUSE_CLICK_EVENT + * || ie.kind == TAB_BAR_EVENT); */ + /* tty_handle_tab_bar_click stores 2 events in the event + queue, so we are done here. */ + /* FIXME: Actually, `tty_handle_tab_bar_click` returns true + without storing any events, when + (ie.modifiers & down_modifier) != 0 */ + count += 2; + return count; + } + /* eassert (ie.kind == MOUSE_CLICK_EVENT); */ + kbd_buffer_store_event (&ie); count++; } @@ -2790,16 +2779,15 @@ tty_menu_calc_size (tty_menu *menu, int *width, int *height) static void mouse_get_xy (int *x, int *y) { - struct frame *sf = SELECTED_FRAME (); - Lisp_Object lmx = Qnil, lmy = Qnil, lisp_dummy; - enum scroll_bar_part part_dummy; - Time time_dummy; - - if (FRAME_TERMINAL (sf)->mouse_position_hook) - (*FRAME_TERMINAL (sf)->mouse_position_hook) (&sf, -1, - &lisp_dummy, &part_dummy, - &lmx, &lmy, - &time_dummy); + Lisp_Object lmx = Qnil, lmy = Qnil; + Lisp_Object mouse = mouse_position (tty_menu_calls_mouse_position_function); + + if (EQ (selected_frame, XCAR (mouse))) + { + lmx = XCAR (XCDR (mouse)); + lmy = XCDR (XCDR (mouse)); + } + if (!NILP (lmx)) { *x = XFIXNUM (lmx); @@ -4126,6 +4114,7 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\ tty->TS_enter_alt_charset_mode = tgetstr ("as", address); tty->TS_exit_alt_charset_mode = tgetstr ("ae", address); tty->TS_exit_attribute_mode = tgetstr ("me", address); + tty->TS_enter_strike_through_mode = tgetstr ("smxx", address); MultiUp (tty) = tgetstr ("UP", address); MultiDown (tty) = tgetstr ("DO", address); @@ -4170,6 +4159,15 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\ could return 32767. */ tty->TN_max_colors = 16777216; } + /* Fall back to xterm+direct (semicolon version) if requested + by the COLORTERM environment variable. */ + else if ((bg = getenv("COLORTERM")) != NULL + && strcasecmp(bg, "truecolor") == 0) + { + tty->TS_set_foreground = "\033[%?%p1%{8}%<%t3%p1%d%e38;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m"; + tty->TS_set_background = "\033[%?%p1%{8}%<%t4%p1%d%e48;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m"; + tty->TN_max_colors = 16777216; + } } #endif @@ -4251,8 +4249,8 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\ #ifdef HAVE_GPM terminal->mouse_position_hook = term_mouse_position; - tty->mouse_highlight.mouse_face_window = Qnil; #endif + tty->mouse_highlight.mouse_face_window = Qnil; terminal->kboard = allocate_kboard (Qnil); terminal->kboard->reference_count++; @@ -4530,6 +4528,13 @@ What means \"very visible\" is up to your terminal. It may make the cursor bigger, or it may make it blink, or it may do nothing at all. */); visible_cursor = 1; + DEFVAR_BOOL ("tty-menu-calls-mouse-position-function", + tty_menu_calls_mouse_position_function, + doc: /* Non-nil means TTY menu code will call `mouse-position-function'. +This should be set if the function in `mouse-position-function' does not +trigger redisplay. */); + tty_menu_calls_mouse_position_function = 0; + defsubr (&Stty_display_color_p); defsubr (&Stty_display_color_cells); defsubr (&Stty_no_underline); diff --git a/src/termcap.c b/src/termcap.c index 67f28facbd2..227dbeb7d92 100644 --- a/src/termcap.c +++ b/src/termcap.c @@ -162,7 +162,7 @@ tgetst1 (char *ptr, char **area) else ret = *area; - /* Copy the string value, stopping at NUL or colon. + /* Copy the string value, stopping at null or colon. Also process ^ and \ abbreviations. */ p = ptr; r = ret; @@ -424,7 +424,7 @@ tgetent (char *bp, const char *name) return -1; buf.size = BUFSIZE; - /* Add 1 to size to ensure room for terminating NUL. */ + /* Add 1 to size to ensure room for terminating null. */ buf.beg = xmalloc (buf.size + 1); term = indirect ? indirect : (char *)name; @@ -480,7 +480,7 @@ tgetent (char *bp, const char *name) *bp1 = '\0'; /* Does this entry refer to another terminal type's entry? - If something is found, copy it into heap and NUL-terminate it. */ + If something is found, copy it into heap and null-terminate it. */ tc_search_point = find_capability (tc_search_point, "tc"); term = tgetst1 (tc_search_point, 0); } @@ -618,7 +618,7 @@ gobble_line (int fd, register struct termcap_buffer *bufp, char *append_end) { ptrdiff_t ptr_offset = bufp->ptr - buf; ptrdiff_t append_end_offset = append_end - buf; - /* Add 1 to size to ensure room for terminating NUL. */ + /* Add 1 to size to ensure room for terminating null. */ ptrdiff_t size = bufp->size + 1; bufp->beg = buf = xpalloc (buf, &size, 1, -1, 1); bufp->size = size - 1; diff --git a/src/termchar.h b/src/termchar.h index ce7b4ffcd13..f50c1bfb6ea 100644 --- a/src/termchar.h +++ b/src/termchar.h @@ -136,6 +136,8 @@ struct tty_display_info const char *TS_enter_reverse_mode; /* "mr" -- enter reverse video mode. */ const char *TS_exit_underline_mode; /* "us" -- start underlining. */ const char *TS_enter_underline_mode; /* "ue" -- end underlining. */ + const char *TS_enter_strike_through_mode; /* "smxx" -- turn on strike-through + mode. */ /* "as"/"ae" -- start/end alternate character set. Not really supported, yet. */ diff --git a/src/termhooks.h b/src/termhooks.h index 2781c5feb9a..3800679e803 100644 --- a/src/termhooks.h +++ b/src/termhooks.h @@ -159,7 +159,6 @@ enum event_kind SELECTION_REQUEST_EVENT, /* Another X client wants a selection from us. See `struct selection_input_event'. */ SELECTION_CLEAR_EVENT, /* Another X client cleared our selection. */ - BUFFER_SWITCH_EVENT, /* A process filter has switched buffers. */ DELETE_WINDOW_EVENT, /* An X client said "delete this window". */ #ifdef HAVE_NTGUI END_SESSION_EVENT, /* The user is logging out or shutting down. */ @@ -220,10 +219,6 @@ enum event_kind save yourself before shutdown. */ SAVE_SESSION_EVENT -#ifdef HAVE_GPM - , GPM_CLICK_EVENT -#endif - #ifdef HAVE_DBUS , DBUS_EVENT #endif @@ -370,10 +365,8 @@ enum { #ifdef HAVE_GPM #include <gpm.h> -extern int handle_one_term_event (struct tty_display_info *, Gpm_Event *, struct input_event *); -#ifndef HAVE_WINDOW_SYSTEM +extern int handle_one_term_event (struct tty_display_info *, Gpm_Event *); extern void term_mouse_moveto (int, int); -#endif /* The device for which we have enabled gpm support. */ extern struct tty_display_info *gpm_tty; diff --git a/src/terminfo.c b/src/terminfo.c index 15aff317f15..a9c9572bbb2 100644 --- a/src/terminfo.c +++ b/src/terminfo.c @@ -23,10 +23,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ /* Define these variables that serve as global parameters to termcap, so that we do not need to conditionalize the places in Emacs - that set them. But don't do that for terminfo, as that could - cause link errors when using -fno-common. */ + that set them. But don't do that if terminfo defines them, as that + could cause link errors when using -fno-common. */ -#if !TERMINFO +#ifndef TERMINFO_DEFINES_BC char *UP, *BC, PC; #endif diff --git a/src/textprop.c b/src/textprop.c index 11ca0b8ccb8..d7d6a669232 100644 --- a/src/textprop.c +++ b/src/textprop.c @@ -131,6 +131,7 @@ validate_interval_range (Lisp_Object object, Lisp_Object *begin, { INTERVAL i; ptrdiff_t searchpos; + Lisp_Object begin0 = *begin, end0 = *end; CHECK_STRING_OR_BUFFER (object); CHECK_FIXNUM_COERCE_MARKER (*begin); @@ -155,7 +156,7 @@ validate_interval_range (Lisp_Object object, Lisp_Object *begin, if (!(BUF_BEGV (b) <= XFIXNUM (*begin) && XFIXNUM (*begin) <= XFIXNUM (*end) && XFIXNUM (*end) <= BUF_ZV (b))) - args_out_of_range (*begin, *end); + args_out_of_range (begin0, end0); i = buffer_intervals (b); /* If there's no text, there are no properties. */ @@ -170,7 +171,7 @@ validate_interval_range (Lisp_Object object, Lisp_Object *begin, if (! (0 <= XFIXNUM (*begin) && XFIXNUM (*begin) <= XFIXNUM (*end) && XFIXNUM (*end) <= len)) - args_out_of_range (*begin, *end); + args_out_of_range (begin0, end0); i = string_intervals (object); if (len == 0) @@ -611,7 +612,7 @@ get_char_property_and_overlay (Lisp_Object position, register Lisp_Object prop, { struct window *w = 0; - CHECK_FIXNUM_COERCE_MARKER (position); + EMACS_INT pos = fix_position (position); if (NILP (object)) XSETBUFFER (object, current_buffer); @@ -628,14 +629,14 @@ get_char_property_and_overlay (Lisp_Object position, register Lisp_Object prop, Lisp_Object *overlay_vec; struct buffer *obuf = current_buffer; - if (XFIXNUM (position) < BUF_BEGV (XBUFFER (object)) - || XFIXNUM (position) > BUF_ZV (XBUFFER (object))) + if (! (BUF_BEGV (XBUFFER (object)) <= pos + && pos <= BUF_ZV (XBUFFER (object)))) xsignal1 (Qargs_out_of_range, position); set_buffer_temp (XBUFFER (object)); USE_SAFE_ALLOCA; - GET_OVERLAYS_AT (XFIXNUM (position), overlay_vec, noverlays, NULL, false); + GET_OVERLAYS_AT (pos, overlay_vec, noverlays, NULL, false); noverlays = sort_overlays (overlay_vec, noverlays, w); set_buffer_temp (obuf); @@ -662,7 +663,7 @@ get_char_property_and_overlay (Lisp_Object position, register Lisp_Object prop, /* Not a buffer, or no appropriate overlay, so fall through to the simpler case. */ - return Fget_text_property (position, prop, object); + return Fget_text_property (make_fixnum (pos), prop, object); } DEFUN ("get-char-property", Fget_char_property, Sget_char_property, 2, 3, 0, @@ -765,14 +766,13 @@ the current buffer), POSITION is a buffer position (integer or marker). If OBJECT is a string, POSITION is a 0-based index into it. In a string, scan runs to the end of the string, unless LIMIT is non-nil. -In a buffer, if LIMIT is nil or omitted, it runs to (point-max), and the -value cannot exceed that. +In a buffer, scan runs to end of buffer, unless LIMIT is non-nil. If the optional fourth argument LIMIT is non-nil, don't search past position LIMIT; return LIMIT if nothing is found before LIMIT. +However, if OBJECT is a buffer and LIMIT is beyond the end of the +buffer, this function returns `point-max', not LIMIT. -The property values are compared with `eq'. -If the property is constant all the way to the end of OBJECT, return the -last valid position in OBJECT. */) +The property values are compared with `eq'. */) (Lisp_Object position, Lisp_Object prop, Lisp_Object object, Lisp_Object limit) { if (STRINGP (object)) @@ -831,6 +831,9 @@ last valid position in OBJECT. */) value = Fget_char_property (position, prop, object); if (!EQ (value, initial_value)) break; + + if (XFIXNAT (position) >= ZV) + break; } position = unbind_to (count, position); diff --git a/src/thread.c b/src/thread.c index c7cc17729f7..f74f6111486 100644 --- a/src/thread.c +++ b/src/thread.c @@ -28,6 +28,12 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "pdumper.h" #include "keyboard.h" +#if defined HAVE_GLIB && ! defined (HAVE_NS) +#include <xgselect.h> +#else +#define release_select_lock() do { } while (0) +#endif + union aligned_thread_state { struct thread_state s; @@ -586,6 +592,8 @@ really_call_select (void *arg) sa->result = (sa->func) (sa->max_fds, sa->rfds, sa->wfds, sa->efds, sa->timeout, sa->sigmask); + release_select_lock (); + block_interrupt_signal (&oldset); /* If we were interrupted by C-g while inside sa->func above, the signal handler could have called maybe_reacquire_global_lock, in @@ -717,12 +725,17 @@ run_thread (void *state) { /* Make sure stack_top and m_stack_bottom are properly aligned as GC expects. */ - max_align_t stack_pos; + union + { + Lisp_Object o; + void *p; + char c; + } stack_pos; struct thread_state *self = state; struct thread_state **iter; - self->m_stack_bottom = self->stack_top = (char *) &stack_pos; + self->m_stack_bottom = self->stack_top = &stack_pos.c; self->thread_id = sys_thread_self (); if (self->thread_name) @@ -1114,9 +1127,6 @@ syms_of_threads (void) staticpro (&last_thread_error); last_thread_error = Qnil; - Fdefalias (intern_c_string ("thread-alive-p"), - intern_c_string ("thread-live-p"), Qnil); - Fprovide (intern_c_string ("threads"), Qnil); } diff --git a/src/thread.h b/src/thread.h index b991ec18a01..cf3ce922c46 100644 --- a/src/thread.h +++ b/src/thread.h @@ -140,7 +140,6 @@ struct thread_state for user-input when that process-filter was called. waiting_for_input cannot be used as that is by definition 0 when lisp code is being evalled. - This is also used in record_asynch_buffer_change. For that purpose, this must be 0 when not inside wait_reading_process_output. */ int m_waiting_for_user_input_p; diff --git a/src/timefns.c b/src/timefns.c index b84bc216e9e..f0e2e97f555 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -593,31 +593,29 @@ timespec_to_lisp (struct timespec t) } /* Return NUMERATOR / DENOMINATOR, rounded to the nearest double. - Arguments must be Lisp integers, and DENOMINATOR must be nonzero. */ + Arguments must be Lisp integers, and DENOMINATOR must be positive. */ static double frac_to_double (Lisp_Object numerator, Lisp_Object denominator) { - intmax_t intmax_numerator; - if (FASTER_TIMEFNS && EQ (denominator, make_fixnum (1)) - && integer_to_intmax (numerator, &intmax_numerator)) - return intmax_numerator; + intmax_t intmax_numerator, intmax_denominator; + if (FASTER_TIMEFNS + && integer_to_intmax (numerator, &intmax_numerator) + && integer_to_intmax (denominator, &intmax_denominator) + && intmax_numerator % intmax_denominator == 0) + return intmax_numerator / intmax_denominator; /* Compute number of base-FLT_RADIX digits in numerator and denominator. */ mpz_t const *n = bignum_integer (&mpz[0], numerator); mpz_t const *d = bignum_integer (&mpz[1], denominator); - ptrdiff_t nbits = mpz_sizeinbase (*n, 2); - ptrdiff_t dbits = mpz_sizeinbase (*d, 2); - eassume (0 < nbits); - eassume (0 < dbits); - ptrdiff_t ndig = (nbits + LOG2_FLT_RADIX - 1) / LOG2_FLT_RADIX; - ptrdiff_t ddig = (dbits + LOG2_FLT_RADIX - 1) / LOG2_FLT_RADIX; + ptrdiff_t ndig = mpz_sizeinbase (*n, FLT_RADIX); + ptrdiff_t ddig = mpz_sizeinbase (*d, FLT_RADIX); /* Scale with SCALE when doing integer division. That is, compute (N * FLT_RADIX**SCALE) / D [or, if SCALE is negative, N / (D * FLT_RADIX**-SCALE)] as a bignum, convert the bignum to double, then divide the double by FLT_RADIX**SCALE. First scale N (or scale D, if SCALE is negative) ... */ - ptrdiff_t scale = ddig - ndig + DBL_MANT_DIG + 1; + ptrdiff_t scale = ddig - ndig + DBL_MANT_DIG; if (scale < 0) { mpz_mul_2exp (mpz[1], *d, - (scale * LOG2_FLT_RADIX)); @@ -645,7 +643,7 @@ frac_to_double (Lisp_Object numerator, Lisp_Object denominator) round to the nearest integer; otherwise, it is less than FLT_RADIX ** (DBL_MANT_DIG + 1) and round it to the nearest multiple of FLT_RADIX. Break ties to even. */ - if (mpz_sizeinbase (*q, 2) < DBL_MANT_DIG * LOG2_FLT_RADIX) + if (mpz_sizeinbase (*q, FLT_RADIX) <= DBL_MANT_DIG) { /* Converting to double will use the whole quotient so add 1 to its absolute value as per round-to-even; i.e., if the doubled @@ -770,44 +768,48 @@ decode_time_components (enum timeform form, /* Normalize out-of-range lower-order components by carrying each overflow into the next higher-order component. */ us += ps / 1000000 - (ps % 1000000 < 0); - mpz_set_intmax (mpz[0], us / 1000000 - (us % 1000000 < 0)); - mpz_add (mpz[0], mpz[0], *bignum_integer (&mpz[1], low)); - mpz_addmul_ui (mpz[0], *bignum_integer (&mpz[1], high), 1 << LO_TIME_BITS); + mpz_t *s = &mpz[1]; + mpz_set_intmax (*s, us / 1000000 - (us % 1000000 < 0)); + mpz_add (*s, *s, *bignum_integer (&mpz[0], low)); + mpz_addmul_ui (*s, *bignum_integer (&mpz[0], high), 1 << LO_TIME_BITS); ps = ps % 1000000 + 1000000 * (ps % 1000000 < 0); us = us % 1000000 + 1000000 * (us % 1000000 < 0); - if (result) + Lisp_Object hz; + switch (form) { - switch (form) - { - case TIMEFORM_HI_LO: - /* Floats and nil were handled above, so it was an integer. */ - result->hz = make_fixnum (1); - break; - - case TIMEFORM_HI_LO_US: - mpz_mul_ui (mpz[0], mpz[0], 1000000); - mpz_add_ui (mpz[0], mpz[0], us); - result->hz = make_fixnum (1000000); - break; - - case TIMEFORM_HI_LO_US_PS: - mpz_mul_ui (mpz[0], mpz[0], 1000000); - mpz_add_ui (mpz[0], mpz[0], us); - mpz_mul_ui (mpz[0], mpz[0], 1000000); - mpz_add_ui (mpz[0], mpz[0], ps); - result->hz = trillion; - break; - - default: - eassume (false); - } - result->ticks = make_integer_mpz (); + case TIMEFORM_HI_LO: + /* Floats and nil were handled above, so it was an integer. */ + mpz_swap (mpz[0], *s); + hz = make_fixnum (1); + break; + + case TIMEFORM_HI_LO_US: + mpz_set_ui (mpz[0], us); + mpz_addmul_ui (mpz[0], *s, 1000000); + hz = make_fixnum (1000000); + break; + + case TIMEFORM_HI_LO_US_PS: + { + #if FASTER_TIMEFNS && TRILLION <= ULONG_MAX + unsigned long i = us; + mpz_set_ui (mpz[0], i * 1000000 + ps); + mpz_addmul_ui (mpz[0], *s, TRILLION); + #else + intmax_t i = us; + mpz_set_intmax (mpz[0], i * 1000000 + ps); + mpz_addmul (mpz[0], *s, ztrillion); + #endif + hz = trillion; + } + break; + + default: + eassume (false); } - else - *dresult = mpz_get_d (mpz[0]) + (us * 1e6L + ps) / 1e12L; - return 0; + return decode_ticks_hz (make_integer_mpz (), hz, result, dresult); } enum { DECODE_SECS_ONLY = WARN_OBSOLETE_TIMESTAMPS + 1 }; @@ -1309,45 +1311,41 @@ or (if you need time as a string) `format-time-string'. */) determine how many bytes would be written, use NULL for S and ((size_t) -1) for MAXSIZE. - This function behaves like nstrftime, except it allows NUL - bytes in FORMAT and it does not support nanoseconds. */ + This function behaves like nstrftime, except it allows null + bytes in FORMAT. */ static size_t emacs_nmemftime (char *s, size_t maxsize, const char *format, size_t format_len, const struct tm *tp, timezone_t tz, int ns) { + int saved_errno = errno; size_t total = 0; - /* Loop through all the NUL-terminated strings in the format - argument. Normally there's just one NUL-terminated string, but + /* Loop through all the null-terminated strings in the format + argument. Normally there's just one null-terminated string, but there can be arbitrarily many, concatenated together, if the format contains '\0' bytes. nstrftime stops at the first '\0' byte so we must invoke it separately for each such string. */ for (;;) { - size_t len; - size_t result; - + errno = 0; + size_t result = nstrftime (s, maxsize, format, tp, tz, ns); + if (result == 0 && errno != 0) + return result; if (s) - s[0] = '\1'; - - result = nstrftime (s, maxsize, format, tp, tz, ns); - - if (s) - { - if (result == 0 && s[0] != '\0') - return 0; - s += result + 1; - } + s += result + 1; maxsize -= result + 1; total += result; - len = strlen (format); + size_t len = strlen (format); if (len == format_len) - return total; + break; total++; format += len + 1; format_len -= len + 1; } + + errno = saved_errno; + return total; } static Lisp_Object @@ -1377,10 +1375,11 @@ format_time_string (char const *format, ptrdiff_t formatlen, while (true) { - buf[0] = '\1'; + errno = 0; len = emacs_nmemftime (buf, size, format, formatlen, tmp, tz, ns); - if ((0 < len && len < size) || (len == 0 && buf[0] == '\0')) + if (len != 0 || errno == 0) break; + eassert (errno == ERANGE); /* Buffer was too small, so make it bigger and try again. */ len = emacs_nmemftime (NULL, SIZE_MAX, format, formatlen, tmp, tz, ns); @@ -2046,7 +2045,7 @@ syms_of_timefns (void) defsubr (&Scurrent_time_zone); defsubr (&Sset_time_zone_rule); - flt_radix_power = make_vector (flt_radix_power_size, Qnil); + flt_radix_power = make_nil_vector (flt_radix_power_size); staticpro (&flt_radix_power); #ifdef NEED_ZTRILLION_INIT diff --git a/src/unexmacosx.c b/src/unexmacosx.c index f4e78beecfb..f226f1b6c19 100644 --- a/src/unexmacosx.c +++ b/src/unexmacosx.c @@ -447,7 +447,7 @@ unexec_regions_recorder (task_t task, void *rr, unsigned type, while (num && num_unexec_regions < MAX_UNEXEC_REGIONS) { - /* Subtract the size of trailing NUL bytes from filesize. It + /* Subtract the size of trailing null bytes from filesize. It can be smaller than vmsize in segment commands. In such a case, trailing bytes are initialized with zeros. */ for (p = ranges->address + ranges->size; p > ranges->address; p--) diff --git a/src/w16select.c b/src/w16select.c index 94c4032bbd8..37239137cf0 100644 --- a/src/w16select.c +++ b/src/w16select.c @@ -220,11 +220,11 @@ set_clipboard_data (unsigned Format, void *Data, unsigned Size, int Raw) /* need to know final size after '\r' chars are inserted (the standard CF_OEMTEXT clipboard format uses CRLF line endings, while Emacs uses just LF internally). */ - truelen = Size + 1; /* +1 for the terminating NUL */ + truelen = Size + 1; /* +1 for the terminating null */ if (!Raw) { - /* avoid using strchr because it recomputes the length everytime */ + /* avoid using strchr because it recomputes the length every time */ while ((dp = memchr (dp, '\n', Size - (dp - dstart))) != 0) { truelen++; @@ -243,7 +243,7 @@ set_clipboard_data (unsigned Format, void *Data, unsigned Size, int Raw) { dosmemput (Data, Size, xbuf_addr); - /* Terminate with a NUL, otherwise Windows does strange things + /* Terminate with a null, otherwise Windows does strange things when the text size is an integral multiple of 32 bytes. */ _farpokeb (_dos_ds, xbuf_addr + Size, '\0'); } @@ -255,7 +255,7 @@ set_clipboard_data (unsigned Format, void *Data, unsigned Size, int Raw) while (Size--) { /* Don't allow them to put binary data into the clipboard, since - it will cause yanked data to be truncated at the first NUL. */ + it will cause yanked data to be truncated at the first null. */ if (*dp == '\0') return 2; if (*dp == '\n') @@ -263,7 +263,7 @@ set_clipboard_data (unsigned Format, void *Data, unsigned Size, int Raw) _farnspokeb (buf_offset++, *dp++); } - /* Terminate with a NUL, otherwise Windows does strange things + /* Terminate with a null, otherwise Windows does strange things when the text size is an integral multiple of 32 bytes. */ _farnspokeb (buf_offset, '\0'); } @@ -354,13 +354,13 @@ get_clipboard_data (unsigned Format, void *Data, unsigned Size, int Raw) __dpmi_int (0x2f, ®s); if (regs.x.ax != 0) { - unsigned char nul_char = '\0'; + unsigned char null_char = '\0'; unsigned long xbuf_beg = xbuf_addr; /* If last_clipboard_text is NULL, we don't want to slow down the next loop by an additional test. */ register unsigned char *lcdp = - last_clipboard_text == NULL ? &nul_char : last_clipboard_text; + last_clipboard_text == NULL ? &null_char : last_clipboard_text; /* Copy data from low memory, remove CR characters before LF if needed. */ @@ -383,7 +383,7 @@ get_clipboard_data (unsigned Format, void *Data, unsigned Size, int Raw) /* Windows reportedly rounds up the size of clipboard data (passed in SIZE) to a multiple of 32, and removes trailing spaces from each line without updating SIZE. We therefore - bail out when we see the first NUL character. */ + bail out when we see the first null character. */ else if (c == '\0') break; } @@ -392,7 +392,7 @@ get_clipboard_data (unsigned Format, void *Data, unsigned Size, int Raw) last time set_clipboard_data was called, pretend there's no data in the clipboard. This is so we don't pass our own text from the clipboard (which might be troublesome if the killed - text includes NUL characters). */ + text includes null characters). */ if (last_clipboard_text && xbuf_addr - xbuf_beg == (long)(lcdp - last_clipboard_text)) dp = (unsigned char *)Data + 1; diff --git a/src/w32.c b/src/w32.c index e6dffe2e63f..a3c247b8b0d 100644 --- a/src/w32.c +++ b/src/w32.c @@ -2370,6 +2370,26 @@ srandom (int seed) iz = rand () % RAND_MAX_Z; } +/* Emulate explicit_bzero. This is to avoid using the Gnulib version, + because it calls SecureZeroMemory at will, disregarding systems + older than Windows XP, which didn't have that function. We want to + avoid having that function as dependency in builds that need to + support systems older than Windows XP, otherwise Emacs will refuse + to start on those systems. */ +void +explicit_bzero (void *buf, size_t len) +{ +#if _WIN32_WINNT >= 0x0501 + /* We are compiling for XP or newer, most probably with MinGW64. + We can use SecureZeroMemory. */ + SecureZeroMemory (buf, len); +#else + memset (buf, 0, len); + /* Compiler barrier. */ + asm volatile ("" ::: "memory"); +#endif +} + /* Return the maximum length in bytes of a multibyte character sequence encoded in the current ANSI codepage. This is required to correctly walk the encoded file names one character at a time. */ @@ -3178,18 +3198,9 @@ fdutimens (int fd, char const *file, struct timespec const timespec[2]) return _futime (fd, &_ut); } else - { - struct utimbuf ut; - - ut.actime = timespec[0].tv_sec; - ut.modtime = timespec[1].tv_sec; - /* Call 'utime', which is implemented below, not the MS library - function, which fails on directories. */ - return utime (file, &ut); - } + return utimensat (fd, file, timespec, 0); } - /* ------------------------------------------------------------------------- */ /* IO support and wrapper functions for the Windows API. */ /* ------------------------------------------------------------------------- */ @@ -3450,8 +3461,6 @@ is_fat_volume (const char * name, const char ** pPath) /* Convert all slashes in a filename to backslashes, and map filename to a valid 8.3 name if necessary. The result is a pointer to a static buffer, so CAVEAT EMPTOR! */ -const char *map_w32_filename (const char *, const char **); - const char * map_w32_filename (const char * name, const char ** pPath) { @@ -4320,10 +4329,9 @@ sys_chdir (const char * path) } } -int -sys_chmod (const char * path, int mode) +static int +chmod_worker (const char * path, int mode) { - path = chase_symlinks (map_w32_filename (path, NULL)); if (w32_unicode_filenames) { wchar_t path_w[MAX_PATH]; @@ -4341,6 +4349,20 @@ sys_chmod (const char * path, int mode) } int +sys_chmod (const char * path, int mode) +{ + path = chase_symlinks (map_w32_filename (path, NULL)); + return chmod_worker (path, mode); +} + +int +lchmod (const char * path, mode_t mode) +{ + path = map_w32_filename (path, NULL); + return chmod_worker (path, mode); +} + +int sys_creat (const char * path, int mode) { path = map_w32_filename (path, NULL); @@ -4592,12 +4614,55 @@ sys_open (const char * path, int oflag, int mode) } int +openat (int fd, const char * path, int oflag, int mode) +{ + /* Rely on a hack: an open directory is modeled as file descriptor 0, + as in fstatat. FIXME: Add proper support for openat. */ + char fullname[MAX_UTF8_PATH]; + + if (fd != AT_FDCWD) + { + if (_snprintf (fullname, sizeof fullname, "%s/%s", dir_pathname, path) + < 0) + { + errno = ENAMETOOLONG; + return -1; + } + path = fullname; + } + + return sys_open (path, oflag, mode); +} + +int fchmod (int fd, mode_t mode) { return 0; } int +fchmodat (int fd, char const *path, mode_t mode, int flags) +{ + /* Rely on a hack: an open directory is modeled as file descriptor 0, + as in fstatat. FIXME: Add proper support for fchmodat. */ + char fullname[MAX_UTF8_PATH]; + + if (fd != AT_FDCWD) + { + if (_snprintf (fullname, sizeof fullname, "%s/%s", dir_pathname, path) + < 0) + { + errno = ENAMETOOLONG; + return -1; + } + path = fullname; + } + + return + flags == AT_SYMLINK_NOFOLLOW ? lchmod (path, mode) : sys_chmod (path, mode); +} + +int sys_rename_replace (const char *oldname, const char *newname, BOOL force) { BOOL result; @@ -4914,7 +4979,7 @@ convert_time (FILETIME ft) } static void -convert_from_time_t (time_t time, FILETIME * pft) +convert_from_timespec (struct timespec time, FILETIME * pft) { ULARGE_INTEGER tmp; @@ -4925,7 +4990,8 @@ convert_from_time_t (time_t time, FILETIME * pft) } /* time in 100ns units since 1-Jan-1601 */ - tmp.QuadPart = (ULONGLONG) time * 10000000L + utc_base; + tmp.QuadPart = + (ULONGLONG) time.tv_sec * 10000000L + time.tv_nsec / 100 + utc_base; pft->dwHighDateTime = tmp.HighPart; pft->dwLowDateTime = tmp.LowPart; } @@ -5592,8 +5658,8 @@ fstatat (int fd, char const *name, struct stat *st, int flags) return stat_worker (name, st, ! (flags & AT_SYMLINK_NOFOLLOW)); } -/* Provide fstat and utime as well as stat for consistent handling of - file timestamps. */ +/* Provide fstat and utimensat as well as stat for consistent handling + of file timestamps. */ int fstat (int desc, struct stat * buf) { @@ -5704,23 +5770,65 @@ fstat (int desc, struct stat * buf) return 0; } -/* A version of 'utime' which handles directories as well as - files. */ +/* Emulate utimensat. */ int -utime (const char *name, struct utimbuf *times) +utimensat (int fd, const char *name, const struct timespec times[2], int flag) { - struct utimbuf deftime; + struct timespec ltimes[2]; HANDLE fh; FILETIME mtime; FILETIME atime; + DWORD flags_and_attrs = FILE_FLAG_BACKUP_SEMANTICS; + + /* Rely on a hack: an open directory is modeled as file descriptor 0. + This is good enough for the current usage in Emacs, but is fragile. + + FIXME: Add proper support for utimensat. + Gnulib does this and can serve as a model. */ + char fullname[MAX_UTF8_PATH]; + + if (fd != AT_FDCWD) + { + char lastc = dir_pathname[strlen (dir_pathname) - 1]; + + if (_snprintf (fullname, sizeof fullname, "%s%s%s", + dir_pathname, IS_DIRECTORY_SEP (lastc) ? "" : "/", name) + < 0) + { + errno = ENAMETOOLONG; + return -1; + } + name = fullname; + } if (times == NULL) { - deftime.modtime = deftime.actime = time (NULL); - times = &deftime; + memset (ltimes, 0, sizeof (ltimes)); + ltimes[0] = ltimes[1] = current_timespec (); + } + else + { + if (times[0].tv_nsec == UTIME_OMIT && times[1].tv_nsec == UTIME_OMIT) + return 0; /* nothing to do */ + if ((times[0].tv_nsec != UTIME_NOW && times[0].tv_nsec != UTIME_OMIT + && !(0 <= times[0].tv_nsec && times[0].tv_nsec < 1000000000)) + || (times[1].tv_nsec != UTIME_NOW && times[1].tv_nsec != UTIME_OMIT + && !(0 <= times[1].tv_nsec && times[1].tv_nsec < 1000000000))) + { + errno = EINVAL; /* reject invalid timespec values */ + return -1; + } + + memcpy (ltimes, times, sizeof (ltimes)); + if (ltimes[0].tv_nsec == UTIME_NOW) + ltimes[0] = current_timespec (); + if (ltimes[1].tv_nsec == UTIME_NOW) + ltimes[1] = current_timespec (); } + if (flag == AT_SYMLINK_NOFOLLOW) + flags_and_attrs |= FILE_FLAG_OPEN_REPARSE_POINT; if (w32_unicode_filenames) { wchar_t name_utf16[MAX_PATH]; @@ -5734,7 +5842,7 @@ utime (const char *name, struct utimbuf *times) allows other processes to delete files inside it, while we have the directory open. */ FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, - 0, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL); + 0, OPEN_EXISTING, flags_and_attrs, NULL); } else { @@ -5745,13 +5853,26 @@ utime (const char *name, struct utimbuf *times) fh = CreateFileA (name_ansi, FILE_WRITE_ATTRIBUTES, FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, - 0, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL); + 0, OPEN_EXISTING, flags_and_attrs, NULL); } if (fh != INVALID_HANDLE_VALUE) { - convert_from_time_t (times->actime, &atime); - convert_from_time_t (times->modtime, &mtime); - if (!SetFileTime (fh, NULL, &atime, &mtime)) + FILETIME *patime, *pmtime; + if (ltimes[0].tv_nsec == UTIME_OMIT) + patime = NULL; + else + { + convert_from_timespec (ltimes[0], &atime); + patime = &atime; + } + if (ltimes[1].tv_nsec == UTIME_OMIT) + pmtime = NULL; + else + { + convert_from_timespec (ltimes[1], &mtime); + pmtime = &mtime; + } + if (!SetFileTime (fh, NULL, patime, pmtime)) { CloseHandle (fh); errno = EACCES; @@ -6023,7 +6144,7 @@ is_symlink (const char *filename) /* If NAME identifies a symbolic link, copy into BUF the file name of the symlink's target. Copy at most BUF_SIZE bytes, and do NOT - NUL-terminate the target name, even if it fits. Return the number + null-terminate the target name, even if it fits. Return the number of bytes copied, or -1 if NAME is not a symlink or any error was encountered while resolving it. The file name copied into BUF is encoded in the current ANSI codepage. */ @@ -6127,10 +6248,10 @@ readlink (const char *name, char *buf, size_t buf_size) size_t size_to_copy = buf_size; /* According to MSDN, PrintNameLength does not include the - terminating NUL character. */ + terminating null character. */ lwname = alloca ((lwname_len + 1) * sizeof(WCHAR)); memcpy (lwname, lwname_src, lwname_len); - lwname[lwname_len/sizeof(WCHAR)] = 0; /* NUL-terminate */ + lwname[lwname_len/sizeof(WCHAR)] = 0; /* null-terminate */ filename_from_utf16 (lwname, resolved); dostounix_filename (resolved); lname_size = strlen (resolved) + 1; @@ -6685,16 +6806,16 @@ w32_copy_file (const char *from, const char *to, FIXME? */ else if (!keep_time) { - struct timespec now; + struct timespec tnow[2]; DWORD attributes; + tnow[0] = tnow[1] = current_timespec (); if (w32_unicode_filenames) { /* Ensure file is writable while its times are set. */ attributes = GetFileAttributesW (to_w); SetFileAttributesW (to_w, attributes & ~FILE_ATTRIBUTE_READONLY); - now = current_timespec (); - if (set_file_times (-1, to, now, now)) + if (utimensat (AT_FDCWD, to, tnow, 0)) { /* Restore original attributes. */ SetFileAttributesW (to_w, attributes); @@ -6709,8 +6830,7 @@ w32_copy_file (const char *from, const char *to, { attributes = GetFileAttributesA (to_a); SetFileAttributesA (to_a, attributes & ~FILE_ATTRIBUTE_READONLY); - now = current_timespec (); - if (set_file_times (-1, to, now, now)) + if (utimensat (AT_FDCWD, to, tnow, 0)) { SetFileAttributesA (to_a, attributes); if (acl) @@ -8547,6 +8667,11 @@ pipe2 (int * phandles, int pipe2_flags) { _close (phandles[0]); _close (phandles[1]); + /* Since we close the handles, set them to -1, so as to + avoid an assertion violation if the caller then tries to + close the handle again (emacs_close will abort otherwise + if errno is EBADF). */ + phandles[0] = phandles[1] = -1; errno = EMFILE; rc = -1; } @@ -9764,7 +9889,7 @@ w32_read_registry (HKEY rootkey, Lisp_Object lkey, Lisp_Object lname) /* Convert input strings to UTF-16. */ encoded_key = code_convert_string_norecord (lkey, Qutf_16le, 1); memcpy (key_w, SSDATA (encoded_key), SBYTES (encoded_key)); - /* wchar_t strings need to be terminated by 2 NUL bytes. */ + /* wchar_t strings need to be terminated by 2 null bytes. */ key_w [SBYTES (encoded_key)/2] = L'\0'; encoded_vname = code_convert_string_norecord (lname, Qutf_16le, 1); memcpy (value_w, SSDATA (encoded_vname), SBYTES (encoded_vname)); @@ -9856,7 +9981,7 @@ w32_read_registry (HKEY rootkey, Lisp_Object lkey, Lisp_Object lname) case REG_SZ: if (use_unicode) { - /* pvalue ends with 2 NUL bytes, but we need only one, + /* pvalue ends with 2 null bytes, but we need only one, and AUTO_STRING_WITH_LEN will add it. */ if (pvalue[vsize - 1] == '\0') vsize -= 2; @@ -9865,7 +9990,7 @@ w32_read_registry (HKEY rootkey, Lisp_Object lkey, Lisp_Object lname) } else { - /* Don't waste a byte on the terminating NUL character, + /* Don't waste a byte on the terminating null character, since make_unibyte_string will add one anyway. */ if (pvalue[vsize - 1] == '\0') vsize--; @@ -10138,6 +10263,10 @@ term_ntproc (int ignored) term_winsock (); term_w32select (); + +#if HAVE_NATIVE_IMAGE_API + w32_gdiplus_shutdown (); +#endif } void diff --git a/src/w32.h b/src/w32.h index ddbd275ba5c..3f8eb250cc1 100644 --- a/src/w32.h +++ b/src/w32.h @@ -194,6 +194,7 @@ extern void syms_of_ntproc (void); extern void syms_of_ntterm (void); extern void dostounix_filename (register char *); extern void unixtodos_filename (register char *); +extern const char *map_w32_filename (const char *, const char **); extern int filename_from_ansi (const char *, char *); extern int filename_to_ansi (const char *, char *); extern int filename_from_utf16 (const wchar_t *, char *); @@ -215,12 +216,15 @@ extern int sys_rename_replace (char const *, char const *, BOOL); extern int pipe2 (int *, int); extern void register_aux_fd (int); -extern void set_process_dir (char *); +extern void set_process_dir (const char *); extern int sys_spawnve (int, char *, char **, char **); extern void register_child (pid_t, int); extern void sys_sleep (int); extern int sys_link (const char *, const char *); +extern int openat (int, const char *, int, int); +extern int fchmodat (int, char const *, mode_t, int); +extern int lchmod (char const *, mode_t); /* Return total and free memory info. */ extern int w32_memory_info (unsigned long long *, unsigned long long *, diff --git a/src/w32common.h b/src/w32common.h index 94bb457e59d..714a2386a68 100644 --- a/src/w32common.h +++ b/src/w32common.h @@ -50,6 +50,11 @@ extern int os_subtype; /* Cache system info, e.g., the NT page size. */ extern void cache_system_info (void); +#ifdef WINDOWSNT +/* Return a static buffer with the MS-Windows version string. */ +extern char * w32_version_string (void); +#endif + typedef void (* VOIDFNPTR) (void); /* Load a function address from a DLL. Cast the result via VOIDFNPTR diff --git a/src/w32fns.c b/src/w32fns.c index fcee1934ba9..5704f1d3c33 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -80,7 +80,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ extern int w32_console_toggle_lock_key (int, Lisp_Object); extern void w32_menu_display_help (HWND, HMENU, UINT, UINT); extern void w32_free_menu_strings (HWND); -extern const char *map_w32_filename (const char *, const char **); #ifndef IDC_HAND #define IDC_HAND MAKEINTRESOURCE(32649) @@ -166,6 +165,10 @@ typedef HIMC (WINAPI * ImmGetContext_Proc) (IN HWND window); typedef BOOL (WINAPI * ImmReleaseContext_Proc) (IN HWND wnd, IN HIMC context); typedef BOOL (WINAPI * ImmSetCompositionWindow_Proc) (IN HIMC context, IN COMPOSITIONFORM *form); +/* For toggling IME status. */ +typedef BOOL (WINAPI * ImmGetOpenStatus_Proc) (IN HIMC); +typedef BOOL (WINAPI * ImmSetOpenStatus_Proc) (IN HIMC, IN BOOL); + typedef HMONITOR (WINAPI * MonitorFromPoint_Proc) (IN POINT pt, IN DWORD flags); typedef BOOL (WINAPI * GetMonitorInfo_Proc) (IN HMONITOR monitor, OUT struct MONITOR_INFO* info); @@ -185,6 +188,8 @@ typedef HRESULT (WINAPI *SetThreadDescription_Proc) TrackMouseEvent_Proc track_mouse_event_fn = NULL; ImmGetCompositionString_Proc get_composition_string_fn = NULL; ImmGetContext_Proc get_ime_context_fn = NULL; +ImmGetOpenStatus_Proc get_ime_open_status_fn = NULL; +ImmSetOpenStatus_Proc set_ime_open_status_fn = NULL; ImmReleaseContext_Proc release_ime_context_fn = NULL; ImmSetCompositionWindow_Proc set_ime_composition_window_fn = NULL; MonitorFromPoint_Proc monitor_from_point_fn = NULL; @@ -859,161 +864,14 @@ x_to_w32_color (const char * colorname) block_input (); - if (colorname[0] == '#') + unsigned short r, g, b; + if (parse_color_spec (colorname, &r, &g, &b)) { - /* Could be an old-style RGB Device specification. */ - int size = strlen (colorname + 1); - char *color = alloca (size + 1); - - strcpy (color, colorname + 1); - if (size == 3 || size == 6 || size == 9 || size == 12) - { - UINT colorval; - int i, pos; - pos = 0; - size /= 3; - colorval = 0; - - for (i = 0; i < 3; i++) - { - char *end; - char t; - unsigned long value; - - /* The check for 'x' in the following conditional takes into - account the fact that strtol allows a "0x" in front of - our numbers, and we don't. */ - if (!isxdigit (color[0]) || color[1] == 'x') - break; - t = color[size]; - color[size] = '\0'; - value = strtoul (color, &end, 16); - color[size] = t; - if (errno == ERANGE || end - color != size) - break; - switch (size) - { - case 1: - value = value * 0x10; - break; - case 2: - break; - case 3: - value /= 0x10; - break; - case 4: - value /= 0x100; - break; - } - colorval |= (value << pos); - pos += 0x8; - if (i == 2) - { - unblock_input (); - XSETINT (ret, colorval); - return ret; - } - color = end; - } - } - } - else if (strnicmp (colorname, "rgb:", 4) == 0) - { - const char *color; - UINT colorval; - int i, pos; - pos = 0; - - colorval = 0; - color = colorname + 4; - for (i = 0; i < 3; i++) - { - char *end; - unsigned long value; - - /* The check for 'x' in the following conditional takes into - account the fact that strtol allows a "0x" in front of - our numbers, and we don't. */ - if (!isxdigit (color[0]) || color[1] == 'x') - break; - value = strtoul (color, &end, 16); - if (errno == ERANGE) - break; - switch (end - color) - { - case 1: - value = value * 0x10 + value; - break; - case 2: - break; - case 3: - value /= 0x10; - break; - case 4: - value /= 0x100; - break; - default: - value = ULONG_MAX; - } - if (value == ULONG_MAX) - break; - colorval |= (value << pos); - pos += 0x8; - if (i == 2) - { - if (*end != '\0') - break; - unblock_input (); - XSETINT (ret, colorval); - return ret; - } - if (*end != '/') - break; - color = end + 1; - } + unblock_input (); + /* Throw away the low 8 bits and return 0xBBGGRR. */ + return make_fixnum ((b & 0xff00) << 8 | (g & 0xff00) | r >> 8); } - else if (strnicmp (colorname, "rgbi:", 5) == 0) - { - /* This is an RGB Intensity specification. */ - const char *color; - UINT colorval; - int i, pos; - pos = 0; - - colorval = 0; - color = colorname + 5; - for (i = 0; i < 3; i++) - { - char *end; - double value; - UINT val; - value = strtod (color, &end); - if (errno == ERANGE) - break; - if (value < 0.0 || value > 1.0) - break; - val = (UINT)(0x100 * value); - /* We used 0x100 instead of 0xFF to give a continuous - range between 0.0 and 1.0 inclusive. The next statement - fixes the 1.0 case. */ - if (val == 0x100) - val = 0xFF; - colorval |= (val << pos); - pos += 0x8; - if (i == 2) - { - if (*end != '\0') - break; - unblock_input (); - XSETINT (ret, colorval); - return ret; - } - if (*end != '/') - break; - color = end + 1; - } - } /* I am not going to attempt to handle any of the CIE color schemes or TekHVC, since I don't know the algorithms for conversion to RGB. */ @@ -1661,9 +1519,13 @@ w32_clear_under_internal_border (struct frame *f) int width = FRAME_PIXEL_WIDTH (f); int height = FRAME_PIXEL_HEIGHT (f); int face_id = - !NILP (Vface_remapping_alist) - ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) - : INTERNAL_BORDER_FACE_ID; + (FRAME_PARENT_FRAME (f) + ? (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, CHILD_FRAME_BORDER_FACE_ID) + : CHILD_FRAME_BORDER_FACE_ID) + : (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) + : INTERNAL_BORDER_FACE_ID)); struct face *face = FACE_FROM_ID_OR_NULL (f, face_id); block_input (); @@ -1690,6 +1552,32 @@ w32_clear_under_internal_border (struct frame *f) } } +/** + * w32_set_child_frame_border_width: + * + * Set width of child frame F's internal border to ARG pixels. + * ARG < 0 is treated like ARG = 0. + */ +static void +w32_set_child_frame_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + int argval = check_integer_range (arg, INT_MIN, INT_MAX); + int border = max (argval, 0); + + if (border != FRAME_CHILD_FRAME_BORDER_WIDTH (f)) + { + f->child_frame_border_width = border; + + if (FRAME_NATIVE_WINDOW (f) != 0) + { + adjust_frame_size (f, -1, -1, 3, false, Qchild_frame_border_width); + + if (FRAME_VISIBLE_P (f)) + w32_clear_under_internal_border (f); + } + } +} + /** * w32_set_internal_border_width: @@ -1700,10 +1588,8 @@ w32_clear_under_internal_border (struct frame *f) static void w32_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { - int border; - - CHECK_TYPE_RANGED_INTEGER (int, arg); - border = max (XFIXNUM (arg), 0); + int argval = check_integer_range (arg, INT_MIN, INT_MAX); + int border = max (argval, 0); if (border != FRAME_INTERNAL_BORDER_WIDTH (f)) { @@ -1751,7 +1637,7 @@ w32_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) if (!old) /* Make menu bar when there was none. Emacs 25 waited until the next redisplay for this to take effect. */ - set_frame_menubar (f, false, true); + set_frame_menubar (f, true); else { /* Remove menu bar. */ @@ -3307,6 +3193,7 @@ w32_name_of_message (UINT msg) M (WM_EMACS_SETCURSOR), M (WM_EMACS_SHOWCURSOR), M (WM_EMACS_PAINT), + M (WM_EMACS_IME_STATUS), M (WM_CHAR), #undef M { 0, 0 } @@ -3444,6 +3331,21 @@ w32_msg_pump (deferred_msg * msg_buf) emacs_abort (); } break; + case WM_EMACS_IME_STATUS: + { + focus_window = GetFocus (); + if (!set_ime_open_status_fn || !focus_window) + break; + + HIMC context = get_ime_context_fn (focus_window); + if (!context) + break; + + set_ime_open_status_fn (context, msg.wParam != 0); + release_ime_context_fn (focus_window, context); + break; + } + #ifdef MSG_DEBUG /* Broadcast messages make it here, so you need to be looking for something in particular for this to be useful. */ @@ -3768,7 +3670,7 @@ get_wm_chars (HWND aWnd, int *buf, int buflen, int ignore_ctrl, int ctrl, non-Emacs window with the same language environment, and using (dead)keys there would change the value stored in the kernel, but not this value. */ /* A layout may emit deadkey=0. It looks like this would reset the state - of the kernel's finite automaton (equivalent to emiting 0-length string, + of the kernel's finite automaton (equivalent to emitting 0-length string, which is otherwise impossible in the dead-key map of a layout). Be ready to treat the case when this delivers WM_(SYS)DEADCHAR. */ static int after_deadkey = -1; @@ -3829,7 +3731,7 @@ deliver_wm_chars (int do_translate, HWND hwnd, UINT msg, UINT wParam, of w32_get_key_modifiers (). */ wmsg.dwModifiers = w32_kbd_mods_to_emacs (console_modifiers, wParam); - /* What follows is just heuristics; the correct treatement requires + /* What follows is just heuristics; the correct treatment requires non-destructive ToUnicode(): http://search.cpan.org/~ilyaz/UI-KeyboardLayout/lib/UI/KeyboardLayout.pm#Can_an_application_on_Windows_accept_keyboard_events?_Part_IV:_application-specific_modifiers @@ -6001,6 +5903,28 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, parameters); } + /* Same for child frames. */ + if (NILP (Fassq (Qchild_frame_border_width, parameters))) + { + Lisp_Object value; + + value = gui_display_get_arg (dpyinfo, parameters, Qchild_frame_border_width, + "childFrameBorderWidth", "childFrameBorderWidth", + RES_TYPE_NUMBER); + if (! EQ (value, Qunbound)) + parameters = Fcons (Fcons (Qchild_frame_border_width, value), + parameters); + + } + + gui_default_parameter (f, parameters, Qchild_frame_border_width, +#ifdef USE_GTK /* We used to impose 0 in xg_create_frame_widgets. */ + make_fixnum (0), +#else + make_fixnum (1), +#endif + "childFrameBorderWidth", "childFrameBorderWidth", + RES_TYPE_NUMBER); gui_default_parameter (f, parameters, Qinternal_border_width, make_fixnum (0), "internalBorderWidth", "InternalBorder", RES_TYPE_NUMBER); gui_default_parameter (f, parameters, Qright_divider_width, make_fixnum (0), @@ -7132,7 +7056,7 @@ w32_create_tip_frame (struct w32_display_info *dpyinfo, Lisp_Object parms) Frame parameters may be changed if .Xdefaults contains specifications for the default font. For example, if there is an `Emacs.default.attributeBackground: pink', the `background-color' - attribute of the frame get's set, which let's the internal border + attribute of the frame gets set, which let's the internal border of the tooltip frame appear in pink. Prevent this. */ { Lisp_Object bg = Fframe_parameter (frame, Qbackground_color); @@ -7216,7 +7140,7 @@ compute_tip_xy (struct frame *f, /* If multiple monitor support is available, constrain the tip onto the current monitor. This improves the above by allowing negative - co-ordinates if monitor positions are such that they are valid, and + coordinates if monitor positions are such that they are valid, and snaps a tooltip onto a single monitor if we are close to the edge where it would otherwise flow onto the other monitor (or into nothingness if there is a gap in the overlap). */ @@ -7500,7 +7424,7 @@ DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0, tip_f = XFRAME (tip_frame); window = FRAME_ROOT_WINDOW (tip_f); - tip_buf = Fget_buffer_create (tip); + tip_buf = Fget_buffer_create (tip, Qnil); /* We will mark the tip window a "pseudo-window" below, and such windows cannot have display margins. */ bset_left_margin_cols (XBUFFER (tip_buf), make_fixnum (0)); @@ -8091,7 +8015,7 @@ DEFUN ("system-move-file-to-trash", Fsystem_move_file_to_trash, { SHFILEOPSTRUCTW file_op_w; /* We need one more element beyond MAX_PATH because this is - a list of file names, with the last element double-NUL + a list of file names, with the last element double-null terminated. */ wchar_t tmp_path_w[MAX_PATH + 1]; @@ -8210,7 +8134,7 @@ operations: \"pastelink\" - create a shortcut in DOCUMENT (which must be a directory) the file or directory whose name is in the clipboard. - \"runas\" - run DOCUMENT, which must be an excutable file, with + \"runas\" - run DOCUMENT, which must be an executable file, with elevated privileges (a.k.a. \"as Administrator\"). \"properties\" - open the property sheet dialog for DOCUMENT. @@ -8263,7 +8187,6 @@ a ShowWindow flag: /* Encode filename, current directory and parameters. */ current_dir = GUI_ENCODE_FILE (current_dir); document = GUI_ENCODE_FILE (document); - doc_w = GUI_SDATA (document); if (STRINGP (parameters)) { parameters = GUI_ENCODE_SYSTEM (parameters); @@ -8274,6 +8197,7 @@ a ShowWindow flag: operation = GUI_ENCODE_SYSTEM (operation); ops_w = GUI_SDATA (operation); } + doc_w = GUI_SDATA (document); result = (intptr_t) ShellExecuteW (NULL, ops_w, doc_w, params_w, GUI_SDATA (current_dir), (FIXNUMP (show_flag) @@ -8358,7 +8282,7 @@ a ShowWindow flag: handler = Ffind_file_name_handler (absdoc, Qfile_exists_p); if (NILP (handler)) { - Lisp_Object absdoc_encoded = ENCODE_FILE (absdoc); + Lisp_Object absdoc_encoded = Fcopy_sequence (ENCODE_FILE (absdoc)); if (faccessat (AT_FDCWD, SSDATA (absdoc_encoded), F_OK, AT_EACCESS) == 0) { @@ -9209,8 +9133,8 @@ The coordinates X and Y are interpreted in pixels relative to a position UINT trail_num = 0; BOOL ret = false; - CHECK_TYPE_RANGED_INTEGER (int, x); - CHECK_TYPE_RANGED_INTEGER (int, y); + int xval = check_integer_range (x, INT_MIN, INT_MAX); + int yval = check_integer_range (y, INT_MIN, INT_MAX); block_input (); /* When "mouse trails" are in effect, moving the mouse cursor @@ -9219,7 +9143,7 @@ The coordinates X and Y are interpreted in pixels relative to a position if (os_subtype == OS_NT && w32_major_version + w32_minor_version >= 6) ret = SystemParametersInfo (SPI_GETMOUSETRAILS, 0, &trail_num, 0); - SetCursorPos (XFIXNUM (x), XFIXNUM (y)); + SetCursorPos (xval, yval); if (ret) SystemParametersInfo (SPI_SETMOUSETRAILS, trail_num, NULL, 0); unblock_input (); @@ -9556,6 +9480,18 @@ cache_system_info (void) w32_num_mouse_buttons = GetSystemMetrics (SM_CMOUSEBUTTONS); } +#ifdef WINDOWSNT +char * +w32_version_string (void) +{ + /* NNN.NNN.NNNNNNNNNN */ + static char version_string[3 + 1 + 3 + 1 + 10 + 1]; + _snprintf (version_string, sizeof version_string, "%d.%d.%d", + w32_major_version, w32_minor_version, w32_build_number); + return version_string; +} +#endif + #ifdef EMACSDEBUG void _DebPrint (const char *fmt, ...) @@ -9866,7 +9802,7 @@ get_dll_version (const char *dll_name) /* Return the number of bytes in UTF-8 encoded string STR that corresponds to at most LIM characters. If STR ends before LIM characters, return the number of bytes in STR including the - terminating NUL byte. */ + terminating null byte. */ static int utf8_mbslen_lim (const char *str, int lim) { @@ -10226,6 +10162,51 @@ DEFUN ("w32-notification-close", #endif /* WINDOWSNT && !HAVE_DBUS */ +DEFUN ("w32-get-ime-open-status", + Fw32_get_ime_open_status, Sw32_get_ime_open_status, + 0, 0, 0, + doc: /* Return non-nil if IME is active, otherwise return nil. + +IME, the MS-Windows Input Method Editor, can be active or inactive. +This function returns non-nil if the IME is active, otherwise nil. */) + (void) +{ + struct frame *sf = + FRAMEP (selected_frame) && FRAME_LIVE_P (XFRAME (selected_frame)) + ? XFRAME (selected_frame) + : NULL; + + if (sf) + { + HWND current_window = FRAME_W32_WINDOW (sf); + HIMC context = get_ime_context_fn (current_window); + if (context) + { + BOOL retval = get_ime_open_status_fn (context); + release_ime_context_fn (current_window, context); + + return retval ? Qt : Qnil; + } + } + + return Qnil; +} + +DEFUN ("w32-set-ime-open-status", + Fw32_set_ime_open_status, Sw32_set_ime_open_status, + 1, 1, 0, + doc: /* Open or close the IME according to STATUS. + +This function activates the IME, the MS-Windows Input Method Editor, +if STATUS is non-nil, otherwise it deactivates the IME. */) + (Lisp_Object status) +{ + unsigned ime_status = NILP (status) ? 0 : 1; + + PostThreadMessage (dwWindowsThreadId, WM_EMACS_IME_STATUS, ime_status, 0); + return Qnil; +} + #ifdef WINDOWSNT /*********************************************************************** @@ -10315,6 +10296,7 @@ frame_parm_handler w32_frame_parm_handlers[] = w32_set_foreground_color, w32_set_icon_name, w32_set_icon_type, + w32_set_child_frame_border_width, w32_set_internal_border_width, gui_set_right_divider_width, gui_set_bottom_divider_width, @@ -10761,6 +10743,8 @@ keys when IME input is received. */); defsubr (&Sw32_notification_notify); defsubr (&Sw32_notification_close); #endif + defsubr (&Sw32_get_ime_open_status); + defsubr (&Sw32_set_ime_open_status); #ifdef WINDOWSNT defsubr (&Sw32_read_registry); @@ -11049,6 +11033,11 @@ globals_of_w32fns (void) get_proc_addr (imm32_lib, "ImmReleaseContext"); set_ime_composition_window_fn = (ImmSetCompositionWindow_Proc) get_proc_addr (imm32_lib, "ImmSetCompositionWindow"); + + get_ime_open_status_fn = (ImmGetOpenStatus_Proc) + get_proc_addr (imm32_lib, "ImmGetOpenStatus"); + set_ime_open_status_fn = (ImmSetOpenStatus_Proc) + get_proc_addr (imm32_lib, "ImmSetOpenStatus"); } HMODULE hm_kernel32 = GetModuleHandle ("kernel32.dll"); diff --git a/src/w32gui.h b/src/w32gui.h index 7576290cca6..d2c34bd00a9 100644 --- a/src/w32gui.h +++ b/src/w32gui.h @@ -41,6 +41,13 @@ typedef struct _XImage /* Optional RGBQUAD array for palette follows (see BITMAPINFO docs). */ } XImage; +struct image; +extern int w32_load_image (struct frame *f, struct image *img, + Lisp_Object spec_file, Lisp_Object spec_data); +extern bool w32_can_use_native_image_api (Lisp_Object); +extern void w32_gdiplus_shutdown (void); +extern size_t w32_image_size (Emacs_Pixmap); + #define FACE_DEFAULT (~0) extern HINSTANCE hinst; diff --git a/src/w32heap.c b/src/w32heap.c index 07694d0f5cf..e002f72608a 100644 --- a/src/w32heap.c +++ b/src/w32heap.c @@ -191,7 +191,7 @@ free_fn the_free_fn; /* It doesn't seem to be useful to allocate from a file mapping. It would be if the memory was shared. - http://stackoverflow.com/questions/307060/what-is-the-purpose-of-allocating-pages-in-the-pagefile-with-createfilemapping */ + https://stackoverflow.com/questions/307060/what-is-the-purpose-of-allocating-pages-in-the-pagefile-with-createfilemapping */ /* This is the function to commit memory when the heap allocator claims for new memory. Before dumping with unexec, we allocate @@ -246,7 +246,7 @@ init_heap (bool use_dynamic_heap) environment before starting GDB to get low fragmentation heap on XP and older systems, for the price of losing "certain heap debug options"; for the details see - http://msdn.microsoft.com/en-us/library/windows/desktop/aa366705%28v=vs.85%29.aspx. */ + https://msdn.microsoft.com/en-us/library/windows/desktop/aa366705%28v=vs.85%29.aspx. */ data_region_end = data_region_base; /* Create the private heap. */ @@ -597,6 +597,16 @@ free_after_dump_9x (void *ptr) } } +void * +sys_calloc (size_t number, size_t size) +{ + size_t nbytes = number * size; + void *ptr = (*the_malloc_fn) (nbytes); + if (ptr) + memset (ptr, 0, nbytes); + return ptr; +} + #if defined HAVE_UNEXEC && defined ENABLE_CHECKING void report_temacs_memory_usage (void) @@ -874,7 +884,7 @@ setrlimit (rlimit_resource_t rltype, const struct rlimit *rlp) { case RLIMIT_STACK: case RLIMIT_NOFILE: - /* We cannot modfy these limits, so we always fail. */ + /* We cannot modify these limits, so we always fail. */ errno = EPERM; break; default: diff --git a/src/w32image.c b/src/w32image.c new file mode 100644 index 00000000000..cc1a6eba22b --- /dev/null +++ b/src/w32image.c @@ -0,0 +1,477 @@ +/* Implementation of MS-Windows native image API via the GDI+ library. + +Copyright (C) 2020-2021 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ + +/* Written by Juan Jose Garcia-Ripoll <juanjose.garciaripoll@gmail.com>. */ + +#include <config.h> +#include "lisp.h" +#include "dispextern.h" +#define COBJMACROS +#ifdef MINGW_W64 +/* FIXME: Do we need to include objidl.h? */ +#include <objidl.h> +#endif +#include <wtypes.h> +#include <gdiplus.h> +#include <shlwapi.h> +#include "w32common.h" +#include "w32term.h" +#ifdef WINDOWSNT +#include "w32.h" /* for map_w32_filename, filename_to_utf16 */ +#endif +#include "frame.h" +#include "coding.h" + +#ifdef WINDOWSNT + +typedef GpStatus (WINGDIPAPI *GdiplusStartup_Proc) + (ULONG_PTR *, GdiplusStartupInput *, GdiplusStartupOutput *); +typedef VOID (WINGDIPAPI *GdiplusShutdown_Proc) (ULONG_PTR); +typedef GpStatus (WINGDIPAPI *GdipGetPropertyItemSize_Proc) + (GpImage *, PROPID, UINT *); +typedef GpStatus (WINGDIPAPI *GdipGetPropertyItem_Proc) + (GpImage *, PROPID, UINT, PropertyItem *); +typedef GpStatus (WINGDIPAPI *GdipImageGetFrameDimensionsCount_Proc) + (GpImage *, UINT *); +typedef GpStatus (WINGDIPAPI *GdipImageGetFrameDimensionsList_Proc) + (GpImage *, GUID *, UINT); +typedef GpStatus (WINGDIPAPI *GdipImageGetFrameCount_Proc) + (GpImage *, GDIPCONST GUID *, UINT *); +typedef GpStatus (WINGDIPAPI *GdipImageSelectActiveFrame_Proc) + (GpImage*, GDIPCONST GUID *, UINT); +typedef GpStatus (WINGDIPAPI *GdipCreateBitmapFromFile_Proc) + (WCHAR *, GpBitmap **); +typedef GpStatus (WINGDIPAPI *GdipCreateBitmapFromStream_Proc) + (IStream *, GpBitmap **); +typedef IStream * (WINAPI *SHCreateMemStream_Proc) (const BYTE *, UINT); +typedef GpStatus (WINGDIPAPI *GdipCreateHBITMAPFromBitmap_Proc) + (GpBitmap *, HBITMAP *, ARGB); +typedef GpStatus (WINGDIPAPI *GdipDisposeImage_Proc) (GpImage *); +typedef GpStatus (WINGDIPAPI *GdipGetImageHeight_Proc) (GpImage *, UINT *); +typedef GpStatus (WINGDIPAPI *GdipGetImageWidth_Proc) (GpImage *, UINT *); + +GdiplusStartup_Proc fn_GdiplusStartup; +GdiplusShutdown_Proc fn_GdiplusShutdown; +GdipGetPropertyItemSize_Proc fn_GdipGetPropertyItemSize; +GdipGetPropertyItem_Proc fn_GdipGetPropertyItem; +GdipImageGetFrameDimensionsCount_Proc fn_GdipImageGetFrameDimensionsCount; +GdipImageGetFrameDimensionsList_Proc fn_GdipImageGetFrameDimensionsList; +GdipImageGetFrameCount_Proc fn_GdipImageGetFrameCount; +GdipImageSelectActiveFrame_Proc fn_GdipImageSelectActiveFrame; +GdipCreateBitmapFromFile_Proc fn_GdipCreateBitmapFromFile; +GdipCreateBitmapFromStream_Proc fn_GdipCreateBitmapFromStream; +SHCreateMemStream_Proc fn_SHCreateMemStream; +GdipCreateHBITMAPFromBitmap_Proc fn_GdipCreateHBITMAPFromBitmap; +GdipDisposeImage_Proc fn_GdipDisposeImage; +GdipGetImageHeight_Proc fn_GdipGetImageHeight; +GdipGetImageWidth_Proc fn_GdipGetImageWidth; + +static bool +gdiplus_init (void) +{ + HANDLE gdiplus_lib, shlwapi_lib; + + if (!((gdiplus_lib = w32_delayed_load (Qgdiplus)) + && (shlwapi_lib = w32_delayed_load (Qshlwapi)))) + return false; + + fn_GdiplusStartup = (GdiplusStartup_Proc) + get_proc_addr (gdiplus_lib, "GdiplusStartup"); + if (!fn_GdiplusStartup) + return false; + fn_GdiplusShutdown = (GdiplusShutdown_Proc) + get_proc_addr (gdiplus_lib, "GdiplusShutdown"); + if (!fn_GdiplusShutdown) + return false; + fn_GdipGetPropertyItemSize = (GdipGetPropertyItemSize_Proc) + get_proc_addr (gdiplus_lib, "GdipGetPropertyItemSize"); + if (!fn_GdipGetPropertyItemSize) + return false; + fn_GdipGetPropertyItem = (GdipGetPropertyItem_Proc) + get_proc_addr (gdiplus_lib, "GdipGetPropertyItem"); + if (!fn_GdipGetPropertyItem) + return false; + fn_GdipImageGetFrameDimensionsCount = (GdipImageGetFrameDimensionsCount_Proc) + get_proc_addr (gdiplus_lib, "GdipImageGetFrameDimensionsCount"); + if (!fn_GdipImageGetFrameDimensionsCount) + return false; + fn_GdipImageGetFrameDimensionsList = (GdipImageGetFrameDimensionsList_Proc) + get_proc_addr (gdiplus_lib, "GdipImageGetFrameDimensionsList"); + if (!fn_GdipImageGetFrameDimensionsList) + return false; + fn_GdipImageGetFrameCount = (GdipImageGetFrameCount_Proc) + get_proc_addr (gdiplus_lib, "GdipImageGetFrameCount"); + if (!fn_GdipImageGetFrameCount) + return false; + fn_GdipImageSelectActiveFrame = (GdipImageSelectActiveFrame_Proc) + get_proc_addr (gdiplus_lib, "GdipImageSelectActiveFrame"); + if (!fn_GdipImageSelectActiveFrame) + return false; + fn_GdipCreateBitmapFromFile = (GdipCreateBitmapFromFile_Proc) + get_proc_addr (gdiplus_lib, "GdipCreateBitmapFromFile"); + if (!fn_GdipCreateBitmapFromFile) + return false; + fn_GdipCreateBitmapFromStream = (GdipCreateBitmapFromStream_Proc) + get_proc_addr (gdiplus_lib, "GdipCreateBitmapFromStream"); + if (!fn_GdipCreateBitmapFromStream) + return false; + fn_GdipCreateHBITMAPFromBitmap = (GdipCreateHBITMAPFromBitmap_Proc) + get_proc_addr (gdiplus_lib, "GdipCreateHBITMAPFromBitmap"); + if (!fn_GdipCreateHBITMAPFromBitmap) + return false; + fn_GdipDisposeImage = (GdipDisposeImage_Proc) + get_proc_addr (gdiplus_lib, "GdipDisposeImage"); + if (!fn_GdipDisposeImage) + return false; + fn_GdipGetImageHeight = (GdipGetImageHeight_Proc) + get_proc_addr (gdiplus_lib, "GdipGetImageHeight"); + if (!fn_GdipGetImageHeight) + return false; + fn_GdipGetImageWidth = (GdipGetImageWidth_Proc) + get_proc_addr (gdiplus_lib, "GdipGetImageWidth"); + if (!fn_GdipGetImageWidth) + return false; + /* LOAD_DLL_FN (shlwapi_lib, SHCreateMemStream); */ + + /* The following terrible kludge is required to use native image API + on Windows before Vista, because SHCreateMemStream was not + exported by name in those versions, only by ordinal number. */ + fn_SHCreateMemStream = (SHCreateMemStream_Proc) + get_proc_addr (shlwapi_lib, "SHCreateMemStream"); + if (!fn_SHCreateMemStream) + { + fn_SHCreateMemStream = (SHCreateMemStream_Proc) + get_proc_addr (shlwapi_lib, MAKEINTRESOURCEA (12)); + if (!fn_SHCreateMemStream) + return false; + } + + return true; +} + +# undef GdiplusStartup +# undef GdiplusShutdown +# undef GdipGetPropertyItemSize +# undef GdipGetPropertyItem +# undef GdipImageGetFrameDimensionsCount +# undef GdipImageGetFrameDimensionsList +# undef GdipImageGetFrameCount +# undef GdipImageSelectActiveFrame +# undef GdipCreateBitmapFromFile +# undef GdipCreateBitmapFromStream +# undef SHCreateMemStream +# undef GdipCreateHBITMAPFromBitmap +# undef GdipDisposeImage +# undef GdipGetImageHeight +# undef GdipGetImageWidth + +# define GdiplusStartup fn_GdiplusStartup +# define GdiplusShutdown fn_GdiplusShutdown +# define GdipGetPropertyItemSize fn_GdipGetPropertyItemSize +# define GdipGetPropertyItem fn_GdipGetPropertyItem +# define GdipImageGetFrameDimensionsCount fn_GdipImageGetFrameDimensionsCount +# define GdipImageGetFrameDimensionsList fn_GdipImageGetFrameDimensionsList +# define GdipImageGetFrameCount fn_GdipImageGetFrameCount +# define GdipImageSelectActiveFrame fn_GdipImageSelectActiveFrame +# define GdipCreateBitmapFromFile fn_GdipCreateBitmapFromFile +# define GdipCreateBitmapFromStream fn_GdipCreateBitmapFromStream +# define SHCreateMemStream fn_SHCreateMemStream +# define GdipCreateHBITMAPFromBitmap fn_GdipCreateHBITMAPFromBitmap +# define GdipDisposeImage fn_GdipDisposeImage +# define GdipGetImageHeight fn_GdipGetImageHeight +# define GdipGetImageWidth fn_GdipGetImageWidth + +#endif /* WINDOWSNT */ + +static int gdip_initialized; +static bool gdiplus_started; +static ULONG_PTR token; +static GdiplusStartupInput input; +static GdiplusStartupOutput output; + + +/* Initialize GDI+, return true if successful. */ +static bool +gdiplus_startup (void) +{ + GpStatus status; + + if (gdiplus_started) + return true; +#ifdef WINDOWSNT + if (!gdip_initialized) + gdip_initialized = gdiplus_init () ? 1 : -1; +#else + gdip_initialized = 1; +#endif + if (gdip_initialized > 0) + { + input.GdiplusVersion = 1; + input.DebugEventCallback = NULL; + input.SuppressBackgroundThread = FALSE; + input.SuppressExternalCodecs = FALSE; + + status = GdiplusStartup (&token, &input, &output); + if (status == Ok) + gdiplus_started = true; + return (status == Ok); + } + return false; +} + +/* This is called from term_ntproc. */ +void +w32_gdiplus_shutdown (void) +{ + if (gdiplus_started) + GdiplusShutdown (token); + gdiplus_started = false; +} + +bool +w32_can_use_native_image_api (Lisp_Object type) +{ + if (!w32_use_native_image_api) + return false; + if (!(EQ (type, Qjpeg) + || EQ (type, Qpng) + || EQ (type, Qgif) + || EQ (type, Qtiff) + || EQ (type, Qnative_image))) + { + /* GDI+ can also display BMP, Exif, ICON, WMF, and EMF images. + But we don't yet support these in image.c. */ + return false; + } + return gdiplus_startup (); +} + +enum PropertyItem_type { + PI_BYTE = 1, + PI_ASCIIZ = 2, + PI_USHORT = 3, + PI_ULONG = 4, + PI_ULONG_PAIR = 5, + PI_BYTE_ANY = 6, + PI_LONG = 7, + PI_LONG_PAIR = 10 +}; + +static double +decode_delay (PropertyItem *propertyItem, int frame) +{ + enum PropertyItem_type type = propertyItem[0].type; + unsigned long udelay; + double retval; + + switch (type) + { + case PI_BYTE: + case PI_BYTE_ANY: + udelay = ((unsigned char *)propertyItem[0].value)[frame]; + retval = udelay; + break; + case PI_USHORT: + udelay = ((unsigned short *)propertyItem[0].value)[frame]; + retval = udelay; + break; + case PI_ULONG: + case PI_LONG: /* delay should always be positive */ + udelay = ((unsigned long *)propertyItem[0].value)[frame]; + retval = udelay; + break; + default: + /* This negative value will cause the caller to disregard the + delay if we cannot determine it reliably. */ + add_to_log ("Invalid or unknown propertyItem type in w32image.c"); + retval = -1.0; + } + + return retval; +} + +static double +w32_frame_delay (GpBitmap *pBitmap, int frame) +{ + UINT size; + PropertyItem *propertyItem; + double delay = -1.0; + + /* Assume that the image has a property item of type PropertyItemEquipMake. + Get the size of that property item. This can fail for multi-frame TIFF + images. */ + GpStatus status = GdipGetPropertyItemSize (pBitmap, PropertyTagFrameDelay, + &size); + + if (status == Ok) + { + /* Allocate a buffer to receive the property item. */ + propertyItem = malloc (size); + if (propertyItem != NULL) + { + /* Get the property item. */ + GdipGetPropertyItem (pBitmap, PropertyTagFrameDelay, size, + propertyItem); + delay = decode_delay (propertyItem, frame); + if (delay <= 0) + { + /* In GIF files, unfortunately, delay is only specified + for the first frame. */ + delay = decode_delay (propertyItem, 0); + } + delay /= 100.0; + free (propertyItem); + } + } + return delay; +} + +static GpStatus +w32_select_active_frame (GpBitmap *pBitmap, int frame, int *nframes, + double *delay) +{ + UINT count, frameCount; + GUID pDimensionIDs[1]; + GpStatus status = Ok; + + status = GdipImageGetFrameDimensionsCount (pBitmap, &count); + frameCount = *nframes = 0; + *delay = -1.0; + if (count) + { + /* The following call will fill pDimensionIDs[0] with the + FrameDimensionTime GUID for GIF images, and + FrameDimensionPage GUID for other image types. Multi-page + GIF and TIFF images expect these values in the + GdipImageSelectActiveFrame call below. */ + status = GdipImageGetFrameDimensionsList (pBitmap, pDimensionIDs, 1); + status = GdipImageGetFrameCount (pBitmap, &pDimensionIDs[0], &frameCount); + if (status == Ok && frameCount > 1) + { + if (frame < 0 || frame >= frameCount) + status = GenericError; + else + { + status = GdipImageSelectActiveFrame (pBitmap, &pDimensionIDs[0], + frame); + *delay = w32_frame_delay (pBitmap, frame); + *nframes = frameCount; + } + } + } + return status; +} + +static ARGB +w32_image_bg_color (struct frame *f, struct image *img) +{ + Lisp_Object specified_bg = Fplist_get (XCDR (img->spec), QCbackground); + Emacs_Color color; + + /* If the user specified a color, try to use it; if not, use the + current frame background, ignoring any default background + color set by the image. */ + if (STRINGP (specified_bg) + ? w32_defined_color (f, SSDATA (specified_bg), &color, false, false) + : (w32_query_frame_background_color (f, &color), true)) + /* The user specified ':background', use that. */ + { + DWORD red = (((DWORD) color.red) & 0xff00) << 8; + DWORD green = ((DWORD) color.green) & 0xff00; + DWORD blue = ((DWORD) color.blue) >> 8; + return (ARGB) (red | green | blue); + } + return (ARGB) 0xff000000; +} + +int +w32_load_image (struct frame *f, struct image *img, + Lisp_Object spec_file, Lisp_Object spec_data) +{ + GpStatus status = GenericError; + GpBitmap *pBitmap; + Lisp_Object metadata; + + eassert (valid_image_p (img->spec)); + + /* This function only gets called if w32_gdiplus_startup was invoked + and succeeded. We have a valid token and GDI+ is active. */ + if (STRINGP (spec_file)) + { + const char *fn = map_w32_filename (SSDATA (spec_file), NULL); + wchar_t filename_w[MAX_PATH]; + filename_to_utf16 (fn, filename_w); + status = GdipCreateBitmapFromFile (filename_w, &pBitmap); + } + else if (STRINGP (spec_data)) + { + IStream *pStream = SHCreateMemStream ((BYTE *) SDATA (spec_data), + SBYTES (spec_data)); + if (pStream != NULL) + { + status = GdipCreateBitmapFromStream (pStream, &pBitmap); + IStream_Release (pStream); + } + } + + metadata = Qnil; + if (status == Ok) + { + /* In multiframe pictures, select the first frame. */ + Lisp_Object lisp_index = Fplist_get (XCDR (img->spec), QCindex); + int index = FIXNATP (lisp_index) ? XFIXNAT (lisp_index) : 0; + int nframes; + double delay; + status = w32_select_active_frame (pBitmap, index, &nframes, &delay); + if (status == Ok) + { + if (nframes > 1) + metadata = Fcons (Qcount, Fcons (make_fixnum (nframes), metadata)); + if (delay >= 0) + metadata = Fcons (Qdelay, Fcons (make_float (delay), metadata)); + } + } + + if (status == Ok) + { + ARGB bg_color = w32_image_bg_color (f, img); + Emacs_Pixmap pixmap; + + status = GdipCreateHBITMAPFromBitmap (pBitmap, &pixmap, bg_color); + if (status == Ok) + { + UINT width, height; + GdipGetImageWidth (pBitmap, &width); + GdipGetImageHeight (pBitmap, &height); + img->width = width; + img->height = height; + img->pixmap = pixmap; + img->lisp_data = metadata; + } + + GdipDisposeImage (pBitmap); + } + + if (status != Ok) + { + add_to_log ("Unable to load image %s", img->spec); + return 0; + } + return 1; +} diff --git a/src/w32menu.c b/src/w32menu.c index 698f7b56deb..3bf76663947 100644 --- a/src/w32menu.c +++ b/src/w32menu.c @@ -155,7 +155,7 @@ w32_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) void w32_activate_menubar (struct frame *f) { - set_frame_menubar (f, false, true); + set_frame_menubar (f, true); /* Lock out further menubar changes while active. */ f->output_data.w32->menubar_active = 1; @@ -258,12 +258,10 @@ menubar_selection_callback (struct frame *f, void * client_data) } -/* Set the contents of the menubar widgets of frame F. - The argument FIRST_TIME is currently ignored; - it is set the first time this is called, from initialize_frame_menubar. */ +/* Set the contents of the menubar widgets of frame F. */ void -set_frame_menubar (struct frame *f, bool first_time, bool deep_p) +set_frame_menubar (struct frame *f, bool deep_p) { HMENU menubar_widget = f->output_data.w32->menubar_widget; Lisp_Object items; @@ -511,7 +509,7 @@ initialize_frame_menubar (struct frame *f) /* This function is called before the first chance to redisplay the frame. It has to be, so the frame will have the right size. */ fset_menu_bar_items (f, menu_bar_items (FRAME_MENU_BAR_ITEMS (f))); - set_frame_menubar (f, true, true); + set_frame_menubar (f, true); } /* Get rid of the menu bar of frame F, and free its storage. @@ -1485,7 +1483,7 @@ w32_menu_display_help (HWND owner, HMENU menu, UINT item, UINT flags) crash Emacs when we try to display those "strings". It is unclear why we get these dwItemData, or what they are: sometimes they point to a wchar_t string that is the menu - title, sometimes to someting that doesn't look like text + title, sometimes to something that doesn't look like text at all. (The problematic data also comes with the 0x0800 bit set, but this bit is not documented, so we don't want to depend on it.) */ diff --git a/src/w32proc.c b/src/w32proc.c index b436eaff2c3..2b6cb9c1e1d 100644 --- a/src/w32proc.c +++ b/src/w32proc.c @@ -2007,9 +2007,9 @@ sys_spawnve (int mode, char *cmdname, char **argv, char **envp) } /* we have to do some conjuring here to put argv and envp into the - form CreateProcess wants... argv needs to be a space separated/NUL - terminated list of parameters, and envp is a NUL - separated/double-NUL terminated list of parameters. + form CreateProcess wants... argv needs to be a space separated/null + terminated list of parameters, and envp is a null + separated/double-null terminated list of parameters. Additionally, zero-length args and args containing whitespace or quote chars need to be wrapped in double quotes - for this to work, @@ -3019,9 +3019,9 @@ reset_standard_handles (int in, int out, int err, HANDLE handles[3]) } void -set_process_dir (char * dir) +set_process_dir (const char * dir) { - process_dir = dir; + process_dir = (char *) dir; } /* To avoid problems with winsock implementations that work over dial-up @@ -3231,7 +3231,7 @@ such programs cannot be invoked by Emacs anyway. */) char *progname, progname_a[MAX_PATH]; program = Fexpand_file_name (program, Qnil); - encoded_progname = ENCODE_FILE (program); + encoded_progname = Fcopy_sequence (ENCODE_FILE (program)); progname = SSDATA (encoded_progname); unixtodos_filename (progname); filename_to_ansi (progname, progname_a); @@ -3398,10 +3398,10 @@ If LCID (a 16-bit number) is not a valid locale, the result is nil. */) got_full = GetLocaleInfo (XFIXNUM (lcid), XFIXNUM (longform), full_name, sizeof (full_name)); - /* GetLocaleInfo's return value includes the terminating NUL + /* GetLocaleInfo's return value includes the terminating null character, when the returned information is a string, whereas make_unibyte_string needs the string length without the - terminating NUL. */ + terminating null. */ if (got_full) return make_unibyte_string (full_name, got_full - 1); } diff --git a/src/w32select.c b/src/w32select.c index 58cbea9130d..85f8e5556a2 100644 --- a/src/w32select.c +++ b/src/w32select.c @@ -803,7 +803,7 @@ DEFUN ("w32-get-clipboard-data", Fw32_get_clipboard_data, (void) ignored; /* Don't pass our own text from the clipboard (which might be - troublesome if the killed text includes NUL characters). */ + troublesome if the killed text includes null characters). */ if (!NILP (current_text)) return ret; @@ -956,7 +956,7 @@ DEFUN ("w32-get-clipboard-data", Fw32_get_clipboard_data, truelen = nbytes; dst = src; - /* avoid using strchr because it recomputes the length everytime */ + /* avoid using strchr because it recomputes the length every time */ while ((dst = memchr (dst, '\r', nbytes - (dst - src))) != NULL) { if (dst[1] == '\n') /* safe because of trailing '\0' */ diff --git a/src/w32term.c b/src/w32term.c index 2de6b0d78c7..0ee805a8526 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -888,10 +888,10 @@ static void w32_draw_image_foreground_1 (struct glyph_string *, HBITMAP); static void w32_clear_glyph_string_rect (struct glyph_string *, int, int, int, int); static void w32_draw_relief_rect (struct frame *, int, int, int, int, - int, int, int, int, int, int, + int, int, int, int, int, int, int, RECT *); static void w32_draw_box_rect (struct glyph_string *, int, int, int, int, - int, bool, bool, RECT *); + int, int, bool, bool, RECT *); /* Set S->gc to a suitable GC for drawing glyph string S in cursor @@ -1101,19 +1101,28 @@ w32_set_glyph_string_clipping_exactly (struct glyph_string *src, static void w32_compute_glyph_string_overhangs (struct glyph_string *s) { - if (s->cmp == NULL - && s->first_glyph->type == CHAR_GLYPH - && !s->font_not_found_p) + if (s->cmp == NULL) { - struct font *font = s->font; struct font_metrics metrics; + if (s->first_glyph->type == CHAR_GLYPH && !s->font_not_found_p) + { + struct font *font = s->font; + font->driver->text_extents (font, s->char2b, s->nchars, &metrics); + s->right_overhang = (metrics.rbearing > metrics.width + ? metrics.rbearing - metrics.width : 0); + s->left_overhang = metrics.lbearing < 0 ? -metrics.lbearing : 0; + } + else if (s->first_glyph->type == COMPOSITE_GLYPH) + { + Lisp_Object gstring = composition_gstring_from_id (s->cmp_id); - font->driver->text_extents (font, s->char2b, s->nchars, &metrics); - s->right_overhang = (metrics.rbearing > metrics.width - ? metrics.rbearing - metrics.width : 0); - s->left_overhang = metrics.lbearing < 0 ? -metrics.lbearing : 0; + composition_gstring_width (gstring, s->cmp_from, s->cmp_to, &metrics); + s->right_overhang = (metrics.rbearing > metrics.width + ? metrics.rbearing - metrics.width : 0); + s->left_overhang = metrics.lbearing < 0 ? -metrics.lbearing : 0; + } } - else if (s->cmp) + else { s->right_overhang = s->cmp->rbearing - s->cmp->pixel_width; s->left_overhang = -s->cmp->lbearing; @@ -1160,7 +1169,7 @@ w32_draw_glyph_string_background (struct glyph_string *s, bool force_p) shouldn't be drawn in the first place. */ if (!s->background_filled_p) { - int box_line_width = max (s->face->box_line_width, 0); + int box_line_width = max (s->face->box_horizontal_line_width, 0); #if 0 /* TODO: stipple */ if (s->stippled_p) @@ -1206,7 +1215,7 @@ w32_draw_glyph_string_foreground (struct glyph_string *s) of S to the right of that box line. */ if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) - x = s->x + eabs (s->face->box_line_width); + x = s->x + max (s->face->box_vertical_line_width, 0); else x = s->x; @@ -1264,7 +1273,7 @@ w32_draw_composite_glyph_string_foreground (struct glyph_string *s) of S to the right of that box line. */ if (s->face && s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) - x = s->x + eabs (s->face->box_line_width); + x = s->x + max (s->face->box_vertical_line_width, 0); else x = s->x; @@ -1361,7 +1370,7 @@ w32_draw_glyphless_glyph_string_foreground (struct glyph_string *s) of S to the right of that box line. */ if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) - x = s->x + eabs (s->face->box_line_width); + x = s->x + max (s->face->box_vertical_line_width, 0); else x = s->x; @@ -1529,7 +1538,7 @@ w32_query_colors (struct frame *f, Emacs_Color *colors, int ncolors) /* Store F's background color into *BGCOLOR. */ -static void +void w32_query_frame_background_color (struct frame *f, Emacs_Color *bgcolor) { bgcolor->pixel = FRAME_BACKGROUND_PIXEL (f); @@ -1617,7 +1626,7 @@ w32_setup_relief_colors (struct glyph_string *s) static void w32_draw_relief_rect (struct frame *f, int left_x, int top_y, int right_x, int bottom_y, - int width, int raised_p, + int hwidth, int vwidth, int raised_p, int top_p, int bot_p, int left_p, int right_p, RECT *clip_rect) { @@ -1634,14 +1643,14 @@ w32_draw_relief_rect (struct frame *f, /* Top. */ if (top_p) - for (i = 0; i < width; ++i) + for (i = 0; i < hwidth; ++i) w32_fill_area (f, hdc, gc.foreground, left_x + i * left_p, top_y + i, right_x - left_x - i * (left_p + right_p ) + 1, 1); /* Left. */ if (left_p) - for (i = 0; i < width; ++i) + for (i = 0; i < vwidth; ++i) w32_fill_area (f, hdc, gc.foreground, left_x + i, top_y + (i + 1) * top_p, 1, bottom_y - top_y - (i + 1) * (bot_p + top_p) + 1); @@ -1653,14 +1662,14 @@ w32_draw_relief_rect (struct frame *f, /* Bottom. */ if (bot_p) - for (i = 0; i < width; ++i) + for (i = 0; i < hwidth; ++i) w32_fill_area (f, hdc, gc.foreground, left_x + i * left_p, bottom_y - i, right_x - left_x - i * (left_p + right_p) + 1, 1); /* Right. */ if (right_p) - for (i = 0; i < width; ++i) + for (i = 0; i < vwidth; ++i) w32_fill_area (f, hdc, gc.foreground, right_x - i, top_y + (i + 1) * top_p, 1, bottom_y - top_y - (i + 1) * (bot_p + top_p) + 1); @@ -1680,31 +1689,31 @@ w32_draw_relief_rect (struct frame *f, static void w32_draw_box_rect (struct glyph_string *s, - int left_x, int top_y, int right_x, int bottom_y, int width, - bool left_p, bool right_p, RECT *clip_rect) + int left_x, int top_y, int right_x, int bottom_y, int hwidth, + int vwidth, bool left_p, bool right_p, RECT *clip_rect) { w32_set_clip_rectangle (s->hdc, clip_rect); /* Top. */ w32_fill_area (s->f, s->hdc, s->face->box_color, - left_x, top_y, right_x - left_x + 1, width); + left_x, top_y, right_x - left_x + 1, hwidth); /* Left. */ if (left_p) { w32_fill_area (s->f, s->hdc, s->face->box_color, - left_x, top_y, width, bottom_y - top_y + 1); + left_x, top_y, vwidth, bottom_y - top_y + 1); } /* Bottom. */ w32_fill_area (s->f, s->hdc, s->face->box_color, - left_x, bottom_y - width + 1, right_x - left_x + 1, width); + left_x, bottom_y - hwidth + 1, right_x - left_x + 1, hwidth); /* Right. */ if (right_p) { w32_fill_area (s->f, s->hdc, s->face->box_color, - right_x - width + 1, top_y, width, bottom_y - top_y + 1); + right_x - vwidth + 1, top_y, vwidth, bottom_y - top_y + 1); } w32_set_clip_rectangle (s->hdc, NULL); @@ -1716,7 +1725,7 @@ w32_draw_box_rect (struct glyph_string *s, static void w32_draw_glyph_string_box (struct glyph_string *s) { - int width, left_x, right_x, top_y, bottom_y, last_x; + int hwidth, vwidth, left_x, right_x, top_y, bottom_y, last_x; bool left_p, right_p, raised_p; struct glyph *last_glyph; RECT clip_rect; @@ -1725,12 +1734,29 @@ w32_draw_glyph_string_box (struct glyph_string *s) ? WINDOW_RIGHT_EDGE_X (s->w) : window_box_right (s->w, s->area)); - /* The glyph that may have a right box line. */ - last_glyph = (s->cmp || s->img - ? s->first_glyph - : s->first_glyph + s->nchars - 1); + /* The glyph that may have a right box line. For static + compositions and images, the right-box flag is on the first glyph + of the glyph string; for other types it's on the last glyph. */ + if (s->cmp || s->img) + last_glyph = s->first_glyph; + else if (s->first_glyph->type == COMPOSITE_GLYPH + && s->first_glyph->u.cmp.automatic) + { + /* For automatic compositions, we need to look up the last glyph + in the composition. */ + struct glyph *end = s->row->glyphs[s->area] + s->row->used[s->area]; + struct glyph *g = s->first_glyph; + for (last_glyph = g++; + g < end && g->u.cmp.automatic && g->u.cmp.id == s->cmp_id + && g->slice.cmp.to < s->cmp_to; + last_glyph = g++) + ; + } + else + last_glyph = s->first_glyph + s->nchars - 1; - width = eabs (s->face->box_line_width); + vwidth = eabs (s->face->box_vertical_line_width); + hwidth = eabs (s->face->box_horizontal_line_width); raised_p = s->face->box == FACE_RAISED_BOX; left_x = s->x; right_x = ((s->row->full_width_p && s->extends_to_end_of_line_p @@ -1751,13 +1777,13 @@ w32_draw_glyph_string_box (struct glyph_string *s) get_glyph_string_clip_rect (s, &clip_rect); if (s->face->box == FACE_SIMPLE_BOX) - w32_draw_box_rect (s, left_x, top_y, right_x, bottom_y, width, - left_p, right_p, &clip_rect); + w32_draw_box_rect (s, left_x, top_y, right_x, bottom_y, hwidth, + vwidth, left_p, right_p, &clip_rect); else { w32_setup_relief_colors (s); - w32_draw_relief_rect (s->f, left_x, top_y, right_x, bottom_y, - width, raised_p, 1, 1, left_p, right_p, &clip_rect); + w32_draw_relief_rect (s->f, left_x, top_y, right_x, bottom_y, hwidth, + vwidth, raised_p, 1, 1, left_p, right_p, &clip_rect); } } @@ -1795,7 +1821,7 @@ w32_draw_image_foreground (struct glyph_string *s) if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p && s->slice.x == 0) - x += eabs (s->face->box_line_width); + x += max (s->face->box_vertical_line_width, 0); /* If there is a margin around the image, adjust x- and y-position by that margin. */ @@ -1965,6 +1991,17 @@ w32_draw_image_foreground (struct glyph_string *s) RestoreDC (s->hdc ,-1); } +size_t +w32_image_size (Emacs_Pixmap pixmap) +{ + BITMAP bm_info; + size_t rv = 0; + + if (GetObject (pixmap, sizeof (BITMAP), &bm_info)) + rv = bm_info.bmWidth * bm_info.bmHeight * bm_info.bmBitsPixel / 8; + return rv; +} + /* Draw a relief around the image glyph string S. */ @@ -1982,7 +2019,7 @@ w32_draw_image_relief (struct glyph_string *s) if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p && s->slice.x == 0) - x += eabs (s->face->box_line_width); + x += max (s->face->box_vertical_line_width, 0); /* If there is a margin around the image, adjust x- and y-position by that margin. */ @@ -2034,7 +2071,7 @@ w32_draw_image_relief (struct glyph_string *s) w32_setup_relief_colors (s); get_glyph_string_clip_rect (s, &r); - w32_draw_relief_rect (s->f, x, y, x1, y1, thick, raised_p, + w32_draw_relief_rect (s->f, x, y, x1, y1, thick, thick, raised_p, top_p, bot_p, left_p, right_p, &r); } @@ -2054,7 +2091,7 @@ w32_draw_image_foreground_1 (struct glyph_string *s, HBITMAP pixmap) if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p && s->slice.x == 0) - x += eabs (s->face->box_line_width); + x += max (s->face->box_vertical_line_width, 0); /* If there is a margin around the image, adjust x- and y-position by that margin. */ @@ -2167,8 +2204,8 @@ static void w32_draw_image_glyph_string (struct glyph_string *s) { int x, y; - int box_line_hwidth = eabs (s->face->box_line_width); - int box_line_vwidth = max (s->face->box_line_width, 0); + int box_line_hwidth = max (s->face->box_vertical_line_width, 0); + int box_line_vwidth = max (s->face->box_horizontal_line_width, 0); int height, width; HBITMAP pixmap = 0; @@ -2367,14 +2404,29 @@ w32_draw_stretch_glyph_string (struct glyph_string *s) else if (!s->background_filled_p) { int background_width = s->background_width; - int x = s->x, left_x = window_box_left_offset (s->w, TEXT_AREA); + int x = s->x, text_left_x = window_box_left_offset (s->w, TEXT_AREA); - /* Don't draw into left margin, fringe or scrollbar area - except for header line and mode line. */ - if (x < left_x && !s->row->mode_line_p) + /* Don't draw into left fringe or scrollbar area except for + header line and mode line. */ + if (x < text_left_x && !s->row->mode_line_p) { - background_width -= left_x - x; - x = left_x; + int left_x = WINDOW_LEFT_SCROLL_BAR_AREA_WIDTH (s->w); + int right_x = text_left_x; + + if (WINDOW_HAS_FRINGES_OUTSIDE_MARGINS (s->w)) + left_x += WINDOW_LEFT_FRINGE_WIDTH (s->w); + else + right_x -= WINDOW_LEFT_FRINGE_WIDTH (s->w); + + /* Adjust X and BACKGROUND_WIDTH to fit inside the space + between LEFT_X and RIGHT_X. */ + if (x < left_x) + { + background_width -= left_x - x; + x = left_x; + } + if (x + background_width > right_x) + background_width = right_x - x; } if (background_width > 0) w32_draw_glyph_string_bg_rect (s, x, s->y, background_width, s->height); @@ -4821,10 +4873,6 @@ w32_read_socket (struct terminal *terminal, inev.kind = DEICONIFY_EVENT; XSETFRAME (inev.frame_or_window, f); } - else if (!NILP (Vframe_list) && !NILP (XCDR (Vframe_list))) - /* Force a redisplay sooner or later to update the - frame titles in case this is the second frame. */ - record_asynch_buffer_change (); } else { @@ -5442,25 +5490,19 @@ w32_read_socket (struct terminal *terminal, inev.kind = DEICONIFY_EVENT; XSETFRAME (inev.frame_or_window, f); } - else if (! NILP (Vframe_list) - && ! NILP (XCDR (Vframe_list))) - /* Force a redisplay sooner or later - to update the frame titles - in case this is the second frame. */ - record_asynch_buffer_change (); /* Windows can send us a SIZE_MAXIMIZED message even when fullscreen is fullboth. The following is a simple hack to check that based on the fact that - only a maximized fullscreen frame should have both - top/left outside the screen. */ + only a maximized fullscreen frame should have top + or left outside the screen. */ if (EQ (fullscreen, Qfullwidth) || EQ (fullscreen, Qfullheight) || NILP (fullscreen)) { int x, y; w32_real_positions (f, &x, &y); - if (x < 0 && y < 0) + if (x < 0 || y < 0) store_frame_param (f, Qfullscreen, Qmaximized); } } @@ -5495,12 +5537,6 @@ w32_read_socket (struct terminal *terminal, inev.kind = DEICONIFY_EVENT; XSETFRAME (inev.frame_or_window, f); } - else if (! NILP (Vframe_list) - && ! NILP (XCDR (Vframe_list))) - /* Force a redisplay sooner or later - to update the frame titles - in case this is the second frame. */ - record_asynch_buffer_change (); } if (EQ (get_frame_param (f, Qfullscreen), Qmaximized)) @@ -5792,9 +5828,6 @@ w32_read_socket (struct terminal *terminal, SET_FRAME_GARBAGED (f); DebPrint (("obscured frame %p (%s) found to be visible\n", f, SDATA (f->name))); - - /* Force a redisplay sooner or later. */ - record_asynch_buffer_change (); } } } @@ -6851,7 +6884,7 @@ w32_make_frame_visible (struct frame *f) /* According to a report in emacs-devel 2008-06-03, SW_SHOWNORMAL causes unexpected behavior when unminimizing frames that were previously maximized. But only SW_SHOWNORMAL works properly for - frames that were truely hidden (using make-frame-invisible), so + frames that were truly hidden (using make-frame-invisible), so we need it to avoid Bug#5482. It seems that iconified is only set for minimized windows that are still visible, so use that to determine the appropriate flag to pass ShowWindow. */ @@ -7139,15 +7172,21 @@ w32_initialize_display_info (Lisp_Object display_name) memset (dpyinfo, 0, sizeof (*dpyinfo)); dpyinfo->name_list_element = Fcons (display_name, Qnil); + static char const title[] = "GNU Emacs"; if (STRINGP (Vsystem_name)) { - dpyinfo->w32_id_name = xmalloc (SCHARS (Vinvocation_name) - + SCHARS (Vsystem_name) + 2); - sprintf (dpyinfo->w32_id_name, "%s@%s", - SDATA (Vinvocation_name), SDATA (Vsystem_name)); + static char const at[] = " at "; + ptrdiff_t nbytes = sizeof (title) + sizeof (at); + if (INT_ADD_WRAPV (nbytes, SCHARS (Vsystem_name), &nbytes)) + memory_full (SIZE_MAX); + dpyinfo->w32_id_name = xmalloc (nbytes); + sprintf (dpyinfo->w32_id_name, "%s%s%s", title, at, SDATA (Vsystem_name)); } else - dpyinfo->w32_id_name = xlispstrdup (Vinvocation_name); + { + dpyinfo->w32_id_name = xmalloc (sizeof (title)); + strcpy (dpyinfo->w32_id_name, title); + } /* Default Console mode values - overridden when running in GUI mode with values obtained from system metrics. */ @@ -7483,7 +7522,8 @@ w32_initialize (void) } #ifdef CYGWIN - if ((w32_message_fd = emacs_open ("/dev/windows", O_RDWR, 0)) == -1) + if ((w32_message_fd = emacs_open_noquit ("/dev/windows", O_RDWR, 0)) + == -1) fatal ("opening /dev/windows: %s", strerror (errno)); #endif /* CYGWIN */ @@ -7657,6 +7697,25 @@ Windows 8. It is set to nil on Windows 9X. */); else w32_unicode_filenames = 1; + DEFVAR_BOOL ("w32-use-native-image-API", + w32_use_native_image_api, + doc: /* Non-nil means use the native MS-Windows image API to display images. + +A value of nil means displaying images other than PBM and XBM requires +optional supporting libraries to be installed. +The native image API library used is GDI+ via GDIPLUS.DLL. This +library is available only since W2K, therefore this variable is +unconditionally set to nil on older systems. */); + + /* For now, disabled by default, since this is an experimental feature. */ +#if 0 && HAVE_NATIVE_IMAGE_API + if (os_subtype == OS_9X) + w32_use_native_image_api = 0; + else + w32_use_native_image_api = 1; +#else + w32_use_native_image_api = 0; +#endif /* FIXME: The following variable will be (hopefully) removed before Emacs 25.1 gets released. */ diff --git a/src/w32term.h b/src/w32term.h index 44378aa4c27..7d351df871d 100644 --- a/src/w32term.h +++ b/src/w32term.h @@ -75,7 +75,6 @@ struct w32_palette_entry { extern void w32_regenerate_palette (struct frame *f); extern void w32_fullscreen_rect (HWND hwnd, int fsmode, RECT normal, RECT *rect); - /* For each display (currently only one on w32), we have a structure that records information about it. */ @@ -248,6 +247,8 @@ extern int w32_display_pixel_height (struct w32_display_info *); extern int w32_display_pixel_width (struct w32_display_info *); extern void initialize_frame_menubar (struct frame *); extern void w32_dialog_in_progress (Lisp_Object in_progress); +extern void w32_query_frame_background_color (struct frame *f, + Emacs_Color *bgcolor); extern void w32_make_frame_visible (struct frame *f); extern void w32_make_frame_invisible (struct frame *f); @@ -475,7 +476,7 @@ struct scroll_bar { editing large files, we establish a minimum height by always drawing handle bottoms VERTICAL_SCROLL_BAR_MIN_HANDLE pixels below where they would be normally; the bottom and top are in a - different co-ordinate system. */ + different coordinate system. */ int start, end; /* If the scroll bar handle is currently being dragged by the user, @@ -670,7 +671,8 @@ do { \ #define WM_EMACS_BRINGTOTOP (WM_EMACS_START + 23) #define WM_EMACS_INPUT_READY (WM_EMACS_START + 24) #define WM_EMACS_FILENOTIFY (WM_EMACS_START + 25) -#define WM_EMACS_END (WM_EMACS_START + 26) +#define WM_EMACS_IME_STATUS (WM_EMACS_START + 26) +#define WM_EMACS_END (WM_EMACS_START + 27) #define WND_FONTWIDTH_INDEX (0) #define WND_LINEHEIGHT_INDEX (4) diff --git a/src/window.c b/src/window.c index f231187f7b3..eb16e2a4338 100644 --- a/src/window.c +++ b/src/window.c @@ -617,11 +617,12 @@ equals the special symbol `mark-for-redisplay'. Run `buffer-list-update-hook' unless NORECORD is non-nil. Note that applications and internal routines often select a window temporarily for various purposes; mostly, to simplify coding. As a rule, such -selections should be not recorded and therefore will not pollute +selections should not be recorded and therefore will not pollute `buffer-list-update-hook'. Selections that "really count" are those causing a visible change in the next redisplay of WINDOW's frame and -should be always recorded. So if you think of running a function each -time a window gets selected put it on `buffer-list-update-hook'. +should always be recorded. So if you think of running a function each +time a window gets selected, put it on `buffer-list-update-hook' or +`window-selection-change-functions'. Also note that the main editor command loop sets the current buffer to the buffer of the selected window before each command. */) @@ -1895,10 +1896,7 @@ POS, ROWH is the visible height of that row, and VPOS is the row number if (EQ (pos, Qt)) posint = -1; else if (!NILP (pos)) - { - CHECK_FIXNUM_COERCE_MARKER (pos); - posint = XFIXNUM (pos); - } + posint = fix_position (pos); else if (w == XWINDOW (selected_window)) posint = PT; else @@ -2111,30 +2109,20 @@ though when run from an idle timer with a delay of zero seconds. */) || window_outdated (w)) return Qnil; - if (NILP (first)) - row = (NILP (body) - ? MATRIX_ROW (w->current_matrix, 0) - : MATRIX_FIRST_TEXT_ROW (w->current_matrix)); - else if (FIXNUMP (first)) - { - CHECK_RANGED_INTEGER (first, 0, w->current_matrix->nrows); - row = MATRIX_ROW (w->current_matrix, XFIXNUM (first)); - } - else - error ("Invalid specification of first line"); - - if (NILP (last)) - - end_row = (NILP (body) - ? MATRIX_ROW (w->current_matrix, w->current_matrix->nrows) - : MATRIX_BOTTOM_TEXT_ROW (w->current_matrix, w)); - else if (FIXNUMP (last)) - { - CHECK_RANGED_INTEGER (last, 0, w->current_matrix->nrows); - end_row = MATRIX_ROW (w->current_matrix, XFIXNUM (last)); - } - else - error ("Invalid specification of last line"); + row = (!NILP (first) + ? MATRIX_ROW (w->current_matrix, + check_integer_range (first, 0, + w->current_matrix->nrows)) + : NILP (body) + ? MATRIX_ROW (w->current_matrix, 0) + : MATRIX_FIRST_TEXT_ROW (w->current_matrix)); + end_row = (!NILP (last) + ? MATRIX_ROW (w->current_matrix, + check_integer_range (last, 0, + w->current_matrix->nrows)) + : NILP (body) + ? MATRIX_ROW (w->current_matrix, w->current_matrix->nrows) + : MATRIX_BOTTOM_TEXT_ROW (w->current_matrix, w)); while (row <= end_row && row->enabled_p && row->y + row->height < max_y) @@ -2656,8 +2644,10 @@ candidate_window_p (Lisp_Object window, Lisp_Object owindow, /* To qualify as candidate, it's not sufficient for WINDOW's frame to just share the minibuffer window - it must be active as well (see Bug#24500). */ - candidate_p = (EQ (XWINDOW (all_frames)->frame, w->frame) - || EQ (XWINDOW (all_frames)->frame, FRAME_FOCUS_FRAME (f))); + candidate_p = ((EQ (XWINDOW (all_frames)->frame, w->frame) + || (EQ (f->minibuffer_window, all_frames) + && EQ (XWINDOW (all_frames)->frame, FRAME_FOCUS_FRAME (f)))) + && !is_minibuffer (0, XWINDOW (all_frames)->contents)); else if (FRAMEP (all_frames)) candidate_p = EQ (all_frames, w->frame); @@ -2673,12 +2663,15 @@ static void decode_next_window_args (Lisp_Object *window, Lisp_Object *minibuf, Lisp_Object *all_frames) { struct window *w = decode_live_window (*window); + Lisp_Object miniwin = XFRAME (w->frame)->minibuffer_window; XSETWINDOW (*window, w); /* MINIBUF nil may or may not include minibuffers. Decide if it does. */ if (NILP (*minibuf)) - *minibuf = minibuf_level ? minibuf_window : Qlambda; + *minibuf = this_minibuffer_depth (XWINDOW (miniwin)->contents) + ? miniwin + : Qlambda; else if (!EQ (*minibuf, Qt)) *minibuf = Qlambda; @@ -4328,11 +4321,11 @@ Note: This function does not operate on any child windows of WINDOW. */) EMACS_INT size_min = NILP (add) ? 0 : - XFIXNUM (w->new_pixel); EMACS_INT size_max = size_min + min (INT_MAX, MOST_POSITIVE_FIXNUM); - CHECK_RANGED_INTEGER (size, size_min, size_max); + int checked_size = check_integer_range (size, size_min, size_max); if (NILP (add)) wset_new_pixel (w, size); else - wset_new_pixel (w, make_fixnum (XFIXNUM (w->new_pixel) + XFIXNUM (size))); + wset_new_pixel (w, make_fixnum (XFIXNUM (w->new_pixel) + checked_size)); return w->new_pixel; } @@ -5475,7 +5468,7 @@ window_scroll (Lisp_Object window, EMACS_INT n, bool whole, bool noerror) wset_redisplay (XWINDOW (window)); - if (whole && Vfast_but_imprecise_scrolling) + if (whole && fast_but_imprecise_scrolling) specbind (Qfontification_functions, Qnil); /* On GUI frames, use the pixel-based version which is much slower @@ -5680,7 +5673,7 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror) if (whole) { ptrdiff_t start_pos = IT_CHARPOS (it); - int dy = frame_line_height; + int flh = frame_line_height; int ht = window_box_height (w); int nscls = sanitize_next_screen_context_lines (); /* In the below we divide the window box height by the frame's @@ -5688,14 +5681,30 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror) box is not an integral multiple of the line height. This is important to ensure we get back to the same position when scrolling up, then down. */ - dy = n * max (dy, (ht / dy - nscls) * dy); + int dy = n * max (flh, (ht / flh - nscls) * flh); + int goal_y; + void *it_data; /* Note that move_it_vertically always moves the iterator to the start of a line. So, if the last line doesn't have a newline, we would end up at the start of the line ending at ZV. */ if (dy <= 0) { + goal_y = it.current_y + dy; move_it_vertically_backward (&it, -dy); + /* move_it_vertically_backward above always overshoots if DY + cannot be reached exactly, i.e. if it falls in the middle + of a screen line. But if that screen line is large + (e.g., a tall image), it might make more sense to + undershoot instead. */ + if (goal_y - it.current_y > 0.5 * flh) + { + it_data = bidi_shelve_cache (); + struct it it1 = it; + if (line_bottom_y (&it1) - goal_y < goal_y - it.current_y) + move_it_by_lines (&it, 1); + bidi_unshelve_cache (it_data, true); + } /* Ensure we actually do move, e.g. in case we are currently looking at an image that is taller that the window height. */ while (start_pos == IT_CHARPOS (it) @@ -5704,8 +5713,28 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror) } else if (dy > 0) { - move_it_to (&it, ZV, -1, it.current_y + dy, -1, - MOVE_TO_POS | MOVE_TO_Y); + goal_y = it.current_y + dy; + move_it_to (&it, ZV, -1, goal_y, -1, MOVE_TO_POS | MOVE_TO_Y); + /* Extra precision for people who want us to preserve the + screen position of the cursor: effectively round DY to the + nearest screen line, instead of rounding to zero; the latter + causes point to move by one line after C-v followed by M-v, + if the buffer has lines of different height. */ + if (!NILP (Vscroll_preserve_screen_position) + && goal_y - it.current_y > 0.5 * flh) + { + it_data = bidi_shelve_cache (); + struct it it2 = it; + + move_it_by_lines (&it, 1); + if (it.current_y > goal_y + 0.5 * flh) + { + it = it2; + bidi_unshelve_cache (it_data, false); + } + else + bidi_unshelve_cache (it_data, true); + } /* Ensure we actually do move, e.g. in case we are currently looking at an image that is taller that the window height. */ while (start_pos == IT_CHARPOS (it) @@ -6835,19 +6864,25 @@ DEFUN ("window-configuration-frame", Fwindow_configuration_frame, Swindow_config } DEFUN ("set-window-configuration", Fset_window_configuration, - Sset_window_configuration, 1, 1, 0, + Sset_window_configuration, 1, 2, 0, doc: /* Set the configuration of windows and buffers as specified by CONFIGURATION. CONFIGURATION must be a value previously returned by `current-window-configuration' (which see). + +Normally, this function selects the frame of the CONFIGURATION, but if +DONT-SET-FRAME is non-nil, it leaves selected the frame which was +current at the start of the function. + If CONFIGURATION was made from a frame that is now deleted, only frame-independent values can be restored. In this case, the return value is nil. Otherwise the value is t. */) - (Lisp_Object configuration) + (Lisp_Object configuration, Lisp_Object dont_set_frame) { register struct save_window_data *data; struct Lisp_Vector *saved_windows; Lisp_Object new_current_buffer; Lisp_Object frame; + Lisp_Object old_frame = selected_frame; struct frame *f; ptrdiff_t old_point = -1; USE_SAFE_ALLOCA; @@ -7164,7 +7199,10 @@ the return value is nil. Otherwise the value is t. */) select_window above totally superfluous; it still sets f's selected window. */ if (FRAME_LIVE_P (XFRAME (data->selected_frame))) - do_switch_frame (data->selected_frame, 0, 0, Qnil); + do_switch_frame (NILP (dont_set_frame) + ? data->selected_frame + : old_frame + , 0, 0, Qnil); } FRAME_WINDOW_CHANGE (f) = true; @@ -7198,11 +7236,13 @@ the return value is nil. Otherwise the value is t. */) return FRAME_LIVE_P (f) ? Qt : Qnil; } - void restore_window_configuration (Lisp_Object configuration) { - Fset_window_configuration (configuration); + if (CONSP (configuration)) + Fset_window_configuration (XCDR (configuration), XCAR (configuration)); + else + Fset_window_configuration (configuration, Qnil); } @@ -7478,7 +7518,7 @@ saved by this function. */) data->minibuf_selected_window = minibuf_level > 0 ? minibuf_selected_window : Qnil; data->root_window = FRAME_ROOT_WINDOW (f); data->focus_frame = FRAME_FOCUS_FRAME (f); - Lisp_Object tem = make_uninit_vector (n_windows); + Lisp_Object tem = make_nil_vector (n_windows); data->saved_windows = tem; for (ptrdiff_t i = 0; i < n_windows; i++) ASET (tem, i, make_nil_vector (VECSIZE (struct saved_window))); @@ -7509,8 +7549,7 @@ extract_dimension (Lisp_Object dimension) { if (NILP (dimension)) return -1; - CHECK_RANGED_INTEGER (dimension, 0, INT_MAX); - return XFIXNUM (dimension); + return check_integer_range (dimension, 0, INT_MAX); } static struct window * @@ -7787,7 +7826,7 @@ set_window_scroll_bars (struct window *w, Lisp_Object width, if more than a single window needs to be considered, see redisplay_internal. */ if (changed) - windows_or_buffers_changed = 31; + wset_redisplay (w); return changed ? w : NULL; } @@ -7976,19 +8015,17 @@ foreach_window_1 (struct window *w, bool (*fn) (struct window *, void *), /* Return true if window configurations CONFIGURATION1 and CONFIGURATION2 describe the same state of affairs. This is used by Fequal. - IGNORE_POSITIONS means ignore non-matching scroll positions - and the like. + Ignore non-matching scroll positions and the like. This ignores a couple of things like the dedication status of window, combination_limit and the like. This might have to be fixed. */ -bool +static bool compare_window_configurations (Lisp_Object configuration1, - Lisp_Object configuration2, - bool ignore_positions) + Lisp_Object configuration2) { - register struct save_window_data *d1, *d2; + struct save_window_data *d1, *d2; struct Lisp_Vector *sws1, *sws2; ptrdiff_t i; @@ -8006,9 +8043,6 @@ compare_window_configurations (Lisp_Object configuration1, || d1->frame_menu_bar_lines != d2->frame_menu_bar_lines || !EQ (d1->selected_frame, d2->selected_frame) || !EQ (d1->f_current_buffer, d2->f_current_buffer) - || (!ignore_positions - && (!EQ (d1->minibuf_scroll_window, d2->minibuf_scroll_window) - || !EQ (d1->minibuf_selected_window, d2->minibuf_selected_window))) || !EQ (d1->focus_frame, d2->focus_frame) /* Verify that the two configurations have the same number of windows. */ || sws1->header.size != sws2->header.size) @@ -8041,12 +8075,6 @@ compare_window_configurations (Lisp_Object configuration1, equality. */ || !EQ (sw1->parent, sw2->parent) || !EQ (sw1->prev, sw2->prev) - || (!ignore_positions - && (!EQ (sw1->hscroll, sw2->hscroll) - || !EQ (sw1->min_hscroll, sw2->min_hscroll) - || !EQ (sw1->start_at_line_beg, sw2->start_at_line_beg) - || NILP (Fequal (sw1->start, sw2->start)) - || NILP (Fequal (sw1->pointm, sw2->pointm)))) || !EQ (sw1->left_margin_cols, sw2->left_margin_cols) || !EQ (sw1->right_margin_cols, sw2->right_margin_cols) || !EQ (sw1->left_fringe_width, sw2->left_fringe_width) @@ -8071,10 +8099,22 @@ This function ignores details such as the values of point and scrolling positions. */) (Lisp_Object x, Lisp_Object y) { - if (compare_window_configurations (x, y, true)) + if (compare_window_configurations (x, y)) return Qt; return Qnil; } + +DEFUN ("window-bump-use-time", Fwindow_bump_use_time, + Swindow_bump_use_time, 1, 1, 0, + doc: /* Mark WINDOW as having been recently used. */) + (Lisp_Object window) +{ + struct window *w = decode_valid_window (window); + + w->use_time = ++window_select_count; + return Qnil; +} + static void init_window_once_for_pdumper (void); @@ -8218,11 +8258,17 @@ is displayed in the `mode-line' face. */); DEFVAR_LISP ("scroll-preserve-screen-position", Vscroll_preserve_screen_position, doc: /* Controls if scroll commands move point to keep its screen position unchanged. + A value of nil means point does not keep its screen position except at the scroll margin or window boundary respectively. + A value of t means point keeps its screen position if the scroll command moved it vertically out of the window, e.g. when scrolling -by full screens. +by full screens. If point is within `next-screen-context-lines' lines +from the edges of the window, point will typically not keep its screen +position when doing commands like `scroll-up-command'/`scroll-down-command' +and the like. + Any other value means point always keeps its screen position. Scroll commands should have the `scroll-command' property on their symbols to be controlled by this variable. */); @@ -8423,7 +8469,7 @@ pixelwise even if this option is nil. */); window_resize_pixelwise = false; DEFVAR_BOOL ("fast-but-imprecise-scrolling", - Vfast_but_imprecise_scrolling, + fast_but_imprecise_scrolling, doc: /* When non-nil, accelerate scrolling operations. This comes into play when scrolling rapidly over previously unfontified buffer regions. Only those portions of the buffer which @@ -8431,7 +8477,7 @@ are actually going to be displayed get fontified. Note that this optimization can cause the portion of the buffer displayed after a scrolling operation to be somewhat inaccurate. */); - Vfast_but_imprecise_scrolling = false; + fast_but_imprecise_scrolling = false; defsubr (&Sselected_window); defsubr (&Sold_selected_window); @@ -8542,6 +8588,7 @@ displayed after a scrolling operation to be somewhat inaccurate. */); defsubr (&Swindow_vscroll); defsubr (&Sset_window_vscroll); defsubr (&Scompare_window_configurations); + defsubr (&Swindow_bump_use_time); defsubr (&Swindow_list); defsubr (&Swindow_list_1); defsubr (&Swindow_prev_buffers); @@ -8552,14 +8599,3 @@ displayed after a scrolling operation to be somewhat inaccurate. */); defsubr (&Swindow_parameter); defsubr (&Sset_window_parameter); } - -void -keys_of_window (void) -{ - initial_define_key (control_x_map, '<', "scroll-left"); - initial_define_key (control_x_map, '>', "scroll-right"); - - initial_define_key (global_map, Ctl ('V'), "scroll-up-command"); - initial_define_key (meta_map, Ctl ('V'), "scroll-other-window"); - initial_define_key (meta_map, 'v', "scroll-down-command"); -} diff --git a/src/window.h b/src/window.h index c2bc04d1831..79eb44e7a38 100644 --- a/src/window.h +++ b/src/window.h @@ -1124,10 +1124,6 @@ extern Lisp_Object echo_area_window; extern EMACS_INT command_loop_level; -/* Depth in minibuffer invocations. */ - -extern EMACS_INT minibuf_level; - /* Non-zero if we should redraw the mode lines on the next redisplay. Usually set to a unique small integer so we can track the main causes of full redisplays in `redisplay--mode-lines-cause'. */ @@ -1184,7 +1180,6 @@ extern Lisp_Object window_list (void); extern Lisp_Object window_parameter (struct window *, Lisp_Object parameter); extern struct window *decode_live_window (Lisp_Object); extern struct window *decode_any_window (Lisp_Object); -extern bool compare_window_configurations (Lisp_Object, Lisp_Object, bool); extern void mark_window_cursors_off (struct window *); extern bool window_wants_mode_line (struct window *); extern bool window_wants_header_line (struct window *); @@ -1203,7 +1198,6 @@ extern bool window_outdated (struct window *); extern void init_window_once (void); extern void init_window (void); extern void syms_of_window (void); -extern void keys_of_window (void); /* Move cursor to row/column position VPOS/HPOS, pixel coordinates Y/X. HPOS/VPOS are window-relative row and column numbers and X/Y are window-relative pixel positions. This is always done during diff --git a/src/xdisp.c b/src/xdisp.c index 77c9af747c3..1815f986781 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -447,6 +447,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "termchar.h" #include "dispextern.h" #include "character.h" +#include "category.h" #include "buffer.h" #include "charset.h" #include "indent.h" @@ -508,13 +509,87 @@ static Lisp_Object list_of_error; && (*BYTE_POS_ADDR (IT_BYTEPOS (*it)) == ' ' \ || *BYTE_POS_ADDR (IT_BYTEPOS (*it)) == '\t')))) +/* These are the category sets we use. They are defined by + kinsoku.el and characters.el. */ +#define NOT_AT_EOL '<' +#define NOT_AT_BOL '>' +#define LINE_BREAKABLE '|' + +static bool +it_char_has_category(struct it *it, int cat) +{ + int ch = 0; + if (it->what == IT_CHARACTER) + ch = it->c; + else if (STRINGP (it->string)) + ch = SREF (it->string, IT_STRING_BYTEPOS (*it)); + else if (it->s) + ch = it->s[IT_BYTEPOS (*it)]; + else if (IT_BYTEPOS (*it) < ZV_BYTE) + ch = *BYTE_POS_ADDR (IT_BYTEPOS (*it)); + + if (ch == 0) + return false; + else + return CHAR_HAS_CATEGORY (ch, cat); +} + +/* Return true if the current character allows wrapping before it. */ +static bool +char_can_wrap_before (struct it *it) +{ + if (!word_wrap_by_category) + return !IT_DISPLAYING_WHITESPACE (it); + + /* For CJK (LTR) text in RTL paragraph, EOL and BOL are flipped. + Because in RTL paragraph, each glyph is prepended to the last + one, effectively drawing right to left. */ + int not_at_bol; + if (it->glyph_row && it->glyph_row->reversed_p) + not_at_bol = NOT_AT_EOL; + else + not_at_bol = NOT_AT_BOL; + /* You cannot wrap before a space or tab because that way you'll + have space and tab at the beginning of next line. */ + return (!IT_DISPLAYING_WHITESPACE (it) + /* Can be at BOL. */ + && !it_char_has_category (it, not_at_bol)); +} + +/* Return true if the current character allows wrapping after it. */ +static bool +char_can_wrap_after (struct it *it) +{ + if (!word_wrap_by_category) + return IT_DISPLAYING_WHITESPACE (it); + + /* For CJK (LTR) text in RTL paragraph, EOL and BOL are flipped. + Because in RTL paragraph, each glyph is prepended to the last + one, effectively drawing right to left. */ + int not_at_eol; + if (it->glyph_row && it->glyph_row->reversed_p) + not_at_eol = NOT_AT_BOL; + else + not_at_eol = NOT_AT_EOL; + + return (IT_DISPLAYING_WHITESPACE (it) + /* Can break after && can be at EOL. */ + || (it_char_has_category (it, LINE_BREAKABLE) + && !it_char_has_category (it, not_at_eol))); +} + +#undef IT_DISPLAYING_WHITESPACE +#undef NOT_AT_EOL +#undef NOT_AT_BOL +#undef LINE_BREAKABLE + /* If all the conditions needed to print the fill column indicator are met, return the (nonnegative) column number, else return a negative value. */ static int fill_column_indicator_column (struct it *it, int char_width) { - if (Vdisplay_fill_column_indicator + if (display_fill_column_indicator && !it->w->pseudo_window_p && it->continuation_lines_width == 0 && CHARACTERP (Vdisplay_fill_column_indicator_character)) @@ -896,11 +971,6 @@ static struct props it_props[] = {0, 0, NULL} }; -/* Value is the position described by X. If X is a marker, value is - the marker_position of X. Otherwise, value is X. */ - -#define COERCE_MARKER(X) (MARKERP ((X)) ? Fmarker_position (X) : (X)) - /* Enumeration returned by some move_it_.* functions internally. */ enum move_it_result @@ -998,12 +1068,12 @@ static void handle_line_prefix (struct it *); static void handle_stop_backwards (struct it *, ptrdiff_t); static void unwind_with_echo_area_buffer (Lisp_Object); static Lisp_Object with_echo_area_buffer_unwind_data (struct window *); -static bool current_message_1 (ptrdiff_t, Lisp_Object); -static bool truncate_message_1 (ptrdiff_t, Lisp_Object); +static bool current_message_1 (void *, Lisp_Object); +static bool truncate_message_1 (void *, Lisp_Object); static void set_message (Lisp_Object); -static bool set_message_1 (ptrdiff_t, Lisp_Object); -static bool display_echo_area_1 (ptrdiff_t, Lisp_Object); -static bool resize_mini_window_1 (ptrdiff_t, Lisp_Object); +static bool set_message_1 (void *, Lisp_Object); +static bool display_echo_area_1 (void *, Lisp_Object); +static bool resize_mini_window_1 (void *, Lisp_Object); static void unwind_redisplay (void); static void extend_face_to_end_of_line (struct it *); static intmax_t message_log_check_duplicate (ptrdiff_t, ptrdiff_t); @@ -1044,7 +1114,8 @@ static ptrdiff_t display_count_lines (ptrdiff_t, ptrdiff_t, ptrdiff_t, static void pint2str (register char *, register int, register ptrdiff_t); static int display_string (const char *, Lisp_Object, Lisp_Object, - ptrdiff_t, ptrdiff_t, struct it *, int, int, int, int); + ptrdiff_t, ptrdiff_t, struct it *, int, int, int, + int); static void compute_line_metrics (struct it *); static void run_redisplay_end_trigger_hook (struct it *); static bool get_overlay_strings (struct it *, ptrdiff_t); @@ -1101,6 +1172,7 @@ static Lisp_Object calc_line_height_property (struct it *, Lisp_Object, static void produce_special_glyphs (struct it *, enum display_element_type); static void show_mouse_face (Mouse_HLInfo *, enum draw_glyphs_face); static bool coords_in_mouse_face_p (struct window *, int, int); +static void reset_box_start_end_flags (struct it *); @@ -1419,6 +1491,7 @@ Value is the height in pixels of the line at point. */) set_buffer_internal_1 (XBUFFER (w->contents)); } SET_TEXT_POS (pt, PT, PT_BYTE); + void *itdata = bidi_shelve_cache (); start_display (&it, w, pt); /* Start from the beginning of the screen line, to make sure we traverse all of its display elements, and thus capture the @@ -1430,6 +1503,7 @@ Value is the height in pixels of the line at point. */) if (old_buffer) set_buffer_internal_1 (old_buffer); + bidi_unshelve_cache (itdata, false); return result; } @@ -1516,6 +1590,29 @@ window_hscroll_limited (struct window *w, struct frame *f) return window_hscroll; } +/* Reset the box-face start and end flags in the iterator. This is + called after producing glyphs, such that we reset these flags only + after producing a glyph with the flag set. */ + +static void +reset_box_start_end_flags (struct it *it) +{ + /* Don't reset if we've drawn the glyph in the display margins -- + those don't count as "produced glyphs". */ + if (it->area == TEXT_AREA + /* Don't reset if we displayed a fringe bitmap. */ + && !(it->what == IT_IMAGE && it->image_id < 0)) + { + /* Don't reset if the face is not a box face: that might mean we + are iterating some overlay or display string, and the first + character to have the box face is yet to be seen, when we pop + the iterator stack. */ + if (it->face_box_p) + it->start_of_box_run_p = false; + it->end_of_box_run_p = false; + } +} + /* Return true if position CHARPOS is visible in window W. CHARPOS < 0 means return info about WINDOW_END position. If visible, set *X and *Y to pixel coordinates of top left corner. @@ -1829,12 +1926,12 @@ pos_visible_p (struct window *w, ptrdiff_t charpos, int *x, int *y, /* If it3_moved stays false after the 'while' loop below, that means we already were at a newline before the loop (e.g., the display string begins - with a newline), so we don't need to (and cannot) - inspect the glyphs of it3.glyph_row, because - PRODUCE_GLYPHS will not produce anything for a - newline, and thus it3.glyph_row stays at its - stale content it got at top of the window. */ + with a newline), so we don't need to return to + the last position before the display string, + because PRODUCE_GLYPHS will not produce anything + for a newline. */ bool it3_moved = false; + int top_x_before_string = it3.current_x; /* Finally, advance the iterator until we hit the first display element whose character position is CHARPOS, or until the first newline from the @@ -1842,6 +1939,8 @@ pos_visible_p (struct window *w, ptrdiff_t charpos, int *x, int *y, display line. */ while (get_next_display_element (&it3)) { + if (!EQ (it3.object, string)) + top_x_before_string = it3.current_x; PRODUCE_GLYPHS (&it3); if (IT_CHARPOS (it3) == charpos || ITERATOR_AT_END_OF_LINE_P (&it3)) @@ -1856,32 +1955,26 @@ pos_visible_p (struct window *w, ptrdiff_t charpos, int *x, int *y, if (!it3.line_number_produced_p) { if (it3.lnum_pixel_width > 0) - top_x += it3.lnum_pixel_width; + { + top_x += it3.lnum_pixel_width; + top_x_before_string += it3.lnum_pixel_width; + } else if (it.line_number_produced_p) - top_x += it.lnum_pixel_width; + { + top_x += it.lnum_pixel_width; + top_x_before_string += it3.lnum_pixel_width; + } } /* Normally, we would exit the above loop because we found the display element whose character position is CHARPOS. For the contingency that we didn't, and stopped at the first newline from the - display string, move back over the glyphs - produced from the string, until we find the - rightmost glyph not from the string. */ + display string, reset top_x to the coordinate of + the rightmost glyph not from the string. */ if (it3_moved && newline_in_string && IT_CHARPOS (it3) != charpos && EQ (it3.object, string)) - { - struct glyph *g = it3.glyph_row->glyphs[TEXT_AREA] - + it3.glyph_row->used[TEXT_AREA]; - - while (EQ ((g - 1)->object, string)) - { - --g; - top_x -= g->pixel_width; - } - eassert (g < it3.glyph_row->glyphs[TEXT_AREA] - + it3.glyph_row->used[TEXT_AREA]); - } + top_x = top_x_before_string; } } @@ -1969,16 +2062,14 @@ pos_visible_p (struct window *w, ptrdiff_t charpos, int *x, int *y, /* Return the next character from STR. Return in *LEN the length of - the character. This is like STRING_CHAR_AND_LENGTH but never + the character. This is like string_char_and_length but never returns an invalid character. If we find one, we return a `?', but with the length of the invalid character. */ static int -string_char_and_length (const unsigned char *str, int *len) +check_char_and_length (const unsigned char *str, int *len) { - int c; - - c = STRING_CHAR_AND_LENGTH (str, *len); + int c = string_char_and_length (str, len); if (!CHAR_VALID_P (c)) /* We may not change the length here because other places in Emacs don't use this function, i.e. they silently accept invalid @@ -2001,11 +2092,10 @@ string_pos_nchars_ahead (struct text_pos pos, Lisp_Object string, ptrdiff_t ncha if (STRING_MULTIBYTE (string)) { const unsigned char *p = SDATA (string) + BYTEPOS (pos); - int len; while (nchars--) { - string_char_and_length (p, &len); + int len = BYTES_BY_CHAR_HEAD (*p); p += len; CHARPOS (pos) += 1; BYTEPOS (pos) += len; @@ -2046,12 +2136,10 @@ c_string_pos (ptrdiff_t charpos, const char *s, bool multibyte_p) if (multibyte_p) { - int len; - SET_TEXT_POS (pos, 0, 0); while (charpos--) { - string_char_and_length ((const unsigned char *) s, &len); + int len = BYTES_BY_CHAR_HEAD (*s); s += len; CHARPOS (pos) += 1; BYTEPOS (pos) += len; @@ -2075,12 +2163,11 @@ number_of_chars (const char *s, bool multibyte_p) if (multibyte_p) { ptrdiff_t rest = strlen (s); - int len; const unsigned char *p = (const unsigned char *) s; for (nchars = 0; rest > 0; ++nchars) { - string_char_and_length (p, &len); + int len = BYTES_BY_CHAR_HEAD (*p); rest -= len, p += len; } } @@ -2129,8 +2216,8 @@ estimate_mode_line_height (struct frame *f, enum face_id face_id) { if (face->font) height = normal_char_height (face->font, -1); - if (face->box_line_width > 0) - height += 2 * face->box_line_width; + if (face->box_horizontal_line_width > 0) + height += 2 * face->box_horizontal_line_width; } } @@ -2142,7 +2229,7 @@ estimate_mode_line_height (struct frame *f, enum face_id face_id) } /* Given a pixel position (PIX_X, PIX_Y) on frame F, return glyph - co-ordinates in (*X, *Y). Set *BOUNDS to the rectangle that the + coordinates in (*X, *Y). Set *BOUNDS to the rectangle that the glyph at X, Y occupies, if BOUNDS != 0. If NOCLIP, do not force the value into range. */ @@ -3286,7 +3373,10 @@ init_iterator (struct it *it, struct window *w, with a left box line. */ face = FACE_FROM_ID_OR_NULL (it->f, remapped_base_face_id); if (face && face->box != FACE_NO_BOX) - it->start_of_box_run_p = true; + { + it->face_box_p = true; + it->start_of_box_run_p = true; + } } /* If a buffer position was specified, set the iterator there, @@ -3653,7 +3743,7 @@ init_to_row_end (struct it *it, struct window *w, struct glyph_row *row) it->continuation_lines_width = row->continuation_lines_width + row->pixel_width; CHECK_IT (it); - /* Initializing IT in the presense of compositions in reordered + /* Initializing IT in the presence of compositions in reordered rows is tricky: row->end above will generally cause us to start at position that is not the first one in the logical order, and we might therefore miss the composition earlier in @@ -3884,8 +3974,7 @@ compute_stop_pos (struct it *it) ptrdiff_t bpos = CHAR_TO_BYTE (pos); while (pos < endpos) { - int ch; - FETCH_CHAR_ADVANCE_NO_CHECK (ch, pos, bpos); + int ch = fetch_char_advance_no_check (&pos, &bpos); if (ch == ' ' || ch == '\t' || ch == '\n' || ch == '\f') { found = true; @@ -4173,6 +4262,7 @@ handle_fontified_prop (struct it *it) if (!STRINGP (it->string) && it->s == NULL && !NILP (Vfontification_functions) + && !(input_was_pending && redisplay_skip_fontification_on_input) && !NILP (Vrun_hooks) && (pos = make_fixnum (IT_CHARPOS (*it)), prop = Fget_char_property (pos, Qfontified, Qnil), @@ -4402,8 +4492,11 @@ handle_face_prop (struct it *it) this is the start of a run of characters with box face, i.e. this character has a shadow on the left side. */ it->face_id = new_face_id; - it->start_of_box_run_p = (new_face->box != FACE_NO_BOX - && (old_face == NULL || !old_face->box)); + /* Don't reset the start_of_box_run_p flag, only set it if + needed. */ + if (!(it->start_of_box_run_p && old_face && old_face->box)) + it->start_of_box_run_p = (new_face->box != FACE_NO_BOX + && (old_face == NULL || !old_face->box)); it->face_box_p = new_face->box != FACE_NO_BOX; } @@ -4541,10 +4634,8 @@ face_before_or_after_it_pos (struct it *it, bool before_p) { struct text_pos pos1 = string_pos (charpos, it->string); const unsigned char *p = SDATA (it->string) + BYTEPOS (pos1); - int c, len; struct face *face = FACE_FROM_ID (it->f, face_id); - - c = string_char_and_length (p, &len); + int len, c = check_char_and_length (p, &len); face_id = FACE_FOR_CHAR (it->f, face, c, charpos, it->string); } } @@ -5680,7 +5771,7 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object, else { it->what = IT_IMAGE; - it->image_id = lookup_image (it->f, value); + it->image_id = lookup_image (it->f, value, it->face_id); it->position = start_pos; it->object = NILP (object) ? it->w->contents : object; it->method = GET_FROM_IMAGE; @@ -6544,7 +6635,16 @@ pop_it (struct it *it) it->object = p->u.stretch.object; break; case GET_FROM_BUFFER: - it->object = it->w->contents; + { + struct face *face = FACE_FROM_ID_OR_NULL (it->f, it->face_id); + + /* Restore the face_box_p flag, since it could have been + overwritten by the face of the object that we just finished + displaying. */ + if (face) + it->face_box_p = face->box != FACE_NO_BOX; + it->object = it->w->contents; + } break; case GET_FROM_STRING: { @@ -6630,7 +6730,7 @@ back_to_previous_line_start (struct it *it) { ptrdiff_t cp = IT_CHARPOS (*it), bp = IT_BYTEPOS (*it); - DEC_BOTH (cp, bp); + dec_both (&cp, &bp); IT_CHARPOS (*it) = find_newline_no_quit (cp, bp, -1, &IT_BYTEPOS (*it)); } @@ -7462,7 +7562,7 @@ get_next_display_element (struct it *it) non-ASCII spaces and hyphens specially. */ if (! ASCII_CHAR_P (c) && ! NILP (Vnobreak_char_display)) { - if (c == NO_BREAK_SPACE) + if (blankp (c)) nonascii_space_p = true; else if (c == SOFT_HYPHEN || c == HYPHEN || c == NON_BREAKING_HYPHEN) @@ -7537,7 +7637,7 @@ get_next_display_element (struct it *it) /* Merge `nobreak-space' into the current face. */ face_id = merge_faces (it->w, Qnobreak_space, 0, it->face_id); - XSETINT (it->ctl_chars[0], ' '); + XSETINT (it->ctl_chars[0], it->c); ctl_len = 1; goto display_control; } @@ -7550,7 +7650,7 @@ get_next_display_element (struct it *it) /* Merge `nobreak-space' into the current face. */ face_id = merge_faces (it->w, Qnobreak_hyphen, 0, it->face_id); - XSETINT (it->ctl_chars[0], '-'); + XSETINT (it->ctl_chars[0], it->c); ctl_len = 1; goto display_control; } @@ -7680,14 +7780,19 @@ get_next_display_element (struct it *it) /* If the box comes from face properties in a display string, check faces in that string. */ int string_face_id = face_after_it_pos (it); - it->end_of_box_run_p - = (FACE_FROM_ID (it->f, string_face_id)->box - == FACE_NO_BOX); + if (FACE_FROM_ID (it->f, string_face_id)->box == FACE_NO_BOX) + it->end_of_box_run_p = true; } /* Otherwise, the box comes from the underlying face. If this is the last string character displayed, check the next buffer location. */ - else if ((IT_STRING_CHARPOS (*it) >= SCHARS (it->string) - 1) + else if (((IT_STRING_CHARPOS (*it) >= SCHARS (it->string) - 1) + /* For a composition, see if the string ends + at the last character included in the + composition. */ + || (it->what == IT_COMPOSITION + && (IT_STRING_CHARPOS (*it) + it->cmp_it.nchars + >= SCHARS (it->string)))) /* n_overlay_strings is unreliable unless overlay_string_index is non-negative. */ && ((it->current.overlay_string_index >= 0 @@ -7751,9 +7856,9 @@ get_next_display_element (struct it *it) CHARPOS (pos), 0, &ignore, face_id, false, 0); - it->end_of_box_run_p - = (FACE_FROM_ID (it->f, next_face_id)->box - == FACE_NO_BOX); + if (FACE_FROM_ID (it->f, next_face_id)->box + == FACE_NO_BOX) + it->end_of_box_run_p = true; } } else if (CHARPOS (pos) >= ZV) @@ -7766,9 +7871,9 @@ get_next_display_element (struct it *it) CHARPOS (pos) + TEXT_PROP_DISTANCE_LIMIT, false, -1, 0); - it->end_of_box_run_p - = (FACE_FROM_ID (it->f, next_face_id)->box - == FACE_NO_BOX); + if (FACE_FROM_ID (it->f, next_face_id)->box + == FACE_NO_BOX) + it->end_of_box_run_p = true; } } } @@ -7778,9 +7883,9 @@ get_next_display_element (struct it *it) else if (it->method != GET_FROM_DISPLAY_VECTOR) { int face_id = face_after_it_pos (it); - it->end_of_box_run_p - = (face_id != it->face_id - && FACE_FROM_ID (it->f, face_id)->box == FACE_NO_BOX); + if (face_id != it->face_id + && FACE_FROM_ID (it->f, face_id)->box == FACE_NO_BOX) + it->end_of_box_run_p = true; } } /* If we reached the end of the object we've been iterating (e.g., a @@ -7817,10 +7922,6 @@ get_next_display_element (struct it *it) void set_iterator_to_next (struct it *it, bool reseat_p) { - /* Reset flags indicating start and end of a sequence of characters - with box. Reset them at the start of this function because - moving the iterator to a new position might set them. */ - it->start_of_box_run_p = it->end_of_box_run_p = false; switch (it->method) { @@ -8232,9 +8333,9 @@ next_element_from_display_vector (struct it *it) } } next_face = FACE_FROM_ID_OR_NULL (it->f, next_face_id); - it->end_of_box_run_p = (this_face && this_face->box != FACE_NO_BOX - && (!next_face - || next_face->box == FACE_NO_BOX)); + if (this_face && this_face->box != FACE_NO_BOX + && (!next_face || next_face->box == FACE_NO_BOX)) + it->end_of_box_run_p = true; it->face_box_p = this_face && this_face->box != FACE_NO_BOX; } else @@ -8456,7 +8557,7 @@ next_element_from_string (struct it *it) { const unsigned char *s = (SDATA (it->string) + IT_STRING_BYTEPOS (*it)); - it->c = string_char_and_length (s, &it->len); + it->c = check_char_and_length (s, &it->len); } else { @@ -8494,7 +8595,7 @@ next_element_from_string (struct it *it) { const unsigned char *s = (SDATA (it->string) + IT_STRING_BYTEPOS (*it)); - it->c = string_char_and_length (s, &it->len); + it->c = check_char_and_length (s, &it->len); } else { @@ -8552,7 +8653,7 @@ next_element_from_c_string (struct it *it) BYTEPOS (it->position) = CHARPOS (it->position) = -1; } else if (it->multibyte_p) - it->c = string_char_and_length (it->s + IT_BYTEPOS (*it), &it->len); + it->c = check_char_and_length (it->s + IT_BYTEPOS (*it), &it->len); else it->c = it->s[IT_BYTEPOS (*it)], it->len = 1; @@ -8667,7 +8768,7 @@ compute_stop_pos_backwards (struct it *it) position before that. This is called when we bump into a stop position while reordering bidirectional text. CHARPOS should be the last previously processed stop_pos (or BEGV/0, if none were - processed yet) whose position is less that IT's current + processed yet) whose position is less than IT's current position. */ static void @@ -8677,6 +8778,7 @@ handle_stop_backwards (struct it *it, ptrdiff_t charpos) ptrdiff_t where_we_are = (bufp ? IT_CHARPOS (*it) : IT_STRING_CHARPOS (*it)); struct display_pos save_current = it->current; struct text_pos save_position = it->position; + struct composition_it save_cmp_it = it->cmp_it; struct text_pos pos1; ptrdiff_t next_stop; @@ -8704,6 +8806,7 @@ handle_stop_backwards (struct it *it, ptrdiff_t charpos) it->bidi_p = true; it->current = save_current; it->position = save_position; + it->cmp_it = save_cmp_it; next_stop = it->stop_charpos; it->stop_charpos = it->prev_stop; handle_stop (it); @@ -8849,7 +8952,7 @@ next_element_from_buffer (struct it *it) /* Get the next character, maybe multibyte. */ p = BYTE_POS_ADDR (IT_BYTEPOS (*it)); if (it->multibyte_p && !ASCII_CHAR_P (*p)) - it->c = STRING_CHAR_AND_LENGTH (p, it->len); + it->c = string_char_and_length (p, &it->len); else it->c = *p, it->len = 1; @@ -9172,13 +9275,20 @@ move_it_in_display_line_to (struct it *it, { if (it->line_wrap == WORD_WRAP && it->area == TEXT_AREA) { - if (IT_DISPLAYING_WHITESPACE (it)) - may_wrap = true; - else if (may_wrap) + bool next_may_wrap = may_wrap; + /* Can we wrap after this character? */ + if (char_can_wrap_after (it)) + next_may_wrap = true; + else + next_may_wrap = false; + /* Can we wrap here? */ + if (may_wrap && char_can_wrap_before (it)) { /* We have reached a glyph that follows one or more - whitespace characters. If the position is - already found, we are done. */ + whitespace characters or characters that allow + wrapping after them. If this character allows + wrapping before it, save this position as a + wrapping point. */ if (atpos_it.sp >= 0) { RESTORE_IT (it, &atpos_it, atpos_data); @@ -9193,8 +9303,9 @@ move_it_in_display_line_to (struct it *it, } /* Otherwise, we can wrap here. */ SAVE_IT (wrap_it, *it, wrap_data); - may_wrap = false; } + /* Update may_wrap for the next iteration. */ + may_wrap = next_may_wrap; } } @@ -9322,10 +9433,10 @@ move_it_in_display_line_to (struct it *it, { bool can_wrap = true; - /* If we are at a whitespace character - that barely fits on this screen line, - but the next character is also - whitespace, we cannot wrap here. */ + /* If the previous character says we can + wrap after it, but the current + character says we can't wrap before + it, then we can't wrap here. */ if (it->line_wrap == WORD_WRAP && wrap_it.sp >= 0 && may_wrap @@ -9337,7 +9448,7 @@ move_it_in_display_line_to (struct it *it, SAVE_IT (tem_it, *it, tem_data); set_iterator_to_next (it, true); if (get_next_display_element (it) - && IT_DISPLAYING_WHITESPACE (it)) + && !char_can_wrap_before (it)) can_wrap = false; RESTORE_IT (it, &tem_it, tem_data); } @@ -9416,19 +9527,18 @@ move_it_in_display_line_to (struct it *it, else IT_RESET_X_ASCENT_DESCENT (it); - /* If the screen line ends with whitespace, and we - are under word-wrap, don't use wrap_it: it is no - longer relevant, but we won't have an opportunity - to update it, since we are done with this screen - line. */ + /* If the screen line ends with whitespace (or + wrap-able character), and we are under word-wrap, + don't use wrap_it: it is no longer relevant, but + we won't have an opportunity to update it, since + we are done with this screen line. */ if (may_wrap && IT_OVERFLOW_NEWLINE_INTO_FRINGE (it) /* If the character after the one which set the - may_wrap flag is also whitespace, we can't - wrap here, since the screen line cannot be - wrapped in the middle of whitespace. - Therefore, wrap_it _is_ relevant in that - case. */ - && !(moved_forward && IT_DISPLAYING_WHITESPACE (it))) + may_wrap flag says we can't wrap before it, + we can't wrap here. Therefore, wrap_it + (previously found wrap-point) _is_ relevant + in that case. */ + && (!moved_forward || char_can_wrap_before (it))) { /* If we've found TO_X, go back there, as we now know the last word fits on this screen line. */ @@ -9727,9 +9837,13 @@ move_it_to (struct it *it, ptrdiff_t to_charpos, int to_x, int to_y, int to_vpos int line_height, line_start_x = 0, reached = 0; int max_current_x = 0; void *backup_data = NULL; + ptrdiff_t orig_charpos = -1; + enum it_method orig_method = NUM_IT_METHODS; for (;;) { + orig_charpos = IT_CHARPOS (*it); + orig_method = it->method; if (op & MOVE_TO_VPOS) { /* If no TO_CHARPOS and no TO_X specified, stop at the @@ -9844,7 +9958,27 @@ move_it_to (struct it *it, ptrdiff_t to_charpos, int to_x, int to_y, int to_vpos { skip = skip2; if (skip == MOVE_POS_MATCH_OR_ZV) - reached = 7; + { + reached = 7; + /* If the last move_it_in_display_line_to call + took us away from TO_CHARPOS, back up to the + previous position, as it is a better + approximation of TO_CHARPOS. (Note that we + could have both positions after TO_CHARPOS or + both positions before it, due to bidi + reordering.) */ + if (IT_CHARPOS (*it) != to_charpos + && ((IT_CHARPOS (it_backup) > to_charpos) + == (IT_CHARPOS (*it) > to_charpos))) + { + int max_ascent = it->max_ascent; + int max_descent = it->max_descent; + + RESTORE_IT (it, &it_backup, backup_data); + it->max_ascent = max_ascent; + it->max_descent = max_descent; + } + } } } else @@ -9963,7 +10097,21 @@ move_it_to (struct it *it, ptrdiff_t to_charpos, int to_x, int to_y, int to_vpos } } else - it->continuation_lines_width += it->current_x; + { + /* Make sure we do advance, otherwise we might infloop. + This could happen when the first display element is + wider than the window, or if we have a wrap-prefix + that doesn't leave enough space after it to display + even a single character. We only do this for moving + through buffer text, as with display/overlay strings + we'd need to also compare it->object's, and this is + unlikely to happen in that case anyway. */ + if (IT_CHARPOS (*it) == orig_charpos + && it->method == orig_method + && orig_method == GET_FROM_BUFFER) + set_iterator_to_next (it, false); + it->continuation_lines_width += it->current_x; + } break; default: @@ -10124,7 +10272,7 @@ move_it_vertically_backward (struct it *it, int dy) { ptrdiff_t cp = IT_CHARPOS (*it), bp = IT_BYTEPOS (*it); - DEC_BOTH (cp, bp); + dec_both (&cp, &bp); cp = find_newline_no_quit (cp, bp, -1, NULL); move_it_to (it, cp, -1, -1, -1, MOVE_TO_POS); } @@ -10174,11 +10322,22 @@ move_it_vertically_backward (struct it *it, int dy) move_it_vertically (it, target_y - it->current_y); else { + struct text_pos last_pos; + int last_y, last_vpos; do { + last_pos = it->current.pos; + last_y = it->current_y; + last_vpos = it->vpos; move_it_by_lines (it, 1); } - while (target_y >= line_bottom_y (it) && IT_CHARPOS (*it) < ZV); + while (target_y > it->current_y && IT_CHARPOS (*it) < ZV); + if (it->current_y > target_y) + { + reseat (it, last_pos, true); + it->current_y = last_y; + it->vpos = last_vpos; + } } } } @@ -10490,22 +10649,22 @@ include the height of both, if present, in the return value. */) bpos = BEGV_BYTE; while (bpos < ZV_BYTE) { - FETCH_CHAR_ADVANCE (c, start, bpos); + c = FETCH_BYTE (bpos); if (!(c == ' ' || c == '\t' || c == '\n' || c == '\r')) break; + inc_both (&start, &bpos); } while (bpos > BEGV_BYTE) { - DEC_BOTH (start, bpos); - c = FETCH_CHAR (bpos); + dec_both (&start, &bpos); + c = FETCH_BYTE (bpos); if (!(c == ' ' || c == '\t')) break; } } else { - CHECK_FIXNUM_COERCE_MARKER (from); - start = min (max (XFIXNUM (from), BEGV), ZV); + start = clip_to_bounds (BEGV, fix_position (from), ZV); bpos = CHAR_TO_BYTE (start); } @@ -10519,23 +10678,23 @@ include the height of both, if present, in the return value. */) bpos = ZV_BYTE; while (bpos > BEGV_BYTE) { - DEC_BOTH (end, bpos); - c = FETCH_CHAR (bpos); + dec_both (&end, &bpos); + c = FETCH_BYTE (bpos); if (!(c == ' ' || c == '\t' || c == '\n' || c == '\r')) - break; + { + inc_both (&end, &bpos); + break; + } } while (bpos < ZV_BYTE) { - FETCH_CHAR_ADVANCE (c, end, bpos); + c = fetch_char_advance (&end, &bpos); if (!(c == ' ' || c == '\t')) break; } } else - { - CHECK_FIXNUM_COERCE_MARKER (to); - end = max (start, min (XFIXNUM (to), ZV)); - } + end = clip_to_bounds (start, fix_position (to), ZV); if (!NILP (x_limit) && RANGED_FIXNUMP (0, x_limit, INT_MAX)) max_x = XFIXNUM (x_limit); @@ -10547,6 +10706,7 @@ include the height of both, if present, in the return value. */) itdata = bidi_shelve_cache (); start_display (&it, w, startp); + int start_y = it.current_y; /* It makes no sense to measure dimensions of region of text that crosses the point where bidi reordering changes scan direction. By using unidirectional movement here we at least support the use @@ -10555,8 +10715,23 @@ include the height of both, if present, in the return value. */) same directionality. */ it.bidi_p = false; + /* Start at the beginning of the line containing FROM. Otherwise + IT.current_x will be incorrectly set to zero at some arbitrary + non-zero X coordinate. */ + reseat_at_previous_visible_line_start (&it); + it.current_x = it.hpos = 0; + if (IT_CHARPOS (it) != start) + move_it_to (&it, start, -1, -1, -1, MOVE_TO_POS); + + /* Now move to TO. */ + int start_x = it.current_x; int move_op = MOVE_TO_POS | MOVE_TO_Y; int to_x = -1; + it.current_y = start_y; + /* If FROM is on a newline, pretend that we start at the beginning + of the next line, because the newline takes no place on display. */ + if (FETCH_BYTE (start) == '\n') + it.current_x = 0; if (!NILP (x_limit)) { it.last_visible_x = max_x; @@ -10599,8 +10774,14 @@ include the height of both, if present, in the return value. */) x = max_x; } - /* Subtract height of header-line which was counted automatically by - start_display. */ + /* If text spans more than one screen line, we don't need to adjust + the x-span for start_x, since the second and subsequent lines + will begin at zero X coordinate. */ + if (it.current_y > start_y) + start_x = 0; + + /* Subtract height of header-line and tab-line which was counted + automatically by start_display. */ y = it.current_y + it.max_ascent + it.max_descent - WINDOW_TAB_LINE_HEIGHT (w) - WINDOW_HEADER_LINE_HEIGHT (w); /* Don't return more than Y-LIMIT. */ @@ -10627,7 +10808,7 @@ include the height of both, if present, in the return value. */) if (old_b) set_buffer_internal (old_b); - return Fcons (make_fixnum (x), make_fixnum (y)); + return Fcons (make_fixnum (x - start_x), make_fixnum (y)); } /*********************************************************************** @@ -10726,7 +10907,7 @@ message_dolog (const char *m, ptrdiff_t nbytes, bool nlflag, bool multibyte) /* Ensure the Messages buffer exists, and switch to it. If we created it, set the major-mode. */ bool newbuffer = NILP (Fget_buffer (Vmessages_buffer_name)); - Fset_buffer (Fget_buffer_create (Vmessages_buffer_name)); + Fset_buffer (Fget_buffer_create (Vmessages_buffer_name, Qnil)); if (newbuffer && !NILP (Ffboundp (intern ("messages-buffer-mode")))) call0 (intern ("messages-buffer-mode")); @@ -10757,32 +10938,26 @@ message_dolog (const char *m, ptrdiff_t nbytes, bool nlflag, bool multibyte) if (multibyte && NILP (BVAR (current_buffer, enable_multibyte_characters))) { - ptrdiff_t i; - int c, char_bytes; - char work[1]; - /* Convert a multibyte string to single-byte for the *Message* buffer. */ - for (i = 0; i < nbytes; i += char_bytes) + for (ptrdiff_t i = 0; i < nbytes; ) { - c = string_char_and_length (msg + i, &char_bytes); - work[0] = CHAR_TO_BYTE8 (c); - insert_1_both (work, 1, 1, true, false, false); + int char_bytes, c = check_char_and_length (msg + i, &char_bytes); + char work = CHAR_TO_BYTE8 (c); + insert_1_both (&work, 1, 1, true, false, false); + i += char_bytes; } } else if (! multibyte && ! NILP (BVAR (current_buffer, enable_multibyte_characters))) { - ptrdiff_t i; - int c, char_bytes; - unsigned char str[MAX_MULTIBYTE_LENGTH]; /* Convert a single-byte string to multibyte for the *Message* buffer. */ - for (i = 0; i < nbytes; i++) + for (ptrdiff_t i = 0; i < nbytes; i++) { - c = msg[i]; - MAKE_CHAR_MULTIBYTE (c); - char_bytes = CHAR_STRING (c, str); + int c = make_char_multibyte (msg[i]); + unsigned char str[MAX_MULTIBYTE_LENGTH]; + int char_bytes = CHAR_STRING (c, str); insert_1_both ((char *) str, 1, char_bytes, true, false, false); } } @@ -10931,7 +11106,7 @@ message_log_check_duplicate (ptrdiff_t prev_bol_byte, ptrdiff_t this_bol_byte) /* Display an echo area message M with a specified length of NBYTES - bytes. The string may include NUL characters. If M is not a + bytes. The string may include null characters. If M is not a string, clear out any existing message, and let the mini-buffer text show through. @@ -11034,7 +11209,7 @@ message3_nolog (Lisp_Object m) } -/* Display a NUL-terminated echo area message M. If M is 0, clear +/* Display a null-terminated echo area message M. If M is 0, clear out any existing message, and let the mini-buffer text show through. The buffer M must continue to exist until after the echo area gets @@ -11218,7 +11393,7 @@ ensure_echo_area_buffers (void) static char const name_fmt[] = " *Echo Area %d*"; char name[sizeof name_fmt + INT_STRLEN_BOUND (int)]; AUTO_STRING_WITH_LEN (lname, name, sprintf (name, name_fmt, i)); - echo_buffer[i] = Fget_buffer_create (lname); + echo_buffer[i] = Fget_buffer_create (lname, Qnil); bset_truncate_lines (XBUFFER (echo_buffer[i]), Qnil); /* to force word wrap in echo area - it was decided to postpone this*/ @@ -11249,8 +11424,8 @@ ensure_echo_area_buffers (void) static bool with_echo_area_buffer (struct window *w, int which, - bool (*fn) (ptrdiff_t, Lisp_Object), - ptrdiff_t a1, Lisp_Object a2) + bool (*fn) (void *, Lisp_Object), + void *a1, Lisp_Object a2) { Lisp_Object buffer; bool this_one, the_other, clear_buffer_p, rc; @@ -11521,8 +11696,7 @@ display_echo_area (struct window *w) window_height_changed_p = with_echo_area_buffer (w, display_last_displayed_message_p, - display_echo_area_1, - (intptr_t) w, Qnil); + display_echo_area_1, w, Qnil); if (no_message_p) echo_area_buffer[i] = Qnil; @@ -11539,10 +11713,9 @@ display_echo_area (struct window *w) Value is true if height of W was changed. */ static bool -display_echo_area_1 (ptrdiff_t a1, Lisp_Object a2) +display_echo_area_1 (void *a1, Lisp_Object a2) { - intptr_t i1 = a1; - struct window *w = (struct window *) i1; + struct window *w = a1; Lisp_Object window; struct text_pos start; @@ -11583,7 +11756,7 @@ resize_echo_area_exactly (void) struct window *w = XWINDOW (echo_area_window); Lisp_Object resize_exactly = (minibuf_level == 0 ? Qt : Qnil); bool resized_p = with_echo_area_buffer (w, 0, resize_mini_window_1, - (intptr_t) w, resize_exactly); + w, resize_exactly); if (resized_p) { windows_or_buffers_changed = 42; @@ -11601,10 +11774,9 @@ resize_echo_area_exactly (void) returns. */ static bool -resize_mini_window_1 (ptrdiff_t a1, Lisp_Object exactly) +resize_mini_window_1 (void *a1, Lisp_Object exactly) { - intptr_t i1 = a1; - return resize_mini_window ((struct window *) i1, !NILP (exactly)); + return resize_mini_window (a1, !NILP (exactly)); } @@ -11637,9 +11809,10 @@ resize_mini_window (struct window *w, bool exact_p) return false; /* By default, start display at the beginning. */ - set_marker_both (w->start, w->contents, - BUF_BEGV (XBUFFER (w->contents)), - BUF_BEGV_BYTE (XBUFFER (w->contents))); + if (redisplay_adhoc_scroll_in_resize_mini_windows) + set_marker_both (w->start, w->contents, + BUF_BEGV (XBUFFER (w->contents)), + BUF_BEGV_BYTE (XBUFFER (w->contents))); /* Nil means don't try to resize. */ if ((NILP (Vresize_mini_windows) @@ -11698,14 +11871,32 @@ resize_mini_window (struct window *w, bool exact_p) if (height > max_height) { height = (max_height / unit) * unit; - init_iterator (&it, w, ZV, ZV_BYTE, NULL, DEFAULT_FACE_ID); - move_it_vertically_backward (&it, height - unit); - start = it.current.pos; + if (redisplay_adhoc_scroll_in_resize_mini_windows) + { + init_iterator (&it, w, ZV, ZV_BYTE, NULL, DEFAULT_FACE_ID); + move_it_vertically_backward (&it, height - unit); + /* The following move is usually a no-op when the stuff + displayed in the mini-window comes entirely from buffer + text, but it is needed when some of it comes from overlay + strings, especially when there's an after-string at ZV. + This happens with some completion packages, like + icomplete, ido-vertical, etc. With those packages, if we + don't force w->start to be at the beginning of a screen + line, important parts of the stuff in the mini-window, + such as user prompt, will be hidden from view. */ + move_it_by_lines (&it, 0); + start = it.current.pos; + /* Prevent redisplay_window from recentering, and thus from + overriding the window-start point we computed here. */ + w->start_at_line_beg = false; + SET_MARKER_FROM_TEXT_POS (w->start, start); + } } else - SET_TEXT_POS (start, BEGV, BEGV_BYTE); - - SET_MARKER_FROM_TEXT_POS (w->start, start); + { + SET_TEXT_POS (start, BEGV, BEGV_BYTE); + SET_MARKER_FROM_TEXT_POS (w->start, start); + } if (EQ (Vresize_mini_windows, Qgrow_only)) { @@ -11740,8 +11931,7 @@ current_message (void) msg = Qnil; else { - with_echo_area_buffer (0, 0, current_message_1, - (intptr_t) &msg, Qnil); + with_echo_area_buffer (0, 0, current_message_1, &msg, Qnil); if (NILP (msg)) echo_area_buffer[0] = Qnil; } @@ -11751,10 +11941,9 @@ current_message (void) static bool -current_message_1 (ptrdiff_t a1, Lisp_Object a2) +current_message_1 (void *a1, Lisp_Object a2) { - intptr_t i1 = a1; - Lisp_Object *msg = (Lisp_Object *) i1; + Lisp_Object *msg = a1; if (Z > BEG) *msg = make_buffer_string (BEG, Z, true); @@ -11800,8 +11989,8 @@ pop_message_unwind (void) /* Check that Vmessage_stack is nil. Called from emacs.c when Emacs - exits. If the stack is not empty, we have a missing pop_message - somewhere. */ + exits. If the stack is not empty, we have a missing + pop_message_unwind somewhere. */ void check_message_stack (void) @@ -11810,6 +11999,11 @@ check_message_stack (void) emacs_abort (); } +void +clear_message_stack (void) +{ + Vmessage_stack = Qnil; +} /* Truncate to NCHARS what will be displayed in the echo area the next time we display it---but don't redisplay it now. */ @@ -11828,7 +12022,8 @@ truncate_echo_area (ptrdiff_t nchars) just an informative message; if the frame hasn't really been initialized yet, just toss it. */ if (sf->glyphs_initialized_p) - with_echo_area_buffer (0, 0, truncate_message_1, nchars, Qnil); + with_echo_area_buffer (0, 0, truncate_message_1, + (void *) (intptr_t) nchars, Qnil); } } @@ -11837,8 +12032,9 @@ truncate_echo_area (ptrdiff_t nchars) message to at most NCHARS characters. */ static bool -truncate_message_1 (ptrdiff_t nchars, Lisp_Object a2) +truncate_message_1 (void *a1, Lisp_Object a2) { + intptr_t nchars = (intptr_t) a1; if (BEG + nchars < Z) del_range (BEG + nchars, Z); if (Z == BEG) @@ -11890,7 +12086,7 @@ set_message (Lisp_Object string) This function is called with the echo area buffer being current. */ static bool -set_message_1 (ptrdiff_t a1, Lisp_Object string) +set_message_1 (void *a1, Lisp_Object string) { eassert (STRINGP (string)); @@ -12278,12 +12474,12 @@ unwind_format_mode_line (Lisp_Object vector) mode_line_string_face_prop = AREF (vector, 5); /* Select window before buffer, since it may change the buffer. */ - if (!NILP (old_window)) + if (WINDOW_LIVE_P (old_window)) { /* If the operation that we are unwinding had selected a window on a different frame, reset its frame-selected-window. For a text terminal, reset its top-frame if necessary. */ - if (!NILP (target_frame_window)) + if (WINDOW_LIVE_P (target_frame_window)) { Lisp_Object frame = WINDOW_FRAME (XWINDOW (target_frame_window)); @@ -12300,7 +12496,7 @@ unwind_format_mode_line (Lisp_Object vector) /* Restore point of target_frame_window's buffer (Bug#32777). But do this only after old_window has been reselected to avoid that the window point of target_frame_window moves. */ - if (!NILP (target_frame_window)) + if (WINDOW_LIVE_P (target_frame_window)) { Lisp_Object buffer = AREF (vector, 10); @@ -12456,6 +12652,11 @@ gui_consider_frame_title (Lisp_Object frame) display_mode_element (&it, 0, -1, -1, fmt, Qnil, false); len = MODE_LINE_NOPROP_LEN (title_start); title = mode_line_noprop_buf + title_start; + /* Make sure that any raw bytes in the title are properly + represented by their multibyte sequences. */ + ptrdiff_t nchars = 0; + len = str_as_multibyte ((unsigned char *)title, + mode_line_noprop_buf_end - title, len, &nchars); unbind_to (count, Qnil); /* Set the title only if it's changed. This avoids consing in @@ -12467,9 +12668,10 @@ gui_consider_frame_title (Lisp_Object frame) || SBYTES (f->name) != len || memcmp (title, SDATA (f->name), len) != 0) && FRAME_TERMINAL (f)->implicit_set_name_hook) - FRAME_TERMINAL (f)->implicit_set_name_hook (f, - make_string (title, len), - Qnil); + { + Lisp_Object title_string = make_multibyte_string (title, nchars, len); + FRAME_TERMINAL (f)->implicit_set_name_hook (f, title_string, Qnil); + } } } @@ -12536,7 +12738,6 @@ prepare_menu_bars (void) continue; if (!FRAME_TOOLTIP_P (f) - && !FRAME_PARENT_FRAME (f) && (FRAME_ICONIFIED_P (f) || FRAME_VISIBLE_P (f) == 1 /* Exclude TTY frames that are obscured because they @@ -12582,10 +12783,9 @@ prepare_menu_bars (void) && !XBUFFER (w->contents)->text->redisplay) continue; - if (FRAME_PARENT_FRAME (f)) - continue; + if (!FRAME_PARENT_FRAME (f)) + menu_bar_hooks_run = update_menu_bar (f, false, menu_bar_hooks_run); - menu_bar_hooks_run = update_menu_bar (f, false, menu_bar_hooks_run); update_tab_bar (f, false); #ifdef HAVE_WINDOW_SYSTEM update_tool_bar (f, false); @@ -12597,7 +12797,10 @@ prepare_menu_bars (void) else { struct frame *sf = SELECTED_FRAME (); - update_menu_bar (sf, true, false); + + if (!FRAME_PARENT_FRAME (sf)) + update_menu_bar (sf, true, false); + update_tab_bar (sf, true); #ifdef HAVE_WINDOW_SYSTEM update_tool_bar (sf, true); @@ -12695,7 +12898,7 @@ update_menu_bar (struct frame *f, bool save_match_data, bool hooks_run) the selected frame should be allowed to set it. */ if (f == SELECTED_FRAME ()) #endif - set_frame_menubar (f, false, false); + set_frame_menubar (f, false); } else /* On a terminal screen, the menu bar is an ordinary screen @@ -12721,23 +12924,68 @@ update_menu_bar (struct frame *f, bool save_match_data, bool hooks_run) Tab-bars ***********************************************************************/ -#ifdef HAVE_WINDOW_SYSTEM - -/* Select `frame' temporarily without running all the code in - do_switch_frame. - FIXME: Maybe do_switch_frame should be trimmed down similarly - when `norecord' is set. */ +/* Restore WINDOW as the selected window and its frame as the selected + frame. If WINDOW is dead but the selected frame is live, make the + latter's selected window the selected window. If both, WINDOW and + the selected frame, are dead, assign selected frame and window from + some arbitrary live frame. Abort if no such frame can be found. */ static void -fast_set_selected_frame (Lisp_Object frame) +restore_selected_window (Lisp_Object window) { - if (!EQ (selected_frame, frame)) + if (WINDOW_LIVE_P (window)) + /* If WINDOW is live, make it the selected window and its frame's + selected window and set the selected frame to its frame. */ { - selected_frame = frame; - selected_window = XFRAME (frame)->selected_window; + selected_window = window; + selected_frame = XWINDOW (window)->frame; + FRAME_SELECTED_WINDOW (XFRAME (selected_frame)) = window; + } + else if (FRAMEP (selected_frame) && FRAME_LIVE_P (XFRAME (selected_frame))) + /* If WINDOW is dead but the selected frame is still live, make the + latter's selected window the selected one. */ + selected_window = FRAME_SELECTED_WINDOW (XFRAME (selected_frame)); + else + /* If WINDOW and the selected frame are dead, choose some live, + non-child and non-tooltip frame as the new selected frame and + make its selected window the selected window. */ + { + Lisp_Object tail; + Lisp_Object frame UNINIT; + + FOR_EACH_FRAME (tail, frame) + { + struct frame *f = XFRAME (frame); + + if (!FRAME_PARENT_FRAME (f) && !FRAME_TOOLTIP_P (f)) + { + selected_frame = frame; + selected_window = FRAME_SELECTED_WINDOW (f); + + return; + } + } + + /* Abort if we cannot find a live frame. */ + emacs_abort (); } } -#endif /* HAVE_WINDOW_SYSTEM */ +/* Restore WINDOW, if live, as its frame's selected window. */ +static void +restore_frame_selected_window (Lisp_Object window) +{ + if (WINDOW_LIVE_P (window)) + /* If WINDOW is live, make it its frame's selected window. If that + frame is the selected frame, make WINDOW the selected window as + well. */ + { + Lisp_Object frame = XWINDOW (window)->frame; + + FRAME_SELECTED_WINDOW (XFRAME (frame)) = window; + if (EQ (frame, selected_frame)) + selected_window = window; + } +} /* Update the tab-bar item list for frame F. This has to be done before we start to fill in any display lines. Called from @@ -12810,9 +13058,10 @@ update_tab_bar (struct frame *f, bool save_match_data) XFRAME (selected_frame)->selected_window)); #ifdef HAVE_WINDOW_SYSTEM Lisp_Object frame; - record_unwind_protect (fast_set_selected_frame, selected_frame); + record_unwind_protect (restore_selected_window, selected_window); XSETFRAME (frame, f); - fast_set_selected_frame (frame); + selected_frame = frame; + selected_window = FRAME_SELECTED_WINDOW (f); #endif /* Build desired tab-bar items from keymaps. */ @@ -13487,11 +13736,6 @@ handle_tab_bar_click (struct frame *f, int x, int y, bool down_p, XSETFRAME (frame, f); event.kind = TAB_BAR_EVENT; event.frame_or_window = frame; - event.arg = frame; - kbd_buffer_store_event (&event); - - event.kind = TAB_BAR_EVENT; - event.frame_or_window = frame; event.arg = key; event.modifiers = close_p ? ctrl_modifier | modifiers : modifiers; kbd_buffer_store_event (&event); @@ -13667,11 +13911,6 @@ tty_handle_tab_bar_click (struct frame *f, int x, int y, bool down_p, XSETFRAME (frame, f); event->kind = TAB_BAR_EVENT; event->frame_or_window = frame; - event->arg = frame; - kbd_buffer_store_event (event); - - event->kind = TAB_BAR_EVENT; - event->frame_or_window = frame; event->arg = key; if (close_p) event->modifiers |= ctrl_modifier; @@ -13754,9 +13993,10 @@ update_tool_bar (struct frame *f, bool save_match_data) /* Since we only explicitly preserve selected_frame, check that selected_window would be redundant. */ XFRAME (selected_frame)->selected_window)); - record_unwind_protect (fast_set_selected_frame, selected_frame); + record_unwind_protect (restore_selected_window, selected_window); XSETFRAME (frame, f); - fast_set_selected_frame (frame); + selected_frame = frame; + selected_window = FRAME_SELECTED_WINDOW (f); /* Build desired tool-bar items from keymaps. */ new_tool_bar @@ -14453,11 +14693,6 @@ handle_tool_bar_click (struct frame *f, int x, int y, bool down_p, XSETFRAME (frame, f); event.kind = TOOL_BAR_EVENT; event.frame_or_window = frame; - event.arg = frame; - kbd_buffer_store_event (&event); - - event.kind = TOOL_BAR_EVENT; - event.frame_or_window = frame; event.arg = key; event.modifiers = modifiers; kbd_buffer_store_event (&event); @@ -15057,7 +15292,7 @@ overlay_arrows_changed_p (bool set_redisplay) val = find_symbol_value (var); if (!MARKERP (val)) continue; - if (! EQ (COERCE_MARKER (val), + if (! EQ (Fmarker_position (val), /* FIXME: Don't we have a problem, using such a global * "last-position" if the variable is buffer-local? */ Fget (var, Qlast_arrow_position)) @@ -15100,8 +15335,7 @@ update_overlay_arrows (int up_to_date) Lisp_Object val = find_symbol_value (var); if (!MARKERP (val)) continue; - Fput (var, Qlast_arrow_position, - COERCE_MARKER (val)); + Fput (var, Qlast_arrow_position, Fmarker_position (val)); Fput (var, Qlast_arrow_string, overlay_arrow_string_or_property (var)); } @@ -15304,7 +15538,8 @@ redisplay_internal (void) /* No redisplay if running in batch mode or frame is not yet fully initialized, or redisplay is explicitly turned off by setting Vinhibit_redisplay. */ - if (FRAME_INITIAL_P (SELECTED_FRAME ()) + if ((FRAME_INITIAL_P (SELECTED_FRAME ()) + && redisplay_skip_initial_frame) || !NILP (Vinhibit_redisplay)) return; @@ -15572,6 +15807,12 @@ redisplay_internal (void) if (it.current_x != this_line_start_x) goto cancel; + /* Give up on this optimization if the line starts with a + string with display property that draws on the fringes, + as that might interfere with line-prefix display. */ + if (it.sp > 1 + && it.method == GET_FROM_IMAGE && it.image_id == -1) + goto cancel; redisplay_trace ("trying display optimization 1\n"); w->cursor.vpos = -1; overlay_arrow_seen = false; @@ -18653,6 +18894,11 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) /* Try to scroll by specified few lines. */ if ((0 < scroll_conservatively + /* FIXME: the option is supposed to affect minibuffers, but we + test MINI_WINDOW_P, which can also catch uses of + mini-windows for displaying the echo area. Do we need to + distinguish these two use cases? */ + || (scroll_minibuffer_conservatively && MINI_WINDOW_P (w)) || 0 < emacs_scroll_step || temp_scroll_step || NUMBERP (BVAR (current_buffer, scroll_up_aggressively)) @@ -18663,7 +18909,10 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) /* The function returns -1 if new fonts were loaded, 1 if successful, 0 if not successful. */ int ss = try_scrolling (window, just_this_one_p, - scroll_conservatively, + ((scroll_minibuffer_conservatively + && MINI_WINDOW_P (w)) + ? SCROLL_LIMIT + 1 + : scroll_conservatively), emacs_scroll_step, temp_scroll_step, last_line_misfit); switch (ss) @@ -19207,19 +19456,21 @@ try_window (Lisp_Object window, struct text_pos pos, int flags) if ((flags & TRY_WINDOW_CHECK_MARGINS) && !MINI_WINDOW_P (w)) { - int this_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS); + int top_scroll_margin = window_scroll_margin (w, MARGIN_IN_PIXELS); + int bot_scroll_margin = top_scroll_margin; + if (window_wants_header_line (w)) + top_scroll_margin += CURRENT_HEADER_LINE_HEIGHT (w); start_display (&it, w, pos); if ((w->cursor.y >= 0 /* not vscrolled */ - && w->cursor.y < this_scroll_margin - && CHARPOS (pos) > BEGV - && it_charpos < ZV) + && w->cursor.y < top_scroll_margin + && CHARPOS (pos) > BEGV) /* rms: considering make_cursor_line_fully_visible_p here seems to give wrong results. We don't want to recenter when the last line is partly visible, we want to allow that case to be handled in the usual way. */ - || w->cursor.y > (it.last_visible_y - partial_line_height (&it) - - this_scroll_margin - 1)) + || w->cursor.y > (it.last_visible_y - partial_line_height (&it) + - bot_scroll_margin - 1)) { w->cursor.vpos = -1; clear_glyph_matrix (w->desired_matrix); @@ -20349,6 +20600,12 @@ try_window_id (struct window *w) if (! init_to_row_end (&it, w, last_unchanged_at_beg_row)) GIVE_UP (18); + /* Give up if the row starts with a display property that draws + on the fringes, since that could prevent correct display of + line-prefix and wrap-prefix. */ + if (it.sp > 1 + && it.method == GET_FROM_IMAGE && it.image_id == -1) + GIVE_UP (26); start_pos = it.current.pos; /* Start displaying new lines in the desired matrix at the same @@ -20587,9 +20844,8 @@ try_window_id (struct window *w) + window_wants_header_line (w) + window_internal_height (w)); -#if defined (HAVE_GPM) || defined (MSDOS) gui_clear_window_mouse_face (w); -#endif + /* Perform the operation on the screen. */ if (dvpos > 0) { @@ -21264,7 +21520,7 @@ get_overlay_arrow_glyph_row (struct window *w, Lisp_Object overlay_arrow_string) /* Get the next character. */ if (multibyte_p) - it.c = it.char_to_display = string_char_and_length (p, &it.len); + it.c = it.char_to_display = check_char_and_length (p, &it.len); else { it.c = it.char_to_display = *p, it.len = 1; @@ -21634,6 +21890,8 @@ append_space_for_newline (struct it *it, bool default_face_p) const int indicator_column = fill_column_indicator_column (it, char_width); + int saved_end_of_box_run = it->end_of_box_run_p; + bool should_keep_end_of_box_run = false; if (it->current_x == indicator_column) { @@ -21656,14 +21914,18 @@ append_space_for_newline (struct it *it, bool default_face_p) have the end_of_box_run_p flag set for it, so there's no need for the appended newline glyph to have that flag set. */ - if (it->glyph_row->reversed_p - /* But if the appended newline glyph goes all the way to - the end of the row, there will be no stretch glyph, - so leave the box flag set. */ - && saved_x + FRAME_COLUMN_WIDTH (it->f) < it->last_visible_x) - it->end_of_box_run_p = false; + if (!(it->glyph_row->reversed_p + /* But if the appended newline glyph goes all the way to + the end of the row, there will be no stretch glyph, + so leave the box flag set. */ + && saved_x + FRAME_COLUMN_WIDTH (it->f) < it->last_visible_x)) + should_keep_end_of_box_run = true; } PRODUCE_GLYPHS (it); + /* Restore the end_of_box_run_p flag which was reset by + PRODUCE_GLYPHS. */ + if (should_keep_end_of_box_run) + it->end_of_box_run_p = saved_end_of_box_run; #ifdef HAVE_WINDOW_SYSTEM if (FRAME_WINDOW_P (it->f)) { @@ -21815,7 +22077,7 @@ extend_face_to_end_of_line (struct it *it) && !face->stipple #endif && !it->glyph_row->reversed_p - && !Vdisplay_fill_column_indicator) + && !display_fill_column_indicator) return; /* Set the glyph row flag indicating that the face of the last glyph @@ -22150,7 +22412,7 @@ trailing_whitespace_p (ptrdiff_t charpos) int c = 0; while (bytepos < ZV_BYTE - && (c = FETCH_CHAR (bytepos), + && (c = FETCH_BYTE (bytepos), c == ' ' || c == '\t')) ++bytepos; @@ -22410,7 +22672,7 @@ push_prefix_prop (struct it *it, Lisp_Object prop) else if (IMAGEP (prop)) { it->what = IT_IMAGE; - it->image_id = lookup_image (it->f, prop); + it->image_id = lookup_image (it->f, prop, it->face_id); it->method = GET_FROM_IMAGE; } #endif /* HAVE_WINDOW_SYSTEM */ @@ -22612,7 +22874,7 @@ find_row_edges (struct it *it, struct glyph_row *row, required when scanning back, because max_pos will already have a much larger value. */ if (CHARPOS (row->end.pos) > max_pos) - INC_BOTH (max_pos, max_bpos); + inc_both (&max_pos, &max_bpos); SET_TEXT_POS (row->maxpos, max_pos, max_bpos); } else if (CHARPOS (it->eol_pos) > 0) @@ -22630,7 +22892,7 @@ find_row_edges (struct it *it, struct glyph_row *row, SET_TEXT_POS (row->maxpos, max_pos, max_bpos); else { - INC_BOTH (max_pos, max_bpos); + inc_both (&max_pos, &max_bpos); SET_TEXT_POS (row->maxpos, max_pos, max_bpos); } } @@ -23306,9 +23568,14 @@ display_line (struct it *it, int cursor_vpos) if (it->line_wrap == WORD_WRAP && it->area == TEXT_AREA) { - if (IT_DISPLAYING_WHITESPACE (it)) - may_wrap = true; - else if (may_wrap) + bool next_may_wrap = may_wrap; + /* Can we wrap after this character? */ + if (char_can_wrap_after (it)) + next_may_wrap = true; + else + next_may_wrap = false; + /* Can we wrap here? */ + if (may_wrap && char_can_wrap_before (it)) { SAVE_IT (wrap_it, *it, wrap_data); wrap_x = x; @@ -23322,8 +23589,9 @@ display_line (struct it *it, int cursor_vpos) wrap_row_min_bpos = min_bpos; wrap_row_max_pos = max_pos; wrap_row_max_bpos = max_bpos; - may_wrap = false; } + /* Update may_wrap for the next iteration. */ + may_wrap = next_may_wrap; } } @@ -23447,14 +23715,18 @@ display_line (struct it *it, int cursor_vpos) /* If line-wrap is on, check if a previous wrap point was found. */ if (!IT_OVERFLOW_NEWLINE_INTO_FRINGE (it) - && wrap_row_used > 0 + && wrap_row_used > 0 /* Found. */ /* Even if there is a previous wrap point, continue the line here as usual, if (i) the previous character - was a space or tab AND (ii) the - current character is not. */ - && (!may_wrap - || IT_DISPLAYING_WHITESPACE (it))) + allows wrapping after it, AND (ii) + the current character allows wrapping + before it. Because this is a valid + break point, we can just continue to + the next line at here, there is no + need to wrap early at the previous + wrap point. */ + && (!may_wrap || !char_can_wrap_before (it))) goto back_to_wrap; /* Record the maximum and minimum buffer @@ -23482,13 +23754,16 @@ display_line (struct it *it, int cursor_vpos) /* If line-wrap is on, check if a previous wrap point was found. */ else if (wrap_row_used > 0 - /* Even if there is a previous wrap - point, continue the line here as - usual, if (i) the previous character - was a space or tab AND (ii) the - current character is not. */ - && (!may_wrap - || IT_DISPLAYING_WHITESPACE (it))) + /* Even if there is a previous + wrap point, continue the + line here as usual, if (i) + the previous character was a + space or tab AND (ii) the + current character is not, + AND (iii) the current + character allows wrapping + before it. */ + && (!may_wrap || !char_can_wrap_before (it))) goto back_to_wrap; } @@ -24048,7 +24323,7 @@ See also `bidi-paragraph-direction'. */) to make sure we are within that paragraph. To that end, find the previous non-empty line. */ if (pos >= ZV && pos > BEGV) - DEC_BOTH (pos, bytepos); + dec_both (&pos, &bytepos); AUTO_STRING (trailing_white_space, "[\f\t ]*\n"); if (fast_looking_at (trailing_white_space, pos, bytepos, ZV, ZV_BYTE, Qnil) > 0) @@ -24444,6 +24719,7 @@ Value is the new character position of point. */) bool at_eol_p; bool overshoot_expected = false; bool target_is_eol_p = false; + void *itdata = bidi_shelve_cache (); /* Setup the arena. */ SET_TEXT_POS (pt, PT, PT_BYTE); @@ -24672,6 +24948,7 @@ Value is the new character position of point. */) /* Move point to that position. */ SET_PT_BOTH (IT_CHARPOS (it), IT_BYTEPOS (it)); + bidi_unshelve_cache (itdata, false); } return make_fixnum (PT); @@ -25082,11 +25359,14 @@ static int display_mode_lines (struct window *w) { Lisp_Object old_selected_window = selected_window; - Lisp_Object old_selected_frame = selected_frame; Lisp_Object new_frame = w->frame; - Lisp_Object old_frame_selected_window = XFRAME (new_frame)->selected_window; + ptrdiff_t count = SPECPDL_INDEX (); int n = 0; + record_unwind_protect (restore_selected_window, selected_window); + record_unwind_protect + (restore_frame_selected_window, XFRAME (new_frame)->selected_window); + if (window_wants_mode_line (w)) { Lisp_Object window; @@ -25152,9 +25432,8 @@ display_mode_lines (struct window *w) ++n; } - XFRAME (new_frame)->selected_window = old_frame_selected_window; - selected_frame = old_selected_frame; - selected_window = old_selected_window; + unbind_to (count, Qnil); + if (n > 0) w->must_be_updated_p = true; return n; @@ -25198,14 +25477,62 @@ display_mode_line (struct window *w, enum face_id face_id, Lisp_Object format) format_mode_line_unwind_data (NULL, NULL, Qnil, false)); - mode_line_target = MODE_LINE_DISPLAY; - /* Temporarily make frame's keyboard the current kboard so that kboard-local variables in the mode_line_format will get the right values. */ push_kboard (FRAME_KBOARD (it.f)); record_unwind_save_match_data (); - display_mode_element (&it, 0, 0, 0, format, Qnil, false); + + if (NILP (Vmode_line_compact)) + { + mode_line_target = MODE_LINE_DISPLAY; + display_mode_element (&it, 0, 0, 0, format, Qnil, false); + } + else + { + Lisp_Object mode_string = Fformat_mode_line (format, Qnil, Qnil, Qnil); + if (EQ (Vmode_line_compact, Qlong) + && WINDOW_TOTAL_COLS (w) >= SCHARS (mode_string)) + { + /* The window is wide enough; just display the mode line we + just computed. */ + display_string (NULL, mode_string, Qnil, + 0, 0, &it, 0, 0, 0, + STRING_MULTIBYTE (mode_string)); + } + else + { + /* Compress the mode line. */ + ptrdiff_t i = 0, i_byte = 0, start = 0; + int prev = 0; + + while (i < SCHARS (mode_string)) + { + int c = fetch_string_char_advance (mode_string, &i, &i_byte); + if (c == ' ' && prev == ' ') + { + display_string (NULL, + Fsubstring (mode_string, make_fixnum (start), + make_fixnum (i - 1)), + Qnil, 0, 0, &it, 0, 0, 0, + STRING_MULTIBYTE (mode_string)); + /* Skip past the rest of the space characters. */ + while (c == ' ' && i < SCHARS (mode_string)) + c = fetch_string_char_advance (mode_string, &i, &i_byte); + start = i - 1; + } + prev = c; + } + + /* Display the final bit. */ + if (start < i) + display_string (NULL, + Fsubstring (mode_string, make_fixnum (start), + make_fixnum (i)), + Qnil, 0, 0, &it, 0, 0, 0, + STRING_MULTIBYTE (mode_string)); + } + } pop_kboard (); unbind_to (count, Qnil); @@ -25517,6 +25844,14 @@ display_mode_element (struct it *it, int depth, int field_width, int precision, spec = decode_mode_spec (it->w, c, field, &string); eassert (NILP (string) || STRINGP (string)); multibyte = !NILP (string) && STRING_MULTIBYTE (string); + /* Non-ASCII characters in SPEC should cause mode-line + element be displayed as a multibyte string. */ + ptrdiff_t nbytes = strlen (spec); + ptrdiff_t nchars, mb_nbytes; + parse_str_as_multibyte ((const unsigned char *)spec, nbytes, + &nchars, &mb_nbytes); + if (!(nbytes == nchars || nbytes != mb_nbytes)) + multibyte = true; switch (mode_line_target) { @@ -25960,7 +26295,7 @@ are the selected window and the WINDOW's buffer). */) return unbind_to (count, str); } -/* Write a NUL-terminated, right justified decimal representation of +/* Write a null-terminated, right justified decimal representation of the positive integer D to BUF using a minimal field width WIDTH. */ static void @@ -25990,7 +26325,7 @@ pint2str (register char *buf, register int width, register ptrdiff_t d) } } -/* Write a NUL-terminated, right justified decimal and "human +/* Write a null-terminated, right justified decimal and "human readable" representation of the nonnegative integer D to BUF using a minimal field width WIDTH. D should be smaller than 999.5e24. */ @@ -26135,9 +26470,11 @@ decode_mode_spec_coding (Lisp_Object coding_system, char *buf, bool eol_flag) attrs = AREF (val, 0); eolvalue = AREF (val, 2); - *buf++ = multibyte - ? XFIXNAT (CODING_ATTR_MNEMONIC (attrs)) - : ' '; + if (multibyte) + buf += CHAR_STRING (XFIXNAT (CODING_ATTR_MNEMONIC (attrs)), + (unsigned char *) buf); + else + *buf++ = ' '; if (eol_flag) { @@ -26211,7 +26548,7 @@ decode_mode_spec (struct window *w, register int c, int field_width, produce strings from numerical values, so limit preposterously large values of FIELD_WIDTH to avoid overrunning the buffer's end. The size of the buffer is enough for FRAME_MESSAGE_BUF_SIZE - bytes plus the terminating NUL. */ + bytes plus the terminating null. */ int width = min (field_width, FRAME_MESSAGE_BUF_SIZE (f)); struct buffer *b = current_buffer; @@ -26654,6 +26991,15 @@ decode_mode_spec (struct window *w, register int c, int field_width, return ""; } +/* Return the number of lines between start_byte and end_byte in the + current buffer. */ + +ptrdiff_t +count_lines (ptrdiff_t start_byte, ptrdiff_t end_byte) +{ + ptrdiff_t ignored; + return display_count_lines (start_byte, end_byte, ZV, &ignored); +} /* Count up to COUNT lines starting from START_BYTE. COUNT negative means count lines back from START_BYTE. But don't go beyond @@ -26827,6 +27173,7 @@ display_string (const char *string, Lisp_Object lisp_string, Lisp_Object face_st with index START. */ reseat_to_string (it, NILP (lisp_string) ? string : NULL, lisp_string, start, precision, field_width, multibyte); + if (string && STRINGP (lisp_string)) /* LISP_STRING is the one returned by decode_mode_spec. We should ignore its text properties. */ @@ -27317,7 +27664,7 @@ calc_pixel_width_or_height (double *res, struct it *it, Lisp_Object prop, if (FRAME_WINDOW_P (it->f) && valid_image_p (prop)) { - ptrdiff_t id = lookup_image (it->f, prop); + ptrdiff_t id = lookup_image (it->f, prop, it->face_id); struct image *img = IMAGE_FROM_ID (it->f, id); return OK_PIXELS (width_p ? img->width : img->height); @@ -27699,22 +28046,32 @@ fill_gstring_glyph_string (struct glyph_string *s, int face_id, struct glyph *glyph, *last; Lisp_Object lgstring; int i; + bool glyph_not_available_p; s->for_overlaps = overlaps; glyph = s->row->glyphs[s->area] + start; last = s->row->glyphs[s->area] + end; + glyph_not_available_p = glyph->glyph_not_available_p; s->cmp_id = glyph->u.cmp.id; s->cmp_from = glyph->slice.cmp.from; s->cmp_to = glyph->slice.cmp.to + 1; s->face = FACE_FROM_ID (s->f, face_id); lgstring = composition_gstring_from_id (s->cmp_id); s->font = XFONT_OBJECT (LGSTRING_FONT (lgstring)); + /* The width of a composition glyph string is the sum of the + composition's glyph widths. */ + s->width = s->first_glyph->pixel_width; glyph++; while (glyph < last && glyph->u.cmp.automatic && glyph->u.cmp.id == s->cmp_id - && s->cmp_to == glyph->slice.cmp.from) - s->cmp_to = (glyph++)->slice.cmp.to + 1; + && glyph->face_id == face_id + && s->cmp_to == glyph->slice.cmp.from + && glyph->glyph_not_available_p == glyph_not_available_p) + { + s->width += glyph->pixel_width; + s->cmp_to = (glyph++)->slice.cmp.to + 1; + } for (i = s->cmp_from; i < s->cmp_to; i++) { @@ -27724,7 +28081,13 @@ fill_gstring_glyph_string (struct glyph_string *s, int face_id, /* Ensure that the code is only 2 bytes wide. */ s->char2b[i] = code & 0xFFFF; } - s->width = composition_gstring_width (lgstring, s->cmp_from, s->cmp_to, NULL); + + /* If the specified font could not be loaded, record that fact in + S->font_not_found_p so that we can draw rectangles for the + characters of the glyph string. */ + if (glyph_not_available_p) + s->font_not_found_p = true; + return glyph - s->row->glyphs[s->area]; } @@ -28921,7 +29284,7 @@ append_composite_glyph (struct it *it) glyph->overlaps_vertically_p = (it->phys_ascent > it->ascent || it->phys_descent > it->descent); glyph->padding_p = false; - glyph->glyph_not_available_p = false; + glyph->glyph_not_available_p = it->glyph_not_available_p; glyph->face_id = it->face_id; glyph->font_type = FONT_TYPE_UNKNOWN; if (it->bidi_p) @@ -29049,18 +29412,21 @@ produce_image_glyph (struct it *it) if (face->box != FACE_NO_BOX) { - if (face->box_line_width > 0) + if (face->box_horizontal_line_width > 0) { if (slice.y == 0) - it->ascent += face->box_line_width; + it->ascent += face->box_horizontal_line_width; if (slice.y + slice.height == img->height) - it->descent += face->box_line_width; + it->descent += face->box_horizontal_line_width; } - if (it->start_of_box_run_p && slice.x == 0) - it->pixel_width += eabs (face->box_line_width); - if (it->end_of_box_run_p && slice.x + slice.width == img->width) - it->pixel_width += eabs (face->box_line_width); + if (face->box_vertical_line_width > 0) + { + if (it->start_of_box_run_p && slice.x == 0) + it->pixel_width += face->box_vertical_line_width; + if (it->end_of_box_run_p && slice.x + slice.width == img->width) + it->pixel_width += face->box_vertical_line_width; + } } take_vertical_position_into_account (it); @@ -29158,15 +29524,18 @@ produce_xwidget_glyph (struct it *it) if (face->box != FACE_NO_BOX) { - if (face->box_line_width > 0) + if (face->box_horizontal_line_width > 0) { - it->ascent += face->box_line_width; - it->descent += face->box_line_width; + it->ascent += face->box_horizontal_line_width; + it->descent += face->box_horizontal_line_width; } - if (it->start_of_box_run_p) - it->pixel_width += eabs (face->box_line_width); - it->pixel_width += eabs (face->box_line_width); + if (face->box_vertical_line_width > 0) + { + if (it->start_of_box_run_p) + it->pixel_width += face->box_vertical_line_width; + it->pixel_width += face->box_vertical_line_width; + } } take_vertical_position_into_account (it); @@ -29389,7 +29758,7 @@ produce_stretch_glyph (struct it *it) /* Compute the width of the stretch. */ if ((prop = Fplist_get (plist, QCwidth), !NILP (prop)) - && calc_pixel_width_or_height (&tem, it, prop, font, true, 0)) + && calc_pixel_width_or_height (&tem, it, prop, font, true, NULL)) { /* Absolute width `:width WIDTH' specified and valid. */ zero_width_ok_p = true; @@ -29405,7 +29774,7 @@ produce_stretch_glyph (struct it *it) it2 = *it; if (it->multibyte_p) - it2.c = it2.char_to_display = STRING_CHAR_AND_LENGTH (p, it2.len); + it2.c = it2.char_to_display = string_char_and_length (p, &it2.len); else { it2.c = it2.char_to_display = *p, it2.len = 1; @@ -29445,7 +29814,7 @@ produce_stretch_glyph (struct it *it) int default_height = normal_char_height (font, ' '); if ((prop = Fplist_get (plist, QCheight), !NILP (prop)) - && calc_pixel_width_or_height (&tem, it, prop, font, false, 0)) + && calc_pixel_width_or_height (&tem, it, prop, font, false, NULL)) { height = (int)tem; zero_height_ok_p = true; @@ -29475,7 +29844,8 @@ produce_stretch_glyph (struct it *it) #endif /* HAVE_WINDOW_SYSTEM */ height = 1; - if (width > 0 && it->line_wrap != TRUNCATE + if (width > 0 + && it->area == TEXT_AREA && it->line_wrap != TRUNCATE && it->current_x + width > it->last_visible_x) { width = it->last_visible_x - it->current_x; @@ -29929,6 +30299,31 @@ produce_glyphless_glyph (struct it *it, bool for_no_font, Lisp_Object acronym) } +/* If face has a box, add the box thickness to the character + height. If character has a box line to the left and/or + right, add the box line width to the character's width. */ +#define IT_APPLY_FACE_BOX(it, face) \ + do { \ + if (face->box != FACE_NO_BOX) \ + { \ + int thick = face->box_horizontal_line_width; \ + if (thick > 0) \ + { \ + it->ascent += thick; \ + it->descent += thick; \ + } \ + \ + thick = face->box_vertical_line_width; \ + if (thick > 0) \ + { \ + if (it->start_of_box_run_p) \ + it->pixel_width += thick; \ + if (it->end_of_box_run_p) \ + it->pixel_width += thick; \ + } \ + } \ + } while (false) + /* RIF: Produce glyphs/get display metrics for the display element IT is loaded with. See the description of struct it in dispextern.h @@ -30044,26 +30439,7 @@ gui_produce_glyphs (struct it *it) if (stretched_p) it->pixel_width *= XFLOATINT (it->space_width); - /* If face has a box, add the box thickness to the character - height. If character has a box line to the left and/or - right, add the box line width to the character's width. */ - if (face->box != FACE_NO_BOX) - { - int thick = face->box_line_width; - - if (thick > 0) - { - it->ascent += thick; - it->descent += thick; - } - else - thick = -thick; - - if (it->start_of_box_run_p) - it->pixel_width += thick; - if (it->end_of_box_run_p) - it->pixel_width += thick; - } + IT_APPLY_FACE_BOX(it, face); /* If face has an overline, add the height of the overline (1 pixel) and a 1 pixel margin to the character height. */ @@ -30178,10 +30554,10 @@ gui_produce_glyphs (struct it *it) if ((it->max_ascent > 0 || it->max_descent > 0) && face->box != FACE_NO_BOX - && face->box_line_width > 0) + && face->box_horizontal_line_width > 0) { - it->ascent += face->box_line_width; - it->descent += face->box_line_width; + it->ascent += face->box_horizontal_line_width; + it->descent += face->box_horizontal_line_width; } if (!NILP (height) && XFIXNUM (height) > it->ascent + it->descent) @@ -30588,23 +30964,7 @@ gui_produce_glyphs (struct it *it) it->pixel_width = cmp->pixel_width; it->ascent = it->phys_ascent = cmp->ascent; it->descent = it->phys_descent = cmp->descent; - if (face->box != FACE_NO_BOX) - { - int thick = face->box_line_width; - - if (thick > 0) - { - it->ascent += thick; - it->descent += thick; - } - else - thick = - thick; - - if (it->start_of_box_run_p) - it->pixel_width += thick; - if (it->end_of_box_run_p) - it->pixel_width += thick; - } + IT_APPLY_FACE_BOX(it, face); /* If face has an overline, add the height of the overline (1 pixel) and a 1 pixel margin to the character height. */ @@ -30633,28 +30993,23 @@ gui_produce_glyphs (struct it *it) it->pixel_width = composition_gstring_width (gstring, it->cmp_it.from, it->cmp_it.to, &metrics); - if (it->glyph_row - && (metrics.lbearing < 0 || metrics.rbearing > metrics.width)) - it->glyph_row->contains_overlapping_glyphs_p = true; - it->ascent = it->phys_ascent = metrics.ascent; - it->descent = it->phys_descent = metrics.descent; - if (face->box != FACE_NO_BOX) + if (it->pixel_width == 0) { - int thick = face->box_line_width; - - if (thick > 0) - { - it->ascent += thick; - it->descent += thick; - } - else - thick = - thick; - - if (it->start_of_box_run_p) - it->pixel_width += thick; - if (it->end_of_box_run_p) - it->pixel_width += thick; + it->glyph_not_available_p = true; + it->phys_ascent = it->ascent; + it->phys_descent = it->descent; + it->pixel_width = face->font->space_width; } + else + { + if (it->glyph_row + && (metrics.lbearing < 0 || metrics.rbearing > metrics.width)) + it->glyph_row->contains_overlapping_glyphs_p = true; + it->ascent = it->phys_ascent = metrics.ascent; + it->descent = it->phys_descent = metrics.descent; + } + IT_APPLY_FACE_BOX(it, face); + /* If face has an overline, add the height of the overline (1 pixel) and a 1 pixel margin to the character height. */ if (face->overline_p) @@ -30900,14 +31255,6 @@ get_specified_cursor_type (Lisp_Object arg, int *width) return BAR_CURSOR; } - if (CONSP (arg) - && EQ (XCAR (arg), Qbar) - && RANGED_FIXNUMP (0, XCDR (arg), INT_MAX)) - { - *width = XFIXNUM (XCDR (arg)); - return BAR_CURSOR; - } - if (EQ (arg, Qhbar)) { *width = 2; @@ -30915,11 +31262,16 @@ get_specified_cursor_type (Lisp_Object arg, int *width) } if (CONSP (arg) - && EQ (XCAR (arg), Qhbar) && RANGED_FIXNUMP (0, XCDR (arg), INT_MAX)) { *width = XFIXNUM (XCDR (arg)); - return HBAR_CURSOR; + + if (EQ (XCAR (arg), Qbox)) + return FILLED_BOX_CURSOR; + else if (EQ (XCAR (arg), Qbar)) + return BAR_CURSOR; + else if (EQ (XCAR (arg), Qhbar)) + return HBAR_CURSOR; } /* Treat anything unknown as "hollow box cursor". @@ -31008,7 +31360,9 @@ get_window_cursor_type (struct window *w, struct glyph *glyph, int *width, { *active_cursor = false; - if (MINI_WINDOW_P (w) && minibuf_level == 0) + if (MINI_WINDOW_P (w) && + (minibuf_level == 0 + || is_minibuffer (0, w->contents))) return NO_CURSOR; non_selected = true; @@ -31046,23 +31400,28 @@ get_window_cursor_type (struct window *w, struct glyph *glyph, int *width, if (!w->cursor_off_p) { if (glyph != NULL && glyph->type == XWIDGET_GLYPH) - return NO_CURSOR; + return NO_CURSOR; if (glyph != NULL && glyph->type == IMAGE_GLYPH) { if (cursor_type == FILLED_BOX_CURSOR) { - /* Using a block cursor on large images can be very annoying. - So use a hollow cursor for "large" images. - If image is not transparent (no mask), also use hollow cursor. */ + /* Using a block cursor on large images can be very + annoying. So use a hollow cursor for "large" images. + If image is not transparent (no mask), also use + hollow cursor. */ struct image *img = IMAGE_OPT_FROM_ID (f, glyph->u.img_id); if (img != NULL && IMAGEP (img->spec)) { - /* Arbitrarily, interpret "Large" as >32x32 and >NxN - where N = size of default frame font size. - This should cover most of the "tiny" icons people may use. */ + /* Interpret "large" as >SIZExSIZE and >NxN where + SIZE is the value from cursor-type of the form + (box . SIZE), where N = size of default frame + font size. So, setting cursor-type to (box . 32) + should cover most of the "tiny" icons people may + use. */ if (!img->mask - || img->width > max (32, WINDOW_FRAME_COLUMN_WIDTH (w)) - || img->height > max (32, WINDOW_FRAME_LINE_HEIGHT (w))) + || (CONSP (BVAR (b, cursor_type)) + && img->width > max (*width, WINDOW_FRAME_COLUMN_WIDTH (w)) + && img->height > max (*width, WINDOW_FRAME_LINE_HEIGHT (w)))) cursor_type = HOLLOW_BOX_CURSOR; } } @@ -31600,9 +31959,8 @@ draw_row_with_mouse_face (struct window *w, int start_x, struct glyph_row *row, return; } #endif -#if defined (HAVE_GPM) || defined (MSDOS) || defined (WINDOWSNT) + tty_draw_row_with_mouse_face (w, row, start_hpos, end_hpos, draw); -#endif } /* Display the active region described by mouse_face_* according to DRAW. */ @@ -34321,7 +34679,14 @@ syms_of_xdisp (void) DEFSYM (Qredisplay_internal_xC_functionx, "redisplay_internal (C function)"); - DEFVAR_BOOL("inhibit-message", inhibit_message, + DEFVAR_BOOL ("scroll-minibuffer-conservatively", + scroll_minibuffer_conservatively, + doc: /* Non-nil means scroll conservatively in minibuffer windows. +When the value is nil, scrolling in minibuffer windows obeys the +settings of `scroll-conservatively'. */); + scroll_minibuffer_conservatively = true; /* bug#44070 */ + + DEFVAR_BOOL ("inhibit-message", inhibit_message, doc: /* Non-nil means calls to `message' are not displayed. They are still logged to the *Messages* buffer. @@ -34329,7 +34694,7 @@ Do NOT set this globally to a non-nil value, as doing that will disable messages everywhere, including in I-search and other places where they are necessary. This variable is intended to be let-bound around code that needs to disable messages temporarily. */); - inhibit_message = 0; + inhibit_message = false; message_dolog_marker1 = Fmake_marker (); staticpro (&message_dolog_marker1); @@ -34524,13 +34889,22 @@ wide as that tab on the display. */); The face used for trailing whitespace is `trailing-whitespace'. */); Vshow_trailing_whitespace = Qnil; + DEFVAR_LISP ("mode-line-compact", Vmode_line_compact, + doc: /* Non-nil means that mode lines should be compact. +This means that repeating spaces will be replaced with a single space. +If this variable is `long', only mode lines that are wider than the +currently selected window are compressed. */); + Vmode_line_compact = Qnil; + DEFSYM (Qlong, "long"); + DEFVAR_LISP ("nobreak-char-display", Vnobreak_char_display, doc: /* Control highlighting of non-ASCII space and hyphen chars. If the value is t, Emacs highlights non-ASCII chars which have the same appearance as an ASCII space or hyphen, using the `nobreak-space' or `nobreak-hyphen' face respectively. -U+00A0 (no-break space), U+00AD (soft hyphen), U+2010 (hyphen), and +All of the non-ASCII characters in the Unicode horizontal whitespace +character class, as well as U+00AD (soft hyphen), U+2010 (hyphen), and U+2011 (non-breaking hyphen) are affected. Any other non-nil value means to display these characters as an escape @@ -34635,6 +35009,23 @@ A value of nil means to respect the value of `truncate-lines'. If `word-wrap' is enabled, you might want to reduce this. */); Vtruncate_partial_width_windows = make_fixnum (50); + DEFVAR_BOOL("word-wrap-by-category", word_wrap_by_category, doc: /* + Non-nil means also wrap after characters of a certain category. +Normally when `word-wrap' is on, Emacs only breaks lines after +whitespace characters. When this option is turned on, Emacs also +breaks lines after characters that have the "|" category (defined in +characters.el). This is useful for allowing breaking after CJK +characters and improves the word-wrapping for CJK text mixed with +Latin text. + +If this variable is set using Customize, Emacs automatically loads +kinsoku.el. When kinsoku.el is loaded, Emacs respects kinsoku rules +when breaking lines. That means characters with the ">" category +don't appear at the beginning of a line (e.g., FULLWIDTH COMMA), and +characters with the "<" category don't appear at the end of a line +(e.g., LEFT DOUBLE ANGLE BRACKET). */); + word_wrap_by_category = false; + DEFVAR_LISP ("line-number-display-limit", Vline_number_display_limit, doc: /* Maximum buffer size for which line number should be displayed. If the buffer is bigger than this, the line number does not appear @@ -34676,8 +35067,7 @@ and is used only on frames for which no explicit name has been set Oracle Developer Studio 12.6. */ Lisp_Object icon_title_name_format = pure_list (empty_unibyte_string, - intern_c_string ("invocation-name"), - build_pure_c_string ("@"), + build_pure_c_string ("%b - GNU Emacs at "), intern_c_string ("system-name")); Vicon_title_format = Vframe_title_format @@ -35034,12 +35424,12 @@ It has no effect when set to 0, or when line numbers are not absolute. */); DEFSYM (Qdisplay_line_numbers_offset, "display-line-numbers-offset"); Fmake_variable_buffer_local (Qdisplay_line_numbers_offset); - DEFVAR_BOOL ("display-fill-column-indicator", Vdisplay_fill_column_indicator, + DEFVAR_BOOL ("display-fill-column-indicator", display_fill_column_indicator, doc: /* Non-nil means display the fill column indicator. If you set this non-nil, make sure `display-fill-column-indicator-character' is also non-nil. See Info node `Displaying Boundaries' for details. */); - Vdisplay_fill_column_indicator = false; + display_fill_column_indicator = false; DEFSYM (Qdisplay_fill_column_indicator, "display-fill-column-indicator"); Fmake_variable_buffer_local (Qdisplay_fill_column_indicator); @@ -35227,7 +35617,7 @@ message displayed by its counterpart function specified by DEFVAR_BOOL ("display-raw-bytes-as-hex", display_raw_bytes_as_hex, doc: /* Non-nil means display raw bytes in hexadecimal format. -The default is to use octal format (\200) whereas hexadecimal (\x80) +The default is to use octal format (\\200) whereas hexadecimal (\\x80) may be more familiar to users. */); display_raw_bytes_as_hex = false; @@ -35237,6 +35627,33 @@ When nil, mouse-movement events will not be generated as long as the mouse stays within the extent of a single glyph (except for images). */); mouse_fine_grained_tracking = false; + DEFVAR_BOOL ("redisplay-skip-initial-frame", redisplay_skip_initial_frame, + doc: /* Non-nil to skip redisplay in initial frame. +The initial frame is not displayed anywhere, so skipping it is +best except in special circumstances such as running redisplay tests +in batch mode. */); + redisplay_skip_initial_frame = true; + + DEFVAR_BOOL ("redisplay-skip-fontification-on-input", + redisplay_skip_fontification_on_input, + doc: /* Skip `fontification_functions` when there is input pending. +If non-nil and there was input pending at the beginning of the command, +the `fontification_functions` hook is not run. This usually does not +affect the display because redisplay is completely skipped anyway if input +was pending, but it can make scrolling smoother by avoiding +unnecessary fontification. +It is similar to `fast-but-imprecise-scrolling' with similar tradeoffs, +but with the advantage that it should only affect the behavior when Emacs +has trouble keeping up with the incoming input rate. */); + redisplay_skip_fontification_on_input = false; + + DEFVAR_BOOL ("redisplay-adhoc-scroll-in-resize-mini-windows", + redisplay_adhoc_scroll_in_resize_mini_windows, + doc: /* If nil always use normal scrolling in minibuffer windows. +Otherwise, use custom-tailored code after resizing minibuffer windows to try +and display the most important part of the minibuffer. */); + /* See bug#43519 for some discussion around this. */ + redisplay_adhoc_scroll_in_resize_mini_windows = true; } @@ -35247,6 +35664,8 @@ init_xdisp (void) { CHARPOS (this_line_start_pos) = 0; + echo_area_window = minibuf_window; + if (!noninteractive) { struct window *m = XWINDOW (minibuf_window); @@ -35256,8 +35675,6 @@ init_xdisp (void) struct window *r = XWINDOW (root); int i; - echo_area_window = minibuf_window; - r->top_line = FRAME_TOP_MARGIN (f); r->pixel_top = r->top_line * FRAME_LINE_HEIGHT (f); r->total_cols = FRAME_COLS (f); diff --git a/src/xfaces.c b/src/xfaces.c index 9d4b4cedbe7..12087138e51 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -220,6 +220,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "sysstdio.h" #include <sys/types.h> #include <sys/stat.h> +#include <math.h> #include "lisp.h" #include "character.h" @@ -819,6 +820,128 @@ load_pixmap (struct frame *f, Lisp_Object name) Color Handling ***********************************************************************/ +/* Parse hex color component specification that starts at S and ends + right before E. Set *DST to the parsed value normalized so that + the maximum value for the number of hex digits given becomes 65535, + and return true on success, false otherwise. */ +static bool +parse_hex_color_comp (const char *s, const char *e, unsigned short *dst) +{ + int n = e - s; + if (n <= 0 || n > 4) + return false; + int val = 0; + for (; s < e; s++) + { + int digit; + if (*s >= '0' && *s <= '9') + digit = *s - '0'; + else if (*s >= 'A' && *s <= 'F') + digit = *s - 'A' + 10; + else if (*s >= 'a' && *s <= 'f') + digit = *s - 'a' + 10; + else + return false; + val = (val << 4) | digit; + } + int maxval = (1 << (n * 4)) - 1; + *dst = (unsigned)val * 65535 / maxval; + return true; +} + +/* Parse floating-point color component specification that starts at S + and ends right before E. Return the parsed number if in the range + [0,1]; otherwise return -1. */ +static double +parse_float_color_comp (const char *s, const char *e) +{ + char *end; + double x = strtod (s, &end); + return (end == e && x >= 0 && x <= 1) ? x : -1; +} + +/* Parse SPEC as a numeric color specification and set *R, *G and *B. + Return true on success, false on failure. + + Recognized formats of SPEC: + + "#RGB", with R, G and B hex strings of equal length, 1-4 digits each. + "rgb:R/G/B", with R, G and B hex strings, 1-4 digits each. + "rgbi:R/G/B", with R, G and B numbers in [0,1]. + + If the function succeeds, it assigns to each of the components *R, + *G, and *B a value normalized to be in the [0, 65535] range. If + the function fails, some or all of the components remain unassigned. */ +bool +parse_color_spec (const char *spec, + unsigned short *r, unsigned short *g, unsigned short *b) +{ + int len = strlen (spec); + if (spec[0] == '#') + { + if ((len - 1) % 3 == 0) + { + int n = (len - 1) / 3; + return ( parse_hex_color_comp (spec + 1 + 0 * n, + spec + 1 + 1 * n, r) + && parse_hex_color_comp (spec + 1 + 1 * n, + spec + 1 + 2 * n, g) + && parse_hex_color_comp (spec + 1 + 2 * n, + spec + 1 + 3 * n, b)); + } + } + else if (strncmp (spec, "rgb:", 4) == 0) + { + char *sep1, *sep2; + return ((sep1 = strchr (spec + 4, '/')) != NULL + && (sep2 = strchr (sep1 + 1, '/')) != NULL + && parse_hex_color_comp (spec + 4, sep1, r) + && parse_hex_color_comp (sep1 + 1, sep2, g) + && parse_hex_color_comp (sep2 + 1, spec + len, b)); + } + else if (strncmp (spec, "rgbi:", 5) == 0) + { + char *sep1, *sep2; + double red, green, blue; + if ((sep1 = strchr (spec + 5, '/')) != NULL + && (sep2 = strchr (sep1 + 1, '/')) != NULL + && (red = parse_float_color_comp (spec + 5, sep1)) >= 0 + && (green = parse_float_color_comp (sep1 + 1, sep2)) >= 0 + && (blue = parse_float_color_comp (sep2 + 1, spec + len)) >= 0) + { + *r = lrint (red * 65535); + *g = lrint (green * 65535); + *b = lrint (blue * 65535); + return true; + } + } + return false; +} + +DEFUN ("color-values-from-color-spec", + Fcolor_values_from_color_spec, + Scolor_values_from_color_spec, + 1, 1, 0, + doc: /* Parse color SPEC as a numeric color and return (RED GREEN BLUE). +This function recognises the following formats for SPEC: + + #RGB, where R, G and B are hex numbers of equal length, 1-4 digits each. + rgb:R/G/B, where R, G, and B are hex numbers, 1-4 digits each. + rgbi:R/G/B, where R, G and B are floating-point numbers in [0,1]. + +If SPEC is not in one of the above forms, return nil. + +Each of the 3 integer members of the resulting list, RED, GREEN, and BLUE, +is normalized to have its value in [0,65535]. */) + (Lisp_Object spec) +{ + CHECK_STRING (spec); + unsigned short r, g, b; + return (parse_color_spec (SSDATA (spec), &r, &g, &b) + ? list3i (r, g, b) + : Qnil); +} + /* Parse RGB_LIST, and fill in the RGB fields of COLOR. RGB_LIST should contain (at least) 3 lisp integers. Return true iff RGB_LIST is OK. */ @@ -1449,22 +1572,18 @@ the face font sort order. */) for (i = nfonts - 1; i >= 0; --i) { Lisp_Object font = AREF (vec, i); - Lisp_Object v = make_uninit_vector (8); - int point; - Lisp_Object spacing; - - ASET (v, 0, AREF (font, FONT_FAMILY_INDEX)); - ASET (v, 1, FONT_WIDTH_SYMBOLIC (font)); - point = PIXEL_TO_POINT (XFIXNUM (AREF (font, FONT_SIZE_INDEX)) * 10, - FRAME_RES_Y (f)); - ASET (v, 2, make_fixnum (point)); - ASET (v, 3, FONT_WEIGHT_SYMBOLIC (font)); - ASET (v, 4, FONT_SLANT_SYMBOLIC (font)); - spacing = Ffont_get (font, QCspacing); - ASET (v, 5, (NILP (spacing) || EQ (spacing, Qp)) ? Qnil : Qt); - ASET (v, 6, Ffont_xlfd_name (font, Qnil)); - ASET (v, 7, AREF (font, FONT_REGISTRY_INDEX)); - + int point = PIXEL_TO_POINT (XFIXNUM (AREF (font, FONT_SIZE_INDEX)) * 10, + FRAME_RES_Y (f)); + Lisp_Object spacing = Ffont_get (font, QCspacing); + Lisp_Object v = CALLN (Fvector, + AREF (font, FONT_FAMILY_INDEX), + FONT_WIDTH_SYMBOLIC (font), + make_fixnum (point), + FONT_WEIGHT_SYMBOLIC (font), + FONT_SLANT_SYMBOLIC (font), + NILP (spacing) || EQ (spacing, Qp) ? Qnil : Qt, + Ffont_xlfd_name (font, Qnil), + AREF (font, FONT_REGISTRY_INDEX)); result = Fcons (v, result); } @@ -1888,7 +2007,7 @@ get_lface_attributes_no_remap (struct frame *f, Lisp_Object face_name, lface = lface_from_face_name_no_resolve (f, face_name, signal_p); if (! NILP (lface)) - memcpy (attrs, XVECTOR (lface)->contents, + memcpy (attrs, xvector_contents (lface), LFACE_VECTOR_SIZE * sizeof *attrs); return !NILP (lface); @@ -2874,7 +2993,7 @@ The value is TO. */) f = XFRAME (new_frame); } - vcopy (copy, 0, XVECTOR (lface)->contents, LFACE_VECTOR_SIZE); + vcopy (copy, 0, xvector_contents (lface), LFACE_VECTOR_SIZE); /* Changing a named face means that all realized faces depending on that face are invalid. Since we cannot tell which realized faces @@ -3142,6 +3261,8 @@ FRAME 0 means change the face on all frames, and change the default valid_p = XFIXNUM (value) != 0; else if (STRINGP (value)) valid_p = SCHARS (value) > 0; + else if (CONSP (value) && FIXNUMP (XCAR (value)) && FIXNUMP (XCDR (value))) + valid_p = true; else if (CONSP (value)) { Lisp_Object tem; @@ -3160,7 +3281,9 @@ FRAME 0 means change the face on all frames, and change the default if (EQ (k, QCline_width)) { - if (!FIXNUMP (v) || XFIXNUM (v) == 0) + if ((!CONSP(v) || !FIXNUMP (XCAR (v)) || XFIXNUM (XCAR (v)) == 0 + || !FIXNUMP (XCDR (v)) || XFIXNUM (XCDR (v)) == 0) + && (!FIXNUMP (v) || XFIXNUM (v) == 0)) break; } else if (EQ (k, QCcolor)) @@ -3170,7 +3293,8 @@ FRAME 0 means change the face on all frames, and change the default } else if (EQ (k, QCstyle)) { - if (!EQ (v, Qpressed_button) && !EQ (v, Qreleased_button)) + if (!EQ (v, Qpressed_button) && !EQ (v, Qreleased_button) + && !EQ(v, Qflat_button)) break; } else @@ -4366,15 +4490,15 @@ color_distance (Emacs_Color *x, Emacs_Color *y) See <https://www.compuphase.com/cmetric.htm> for more info. */ - long r = (x->red - y->red) >> 8; - long g = (x->green - y->green) >> 8; - long b = (x->blue - y->blue) >> 8; - long r_mean = (x->red + y->red) >> 9; + long long r = x->red - y->red; + long long g = x->green - y->green; + long long b = x->blue - y->blue; + long long r_mean = (x->red + y->red) >> 1; - return - (((512 + r_mean) * r * r) >> 8) - + 4 * g * g - + (((767 - r_mean) * b * b) >> 8); + return (((((2 * 65536 + r_mean) * r * r) >> 16) + + 4 * g * g + + (((2 * 65536 + 65535 - r_mean) * b * b) >> 16)) + >> 16); } @@ -4384,7 +4508,9 @@ COLOR1 and COLOR2 may be either strings containing the color name, or lists of the form (RED GREEN BLUE), each in the range 0 to 65535 inclusive. If FRAME is unspecified or nil, the current frame is used. If METRIC is specified, it should be a function that accepts -two lists of the form (RED GREEN BLUE) aforementioned. */) +two lists of the form (RED GREEN BLUE) aforementioned. +Despite the name, this is not a true distance metric as it does not satisfy +the triangle inequality. */) (Lisp_Object color1, Lisp_Object color2, Lisp_Object frame, Lisp_Object metric) { @@ -4788,6 +4914,7 @@ lookup_basic_face (struct window *w, struct frame *f, int face_id) case WINDOW_DIVIDER_FIRST_PIXEL_FACE_ID: name = Qwindow_divider_first_pixel; break; case WINDOW_DIVIDER_LAST_PIXEL_FACE_ID: name = Qwindow_divider_last_pixel; break; case INTERNAL_BORDER_FACE_ID: name = Qinternal_border; break; + case CHILD_FRAME_BORDER_FACE_ID: name = Qchild_frame_border; break; default: emacs_abort (); /* the caller is supposed to pass us a basic face id */ @@ -4941,7 +5068,7 @@ DEFUN ("face-attributes-as-vector", Fface_attributes_as_vector, /* If the distance (as returned by color_distance) between two colors is less than this, then they are considered the same, for determining - whether a color is supported or not. The range of values is 0-65535. */ + whether a color is supported or not. */ #define TTY_SAME_COLOR_THRESHOLD 10000 @@ -5092,7 +5219,6 @@ tty_supports_face_attributes_p (struct frame *f, || !UNSPECIFIEDP (attrs[LFACE_HEIGHT_INDEX]) || !UNSPECIFIEDP (attrs[LFACE_SWIDTH_INDEX]) || !UNSPECIFIEDP (attrs[LFACE_OVERLINE_INDEX]) - || !UNSPECIFIEDP (attrs[LFACE_STRIKE_THROUGH_INDEX]) || !UNSPECIFIEDP (attrs[LFACE_BOX_INDEX])) return false; @@ -5157,6 +5283,15 @@ tty_supports_face_attributes_p (struct frame *f, test_caps |= TTY_CAP_INVERSE; } + /* strike through */ + val = attrs[LFACE_STRIKE_THROUGH_INDEX]; + if (!UNSPECIFIEDP (val)) + { + if (face_attr_equal_p (val, def_attrs[LFACE_STRIKE_THROUGH_INDEX])) + return false; /* same as default */ + else + test_caps |= TTY_CAP_STRIKE_THROUGH; + } /* Color testing. */ @@ -5486,6 +5621,7 @@ realize_basic_faces (struct frame *f) realize_named_face (f, Qwindow_divider_last_pixel, WINDOW_DIVIDER_LAST_PIXEL_FACE_ID); realize_named_face (f, Qinternal_border, INTERNAL_BORDER_FACE_ID); + realize_named_face (f, Qchild_frame_border, CHILD_FRAME_BORDER_FACE_ID); realize_named_face (f, Qtab_bar, TAB_BAR_FACE_ID); realize_named_face (f, Qtab_line, TAB_LINE_FACE_ID); @@ -5608,7 +5744,7 @@ realize_default_face (struct frame *f) /* Realize the face; it must be fully-specified now. */ eassert (lface_fully_specified_p (XVECTOR (lface)->contents)); check_lface (lface); - memcpy (attrs, XVECTOR (lface)->contents, sizeof attrs); + memcpy (attrs, xvector_contents (lface), sizeof attrs); struct face *face = realize_face (c, attrs, DEFAULT_FACE_ID); #ifndef HAVE_WINDOW_SYSTEM @@ -5829,7 +5965,7 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] face->box_color = load_color (f, face, attrs[LFACE_BOX_INDEX], LFACE_BOX_INDEX); face->box = FACE_SIMPLE_BOX; - face->box_line_width = 1; + face->box_vertical_line_width = face->box_horizontal_line_width = 1; } else if (FIXNUMP (box)) { @@ -5837,9 +5973,19 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] face. */ eassert (XFIXNUM (box) != 0); face->box = FACE_SIMPLE_BOX; - face->box_line_width = XFIXNUM (box); + face->box_vertical_line_width = eabs(XFIXNUM (box)); + face->box_horizontal_line_width = XFIXNUM (box); + face->box_color = face->foreground; + face->box_color_defaulted_p = true; + } + else if (CONSP (box) && FIXNUMP (XCAR (box)) && FIXNUMP (XCDR (box))) + { + /* `(VWIDTH . HWIDTH)'. */ + face->box = FACE_SIMPLE_BOX; face->box_color = face->foreground; face->box_color_defaulted_p = true; + face->box_vertical_line_width = XFIXNUM (XCAR (box)); + face->box_horizontal_line_width = XFIXNUM (XCDR (box)); } else if (CONSP (box)) { @@ -5848,7 +5994,7 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] face->box = FACE_SIMPLE_BOX; face->box_color = face->foreground; face->box_color_defaulted_p = true; - face->box_line_width = 1; + face->box_vertical_line_width = face->box_horizontal_line_width = 1; while (CONSP (box)) { @@ -5864,8 +6010,14 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] if (EQ (keyword, QCline_width)) { - if (FIXNUMP (value) && XFIXNUM (value) != 0) - face->box_line_width = XFIXNUM (value); + if (CONSP (value) && FIXNUMP (XCAR (value)) && FIXNUMP (XCDR (value))) { + face->box_vertical_line_width = XFIXNUM (XCAR (value)); + face->box_horizontal_line_width = XFIXNUM (XCDR (value)); + } + else if (FIXNUMP (value) && XFIXNUM (value) != 0) { + face->box_vertical_line_width = eabs (XFIXNUM (value)); + face->box_horizontal_line_width = XFIXNUM (value); + } } else if (EQ (keyword, QCcolor)) { @@ -5882,6 +6034,10 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] face->box = FACE_RAISED_BOX; else if (EQ (value, Qpressed_button)) face->box = FACE_SUNKEN_BOX; + else if (EQ (value, Qflat_button)) { + face->box = FACE_SIMPLE_BOX; + face->box_color = face->background; + } } } } @@ -6103,6 +6259,8 @@ realize_tty_face (struct face_cache *cache, face->tty_underline_p = true; if (!NILP (attrs[LFACE_INVERSE_INDEX])) face->tty_reverse_p = true; + if (!NILP (attrs[LFACE_STRIKE_THROUGH_INDEX])) + face->tty_strike_through_p = true; /* Map color names to color indices. */ map_tty_color (f, face, LFACE_FOREGROUND_INDEX, &face_colors_defaulted); @@ -6768,6 +6926,7 @@ syms_of_xfaces (void) DEFSYM (Qwave, "wave"); DEFSYM (Qreleased_button, "released-button"); DEFSYM (Qpressed_button, "pressed-button"); + DEFSYM (Qflat_button, "flat-button"); DEFSYM (Qnormal, "normal"); DEFSYM (Qextra_light, "extra-light"); DEFSYM (Qlight, "light"); @@ -6816,6 +6975,7 @@ syms_of_xfaces (void) DEFSYM (Qwindow_divider_first_pixel, "window-divider-first-pixel"); DEFSYM (Qwindow_divider_last_pixel, "window-divider-last-pixel"); DEFSYM (Qinternal_border, "internal-border"); + DEFSYM (Qchild_frame_border, "child-frame-border"); /* TTY color-related functions (defined in tty-colors.el). */ DEFSYM (Qtty_color_desc, "tty-color-desc"); @@ -7011,4 +7171,5 @@ clear the face cache, see `clear-face-cache'. */); defsubr (&Sinternal_face_x_get_resource); defsubr (&Sx_family_fonts); #endif + defsubr (&Scolor_values_from_color_spec); } diff --git a/src/xfns.c b/src/xfns.c index ab04396703e..cac41ee4856 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -1236,13 +1236,10 @@ x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) for (i = 0; i < mouse_cursor_max; i++) { Lisp_Object shape_var = *mouse_cursor_types[i].shape_var_ptr; - if (!NILP (shape_var)) - { - CHECK_TYPE_RANGED_INTEGER (unsigned, shape_var); - cursor_data.cursor_num[i] = XFIXNUM (shape_var); - } - else - cursor_data.cursor_num[i] = mouse_cursor_types[i].default_shape; + cursor_data.cursor_num[i] + = (!NILP (shape_var) + ? check_uinteger_max (shape_var, UINT_MAX) + : mouse_cursor_types[i].default_shape); } block_input (); @@ -1803,14 +1800,33 @@ x_change_tool_bar_height (struct frame *f, int height) #endif /* USE_GTK */ } +static void +x_set_child_frame_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) +{ + int border = check_int_nonnegative (arg); + + if (border != FRAME_CHILD_FRAME_BORDER_WIDTH (f)) + { + f->child_frame_border_width = border; + +#ifdef USE_X_TOOLKIT + if (FRAME_X_OUTPUT (f)->edit_widget) + widget_store_internal_border (FRAME_X_OUTPUT (f)->edit_widget); +#endif + + if (FRAME_X_WINDOW (f)) + { + adjust_frame_size (f, -1, -1, 3, false, Qchild_frame_border_width); + x_clear_under_internal_border (f); + } + } + +} static void x_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { - int border; - - CHECK_TYPE_RANGED_INTEGER (int, arg); - border = max (XFIXNUM (arg), 0); + int border = check_int_nonnegative (arg); if (border != FRAME_INTERNAL_BORDER_WIDTH (f)) { @@ -2327,24 +2343,6 @@ hack_wm_protocols (struct frame *f, Widget widget) static XFontSet xic_create_xfontset (struct frame *); static XIMStyle best_xim_style (XIMStyles *); - -/* Supported XIM styles, ordered by preference. */ - -static const XIMStyle supported_xim_styles[] = -{ - XIMPreeditPosition | XIMStatusArea, - XIMPreeditPosition | XIMStatusNothing, - XIMPreeditPosition | XIMStatusNone, - XIMPreeditNothing | XIMStatusArea, - XIMPreeditNothing | XIMStatusNothing, - XIMPreeditNothing | XIMStatusNone, - XIMPreeditNone | XIMStatusArea, - XIMPreeditNone | XIMStatusNothing, - XIMPreeditNone | XIMStatusNone, - 0, -}; - - #if defined HAVE_X_WINDOWS && defined USE_X_TOOLKIT /* Create an X fontset on frame F with base font name BASE_FONTNAME. */ @@ -2628,15 +2626,8 @@ xic_free_xfontset (struct frame *f) static XIMStyle best_xim_style (XIMStyles *xim) { - int i, j; - int nr_supported = ARRAYELTS (supported_xim_styles); - - for (i = 0; i < nr_supported; ++i) - for (j = 0; j < xim->count_styles; ++j) - if (supported_xim_styles[i] == xim->supported_styles[j]) - return supported_xim_styles[i]; - - /* Return the default style. */ + /* Return the default style. This is what GTK3 uses and + should work fine with all modern input methods. */ return XIMPreeditNothing | XIMStatusNothing; } @@ -3382,10 +3373,12 @@ x_icon (struct frame *f, Lisp_Object parms) = gui_frame_get_and_record_arg (f, parms, Qicon_left, 0, 0, RES_TYPE_NUMBER); Lisp_Object icon_y = gui_frame_get_and_record_arg (f, parms, Qicon_top, 0, 0, RES_TYPE_NUMBER); + int icon_xval, icon_yval; + if (!EQ (icon_x, Qunbound) && !EQ (icon_y, Qunbound)) { - CHECK_TYPE_RANGED_INTEGER (int, icon_x); - CHECK_TYPE_RANGED_INTEGER (int, icon_y); + icon_xval = check_integer_range (icon_x, INT_MIN, INT_MAX); + icon_yval = check_integer_range (icon_y, INT_MIN, INT_MAX); } else if (!EQ (icon_x, Qunbound) || !EQ (icon_y, Qunbound)) error ("Both left and top icon corners of icon must be specified"); @@ -3393,7 +3386,7 @@ x_icon (struct frame *f, Lisp_Object parms) block_input (); if (! EQ (icon_x, Qunbound)) - x_wm_set_icon_position (f, XFIXNUM (icon_x), XFIXNUM (icon_y)); + x_wm_set_icon_position (f, icon_xval, icon_yval); #if false /* gui_display_get_arg removes the visibility parameter as a side effect, but x_create_frame still needs it. */ @@ -3884,8 +3877,6 @@ This function is an internal primitive--use `make-frame' instead. */) #ifdef HAVE_HARFBUZZ register_font_driver (&xfthbfont_driver, f); #endif -#else /* not HAVE_XFT */ - register_font_driver (&ftxfont_driver, f); #endif /* not HAVE_XFT */ #endif /* HAVE_FREETYPE */ #endif /* not USE_CAIRO */ @@ -3928,6 +3919,29 @@ This function is an internal primitive--use `make-frame' instead. */) parms = Fcons (Fcons (Qinternal_border_width, value), parms); } + + /* Same for child frames. */ + if (NILP (Fassq (Qchild_frame_border_width, parms))) + { + Lisp_Object value; + + value = gui_display_get_arg (dpyinfo, parms, Qchild_frame_border_width, + "childFrameBorderWidth", "childFrameBorderWidth", + RES_TYPE_NUMBER); + if (! EQ (value, Qunbound)) + parms = Fcons (Fcons (Qchild_frame_border_width, value), + parms); + + } + + gui_default_parameter (f, parms, Qchild_frame_border_width, +#ifdef USE_GTK /* We used to impose 0 in xg_create_frame_widgets. */ + make_fixnum (0), +#else + make_fixnum (1), +#endif + "childFrameBorderWidth", "childFrameBorderWidth", + RES_TYPE_NUMBER); gui_default_parameter (f, parms, Qinternal_border_width, #ifdef USE_GTK /* We used to impose 0 in xg_create_frame_widgets. */ make_fixnum (0), @@ -5563,12 +5577,12 @@ The coordinates X and Y are interpreted in pixels relative to a position if (FRAME_INITIAL_P (f) || !FRAME_X_P (f)) return Qnil; - CHECK_TYPE_RANGED_INTEGER (int, x); - CHECK_TYPE_RANGED_INTEGER (int, y); + int xval = check_integer_range (x, INT_MIN, INT_MAX); + int yval = check_integer_range (y, INT_MIN, INT_MAX); block_input (); XWarpPointer (FRAME_X_DISPLAY (f), None, DefaultRootWindow (FRAME_X_DISPLAY (f)), - 0, 0, 0, 0, XFIXNUM (x), XFIXNUM (y)); + 0, 0, 0, 0, xval, yval); unblock_input (); return Qnil; @@ -5896,7 +5910,8 @@ If WINDOW-ID is non-nil, change the property of that window instead elsize = element_format == 32 ? sizeof (long) : element_format >> 3; data = xnmalloc (nelements, elsize); - x_fill_property_data (FRAME_X_DISPLAY (f), value, data, element_format); + x_fill_property_data (FRAME_X_DISPLAY (f), value, data, nelements, + element_format); } else { @@ -6202,10 +6217,10 @@ Otherwise, the return value is a vector with the following fields: { XFree (tmp_data); - prop_attr = make_uninit_vector (3); - ASET (prop_attr, 0, make_fixnum (actual_type)); - ASET (prop_attr, 1, make_fixnum (actual_format)); - ASET (prop_attr, 2, make_fixnum (bytes_remaining / (actual_format >> 3))); + prop_attr = CALLN (Fvector, + make_fixnum (actual_type), + make_fixnum (actual_format), + make_fixnum (bytes_remaining / (actual_format >> 3))); } unblock_input (); @@ -6375,8 +6390,6 @@ x_create_tip_frame (struct x_display_info *dpyinfo, Lisp_Object parms) #ifdef HAVE_HARFBUZZ register_font_driver (&xfthbfont_driver, f); #endif -#else /* not HAVE_XFT */ - register_font_driver (&ftxfont_driver, f); #endif /* not HAVE_XFT */ #endif /* HAVE_FREETYPE */ #endif /* not USE_CAIRO */ @@ -6542,7 +6555,7 @@ x_create_tip_frame (struct x_display_info *dpyinfo, Lisp_Object parms) Frame parameters may be changed if .Xdefaults contains specifications for the default font. For example, if there is an `Emacs.default.attributeBackground: pink', the `background-color' - attribute of the frame get's set, which let's the internal border + attribute of the frame gets set, which let's the internal border of the tooltip frame appear in pink. Prevent this. */ { Lisp_Object bg = Fframe_parameter (frame, Qbackground_color); @@ -7048,7 +7061,7 @@ Text larger than the specified size is clipped. */) tip_f = XFRAME (tip_frame); window = FRAME_ROOT_WINDOW (tip_f); - tip_buf = Fget_buffer_create (tip); + tip_buf = Fget_buffer_create (tip, Qnil); /* We will mark the tip window a "pseudo-window" below, and such windows cannot have display margins. */ bset_left_margin_cols (XBUFFER (tip_buf), make_fixnum (0)); @@ -7794,6 +7807,7 @@ frame_parm_handler x_frame_parm_handlers[] = x_set_foreground_color, x_set_icon_name, x_set_icon_type, + x_set_child_frame_border_width, x_set_internal_border_width, gui_set_right_divider_width, gui_set_bottom_divider_width, diff --git a/src/xfont.c b/src/xfont.c index 7a8befdcb60..0570ee96a90 100644 --- a/src/xfont.c +++ b/src/xfont.c @@ -133,7 +133,7 @@ compare_font_names (const void *name1, const void *name2) /* Decode XLFD as iso-8859-1 into OUTPUT, and return the byte length of the decoding result. LEN is the byte length of XLFD, or -1 if - XLFD is NUL terminated. The caller must assure that OUTPUT is at + XLFD is NULL terminated. The caller must assure that OUTPUT is at least twice (plus 1) as large as XLFD. */ static ptrdiff_t @@ -166,7 +166,7 @@ xfont_encode_coding_xlfd (char *xlfd) while (*p0) { - int c = STRING_CHAR_ADVANCE (p0); + int c = string_char_advance (&p0); if (c >= 0x100) return -1; diff --git a/src/xgselect.c b/src/xgselect.c index d7c63e3be10..0d91d55bad6 100644 --- a/src/xgselect.c +++ b/src/xgselect.c @@ -29,6 +29,27 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "blockinput.h" #include "systime.h" +static ptrdiff_t threads_holding_glib_lock; +static GMainContext *glib_main_context; + +void release_select_lock (void) +{ + if (--threads_holding_glib_lock == 0) + g_main_context_release (glib_main_context); +} + +static void acquire_select_lock (GMainContext *context) +{ + if (threads_holding_glib_lock++ == 0) + { + glib_main_context = context; + while (!g_main_context_acquire (context)) + { + /* Spin. */ + } + } +} + /* `xg_select' is a `pselect' replacement. Why do we need a separate function? 1. Timeouts. Glib and Gtk rely on timer events. If we did pselect with a greater timeout then the one scheduled by Glib, we would @@ -54,26 +75,19 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set *efds, GPollFD *gfds = gfds_buf; int gfds_size = ARRAYELTS (gfds_buf); int n_gfds, retval = 0, our_fds = 0, max_fds = fds_lim - 1; - bool context_acquired = false; int i, nfds, tmo_in_millisec, must_free = 0; bool need_to_dispatch; context = g_main_context_default (); - context_acquired = g_main_context_acquire (context); - /* FIXME: If we couldn't acquire the context, we just silently proceed - because this function handles more than just glib file descriptors. - Note that, as implemented, this failure is completely silent: there is - no feedback to the caller. */ + acquire_select_lock (context); if (rfds) all_rfds = *rfds; else FD_ZERO (&all_rfds); if (wfds) all_wfds = *wfds; else FD_ZERO (&all_wfds); - n_gfds = (context_acquired - ? g_main_context_query (context, G_PRIORITY_LOW, &tmo_in_millisec, - gfds, gfds_size) - : -1); + n_gfds = g_main_context_query (context, G_PRIORITY_LOW, &tmo_in_millisec, + gfds, gfds_size); if (gfds_size < n_gfds) { @@ -151,8 +165,10 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set *efds, #else need_to_dispatch = true; #endif - if (need_to_dispatch && context_acquired) + if (need_to_dispatch) { + acquire_select_lock (context); + int pselect_errno = errno; /* Prevent g_main_dispatch recursion, that would occur without block_input wrapper, because event handlers call @@ -162,11 +178,9 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set *efds, g_main_context_dispatch (context); unblock_input (); errno = pselect_errno; + release_select_lock (); } - if (context_acquired) - g_main_context_release (context); - /* To not have to recalculate timeout, return like this. */ if ((our_fds > 0 || (nfds == 0 && tmop == &tmo)) && (retval == 0)) { diff --git a/src/xgselect.h b/src/xgselect.h index e00dce12835..2142a236b23 100644 --- a/src/xgselect.h +++ b/src/xgselect.h @@ -29,4 +29,6 @@ extern int xg_select (int max_fds, fd_set *rfds, fd_set *wfds, fd_set *efds, struct timespec *timeout, sigset_t *sigmask); +extern void release_select_lock (void); + #endif /* XGSELECT_H */ diff --git a/src/xmenu.c b/src/xmenu.c index 7092ecf461e..a83fffbf1ce 100644 --- a/src/xmenu.c +++ b/src/xmenu.c @@ -289,7 +289,7 @@ DEFUN ("x-menu-bar-open-internal", Fx_menu_bar_open_internal, Sx_menu_bar_open_i block_input (); if (FRAME_EXTERNAL_MENU_BAR (f)) - set_frame_menubar (f, false, true); + set_frame_menubar (f, true); menubar = FRAME_X_OUTPUT (f)->menubar_widget; if (menubar) @@ -368,7 +368,7 @@ If FRAME is nil or not given, use the selected frame. */) f = decode_window_system_frame (frame); if (FRAME_EXTERNAL_MENU_BAR (f)) - set_frame_menubar (f, false, true); + set_frame_menubar (f, true); menubar = FRAME_X_OUTPUT (f)->menubar_widget; if (menubar) @@ -433,7 +433,7 @@ x_activate_menubar (struct frame *f) return; #endif - set_frame_menubar (f, false, true); + set_frame_menubar (f, true); block_input (); popup_activated_flag = 1; #ifdef USE_GTK @@ -677,12 +677,10 @@ apply_systemfont_to_menu (struct frame *f, Widget w) #endif -/* Set the contents of the menubar widgets of frame F. - The argument FIRST_TIME is currently ignored; - it is set the first time this is called, from initialize_frame_menubar. */ +/* Set the contents of the menubar widgets of frame F. */ void -set_frame_menubar (struct frame *f, bool first_time, bool deep_p) +set_frame_menubar (struct frame *f, bool deep_p) { xt_or_gtk_widget menubar_widget, old_widget; #ifdef USE_X_TOOLKIT @@ -763,7 +761,7 @@ set_frame_menubar (struct frame *f, bool first_time, bool deep_p) /* Save the frame's previous menu bar contents data. */ if (previous_menu_items_used) - memcpy (previous_items, XVECTOR (f->menu_bar_vector)->contents, + memcpy (previous_items, xvector_contents (f->menu_bar_vector), previous_menu_items_used * word_size); /* Fill in menu_items with the current menu bar contents. @@ -1029,7 +1027,7 @@ initialize_frame_menubar (struct frame *f) /* This function is called before the first chance to redisplay the frame. It has to be, so the frame will have the right size. */ fset_menu_bar_items (f, menu_bar_items (FRAME_MENU_BAR_ITEMS (f))); - set_frame_menubar (f, true, true); + set_frame_menubar (f, true); } diff --git a/src/xrdb.c b/src/xrdb.c index 319f7ab2107..7d84762978f 100644 --- a/src/xrdb.c +++ b/src/xrdb.c @@ -353,7 +353,7 @@ get_environ_db (void) p = filename = xmalloc (strlen (home) + 1 + sizeof xdefaults + 1 + SBYTES (system_name)); char *e = splice_dir_file (p, home, xdefaults); - *e++ = '/'; + *e++ = '-'; lispstpcpy (e, system_name); } } diff --git a/src/xselect.c b/src/xselect.c index ad117983ae7..030f6240712 100644 --- a/src/xselect.c +++ b/src/xselect.c @@ -1594,7 +1594,7 @@ selection_data_to_lisp_data (struct x_display_info *dpyinfo, return x_atom_to_symbol (dpyinfo, (Atom) idata[0]); else { - Lisp_Object v = make_uninit_vector (size / sizeof (int)); + Lisp_Object v = make_nil_vector (size / sizeof (int)); for (i = 0; i < size / sizeof (int); i++) ASET (v, i, x_atom_to_symbol (dpyinfo, (Atom) idata[i])); @@ -1653,7 +1653,7 @@ selection_data_to_lisp_data (struct x_display_info *dpyinfo, else { ptrdiff_t i; - Lisp_Object v = make_uninit_vector (size / X_LONG_SIZE); + Lisp_Object v = make_nil_vector (size / X_LONG_SIZE); if (type == XA_INTEGER) { @@ -1860,7 +1860,7 @@ clean_local_selection_data (Lisp_Object obj) Lisp_Object copy; if (size == 1) return clean_local_selection_data (AREF (obj, 0)); - copy = make_uninit_vector (size); + copy = make_nil_vector (size); for (i = 0; i < size; i++) ASET (copy, i, clean_local_selection_data (AREF (obj, i))); return copy; @@ -2276,23 +2276,28 @@ x_check_property_data (Lisp_Object data) DPY is the display use to look up X atoms. DATA is a Lisp list of values to be converted. - RET is the C array that contains the converted values. It is assumed - it is big enough to hold all values. + RET is the C array that contains the converted values. + NELEMENTS_MAX is the number of values that will fit in RET. + Any excess values in DATA are ignored. FORMAT is 8, 16 or 32 and denotes char/short/long for each C value to be stored in RET. Note that long is used for 32 even if long is more than 32 bits (see man pages for XChangeProperty, XGetWindowProperty and XClientMessageEvent). */ void -x_fill_property_data (Display *dpy, Lisp_Object data, void *ret, int format) +x_fill_property_data (Display *dpy, Lisp_Object data, void *ret, + int nelements_max, int format) { unsigned long val; unsigned long *d32 = (unsigned long *) ret; unsigned short *d16 = (unsigned short *) ret; unsigned char *d08 = (unsigned char *) ret; + int nelements; Lisp_Object iter; - for (iter = data; CONSP (iter); iter = XCDR (iter)) + for (iter = data, nelements = 0; + CONSP (iter) && nelements < nelements_max; + iter = XCDR (iter), nelements++) { Lisp_Object o = XCAR (iter); @@ -2593,7 +2598,9 @@ x_send_client_event (Lisp_Object display, Lisp_Object dest, Lisp_Object from, event.xclient.window = to_root ? FRAME_OUTER_WINDOW (f) : wdest; memset (event.xclient.data.l, 0, sizeof (event.xclient.data.l)); + /* event.xclient.data can hold 20 chars, 10 shorts, or 5 longs. */ x_fill_property_data (dpyinfo->display, values, event.xclient.data.b, + 5 * 32 / event.xclient.format, event.xclient.format); /* If event mask is 0 the event is sent to the client that created diff --git a/src/xterm.c b/src/xterm.c index da2efffccaa..744b80c68a0 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1293,9 +1293,13 @@ x_clear_under_internal_border (struct frame *f) int height = FRAME_PIXEL_HEIGHT (f); int margin = FRAME_TOP_MARGIN_HEIGHT (f); int face_id = - !NILP (Vface_remapping_alist) - ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) - : INTERNAL_BORDER_FACE_ID; + (FRAME_PARENT_FRAME (f) + ? (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, CHILD_FRAME_BORDER_FACE_ID) + : CHILD_FRAME_BORDER_FACE_ID) + : (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) + : INTERNAL_BORDER_FACE_ID)); struct face *face = FACE_FROM_ID_OR_NULL (f, face_id); block_input (); @@ -1360,9 +1364,13 @@ x_after_update_window_line (struct window *w, struct glyph_row *desired_row) { int y = WINDOW_TO_FRAME_PIXEL_Y (w, max (0, desired_row->y)); int face_id = - !NILP (Vface_remapping_alist) - ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) - : INTERNAL_BORDER_FACE_ID; + (FRAME_PARENT_FRAME (f) + ? (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, CHILD_FRAME_BORDER_FACE_ID) + : CHILD_FRAME_BORDER_FACE_ID) + : (!NILP (Vface_remapping_alist) + ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID) + : INTERNAL_BORDER_FACE_ID)); struct face *face = FACE_FROM_ID_OR_NULL (f, face_id); block_input (); @@ -1750,7 +1758,7 @@ x_draw_glyph_string_background (struct glyph_string *s, bool force_p) shouldn't be drawn in the first place. */ if (!s->background_filled_p) { - int box_line_width = max (s->face->box_line_width, 0); + int box_line_width = max (s->face->box_horizontal_line_width, 0); if (s->stippled_p) { @@ -1795,7 +1803,7 @@ x_draw_glyph_string_foreground (struct glyph_string *s) of S to the right of that box line. */ if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) - x = s->x + eabs (s->face->box_line_width); + x = s->x + max (s->face->box_vertical_line_width, 0); else x = s->x; @@ -1845,7 +1853,7 @@ x_draw_glyph_string_foreground (struct glyph_string *s) if (!(s->for_overlaps || (s->background_filled_p && s->hl != DRAW_CURSOR))) { - int box_line_width = max (s->face->box_line_width, 0); + int box_line_width = max (s->face->box_horizontal_line_width, 0); if (s->stippled_p) { @@ -1889,7 +1897,7 @@ x_draw_composite_glyph_string_foreground (struct glyph_string *s) of S to the right of that box line. */ if (s->face && s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) - x = s->x + eabs (s->face->box_line_width); + x = s->x + max (s->face->box_vertical_line_width, 0); else x = s->x; @@ -2000,7 +2008,7 @@ x_draw_glyphless_glyph_string_foreground (struct glyph_string *s) of S to the right of that box line. */ if (s->face && s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) - x = s->x + eabs (s->face->box_line_width); + x = s->x + max (s->face->box_vertical_line_width, 0); else x = s->x; @@ -2376,8 +2384,6 @@ x_query_frame_background_color (struct frame *f, XColor *bgcolor) x_query_colors (f, bgcolor, 1); } -#define HEX_COLOR_NAME_LENGTH 32 - /* On frame F, translate the color name to RGB values. Use cached information, if possible. @@ -2389,44 +2395,23 @@ x_query_frame_background_color (struct frame *f, XColor *bgcolor) Status x_parse_color (struct frame *f, const char *color_name, XColor *color) { + /* Don't pass #RGB strings directly to XParseColor, because that + follows the X convention of zero-extending each channel + value: #f00 means #f00000. We want the convention of scaling + channel values, so #f00 means #ff0000, just as it does for + HTML, SVG, and CSS. */ + unsigned short r, g, b; + if (parse_color_spec (color_name, &r, &g, &b)) + { + color->red = r; + color->green = g; + color->blue = b; + return 1; + } + Display *dpy = FRAME_X_DISPLAY (f); Colormap cmap = FRAME_X_COLORMAP (f); struct color_name_cache_entry *cache_entry; - - if (color_name[0] == '#') - { - /* Don't pass #RGB strings directly to XParseColor, because that - follows the X convention of zero-extending each channel - value: #f00 means #f00000. We want the convention of scaling - channel values, so #f00 means #ff0000, just as it does for - HTML, SVG, and CSS. - - So we translate #f00 to rgb:f/0/0, which X handles - differently. */ - char rgb_color_name[HEX_COLOR_NAME_LENGTH]; - int len = strlen (color_name); - int digits_per_channel; - if (len == 4) - digits_per_channel = 1; - else if (len == 7) - digits_per_channel = 2; - else if (len == 10) - digits_per_channel = 3; - else if (len == 13) - digits_per_channel = 4; - else - return 0; - - snprintf (rgb_color_name, sizeof rgb_color_name, "rgb:%.*s/%.*s/%.*s", - digits_per_channel, color_name + 1, - digits_per_channel, color_name + digits_per_channel + 1, - digits_per_channel, color_name + 2 * digits_per_channel + 1); - - /* The rgb form is parsed directly by XParseColor without - talking to the X server. No need for caching. */ - return XParseColor (dpy, cmap, rgb_color_name, color); - } - for (cache_entry = FRAME_DISPLAY_INFO (f)->color_names; cache_entry; cache_entry = cache_entry->next) { @@ -2765,7 +2750,7 @@ x_setup_relief_colors (struct glyph_string *s) static void x_draw_relief_rect (struct frame *f, int left_x, int top_y, int right_x, int bottom_y, - int width, bool raised_p, bool top_p, bool bot_p, + int hwidth, int vwidth, bool raised_p, bool top_p, bool bot_p, bool left_p, bool right_p, XRectangle *clip_rect) { @@ -2790,7 +2775,7 @@ x_draw_relief_rect (struct frame *f, if (left_p) { x_fill_rectangle (f, top_left_gc, left_x, top_y, - width, bottom_y + 1 - top_y); + vwidth, bottom_y + 1 - top_y); if (top_p) corners |= 1 << CORNER_TOP_LEFT; if (bot_p) @@ -2798,8 +2783,8 @@ x_draw_relief_rect (struct frame *f, } if (right_p) { - x_fill_rectangle (f, bottom_right_gc, right_x + 1 - width, top_y, - width, bottom_y + 1 - top_y); + x_fill_rectangle (f, bottom_right_gc, right_x + 1 - vwidth, top_y, + vwidth, bottom_y + 1 - top_y); if (top_p) corners |= 1 << CORNER_TOP_RIGHT; if (bot_p) @@ -2809,25 +2794,25 @@ x_draw_relief_rect (struct frame *f, { if (!right_p) x_fill_rectangle (f, top_left_gc, left_x, top_y, - right_x + 1 - left_x, width); + right_x + 1 - left_x, hwidth); else x_fill_trapezoid_for_relief (f, top_left_gc, left_x, top_y, - right_x + 1 - left_x, width, 1); + right_x + 1 - left_x, hwidth, 1); } if (bot_p) { if (!left_p) - x_fill_rectangle (f, bottom_right_gc, left_x, bottom_y + 1 - width, - right_x + 1 - left_x, width); + x_fill_rectangle (f, bottom_right_gc, left_x, bottom_y + 1 - hwidth, + right_x + 1 - left_x, hwidth); else x_fill_trapezoid_for_relief (f, bottom_right_gc, - left_x, bottom_y + 1 - width, - right_x + 1 - left_x, width, 0); + left_x, bottom_y + 1 - hwidth, + right_x + 1 - left_x, hwidth, 0); } - if (left_p && width != 1) + if (left_p && vwidth > 1) x_fill_rectangle (f, bottom_right_gc, left_x, top_y, 1, bottom_y + 1 - top_y); - if (top_p && width != 1) + if (top_p && hwidth > 1) x_fill_rectangle (f, bottom_right_gc, left_x, top_y, right_x + 1 - left_x, 1); if (corners) @@ -2861,12 +2846,12 @@ x_draw_relief_rect (struct frame *f, /* Top. */ if (top_p) { - if (width == 1) + if (hwidth == 1) XDrawLine (dpy, drawable, gc, left_x + left_p, top_y, right_x + !right_p, top_y); - for (i = 1; i < width; ++i) + for (i = 1; i < hwidth; ++i) XDrawLine (dpy, drawable, gc, left_x + i * left_p, top_y + i, right_x + 1 - i * right_p, top_y + i); @@ -2875,13 +2860,10 @@ x_draw_relief_rect (struct frame *f, /* Left. */ if (left_p) { - if (width == 1) + if (vwidth == 1) XDrawLine (dpy, drawable, gc, left_x, top_y + 1, left_x, bottom_y); - x_clear_area(f, left_x, top_y, 1, 1); - x_clear_area(f, left_x, bottom_y, 1, 1); - - for (i = (width > 1 ? 1 : 0); i < width; ++i) + for (i = 1; i < vwidth; ++i) XDrawLine (dpy, drawable, gc, left_x + i, top_y + (i + 1) * top_p, left_x + i, bottom_y + 1 - (i + 1) * bot_p); @@ -2894,26 +2876,25 @@ x_draw_relief_rect (struct frame *f, gc = f->output_data.x->white_relief.gc; XSetClipRectangles (dpy, gc, 0, 0, clip_rect, 1, Unsorted); - if (width > 1) - { - /* Outermost top line. */ - if (top_p) - XDrawLine (dpy, drawable, gc, - left_x + left_p, top_y, - right_x + !right_p, top_y); + /* Outermost top line. */ + if (top_p && hwidth > 1) + XDrawLine (dpy, drawable, gc, + left_x + left_p, top_y, + right_x + !right_p, top_y); - /* Outermost left line. */ - if (left_p) - XDrawLine (dpy, drawable, gc, left_x, top_y + 1, left_x, bottom_y); - } + /* Outermost left line. */ + if (left_p && vwidth > 1) + XDrawLine (dpy, drawable, gc, left_x, top_y + 1, left_x, bottom_y); /* Bottom. */ if (bot_p) { - XDrawLine (dpy, drawable, gc, - left_x + left_p, bottom_y, - right_x + !right_p, bottom_y); - for (i = 1; i < width; ++i) + if (hwidth >= 1) + XDrawLine (dpy, drawable, gc, + left_x + left_p, bottom_y, + right_x + !right_p, bottom_y); + + for (i = 1; i < hwidth; ++i) XDrawLine (dpy, drawable, gc, left_x + i * left_p, bottom_y - i, right_x + 1 - i * right_p, bottom_y - i); @@ -2922,9 +2903,7 @@ x_draw_relief_rect (struct frame *f, /* Right. */ if (right_p) { - x_clear_area(f, right_x, top_y, 1, 1); - x_clear_area(f, right_x, bottom_y, 1, 1); - for (i = 0; i < width; ++i) + for (i = 0; i < vwidth; ++i) XDrawLine (dpy, drawable, gc, right_x - i, top_y + (i + 1) * top_p, right_x - i, bottom_y + 1 - (i + 1) * bot_p); @@ -2945,8 +2924,8 @@ x_draw_relief_rect (struct frame *f, static void x_draw_box_rect (struct glyph_string *s, - int left_x, int top_y, int right_x, int bottom_y, int width, - bool left_p, bool right_p, XRectangle *clip_rect) + int left_x, int top_y, int right_x, int bottom_y, int hwidth, + int vwidth, bool left_p, bool right_p, XRectangle *clip_rect) { Display *display = FRAME_X_DISPLAY (s->f); XGCValues xgcv; @@ -2957,21 +2936,21 @@ x_draw_box_rect (struct glyph_string *s, /* Top. */ x_fill_rectangle (s->f, s->gc, - left_x, top_y, right_x - left_x + 1, width); + left_x, top_y, right_x - left_x + 1, hwidth); /* Left. */ if (left_p) x_fill_rectangle (s->f, s->gc, - left_x, top_y, width, bottom_y - top_y + 1); + left_x, top_y, vwidth, bottom_y - top_y + 1); /* Bottom. */ x_fill_rectangle (s->f, s->gc, - left_x, bottom_y - width + 1, right_x - left_x + 1, width); + left_x, bottom_y - hwidth + 1, right_x - left_x + 1, hwidth); /* Right. */ if (right_p) x_fill_rectangle (s->f, s->gc, - right_x - width + 1, top_y, width, bottom_y - top_y + 1); + right_x - vwidth + 1, top_y, vwidth, bottom_y - top_y + 1); XSetForeground (display, s->gc, xgcv.foreground); x_reset_clip_rectangles (s->f, s->gc); @@ -2983,7 +2962,7 @@ x_draw_box_rect (struct glyph_string *s, static void x_draw_glyph_string_box (struct glyph_string *s) { - int width, left_x, right_x, top_y, bottom_y, last_x; + int hwidth, vwidth, left_x, right_x, top_y, bottom_y, last_x; bool raised_p, left_p, right_p; struct glyph *last_glyph; XRectangle clip_rect; @@ -2992,12 +2971,29 @@ x_draw_glyph_string_box (struct glyph_string *s) ? WINDOW_RIGHT_EDGE_X (s->w) : window_box_right (s->w, s->area)); - /* The glyph that may have a right box line. */ - last_glyph = (s->cmp || s->img - ? s->first_glyph - : s->first_glyph + s->nchars - 1); + /* The glyph that may have a right box line. For static + compositions and images, the right-box flag is on the first glyph + of the glyph string; for other types it's on the last glyph. */ + if (s->cmp || s->img) + last_glyph = s->first_glyph; + else if (s->first_glyph->type == COMPOSITE_GLYPH + && s->first_glyph->u.cmp.automatic) + { + /* For automatic compositions, we need to look up the last glyph + in the composition. */ + struct glyph *end = s->row->glyphs[s->area] + s->row->used[s->area]; + struct glyph *g = s->first_glyph; + for (last_glyph = g++; + g < end && g->u.cmp.automatic && g->u.cmp.id == s->cmp_id + && g->slice.cmp.to < s->cmp_to; + last_glyph = g++) + ; + } + else + last_glyph = s->first_glyph + s->nchars - 1; - width = eabs (s->face->box_line_width); + vwidth = eabs (s->face->box_vertical_line_width); + hwidth = eabs (s->face->box_horizontal_line_width); raised_p = s->face->box == FACE_RAISED_BOX; left_x = s->x; right_x = (s->row->full_width_p && s->extends_to_end_of_line_p @@ -3018,13 +3014,13 @@ x_draw_glyph_string_box (struct glyph_string *s) get_glyph_string_clip_rect (s, &clip_rect); if (s->face->box == FACE_SIMPLE_BOX) - x_draw_box_rect (s, left_x, top_y, right_x, bottom_y, width, - left_p, right_p, &clip_rect); + x_draw_box_rect (s, left_x, top_y, right_x, bottom_y, hwidth, + vwidth, left_p, right_p, &clip_rect); else { x_setup_relief_colors (s); - x_draw_relief_rect (s->f, left_x, top_y, right_x, bottom_y, - width, raised_p, true, true, left_p, right_p, + x_draw_relief_rect (s->f, left_x, top_y, right_x, bottom_y, hwidth, + vwidth, raised_p, true, true, left_p, right_p, &clip_rect); } } @@ -3082,7 +3078,7 @@ x_draw_image_foreground (struct glyph_string *s) if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p && s->slice.x == 0) - x += eabs (s->face->box_line_width); + x += max (s->face->box_vertical_line_width, 0); /* If there is a margin around the image, adjust x- and y-position by that margin. */ @@ -3201,7 +3197,7 @@ x_draw_image_relief (struct glyph_string *s) if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p && s->slice.x == 0) - x += eabs (s->face->box_line_width); + x += max (s->face->box_vertical_line_width, 0); /* If there is a margin around the image, adjust x- and y-position by that margin. */ @@ -3269,7 +3265,7 @@ x_draw_image_relief (struct glyph_string *s) x_setup_relief_colors (s); get_glyph_string_clip_rect (s, &r); - x_draw_relief_rect (s->f, x, y, x1, y1, thick, raised_p, + x_draw_relief_rect (s->f, x, y, x1, y1, thick, thick, raised_p, top_p, bot_p, left_p, right_p, &r); } @@ -3288,7 +3284,7 @@ x_draw_image_foreground_1 (struct glyph_string *s, Pixmap pixmap) if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p && s->slice.x == 0) - x += eabs (s->face->box_line_width); + x += max (s->face->box_vertical_line_width, 0); /* If there is a margin around the image, adjust x- and y-position by that margin. */ @@ -3390,8 +3386,8 @@ x_draw_glyph_string_bg_rect (struct glyph_string *s, int x, int y, int w, int h) static void x_draw_image_glyph_string (struct glyph_string *s) { - int box_line_hwidth = eabs (s->face->box_line_width); - int box_line_vwidth = max (s->face->box_line_width, 0); + int box_line_hwidth = max (s->face->box_vertical_line_width, 0); + int box_line_vwidth = max (s->face->box_horizontal_line_width, 0); int height; #ifndef USE_CAIRO Display *display = FRAME_X_DISPLAY (s->f); @@ -3589,14 +3585,29 @@ x_draw_stretch_glyph_string (struct glyph_string *s) else if (!s->background_filled_p) { int background_width = s->background_width; - int x = s->x, left_x = window_box_left_offset (s->w, TEXT_AREA); + int x = s->x, text_left_x = window_box_left_offset (s->w, TEXT_AREA); - /* Don't draw into left margin, fringe or scrollbar area - except for header line and mode line. */ - if (x < left_x && !s->row->mode_line_p) + /* Don't draw into left fringe or scrollbar area except for + header line and mode line. */ + if (x < text_left_x && !s->row->mode_line_p) { - background_width -= left_x - x; - x = left_x; + int left_x = WINDOW_LEFT_SCROLL_BAR_AREA_WIDTH (s->w); + int right_x = text_left_x; + + if (WINDOW_HAS_FRINGES_OUTSIDE_MARGINS (s->w)) + left_x += WINDOW_LEFT_FRINGE_WIDTH (s->w); + else + right_x -= WINDOW_LEFT_FRINGE_WIDTH (s->w); + + /* Adjust X and BACKGROUND_WIDTH to fit inside the space + between LEFT_X and RIGHT_X. */ + if (x < left_x) + { + background_width -= left_x - x; + x = left_x; + } + if (x + background_width > right_x) + background_width = right_x - x; } if (background_width > 0) x_draw_glyph_string_bg_rect (s, x, s->y, background_width, s->height); @@ -4786,6 +4797,16 @@ x_detect_focus_change (struct x_display_info *dpyinfo, struct frame *frame, case FocusIn: case FocusOut: + /* Ignore transient focus events from hotkeys, window manager + gadgets, and other odd sources. Some buggy window managers + (e.g., Muffin 4.2.4) send FocusIn events of this type without + corresponding FocusOut events even when some other window + really has focus, and these kinds of focus event don't + correspond to real user input changes. GTK+ uses the same + filtering. */ + if (event->xfocus.mode == NotifyGrab || + event->xfocus.mode == NotifyUngrab) + return; x_focus_changed (event->type, (event->xfocus.detail == NotifyPointer ? FOCUS_IMPLICIT : FOCUS_EXPLICIT), @@ -8385,10 +8406,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, inev.ie.kind = DEICONIFY_EVENT; XSETFRAME (inev.ie.frame_or_window, f); } - else if (! NILP (Vframe_list) && ! NILP (XCDR (Vframe_list))) - /* Force a redisplay sooner or later to update the - frame titles in case this is the second frame. */ - record_asynch_buffer_change (); } goto OTHER; @@ -8701,7 +8718,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (nchars == nbytes) ch = copy_bufptr[i], len = 1; else - ch = STRING_CHAR_AND_LENGTH (copy_bufptr + i, len); + ch = string_char_and_length (copy_bufptr + i, &len); inev.ie.kind = (SINGLE_BYTE_CHAR_P (ch) ? ASCII_KEYSTROKE_EVENT : MULTIBYTE_CHAR_KEYSTROKE_EVENT); @@ -8951,8 +8968,11 @@ handle_one_xevent (struct x_display_info *dpyinfo, #endif #ifdef USE_GTK if (!f - && (f = any) - && configureEvent.xconfigure.window == FRAME_X_WINDOW (f)) + && (f = any) + && configureEvent.xconfigure.window == FRAME_X_WINDOW (f) + && (FRAME_VISIBLE_P(f) + || !(configureEvent.xconfigure.width <= 1 + && configureEvent.xconfigure.height <= 1))) { block_input (); if (FRAME_X_DOUBLE_BUFFERED_P (f)) @@ -8965,10 +8985,13 @@ handle_one_xevent (struct x_display_info *dpyinfo, configureEvent.xconfigure.height); #endif f = 0; - } + } #endif - if (f) - { + if (f + && (FRAME_VISIBLE_P(f) + || !(configureEvent.xconfigure.width <= 1 + && configureEvent.xconfigure.height <= 1))) + { #ifdef USE_GTK /* For GTK+ don't call x_net_wm_state for the scroll bar window. (Bug#24963, Bug#25887) */ @@ -9058,7 +9081,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, xic_set_statusarea (f); #endif - } + } goto OTHER; case ButtonRelease: @@ -9706,7 +9729,7 @@ x_draw_window_cursor (struct window *w, struct glyph_row *glyph_row, int x, #ifdef HAVE_X_I18N if (w == XWINDOW (f->selected_window)) - if (FRAME_XIC (f) && (FRAME_XIC_STYLE (f) & XIMPreeditPosition)) + if (FRAME_XIC (f)) xic_set_preeditarea (w, x, y); #endif } @@ -9923,6 +9946,13 @@ x_uncatch_errors (void) { struct x_error_message_stack *tmp; + /* In rare situations when running Emacs run in daemon mode, + shutting down an emacsclient via delete-frame can cause + x_uncatch_errors to be called when x_error_message is set to + NULL. */ + if (x_error_message == NULL) + return; + block_input (); /* The display may have been closed before this function is called. @@ -10382,11 +10412,8 @@ xim_instantiate_callback (Display *display, XPointer client_data, XPointer call_ create_frame_xic (f); if (FRAME_XIC_STYLE (f) & XIMStatusArea) xic_set_statusarea (f); - if (FRAME_XIC_STYLE (f) & XIMPreeditPosition) - { - struct window *w = XWINDOW (f->selected_window); - xic_set_preeditarea (w, w->cursor.x, w->cursor.y); - } + struct window *w = XWINDOW (f->selected_window); + xic_set_preeditarea (w, w->cursor.x, w->cursor.y); } } @@ -12922,19 +12949,23 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) #endif Lisp_Object system_name = Fsystem_name (); - - ptrdiff_t nbytes = SBYTES (Vinvocation_name) + 1; - if (STRINGP (system_name) - && INT_ADD_WRAPV (nbytes, SBYTES (system_name) + 1, &nbytes)) - memory_full (SIZE_MAX); - dpyinfo->x_id = ++x_display_id; - dpyinfo->x_id_name = xmalloc (nbytes); - char *nametail = lispstpcpy (dpyinfo->x_id_name, Vinvocation_name); + static char const title[] = "GNU Emacs"; if (STRINGP (system_name)) { - *nametail++ = '@'; - lispstpcpy (nametail, system_name); + static char const at[] = " at "; + ptrdiff_t nbytes = sizeof (title) + sizeof (at); + if (INT_ADD_WRAPV (nbytes, SBYTES (system_name), &nbytes)) + memory_full (SIZE_MAX); + dpyinfo->x_id_name = xmalloc (nbytes); + sprintf (dpyinfo->x_id_name, "%s%s%s", title, at, SDATA (system_name)); } + else + { + dpyinfo->x_id_name = xmalloc (sizeof (title)); + strcpy (dpyinfo->x_id_name, title); + } + + dpyinfo->x_id = ++x_display_id; /* Figure out which modifier bits mean what. */ x_find_modifier_meanings (dpyinfo); @@ -13027,13 +13058,13 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) or larger than other for other applications, even if it is the same font name (monospace-10 for example). */ +# ifdef HAVE_XRENDER int event_base, error_base; - char *v; - double d; - XRenderQueryExtension (dpyinfo->display, &event_base, &error_base); +# endif - v = XGetDefault (dpyinfo->display, "Xft", "dpi"); + char *v = XGetDefault (dpyinfo->display, "Xft", "dpi"); + double d; if (v != NULL && sscanf (v, "%lf", &d) == 1) dpyinfo->resy = dpyinfo->resx = d; } diff --git a/src/xterm.h b/src/xterm.h index 488aa98f9ef..ebc42b7dd55 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -890,7 +890,7 @@ struct scroll_bar editing large files, we establish a minimum height by always drawing handle bottoms VERTICAL_SCROLL_BAR_MIN_HANDLE pixels below where they would be normally; the bottom and top are in a - different co-ordinate system. */ + different coordinate system. */ int start, end; /* If the scroll bar handle is currently being dragged by the user, @@ -1207,6 +1207,7 @@ extern int x_check_property_data (Lisp_Object); extern void x_fill_property_data (Display *, Lisp_Object, void *, + int, int); extern Lisp_Object x_property_data_to_lisp (struct frame *, const unsigned char *, diff --git a/src/xwidget.c b/src/xwidget.c index f57bc355fa3..e4b42e6e0c6 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -23,13 +23,21 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "lisp.h" #include "blockinput.h" +#include "dispextern.h" #include "frame.h" #include "keyboard.h" #include "gtkutil.h" #include "sysstdio.h" +#include "termhooks.h" +#include "window.h" +/* Include xwidget bottom end headers. */ +#ifdef USE_GTK #include <webkit2/webkit2.h> #include <JavaScriptCore/JavaScript.h> +#elif defined NS_IMPL_COCOA +#include "nsxwidget.h" +#endif static struct xwidget * allocate_xwidget (void) @@ -48,6 +56,7 @@ allocate_xwidget_view (void) static struct xwidget_view *xwidget_view_lookup (struct xwidget *, struct window *); +#ifdef USE_GTK static void webkit_view_load_changed_cb (WebKitWebView *, WebKitLoadEvent, gpointer); @@ -61,6 +70,7 @@ webkit_decide_policy_cb (WebKitWebView *, WebKitPolicyDecision *, WebKitPolicyDecisionType, gpointer); +#endif DEFUN ("make-xwidget", @@ -78,8 +88,10 @@ Returns the newly constructed xwidget, or nil if construction fails. */) Lisp_Object title, Lisp_Object width, Lisp_Object height, Lisp_Object arguments, Lisp_Object buffer) { +#ifdef USE_GTK if (!xg_gtk_initialized) error ("make-xwidget: GTK has not been initialized"); +#endif CHECK_SYMBOL (type); CHECK_FIXNAT (width); CHECK_FIXNAT (height); @@ -88,16 +100,18 @@ Returns the newly constructed xwidget, or nil if construction fails. */) Lisp_Object val; xw->type = type; xw->title = title; - xw->buffer = NILP (buffer) ? Fcurrent_buffer () : Fget_buffer_create (buffer); + xw->buffer = (NILP (buffer) ? Fcurrent_buffer () + : Fget_buffer_create (buffer, Qnil)); xw->height = XFIXNAT (height); xw->width = XFIXNAT (width); xw->kill_without_query = false; XSETXWIDGET (val, xw); Vxwidget_list = Fcons (val, Vxwidget_list); - xw->widgetwindow_osr = NULL; - xw->widget_osr = NULL; xw->plist = Qnil; +#ifdef USE_GTK + xw->widgetwindow_osr = NULL; + xw->widget_osr = NULL; if (EQ (xw->type, Qwebkit)) { block_input (); @@ -115,6 +129,16 @@ Returns the newly constructed xwidget, or nil if construction fails. */) if (EQ (xw->type, Qwebkit)) { xw->widget_osr = webkit_web_view_new (); + + /* webkitgtk uses GSubprocess which sets sigaction causing + Emacs to not catch SIGCHLD with its usual handle setup in + catch_child_signal(). This resets the SIGCHLD + sigaction. */ + struct sigaction old_action; + sigaction (SIGCHLD, NULL, &old_action); + webkit_web_view_load_uri(WEBKIT_WEB_VIEW (xw->widget_osr), + "about:blank"); + sigaction (SIGCHLD, &old_action, NULL); } gtk_widget_set_size_request (GTK_WIDGET (xw->widget_osr), xw->width, @@ -159,6 +183,9 @@ Returns the newly constructed xwidget, or nil if construction fails. */) unblock_input (); } +#elif defined NS_IMPL_COCOA + nsxwidget_init (xw); +#endif return val; } @@ -194,6 +221,7 @@ xwidget_hidden (struct xwidget_view *xv) return xv->hidden; } +#ifdef USE_GTK static void xwidget_show_view (struct xwidget_view *xv) { @@ -227,13 +255,14 @@ offscreen_damage_event (GtkWidget *widget, GdkEvent *event, if (GTK_IS_WIDGET (xv_widget)) gtk_widget_queue_draw (GTK_WIDGET (xv_widget)); else - printf ("Warning, offscreen_damage_event received invalid xv pointer:%p\n", - xv_widget); + message ("Warning, offscreen_damage_event received invalid xv pointer:%p\n", + xv_widget); return FALSE; } +#endif /* USE_GTK */ -static void +void store_xwidget_event_string (struct xwidget *xw, const char *eventname, const char *eventstr) { @@ -247,7 +276,27 @@ store_xwidget_event_string (struct xwidget *xw, const char *eventname, kbd_buffer_store_event (&event); } -static void +void +store_xwidget_download_callback_event (struct xwidget *xw, + const char *url, + const char *mimetype, + const char *filename) +{ + struct input_event event; + Lisp_Object xwl; + XSETXWIDGET (xwl, xw); + EVENT_INIT (event); + event.kind = XWIDGET_EVENT; + event.frame_or_window = Qnil; + event.arg = list5 (intern ("download-callback"), + xwl, + build_string (url), + build_string (mimetype), + build_string (filename)); + kbd_buffer_store_event (&event); +} + +void store_xwidget_js_callback_event (struct xwidget *xw, Lisp_Object proc, Lisp_Object argument) @@ -263,6 +312,7 @@ store_xwidget_js_callback_event (struct xwidget *xw, } +#ifdef USE_GTK void webkit_view_load_changed_cb (WebKitWebView *webkitwebview, WebKitLoadEvent load_event, @@ -311,7 +361,7 @@ webkit_js_to_lisp (JSCValue *value) memory_full (SIZE_MAX); ptrdiff_t n = dlen; - struct Lisp_Vector *p = allocate_vector (n); + struct Lisp_Vector *p = allocate_nil_vector (n); for (ptrdiff_t i = 0; i < n; ++i) { @@ -329,7 +379,7 @@ webkit_js_to_lisp (JSCValue *value) Lisp_Object obj; if (PTRDIFF_MAX < n) memory_full (n); - struct Lisp_Vector *p = allocate_vector (n); + struct Lisp_Vector *p = allocate_nil_vector (n); for (ptrdiff_t i = 0; i < n; ++i) { @@ -493,6 +543,7 @@ xwidget_osr_event_set_embedder (GtkWidget *widget, GdkEvent *event, gtk_widget_get_window (xv->widget)); return FALSE; } +#endif /* USE_GTK */ /* Initializes and does initial placement of an xwidget view on screen. */ @@ -502,8 +553,10 @@ xwidget_init_view (struct xwidget *xww, int x, int y) { +#ifdef USE_GTK if (!xg_gtk_initialized) error ("xwidget_init_view: GTK has not been initialized"); +#endif struct xwidget_view *xv = allocate_xwidget_view (); Lisp_Object val; @@ -514,6 +567,7 @@ xwidget_init_view (struct xwidget *xww, XSETWINDOW (xv->w, s->w); XSETXWIDGET (xv->model, xww); +#ifdef USE_GTK if (EQ (xww->type, Qwebkit)) { xv->widget = gtk_drawing_area_new (); @@ -571,6 +625,10 @@ xwidget_init_view (struct xwidget *xww, xv->x = x; xv->y = y; gtk_widget_show_all (xv->widgetwindow); +#elif defined NS_IMPL_COCOA + nsxwidget_init_view (xv, xww, s, x, y); + nsxwidget_resize_view(xv, xww->width, xww->height); +#endif return xv; } @@ -583,6 +641,7 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) initialization. */ struct xwidget *xww = s->xwidget; struct xwidget_view *xv = xwidget_view_lookup (xww, s->w); + int text_area_x, text_area_y, text_area_width, text_area_height; int clip_right; int clip_bottom; int clip_top; @@ -594,13 +653,47 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) /* Do initialization here in the display loop because there is no other time to know things like window placement etc. Do not create a new view if we have found one that is usable. */ +#ifdef USE_GTK if (!xv) xv = xwidget_init_view (xww, s, x, y); - - int text_area_x, text_area_y, text_area_width, text_area_height; +#elif defined NS_IMPL_COCOA + if (!xv) + { + /* Enforce 1 to 1, model and view for macOS Cocoa webkit2. */ + if (xww->xv) + { + if (xwidget_hidden (xww->xv)) + { + Lisp_Object xvl; + XSETXWIDGET_VIEW (xvl, xww->xv); + Fdelete_xwidget_view (xvl); + } + else + { + message ("You can't share an xwidget (webkit2) among windows."); + return; + } + } + xv = xwidget_init_view (xww, s, x, y); + } +#endif window_box (s->w, TEXT_AREA, &text_area_x, &text_area_y, &text_area_width, &text_area_height); + + /* Resize xwidget webkit if its container window size is changed in + some ways, for example, a buffer became hidden in small split + window, then it can appear front in merged whole window. */ + if (EQ (xww->type, Qwebkit) + && (xww->width != text_area_width || xww->height != text_area_height)) + { + Lisp_Object xwl; + XSETXWIDGET (xwl, xww); + Fxwidget_resize (xwl, + make_int (text_area_width), + make_int (text_area_height)); + } + clip_left = max (0, text_area_x - x); clip_right = max (clip_left, min (xww->width, text_area_x + text_area_width - x)); @@ -623,8 +716,14 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) /* Has it moved? */ if (moved) - gtk_fixed_move (GTK_FIXED (FRAME_GTK_WIDGET (s->f)), - xv->widgetwindow, x + clip_left, y + clip_top); + { +#ifdef USE_GTK + gtk_fixed_move (GTK_FIXED (FRAME_GTK_WIDGET (s->f)), + xv->widgetwindow, x + clip_left, y + clip_top); +#elif defined NS_IMPL_COCOA + nsxwidget_move_view (xv, x + clip_left, y + clip_top); +#endif + } /* Clip the widget window if some parts happen to be outside drawable area. An Emacs window is not a gtk window. A gtk window @@ -635,10 +734,16 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) || xv->clip_bottom != clip_bottom || xv->clip_top != clip_top || xv->clip_left != clip_left) { +#ifdef USE_GTK gtk_widget_set_size_request (xv->widgetwindow, clip_right - clip_left, clip_bottom - clip_top); gtk_fixed_move (GTK_FIXED (xv->widgetwindow), xv->widget, -clip_left, -clip_top); +#elif defined NS_IMPL_COCOA + nsxwidget_resize_view (xv, clip_right - clip_left, + clip_bottom - clip_top); + nsxwidget_move_widget_in_view (xv, -clip_left, -clip_top); +#endif xv->clip_right = clip_right; xv->clip_bottom = clip_bottom; @@ -652,22 +757,68 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) xwidgets background. It's just a visual glitch though. */ if (!xwidget_hidden (xv)) { +#ifdef USE_GTK gtk_widget_queue_draw (xv->widgetwindow); gtk_widget_queue_draw (xv->widget); +#elif defined NS_IMPL_COCOA + nsxwidget_set_needsdisplay (xv); +#endif } } -/* Macro that checks WEBKIT_IS_WEB_VIEW (xw->widget_osr) first. */ +static bool +xwidget_is_web_view (struct xwidget *xw) +{ +#ifdef USE_GTK + return xw->widget_osr != NULL && WEBKIT_IS_WEB_VIEW (xw->widget_osr); +#elif defined NS_IMPL_COCOA + return nsxwidget_is_web_view (xw); +#endif +} + +/* Macro that checks xwidget hold webkit web view first. */ #define WEBKIT_FN_INIT() \ CHECK_XWIDGET (xwidget); \ struct xwidget *xw = XXWIDGET (xwidget); \ - if (!xw->widget_osr || !WEBKIT_IS_WEB_VIEW (xw->widget_osr)) \ + if (!xwidget_is_web_view (xw)) \ { \ fputs ("ERROR xw->widget_osr does not hold a webkit instance\n", \ stdout); \ return Qnil; \ } +DEFUN ("xwidget-webkit-uri", + Fxwidget_webkit_uri, Sxwidget_webkit_uri, + 1, 1, 0, + doc: /* Get the current URL of XWIDGET webkit. */) + (Lisp_Object xwidget) +{ + WEBKIT_FN_INIT (); +#ifdef USE_GTK + WebKitWebView *wkwv = WEBKIT_WEB_VIEW (xw->widget_osr); + return build_string (webkit_web_view_get_uri (wkwv)); +#elif defined NS_IMPL_COCOA + return nsxwidget_webkit_uri (xw); +#endif +} + +DEFUN ("xwidget-webkit-title", + Fxwidget_webkit_title, Sxwidget_webkit_title, + 1, 1, 0, + doc: /* Get the current title of XWIDGET webkit. */) + (Lisp_Object xwidget) +{ + WEBKIT_FN_INIT (); +#ifdef USE_GTK + WebKitWebView *wkwv = WEBKIT_WEB_VIEW (xw->widget_osr); + const gchar *title = webkit_web_view_get_title (wkwv); + + return build_string (title ? title : ""); +#elif defined NS_IMPL_COCOA + return nsxwidget_webkit_title (xw); +#endif +} + DEFUN ("xwidget-webkit-goto-uri", Fxwidget_webkit_goto_uri, Sxwidget_webkit_goto_uri, 2, 2, 0, @@ -677,7 +828,36 @@ DEFUN ("xwidget-webkit-goto-uri", WEBKIT_FN_INIT (); CHECK_STRING (uri); uri = ENCODE_FILE (uri); +#ifdef USE_GTK webkit_web_view_load_uri (WEBKIT_WEB_VIEW (xw->widget_osr), SSDATA (uri)); +#elif defined NS_IMPL_COCOA + nsxwidget_webkit_goto_uri (xw, SSDATA (uri)); +#endif + return Qnil; +} + +DEFUN ("xwidget-webkit-goto-history", + Fxwidget_webkit_goto_history, Sxwidget_webkit_goto_history, + 2, 2, 0, + doc: /* Make the XWIDGET webkit load REL-POS (-1, 0, 1) page in browse history. */) + (Lisp_Object xwidget, Lisp_Object rel_pos) +{ + WEBKIT_FN_INIT (); + /* Should be one of -1, 0, 1 */ + if (XFIXNUM (rel_pos) < -1 || XFIXNUM (rel_pos) > 1) + args_out_of_range_3 (rel_pos, make_fixnum (-1), make_fixnum (1)); + +#ifdef USE_GTK + WebKitWebView *wkwv = WEBKIT_WEB_VIEW (xw->widget_osr); + switch (XFIXNAT (rel_pos)) + { + case -1: webkit_web_view_go_back (wkwv); break; + case 0: webkit_web_view_reload (wkwv); break; + case 1: webkit_web_view_go_forward (wkwv); break; + } +#elif defined NS_IMPL_COCOA + nsxwidget_webkit_goto_history (xw, XFIXNAT (rel_pos)); +#endif return Qnil; } @@ -691,14 +871,19 @@ DEFUN ("xwidget-webkit-zoom", if (FLOATP (factor)) { double zoom_change = XFLOAT_DATA (factor); +#ifdef USE_GTK webkit_web_view_set_zoom_level (WEBKIT_WEB_VIEW (xw->widget_osr), webkit_web_view_get_zoom_level (WEBKIT_WEB_VIEW (xw->widget_osr)) + zoom_change); +#elif defined NS_IMPL_COCOA + nsxwidget_webkit_zoom (xw, zoom_change); +#endif } return Qnil; } +#ifdef USE_GTK /* Save script and fun in the script/callback save vector and return its index. */ static ptrdiff_t @@ -720,6 +905,7 @@ save_script_callback (struct xwidget *xw, Lisp_Object script, Lisp_Object fun) ASET (cbs, idx, Fcons (make_mint_ptr (xlispstrdup (script)), fun)); return idx; } +#endif DEFUN ("xwidget-webkit-execute-script", Fxwidget_webkit_execute_script, Sxwidget_webkit_execute_script, @@ -736,6 +922,7 @@ argument procedure FUN.*/) script = ENCODE_SYSTEM (script); +#ifdef USE_GTK /* Protect script and fun during GC. */ intptr_t idx = save_script_callback (xw, script, fun); @@ -749,6 +936,9 @@ argument procedure FUN.*/) NULL, /* cancelable */ webkit_javascript_finished_cb, (gpointer) idx); +#elif defined NS_IMPL_COCOA + nsxwidget_webkit_execute_script (xw, SSDATA (script), fun); +#endif return Qnil; } @@ -757,16 +947,15 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0, (Lisp_Object xwidget, Lisp_Object new_width, Lisp_Object new_height) { CHECK_XWIDGET (xwidget); - CHECK_RANGED_INTEGER (new_width, 0, INT_MAX); - CHECK_RANGED_INTEGER (new_height, 0, INT_MAX); + int w = check_integer_range (new_width, 0, INT_MAX); + int h = check_integer_range (new_height, 0, INT_MAX); struct xwidget *xw = XXWIDGET (xwidget); - int w = XFIXNAT (new_width); - int h = XFIXNAT (new_height); xw->width = w; xw->height = h; /* If there is an offscreen widget resize it first. */ +#ifdef USE_GTK if (xw->widget_osr) { gtk_window_resize (GTK_WINDOW (xw->widgetwindow_osr), xw->width, @@ -775,6 +964,9 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0, gtk_widget_set_size_request (GTK_WIDGET (xw->widget_osr), xw->width, xw->height); } +#elif defined NS_IMPL_COCOA + nsxwidget_resize (xw); +#endif for (Lisp_Object tail = Vxwidget_view_list; CONSP (tail); tail = XCDR (tail)) { @@ -782,8 +974,14 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0, { struct xwidget_view *xv = XXWIDGET_VIEW (XCAR (tail)); if (XXWIDGET (xv->model) == xw) + { +#ifdef USE_GTK gtk_widget_set_size_request (GTK_WIDGET (xv->widget), xw->width, xw->height); +#elif defined NS_IMPL_COCOA + nsxwidget_resize_view(xv, xw->width, xw->height); +#endif + } } } @@ -802,9 +1000,13 @@ Emacs allocated area accordingly. */) (Lisp_Object xwidget) { CHECK_XWIDGET (xwidget); +#ifdef USE_GTK GtkRequisition requisition; gtk_widget_size_request (XXWIDGET (xwidget)->widget_osr, &requisition); return list2i (requisition.width, requisition.height); +#elif defined NS_IMPL_COCOA + return nsxwidget_get_size (XXWIDGET (xwidget)); +#endif } DEFUN ("xwidgetp", @@ -881,14 +1083,19 @@ DEFUN ("delete-xwidget-view", { CHECK_XWIDGET_VIEW (xwidget_view); struct xwidget_view *xv = XXWIDGET_VIEW (xwidget_view); +#ifdef USE_GTK gtk_widget_destroy (xv->widgetwindow); - Vxwidget_view_list = Fdelq (xwidget_view, Vxwidget_view_list); /* xv->model still has signals pointing to the view. There can be several views. Find the matching signals and delete them all. */ g_signal_handlers_disconnect_matched (XXWIDGET (xv->model)->widgetwindow_osr, G_SIGNAL_MATCH_DATA, 0, 0, 0, 0, xv->widget); +#elif defined NS_IMPL_COCOA + nsxwidget_delete_view (xv); +#endif + + Vxwidget_view_list = Fdelq (xwidget_view, Vxwidget_view_list); return Qnil; } @@ -994,7 +1201,10 @@ syms_of_xwidget (void) defsubr (&Sxwidget_query_on_exit_flag); defsubr (&Sset_xwidget_query_on_exit_flag); + defsubr (&Sxwidget_webkit_uri); + defsubr (&Sxwidget_webkit_title); defsubr (&Sxwidget_webkit_goto_uri); + defsubr (&Sxwidget_webkit_goto_history); defsubr (&Sxwidget_webkit_zoom); defsubr (&Sxwidget_webkit_execute_script); DEFSYM (Qwebkit, "webkit"); @@ -1165,11 +1375,19 @@ xwidget_end_redisplay (struct window *w, struct glyph_matrix *matrix) xwidget_end_redisplay (w->current_matrix); */ struct xwidget_view *xv = xwidget_view_lookup (glyph->u.xwidget, w); +#ifdef USE_GTK /* FIXME: Is it safe to assume xwidget_view_lookup always succeeds here? If so, this comment can be removed. If not, the code probably needs fixing. */ eassume (xv); xwidget_touch (xv); +#elif defined NS_IMPL_COCOA + /* In NS xwidget, xv can be NULL for the second or + later views for a model, the result of 1 to 1 + model view relation enforcement. */ + if (xv) + xwidget_touch (xv); +#endif } } } @@ -1186,9 +1404,21 @@ xwidget_end_redisplay (struct window *w, struct glyph_matrix *matrix) if (XWINDOW (xv->w) == w) { if (xwidget_touched (xv)) - xwidget_show_view (xv); + { +#ifdef USE_GTK + xwidget_show_view (xv); +#elif defined NS_IMPL_COCOA + nsxwidget_show_view (xv); +#endif + } else - xwidget_hide_view (xv); + { +#ifdef USE_GTK + xwidget_hide_view (xv); +#elif defined NS_IMPL_COCOA + nsxwidget_hide_view (xv); +#endif + } } } } @@ -1207,6 +1437,7 @@ kill_buffer_xwidgets (Lisp_Object buffer) { CHECK_XWIDGET (xwidget); struct xwidget *xw = XXWIDGET (xwidget); +#ifdef USE_GTK if (xw->widget_osr && xw->widgetwindow_osr) { gtk_widget_destroy (xw->widget_osr); @@ -1220,6 +1451,9 @@ kill_buffer_xwidgets (Lisp_Object buffer) xfree (xmint_pointer (XCAR (cb))); ASET (xw->script_callbacks, idx, Qnil); } +#elif defined NS_IMPL_COCOA + nsxwidget_kill (xw); +#endif } } } diff --git a/src/xwidget.h b/src/xwidget.h index 249416aaa6d..591f23489db 100644 --- a/src/xwidget.h +++ b/src/xwidget.h @@ -29,7 +29,13 @@ struct xwidget_view; struct window; #ifdef HAVE_XWIDGETS -# include <gtk/gtk.h> + +#if defined (USE_GTK) +#include <gtk/gtk.h> +#elif defined (NS_IMPL_COCOA) && defined (__OBJC__) +#import <AppKit/NSView.h> +#import "nsxwidget.h" +#endif struct xwidget { @@ -54,9 +60,25 @@ struct xwidget int height; int width; +#if defined (USE_GTK) /* For offscreen widgets, unused if not osr. */ GtkWidget *widget_osr; GtkWidget *widgetwindow_osr; +#elif defined (NS_IMPL_COCOA) +# ifdef __OBJC__ + /* For offscreen widgets, unused if not osr. */ + NSView *xwWidget; + XwWindow *xwWindow; + + /* Used only for xwidget types (such as webkit2) enforcing 1 to 1 + relationship between model and view. */ + struct xwidget_view *xv; +# else + void *xwWidget; + void *xwWindow; + struct xwidget_view *xv; +# endif +#endif /* Kill silently if Emacs is exited. */ bool_bf kill_without_query : 1; @@ -75,9 +97,20 @@ struct xwidget_view /* The "live" instance isn't drawn. */ bool hidden; +#if defined (USE_GTK) GtkWidget *widget; GtkWidget *widgetwindow; GtkWidget *emacswindow; +#elif defined (NS_IMPL_COCOA) +# ifdef __OBJC__ + XvWindow *xvWindow; + NSView *emacswindow; +# else + void *xvWindow; + void *emacswindow; +# endif +#endif + int x; int y; int clip_right; @@ -116,6 +149,19 @@ void x_draw_xwidget_glyph_string (struct glyph_string *); struct xwidget *lookup_xwidget (Lisp_Object spec); void xwidget_end_redisplay (struct window *, struct glyph_matrix *); void kill_buffer_xwidgets (Lisp_Object); +/* Defined in 'xwidget.c'. */ +void store_xwidget_event_string (struct xwidget *xw, + const char *eventname, + const char *eventstr); + +void store_xwidget_download_callback_event (struct xwidget *xw, + const char *url, + const char *mimetype, + const char *filename); + +void store_xwidget_js_callback_event (struct xwidget *xw, + Lisp_Object proc, + Lisp_Object argument); #else INLINE_HEADER_BEGIN INLINE void syms_of_xwidget (void) {} |