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 | 19 | ||||
| -rw-r--r-- | src/alloc.c | 1088 | ||||
| -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 | 160 | ||||
| -rw-r--r-- | src/buffer.h | 157 | ||||
| -rw-r--r-- | src/bytecode.c | 50 | ||||
| -rw-r--r-- | src/callint.c | 6 | ||||
| -rw-r--r-- | src/callproc.c | 18 | ||||
| -rw-r--r-- | src/casefiddle.c | 32 | ||||
| -rw-r--r-- | src/ccl.c | 128 | ||||
| -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 | 19 | ||||
| -rw-r--r-- | src/coding.c | 283 | ||||
| -rw-r--r-- | src/coding.h | 10 | ||||
| -rw-r--r-- | src/composite.c | 108 | ||||
| -rw-r--r-- | src/composite.h | 12 | ||||
| -rw-r--r-- | src/conf_post.h | 109 | ||||
| -rw-r--r-- | src/data.c | 208 | ||||
| -rw-r--r-- | src/dbusbind.c | 377 | ||||
| -rw-r--r-- | src/deps.mk | 3 | ||||
| -rw-r--r-- | src/dired.c | 59 | ||||
| -rw-r--r-- | src/dispextern.h | 70 | ||||
| -rw-r--r-- | src/dispnew.c | 74 | ||||
| -rw-r--r-- | src/doc.c | 331 | ||||
| -rw-r--r-- | src/doprnt.c | 240 | ||||
| -rw-r--r-- | src/editfns.c | 290 | ||||
| -rw-r--r-- | src/emacs-module.c | 285 | ||||
| -rw-r--r-- | src/emacs-module.h.in | 52 | ||||
| -rw-r--r-- | src/emacs.c | 94 | ||||
| -rw-r--r-- | src/eval.c | 85 | ||||
| -rw-r--r-- | src/fileio.c | 171 | ||||
| -rw-r--r-- | src/filelock.c | 35 | ||||
| -rw-r--r-- | src/fns.c | 507 | ||||
| -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 | 157 | ||||
| -rw-r--r-- | src/frame.h | 49 | ||||
| -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 | 20 | ||||
| -rw-r--r-- | src/gtkutil.c | 18 | ||||
| -rw-r--r-- | src/hbfont.c | 11 | ||||
| -rw-r--r-- | src/image.c | 672 | ||||
| -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 | 194 | ||||
| -rw-r--r-- | src/keymap.c | 741 | ||||
| -rw-r--r-- | src/keymap.h | 2 | ||||
| -rw-r--r-- | src/kqueue.c | 5 | ||||
| -rw-r--r-- | src/lcms.c | 7 | ||||
| -rw-r--r-- | src/lisp.h | 330 | ||||
| -rw-r--r-- | src/lread.c | 246 | ||||
| -rw-r--r-- | src/macfont.m | 97 | ||||
| -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 | 182 | ||||
| -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 | 272 | ||||
| -rw-r--r-- | src/nsfont.m | 254 | ||||
| -rw-r--r-- | src/nsimage.m | 80 | ||||
| -rw-r--r-- | src/nsmenu.m | 10 | ||||
| -rw-r--r-- | src/nsselect.m | 2 | ||||
| -rw-r--r-- | src/nsterm.h | 93 | ||||
| -rw-r--r-- | src/nsterm.m | 1792 | ||||
| -rw-r--r-- | src/nsxwidget.h | 80 | ||||
| -rw-r--r-- | src/nsxwidget.m | 601 | ||||
| -rw-r--r-- | src/pdumper.c | 382 | ||||
| -rw-r--r-- | src/pdumper.h | 1 | ||||
| -rw-r--r-- | src/print.c | 194 | ||||
| -rw-r--r-- | src/process.c | 225 | ||||
| -rw-r--r-- | src/process.h | 2 | ||||
| -rw-r--r-- | src/ptr-bounds.h | 79 | ||||
| -rw-r--r-- | src/regex-emacs.c | 115 | ||||
| -rw-r--r-- | src/search.c | 88 | ||||
| -rw-r--r-- | src/syntax.c | 152 | ||||
| -rw-r--r-- | src/sysdep.c | 312 | ||||
| -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 | 184 | ||||
| -rw-r--r-- | src/termcap.c | 8 | ||||
| -rw-r--r-- | src/termchar.h | 2 | ||||
| -rw-r--r-- | src/termhooks.h | 6 | ||||
| -rw-r--r-- | src/textprop.c | 27 | ||||
| -rw-r--r-- | src/thread.c | 20 | ||||
| -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 | 206 | ||||
| -rw-r--r-- | src/w32.h | 4 | ||||
| -rw-r--r-- | src/w32fns.c | 262 | ||||
| -rw-r--r-- | src/w32gui.h | 6 | ||||
| -rw-r--r-- | src/w32heap.c | 16 | ||||
| -rw-r--r-- | src/w32image.c | 477 | ||||
| -rw-r--r-- | src/w32menu.c | 2 | ||||
| -rw-r--r-- | src/w32proc.c | 12 | ||||
| -rw-r--r-- | src/w32select.c | 4 | ||||
| -rw-r--r-- | src/w32term.c | 155 | ||||
| -rw-r--r-- | src/w32term.h | 8 | ||||
| -rw-r--r-- | src/window.c | 106 | ||||
| -rw-r--r-- | src/window.h | 1 | ||||
| -rw-r--r-- | src/xdisp.c | 946 | ||||
| -rw-r--r-- | src/xfaces.c | 224 | ||||
| -rw-r--r-- | src/xfns.c | 47 | ||||
| -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 | 2 | ||||
| -rw-r--r-- | src/xrdb.c | 2 | ||||
| -rw-r--r-- | src/xselect.c | 21 | ||||
| -rw-r--r-- | src/xterm.c | 246 | ||||
| -rw-r--r-- | src/xterm.h | 3 | ||||
| -rw-r--r-- | src/xwidget.c | 275 | ||||
| -rw-r--r-- | src/xwidget.h | 48 |
140 files changed, 10202 insertions, 12958 deletions
diff --git a/src/.gdbinit b/src/.gdbinit index 30c7b055ce0..78536fc01fb 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 1c954b20eec..fbbd3608909 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 2942d35561a..cf9e87a6a80 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 0397a495212..04983fe03e6 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 791de9a6a8b..87055d70315 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 973251859c1..4e403058837 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 17522e450f0..c7b99a443d5 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 9f12748fbeb..0c1f72a6787 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 ab63b926272..39c0f12fe6c 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 @@ -337,6 +336,10 @@ DUMPING=@DUMPING@ CHECK_STRUCTS = @CHECK_STRUCTS@ 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 aarch64-apple-darwin%,yes,@configuration@) + # 'make' verbosity. AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ @@ -434,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. @@ -531,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, @@ -653,6 +657,9 @@ temacs$(EXEEXT): $(LIBXMENU) $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(EMACSRES) \ $(ALLOBJS) $(LIBEGNU_ARCHIVE) $(W32_RES_LINK) $(LIBES) ifeq ($(HAVE_PDUMPER),yes) $(AM_V_at)$(MAKE_PDUMPER_FINGERPRINT) $@.tmp +ifeq ($(DO_CODESIGN),yes) + codesign -s - -f $@.tmp +endif endif $(AM_V_at)mv $@.tmp $@ $(MKDIR_P) $(etc) diff --git a/src/alloc.c b/src/alloc.c index 568fee666fe..2b3643e35bd 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, @@ -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 }; @@ -694,7 +747,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 +758,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 +775,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 +795,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 +991,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 +1001,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 +1342,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 +1385,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 +1434,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 +1501,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 +1578,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 +1623,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 +1658,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 +1785,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 +1797,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 +1833,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 +1850,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 +1862,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 +1874,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 +1906,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 +1918,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 +2034,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 +2042,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 +2169,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 +2203,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 +2214,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 +2238,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 +2428,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 +2470,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 +2956,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 +3140,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 +3262,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 +3276,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 +3303,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 +3354,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 +3364,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 +3382,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 +3435,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 +3455,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 +3473,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 +3489,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 +3575,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 +4037,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 +4437,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 +4445,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 +4688,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 +4829,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 +4837,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 +4940,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 +4966,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 +4985,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 +5031,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 +5041,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 +5147,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 +5160,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 +5213,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 +5304,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 +5685,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 +5965,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 +5981,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 +6028,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); } } @@ -5958,8 +6071,9 @@ garbage_collect (void) 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 @@ -6133,7 +6247,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)); @@ -6148,8 +6261,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 @@ -6224,7 +6336,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); @@ -6243,8 +6360,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); @@ -6253,8 +6369,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); } } } @@ -6367,6 +6482,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 @@ -6404,7 +6526,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 (); \ @@ -6417,19 +6539,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. */ @@ -6438,15 +6560,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 */ @@ -6457,7 +6578,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 @@ -6475,36 +6596,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; @@ -6539,7 +6649,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); @@ -6570,7 +6680,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); @@ -6611,7 +6721,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)) @@ -6629,7 +6739,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))) @@ -6756,8 +6866,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++; @@ -6810,7 +6919,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++; @@ -6983,25 +7092,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. */ @@ -7093,6 +7194,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,6 +7552,9 @@ N should be nonnegative. */); defsubr (&Sgarbage_collect); 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 77e92c302f3..ef062addd16 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 51d90ffaefa..dce5908a1e4 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 0c2541a9dc7..251a19e338a 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 5433c80edb0..360dd348e05 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -51,11 +51,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 @@ -124,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) @@ -131,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 @@ -284,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; @@ -991,7 +999,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. */ @@ -1288,6 +1295,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. @@ -1299,25 +1325,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; } @@ -1769,15 +1795,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)) @@ -1832,6 +1854,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. */ @@ -1946,7 +1971,6 @@ 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) @@ -2257,19 +2281,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 @@ -2297,7 +2322,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 @@ -2333,10 +2358,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"); } @@ -2484,7 +2509,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)); @@ -2541,8 +2566,6 @@ current buffer is cleared. */) p = BEG_ADDR; while (1) { - int c, bytes; - if (pos == stop) { if (pos == Z) @@ -2554,7 +2577,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. */ @@ -2571,7 +2594,7 @@ current buffer is cleared. */) } else { - bytes = BYTES_BY_CHAR_HEAD (*p); + int bytes = BYTES_BY_CHAR_HEAD (*p); p += bytes, pos += bytes; } } @@ -2625,8 +2648,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 { @@ -2737,13 +2759,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))) @@ -5052,6 +5077,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) { @@ -5148,7 +5174,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)); @@ -5309,8 +5334,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"); @@ -5341,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 @@ -5363,23 +5386,13 @@ 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*"); @@ -6250,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 diff --git a/src/buffer.h b/src/buffer.h index fd05fdd37de..fe549c5dac1 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; @@ -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 9e75c9012e0..1c3b6eac0d1 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 eb916353a0c..f80436f3d91 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" @@ -440,9 +439,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 +712,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 8883415f3f5..e3346e2eabb 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -231,6 +231,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. @@ -1060,6 +1063,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 +1105,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) { diff --git a/src/casefiddle.c b/src/casefiddle.c index 1945aa15e71..debd2412238 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)) diff --git a/src/ccl.c b/src/ccl.c index ac44dc1f608..796698eb1ce 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_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: reg[rrr] %= i; break; + 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 97065e17f01..00b73293a3f 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 2771b0ba2ac..520dd3a9605 100644 --- a/src/charset.c +++ b/src/charset.c @@ -866,15 +866,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; @@ -887,13 +882,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 @@ -979,13 +969,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)) @@ -1051,12 +1035,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, @@ -1090,8 +1071,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 { @@ -1477,7 +1457,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; @@ -1521,7 +1501,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 04205ac1032..cb2ced568d9 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 9914b7a01f7..c29cf00dad1 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 @@ -398,8 +389,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 @@ -460,7 +451,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) @@ -526,7 +520,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); diff --git a/src/coding.c b/src/coding.c index ed755b1afcf..2142e7fa518 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); } } @@ -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,14 +10342,13 @@ 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 @@ -10334,14 +10368,13 @@ 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 @@ -10362,7 +10395,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 +10415,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 +10856,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 +10895,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 +11094,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 +11180,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 +11320,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 +11411,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); } @@ -11745,6 +11779,8 @@ syms_of_coding (void) DEFSYM (Qignored, "ignored"); + DEFSYM (Qutf_8_string_p, "utf-8-string-p"); + defsubr (&Scoding_system_p); defsubr (&Sread_coding_system); defsubr (&Sread_non_nil_coding_system); @@ -11796,8 +11832,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 +12086,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 +12156,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 91856c5702b..4973cf89eb1 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 @@ -139,7 +139,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 +353,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 +642,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/composite.c b/src/composite.c index bbb36dcbfa2..66c1e86aae1 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 62c4de40e3b..bdf63fed10e 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 2f8d19fdca8..1ef4ff33428 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,31 @@ 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) +#ifdef __has_attribute +# 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 +228,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 +261,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 +273,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 +295,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 +307,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 +384,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 0f3ac8c6571..384c2592204 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) @@ -1790,6 +1797,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; } @@ -2305,61 +2313,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 +2359,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 +2385,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 +2788,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 +2850,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 +2879,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 +2926,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 +2939,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 +2959,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 +2971,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 +3053,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 +3066,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 +3077,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 +3115,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 +3127,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 +3139,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 +3258,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 +3273,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 +3319,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 +3343,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 +3474,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 +3488,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 +3512,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; diff --git a/src/dbusbind.c b/src/dbusbind.c index f6a0879e6a9..dc4db5c8513 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. */ @@ -129,36 +132,23 @@ static bool xd_in_read_queued_messages = 0; #define XD_BASIC_DBUS_TYPE(type) \ (dbus_type_is_valid (type) && dbus_type_is_basic (type)) #else -#ifdef DBUS_TYPE_UNIX_FD -#define XD_BASIC_DBUS_TYPE(type) \ - ((type == DBUS_TYPE_BYTE) \ - || (type == DBUS_TYPE_BOOLEAN) \ - || (type == DBUS_TYPE_INT16) \ - || (type == DBUS_TYPE_UINT16) \ - || (type == DBUS_TYPE_INT32) \ - || (type == DBUS_TYPE_UINT32) \ - || (type == DBUS_TYPE_INT64) \ - || (type == DBUS_TYPE_UINT64) \ - || (type == DBUS_TYPE_DOUBLE) \ - || (type == DBUS_TYPE_STRING) \ - || (type == DBUS_TYPE_OBJECT_PATH) \ - || (type == DBUS_TYPE_SIGNATURE) \ - || (type == DBUS_TYPE_UNIX_FD)) -#else #define XD_BASIC_DBUS_TYPE(type) \ - ((type == DBUS_TYPE_BYTE) \ - || (type == DBUS_TYPE_BOOLEAN) \ - || (type == DBUS_TYPE_INT16) \ - || (type == DBUS_TYPE_UINT16) \ - || (type == DBUS_TYPE_INT32) \ - || (type == DBUS_TYPE_UINT32) \ - || (type == DBUS_TYPE_INT64) \ - || (type == DBUS_TYPE_UINT64) \ - || (type == DBUS_TYPE_DOUBLE) \ - || (type == DBUS_TYPE_STRING) \ - || (type == DBUS_TYPE_OBJECT_PATH) \ - || (type == DBUS_TYPE_SIGNATURE)) + ((type == DBUS_TYPE_BYTE) \ + || (type == DBUS_TYPE_BOOLEAN) \ + || (type == DBUS_TYPE_INT16) \ + || (type == DBUS_TYPE_UINT16) \ + || (type == DBUS_TYPE_INT32) \ + || (type == DBUS_TYPE_UINT32) \ + || (type == DBUS_TYPE_INT64) \ + || (type == DBUS_TYPE_UINT64) \ + || (type == DBUS_TYPE_DOUBLE) \ + || (type == DBUS_TYPE_STRING) \ + || (type == DBUS_TYPE_OBJECT_PATH) \ + || (type == DBUS_TYPE_SIGNATURE) \ +#ifdef DBUS_TYPE_UNIX_FD + || (type == DBUS_TYPE_UNIX_FD) \ #endif + ) #endif /* This was a macro. On Solaris 2.11 it was said to compile for @@ -192,9 +182,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 +285,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 +383,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 +409,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 +449,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 +475,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 +487,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 +523,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 +533,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 +634,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 +735,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 +863,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 +871,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 +882,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 +892,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 +902,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 +915,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 +924,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 +933,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 +941,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 +951,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 +971,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 +1001,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 +1065,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 +1081,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 +1155,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 +1182,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 +1213,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 +1229,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 +1246,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 +1260,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 +1315,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 +1328,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 +1338,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 +1348,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 +1363,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 +1414,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 +1490,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 +1513,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 +1521,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 +1542,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 +1570,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 +1581,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 +1594,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 +1619,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 +1627,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 +1651,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 +1660,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 +1669,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 +1694,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 +1703,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 +1732,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 +1812,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 +1860,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 +1887,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 +1949,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 a7e1b559173..4d162eeb0f2 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 611477aa4ef..feb5f05cb18 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 6b72e68d315..da51772b37a 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 @@ -1850,20 +1856,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 +1996,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 +2774,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. */ @@ -3064,9 +3057,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 @@ -3157,21 +3150,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 @@ -3313,6 +3291,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 /*********************************************************************** @@ -3498,7 +3477,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 @@ -3537,6 +3516,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); @@ -3625,6 +3606,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 7822829d648..89dd32ad0fb 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 @@ -6498,6 +6545,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 285c0dbbbee..5f23e3d0bba 100644 --- a/src/doc.c +++ b/src/doc.c @@ -233,7 +233,7 @@ 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) @@ -415,7 +415,7 @@ string is passed through `substitute-command-keys'. */) } if (NILP (raw)) - doc = Fsubstitute_command_keys (doc); + doc = call1 (Qsubstitute_command_keys, doc); return doc; } @@ -472,7 +472,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; } @@ -682,329 +682,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; + return Qgrave; - 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); - - 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 +743,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 b0ba12552bc..93164977206 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,21 @@ 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. + ASCII bytes in FORMAT other than % are copied through as-is; + non-ASCII bytes should not appear in FORMAT. 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 +104,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 +122,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,7 +173,7 @@ 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. */ @@ -131,12 +181,12 @@ 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 +199,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 +295,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 +350,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 +364,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 +385,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,31 +470,29 @@ 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 { - while (fmt < format_end && !CHAR_HEAD_P (*fmt)) - fmt++; - src = fmt0, srclen = fmt - fmt0; + if (EQ (quoting_style, Qstraight) && fmtchar == '`') + fmtchar = '\''; + eassert (ASCII_CHAR_P (fmtchar)); + *bufptr++ = fmtchar; + continue; } if (bufsize < srclen) @@ -479,8 +515,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 fb420dac7fa..4104edd77fd 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -46,7 +46,6 @@ 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" @@ -162,20 +161,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, @@ -714,7 +707,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 +719,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 +762,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 +942,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 +993,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 +1062,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 +1096,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 +1264,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 +1543,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 +1720,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 +1775,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 +1800,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 +1824,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 +1900,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 +1954,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 +2005,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); - - 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; - } + buffer = SAFE_ALLOCA (bytes_needed); + unsigned char *deletions_insertions = memset (buffer + 2 * diags, 0, + del_bytes + ins_bytes); - /* 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 +2030,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 +2082,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 +2132,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 +2304,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 +2365,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 +2442,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 +2501,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 +2518,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 +2661,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 +3076,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) @@ -3175,8 +3139,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 +3154,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; @@ -3812,7 +3774,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 +3785,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; diff --git a/src/emacs-module.c b/src/emacs-module.c index a90a9765dbf..23b8e8620c9 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); @@ -220,6 +215,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 +249,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 +348,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 +364,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 +424,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 +458,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 +503,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 +519,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 +539,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 +551,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 +575,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 +589,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 +604,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 +662,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 +678,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 +699,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 +718,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 +734,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 +759,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 = 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 = make_uninit_string (length); + memcpy (SDATA (lstr), str, length); + SDATA (lstr)[length] = 0; 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 +856,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 +901,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 +1061,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. */ @@ -1041,7 +1125,14 @@ 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; @@ -1125,6 +1216,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,14 +1238,14 @@ 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) + if (xmint_pointer (XCAR (tail)) == runtime) return; ++count; } @@ -1261,7 +1358,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 +1395,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); @@ -1351,7 +1448,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 +1476,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,6 +1491,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; + 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; Vmodule_environments = Fcons (make_mint_ptr (env), Vmodule_environments); return env; } diff --git a/src/emacs-module.h.in b/src/emacs-module.h.in index 898021dc5e6..6a39d507c84 100644 --- a/src/emacs-module.h.in +++ b/src/emacs-module.h.in @@ -42,10 +42,20 @@ 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 +# if __has_attribute (__nonnull__) +# define EMACS_ATTRIBUTE_NONNULL(...) \ + __attribute__ ((__nonnull__ (__VA_ARGS__))) +# endif #endif #ifndef EMACS_ATTRIBUTE_NONNULL # define EMACS_ATTRIBUTE_NONNULL(...) @@ -56,7 +66,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 +84,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 +156,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 3836f179abc..172e4607694 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" @@ -938,7 +937,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; @@ -1243,19 +1241,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; @@ -1273,7 +1273,7 @@ main (int argc, char **argv) || (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); } @@ -1536,6 +1536,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 (); @@ -1584,14 +1585,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; @@ -1628,12 +1621,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 @@ -1747,11 +1734,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. */ @@ -1882,7 +1864,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 (); @@ -1959,6 +1940,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 (); @@ -1994,7 +1976,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. */ @@ -2631,25 +2612,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) @@ -2658,15 +2639,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 */ @@ -2750,7 +2735,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 */ @@ -2988,19 +2973,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 16c36fa284c..76708e6e7e2 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) { @@ -1948,6 +1951,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 +2374,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 +2389,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 +2919,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 +2998,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 +3009,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 +3078,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 +3163,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 +3205,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 +3217,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)); } } @@ -3958,7 +3974,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,8 +3988,7 @@ 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; diff --git a/src/fileio.c b/src/fileio.c index 482f88627a5..283813ff89e 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; @@ -3080,7 +3106,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 +3139,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 +3184,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 +3352,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 +3450,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 +3524,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 +3532,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; @@ -3880,7 +3918,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) @@ -5625,7 +5663,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 +5703,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 +5727,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; @@ -5728,12 +5767,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; } diff --git a/src/filelock.c b/src/filelock.c index b28f16e9b5a..39febd366d8 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 392196e2c7a..e4c9acc3163 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. */ @@ -225,12 +223,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 +309,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 +345,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 +354,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 +406,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 +753,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 +807,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 +1530,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 +1632,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 +1684,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 +1747,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 +1786,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 +1816,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 +1962,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 +2295,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 +2434,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 +2457,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 +2488,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 +2522,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 +2566,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 +2627,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 +2850,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 +3458,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 +3501,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 +3526,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 +3707,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 +3749,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 +3779,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 +4019,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 +4039,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 +4251,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 +4287,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 +4321,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 +4353,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 +4393,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 +4429,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 +4474,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 { @@ -4606,13 +4575,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 +4601,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 +4644,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 +4898,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 +5165,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 +5252,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 +5260,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)) @@ -5477,6 +5455,102 @@ It should not be used for anything security-related. See return make_digest_string (digest, SHA1_DIGEST_SIZE); } +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))); +} void @@ -5517,6 +5591,7 @@ syms_of_fns (void) defsubr (&Sremhash); defsubr (&Smaphash); defsubr (&Sdefine_hash_table_test); + defsubr (&Sstring_search); /* Crypto and hashing stuff. */ DEFSYM (Qiv_auto, "iv-auto"); diff --git a/src/font.c b/src/font.c index b71eae6c319..5f9db2ebb8c 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 6f4792afe55..8614e7fa10a 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 c2bb8b21f26..8c86075c07e 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 adcc489a406..512aaf5f45c 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); @@ -1483,6 +1482,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; } @@ -2435,6 +2435,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; @@ -2463,7 +2469,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; } @@ -2558,29 +2564,26 @@ 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) + frame_set_mouse_position (XFRAME (frame), xval, yval); +#elif defined MSDOS if (FRAME_MSDOS_P (XFRAME (frame))) { Fselect_frame (frame, Qnil); - mouse_moveto (XFIXNUM (x), XFIXNUM (y)); + mouse_moveto (xval, yval); } +#elif defined HAVE_GPM + Fselect_frame (frame, Qnil); + term_mouse_moveto (xval, yval); #else -#ifdef HAVE_GPM - { - Fselect_frame (frame, Qnil); - term_mouse_moveto (XFIXNUM (x), XFIXNUM (y)); - } -#endif -#endif + (void) xval; + (void) yval; #endif return Qnil; @@ -2599,29 +2602,26 @@ 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) + frame_set_mouse_pixel_position (XFRAME (frame), xval, yval); +#elif defined MSDOS if (FRAME_MSDOS_P (XFRAME (frame))) { Fselect_frame (frame, Qnil); - mouse_moveto (XFIXNUM (x), XFIXNUM (y)); + mouse_moveto (xval, yval); } +#elif defined HAVE_GPM + Fselect_frame (frame, Qnil); + term_mouse_moveto (xval, yval); #else -#ifdef HAVE_GPM - { - Fselect_frame (frame, Qnil); - term_mouse_moveto (XFIXNUM (x), XFIXNUM (y)); - } -#endif -#endif + (void) xval; + (void) yval; #endif return Qnil; @@ -3545,6 +3545,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,15 +3577,9 @@ currently selected frame will be set to this height. */) (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,15 +3600,9 @@ currently selected frame will be set to this width. */) (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,19 +3616,11 @@ font height. */) (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; } @@ -3655,18 +3650,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 } @@ -4641,23 +4635,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; @@ -4671,8 +4664,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; @@ -5030,8 +5022,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). */ @@ -5102,9 +5092,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); @@ -5651,8 +5638,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; } @@ -5682,8 +5668,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; } diff --git a/src/frame.h b/src/frame.h index a54b8623e50..16ecfd311c3 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 */ @@ -1360,6 +1361,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; @@ -1449,6 +1451,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 diff --git a/src/fringe.c b/src/fringe.c index 2a46e3c34f2..75496692d53 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 c5dfa099745..b89510704e1 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 6b549c3ddf2..6fca9c85093 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 9bbb2c064c2..00000000000 --- a/src/ftxfont.c +++ /dev/null @@ -1,371 +0,0 @@ -/* ftxfont.c -- FreeType font driver on X (without using XFT). - Copyright (C) 2006-2020 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 8450a639e77..3560c744539 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 70176c41cdd..0010553a9d4 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"), @@ -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 df537c515a2..fafd94c0f71 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)); } } @@ -4436,13 +4441,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 +5113,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 4b3f64ef504..82b115e6868 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 956fb1325ed..5eb41322950 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,23 @@ make_image_cache (void) return c; } +/* Compare two lists (one of which must be proper), comparing each + element with `eq'. */ +static bool +equal_lists (Lisp_Object a, Lisp_Object b) +{ + while (CONSP (a) && CONSP (b) && EQ (XCAR (a), XCAR (b))) + a = XCDR (a), b = XCDR (b); + + return EQ (a, b); +} /* 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); @@ -1607,9 +1630,9 @@ 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)) + && equal_lists (img->spec, spec) + && (ignore_colors || (img->face_foreground == foreground + && img->face_background == background))) break; return img; } @@ -1620,8 +1643,13 @@ 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; + + /* 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, sxhash (spec), 0, 0, true))) { free_image (f, img); /* As display glyphs may still be referring to the image ID, we @@ -2107,12 +2135,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 @@ -2224,11 +2271,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) @@ -2245,14 +2295,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); } @@ -2274,19 +2324,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, true); if (img && img->load_failed_p) { free_image (f, img); @@ -2299,9 +2360,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 @@ -2355,8 +2416,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; } } @@ -3629,8 +3689,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; @@ -3726,8 +3786,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; @@ -4572,8 +4632,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. */ @@ -6086,8 +6147,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); @@ -6232,10 +6293,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. */ @@ -6286,10 +6441,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. */ @@ -6879,18 +7034,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 */ @@ -6898,7 +7042,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. */ @@ -6950,7 +7094,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 @@ -7452,18 +7596,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 */ @@ -7472,7 +7604,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. */ @@ -7525,7 +7657,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 @@ -7893,16 +8025,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 @@ -7911,7 +8033,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. */ @@ -8215,7 +8337,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; } @@ -8494,18 +8619,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 */ @@ -9346,6 +9459,7 @@ enum svg_keyword_index SVG_ALGORITHM, SVG_HEURISTIC_MASK, SVG_MASK, + SVG_FOREGROUND, SVG_BACKGROUND, SVG_LAST }; @@ -9364,6 +9478,7 @@ static const struct image_keyword svg_format[SVG_LAST] = {":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} }; @@ -9427,11 +9542,19 @@ 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 + +# 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 *)); @@ -9477,6 +9600,10 @@ init_svg_functions (void) LOAD_DLL_FN (library, rsvg_handle_write); LOAD_DLL_FN (library, rsvg_handle_close); #endif +#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); @@ -9512,6 +9639,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) @@ -9538,6 +9669,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) @@ -9609,6 +9746,49 @@ svg_load (struct frame *f, struct image *img) return success_p; } +#if LIBRSVG_CHECK_VERSION (2, 46, 0) +static double +svg_css_length_to_pixels (RsvgLength length) +{ + /* FIXME: 96 appears to be a pretty standard DPI but we should + probably use the real DPI if we can get it. */ + double dpi = 96; + 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. @@ -9621,13 +9801,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 @@ -9635,6 +9817,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); @@ -9663,24 +9847,183 @@ 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; + + 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); + viewbox_height = svg_css_length_to_pixels (iheight); + } + else if (has_width && has_viewbox) + { + viewbox_width = svg_css_length_to_pixels (iwidth); + viewbox_height = svg_css_length_to_pixels (iwidth) + * viewbox.width / viewbox.height; + } + else if (has_height && has_viewbox) + { + viewbox_height = svg_css_length_to_pixels (iheight); + viewbox_width = svg_css_length_to_pixels (iheight) + * 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; +#else + /* Make a handle to a new rsvg object. */ + rsvg_handle = rsvg_handle_new (); + eassume (rsvg_handle); + + /* Set base_uri for properly handling referenced images (via 'href'). + 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); @@ -9705,25 +10048,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 @@ -9735,16 +10059,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; @@ -9774,6 +10093,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); @@ -10072,7 +10393,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); @@ -10136,6 +10457,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)) @@ -10168,19 +10495,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 @@ -10192,12 +10519,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]; @@ -10319,22 +10657,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 @@ -10358,6 +10696,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); diff --git a/src/indent.c b/src/indent.c index 939e5931db0..4ecf02b6b96 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 dfa1cc311ca..6e245971085 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 585ef18bd2e..0257591a142 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 a93b10e9fff..9a7ba910a10 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 4648cb4c3b7..744c40a1bef 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 fca71985b92..49261fcc3e8 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. @@ -1421,10 +1425,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 +2040,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 +2122,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 +2283,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 +2905,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 +2931,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 +3252,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 +3311,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 +3330,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); } } @@ -3728,9 +3736,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) { @@ -5534,9 +5539,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 +5553,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 +5687,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 +5991,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 +6225,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 +6635,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; @@ -7007,12 +6995,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 +7004,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 +7840,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 +8291,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 +8768,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 +10399,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 +10466,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 +10513,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 +10526,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 +10551,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) { @@ -11695,7 +11731,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 +11781,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); @@ -12052,7 +12089,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, @@ -12484,13 +12522,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/keymap.c b/src/keymap.c index cfba98c72f2..e22eb411f63 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -89,11 +89,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); @@ -679,6 +674,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 @@ -1949,8 +1961,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)); @@ -2006,23 +2017,16 @@ 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 +2034,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); + if (! (NILP (list) || STRINGP (list) || VECTORP (list) || CONSP (list))) + 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 + for (ptrdiff_t i = 0; i < listlen; ) { - key = XCAR (list); - list = XCDR (list); - i++; - } - - if (add_meta) - { - 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; } @@ -2282,12 +2280,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 +2308,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; @@ -2754,7 +2745,7 @@ The optional argument MENUS, if non-nil, says to mention menu bindings. (Lisp_Object buffer, Lisp_Object prefix, Lisp_Object menus) { Lisp_Object outbuf, shadow; - bool nomenu = NILP (menus); + Lisp_Object nomenu = NILP (menus) ? Qt : Qnil; Lisp_Object start1; const char *alternate_heading @@ -2803,9 +2794,13 @@ 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; @@ -2814,8 +2809,11 @@ 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); start1 = Qnil; } @@ -2824,8 +2822,11 @@ 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 @@ -2845,9 +2846,11 @@ You type Translation\n\ 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); } @@ -2856,7 +2859,7 @@ You type Translation\n\ { /* 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 +2879,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 +2893,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 +2972,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 @@ -3413,6 +3085,7 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, for (i = from; ; i++) { bool this_shadowed = 0; + Lisp_Object shadowed_by = Qnil; int range_beg, range_end; Lisp_Object val; @@ -3455,11 +3128,9 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, /* If this binding is shadowed by some other map, ignore it. */ if (!NILP (shadow)) { - Lisp_Object tem; - - tem = shadow_lookup (shadow, kludge, Qt, 0); + shadowed_by = shadow_lookup (shadow, kludge, Qt, 0); - if (!NILP (tem)) + if (!NILP (shadowed_by) && !EQ (shadowed_by, definition)) { if (mention_shadow) this_shadowed = 1; @@ -3514,6 +3185,21 @@ 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 tem; + Lisp_Object key = make_nil_vector (1); + for (int j = starting_i + 1; j <= i; j++) + { + ASET (key, 0, make_fixnum (j)); + 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 +3223,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); } } @@ -3589,6 +3281,7 @@ void syms_of_keymap (void) { DEFSYM (Qkeymap, "keymap"); + DEFSYM (Qdescribe_map_tree, "describe-map-tree"); staticpro (&apropos_predicate); staticpro (&apropos_accumulate); apropos_predicate = Qnil; @@ -3729,6 +3422,8 @@ 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); diff --git a/src/keymap.h b/src/keymap.h index 3ef48fb748e..2f7df2bd955 100644 --- a/src/keymap.h +++ b/src/keymap.h @@ -36,8 +36,6 @@ 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 *); diff --git a/src/kqueue.c b/src/kqueue.c index adbb8d92c0b..590b747ef7c 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 a74c5539860..924bdd299dc 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 92294ac1d33..76d74200ac8 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)) @@ -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 are like a vector but with a few other slots. For some purposes, it makes @@ -2295,11 +2265,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; @@ -2418,20 +2384,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. */ @@ -2798,8 +2751,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) @@ -2997,28 +2952,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) { @@ -3038,22 +2971,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 @@ -3071,7 +2988,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 @@ -3385,6 +3302,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 @@ -3392,7 +3330,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. */ @@ -3507,9 +3445,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); @@ -3600,7 +3538,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 { @@ -3653,7 +3590,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 *); @@ -3813,20 +3750,47 @@ 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 const char *pending_malloc_warning; @@ -3941,8 +3905,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 @@ -3951,7 +3914,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) @@ -3973,14 +3940,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, @@ -4244,8 +4210,12 @@ 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 *module_function_data (const struct Lisp_Module_Function *); +extern void module_finalize_function (const struct Lisp_Module_Function *); extern void mark_modules (void); extern void init_module_assertions (bool); extern void syms_of_module (void); @@ -4366,6 +4336,8 @@ 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 Lisp_Object get_minibuffer (EMACS_INT); extern void init_minibuf_once (void); extern void syms_of_minibuf (void); @@ -4525,18 +4497,6 @@ 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); @@ -4605,6 +4565,8 @@ 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_pipe (int[2]); extern int emacs_close (int); @@ -4640,7 +4602,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; @@ -4767,7 +4729,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) @@ -4777,6 +4739,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); @@ -4892,7 +4865,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) @@ -4971,7 +4947,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 @@ -4981,8 +4957,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 f9a8cb3e1a0..a3d5fd7bb81 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,11 @@ 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; - else - FETCH_STRING_CHAR_ADVANCE (c, string, - read_from_string_index, - read_from_string_index_byte); - return c; + return (read_from_string_index < read_from_string_limit + ? fetch_string_char_advance (string, + &read_from_string_index, + &read_from_string_index_byte) + : -1); } @@ -985,9 +980,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 +1028,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 +1140,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 +1185,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 +1257,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 +1322,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 +1335,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 +1429,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 +1489,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 +2259,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) @@ -2590,6 +2573,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); @@ -2983,9 +2973,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"); + + 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 == '(') @@ -3263,70 +3290,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; - - if (ch == '@') - comma_type = Qcomma_at; - else - { - if (ch >= 0) UNREAD (ch); - comma_type = Qcomma; - } + Lisp_Object comma_type = Qnil; + Lisp_Object value; + int ch = READCHAR; - 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 '?': { @@ -3869,10 +3850,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++) { @@ -4128,6 +4111,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 +4842,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 +5000,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 +5043,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 c589b6685eb..904814647f9 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/marker.c b/src/marker.c index 684b7509c51..64f210db88b 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 28bfcae05d6..e4fda572cd8 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 b8399b075e0..00000000000 --- a/src/mini-gmp-emacs.c +++ /dev/null @@ -1,32 +0,0 @@ -/* Tailor mini-gmp.c for GNU Emacs - -Copyright 2018-2020 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 135655064a3..fc3fd92a880 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -64,6 +64,12 @@ static Lisp_Object minibuf_prompt; static ptrdiff_t minibuf_prompt_width; +static bool +minibuf_follows_frame (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,37 +82,68 @@ 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 && !minibuf_follows_frame ()) + { + 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. */ - { - Lisp_Object tail, frame; + if (minibuf_follows_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; + + 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); + } +} - 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 `minibuffer_follows_selected_frame' 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)) + { + struct frame *sf = XFRAME (selected_frame); + Lisp_Object old_frame = XWINDOW (minibuf_window)->frame; + struct frame *of = XFRAME (old_frame); + Lisp_Object buffer = XWINDOW (minibuf_window)->contents; + + set_window_buffer (sf->minibuffer_window, buffer, 0, 0); + minibuf_window = sf->minibuffer_window; + set_window_buffer (of->minibuffer_window, get_minibuffer (0), 0, 0); + } } DEFUN ("active-minibuffer-window", Factive_minibuffer_window, @@ -251,7 +288,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 +298,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 +330,10 @@ 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 ("minibuffer-prompt-end", Fminibuffer_prompt_end, @@ -414,12 +469,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 +488,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 @@ -443,14 +501,18 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, 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 +545,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 +626,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 +635,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. */ @@ -714,6 +780,16 @@ 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 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. */ @@ -775,6 +851,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 +886,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 +903,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 @@ -1039,7 +1118,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 +1291,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 +1990,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); @@ -1957,6 +2035,14 @@ For example, `eval-expression' uses this. */); The function is called with the arguments passed to `read-buffer'. */); Vread_buffer_function = Qnil; + DEFVAR_BOOL ("minibuffer-follows-selected-frame", minibuffer_follows_selected_frame, + doc: /* Non-nil 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 buffer local or dynamic binding of this variable is ignored. Only the +default top level value is used. */); + minibuffer_follows_selected_frame = 1; + DEFVAR_BOOL ("read-buffer-completion-ignore-case", read_buffer_completion_ignore_case, doc: /* Non-nil means completion ignores case when reading a buffer name. */); 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 6a89178a6e9..b5f06c99c3d 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 0f879fe390c..c7956497c4c 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); @@ -484,7 +475,7 @@ ns_set_represented_filename (struct frame *f) { encoded_filename = ENCODE_UTF_8 (filename); - fstr = [NSString stringWithUTF8String: SSDATA (encoded_filename)]; + fstr = [NSString stringWithLispString:encoded_filename]; if (fstr == nil) fstr = @""; } else @@ -703,14 +694,11 @@ 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 +722,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 +747,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 +759,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 +803,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 +837,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]; } @@ -1168,7 +1152,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 @@ -1271,14 +1255,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, @@ -1603,12 +1593,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 +1674,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 +1704,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 +1723,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 +2027,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 +2075,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 +2109,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 +2132,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 +2310,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 +2934,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 +2990,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 +3012,60 @@ handlePanelKeys (NSSavePanel *panel, NSEvent *theEvent) #endif +/* Whether N bytes at STR are in the [0,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 +3079,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 9bec3691786..378a6408401 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 = @@ -511,10 +497,6 @@ static NSSet } [charset release]; } -#ifdef NS_IMPL_COCOA - if ([families count] == 0) - [families addObject: @"LastResort"]; -#endif [scriptToFamilies setObject: families forKey: script]; } @@ -734,11 +716,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 +742,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 +769,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 +802,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 +843,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 +933,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 +940,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 +977,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 +1007,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 +1018,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 +1031,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 +1055,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 +1089,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 +1117,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 +1134,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 +1144,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 +1157,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 +1184,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 +1222,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 fa1e98b8848..da6f01cf6a3 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) { @@ -240,7 +303,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 +423,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 +470,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 +605,10 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) [transform setTransformStruct:tm]; } +- (void)setSmoothing: (BOOL) s +{ + smoothing = s; +} + + @end diff --git a/src/nsmenu.m b/src/nsmenu.m index 67f9a45a401..a286a80da17 100644 --- a/src/nsmenu.m +++ b/src/nsmenu.m @@ -122,7 +122,6 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) /*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) @@ -240,7 +239,6 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) [[submenu title] UTF8String]); discard_menu_items (); unbind_to (specpdl_count, Qnil); - [pool release]; unblock_input (); return; } @@ -298,7 +296,6 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) free_menubar_widget_value_tree (first_wv); discard_menu_items (); unbind_to (specpdl_count, Qnil); - [pool release]; unblock_input (); return; } @@ -364,7 +361,6 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) if (NILP (items)) { free_menubar_widget_value_tree (first_wv); - [pool release]; unblock_input (); return; } @@ -395,7 +391,6 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) if (i == n) { free_menubar_widget_value_tree (first_wv); - [pool release]; unblock_input (); return; } @@ -454,7 +449,6 @@ ns_update_menubar (struct frame *f, bool deep_p, EmacsMenu *submenu) if (needsSet) [NSApp setMainMenu: menu]; - [pool release]; unblock_input (); } @@ -1092,7 +1086,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 +1135,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; diff --git a/src/nsselect.m b/src/nsselect.m index 38ac66e9c7b..7b1937f5d99 100644 --- a/src/nsselect.m +++ b/src/nsselect.m @@ -114,7 +114,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; diff --git a/src/nsterm.h b/src/nsterm.h index f68c3246a70..f292993d8f7 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -339,6 +339,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 +361,12 @@ typedef id instancetype; @end + +@interface NSString (EmacsString) ++ (NSString *)stringWithLispString:(Lisp_Object)string; +- (Lisp_Object)lispString; +@end + /* ========================================================================== The Emacs application @@ -417,9 +433,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 + CGContextRef drawingBuffer; +#endif @public struct frame *emacsframe; - int rows, cols; int scrollbarsNeedingUpdate; EmacsToolbar *toolbar; NSRect ns_userRect; @@ -438,16 +457,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 +476,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)createDrawingBuffer; +#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 +496,8 @@ typedef id instancetype; { NSPoint grabOffset; } + +- (void)setAppearance; @end @@ -619,6 +646,7 @@ typedef id instancetype; unsigned long xbm_fg; @public NSAffineTransform *transform; + BOOL smoothing; } + (instancetype)allocInitFromFile: (Lisp_Object)file; - (void)dealloc; @@ -637,6 +665,7 @@ typedef id instancetype; - (Lisp_Object)getMetadata; - (BOOL)setFrame: (unsigned int) index; - (void)setTransform: (double[3][3]) m; +- (void)setSmoothing: (BOOL)s; @end @@ -689,22 +718,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 +795,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 +812,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 +823,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 +1062,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 +1086,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 +1094,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, @@ -1180,6 +1177,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,6 +1188,7 @@ 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); @@ -1255,10 +1254,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 3dd915e3703..a9280eb4af9 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" @@ -139,14 +140,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 +156,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 +267,10 @@ struct ns_display_info *x_display_list; /* Chain of existing displays */ long context_menu_value = 0; /* display update */ +static struct frame *ns_updating_frame; +static NSView *focus_view = NULL; 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; @@ -840,6 +823,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 +1106,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 +1121,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 +1153,149 @@ ns_update_end (struct frame *f) external (RIF) call; for whole frame, called after gui_update_window_end -------------------------------------------------------------------------- */ { + EmacsView *view = FRAME_NS_VIEW (f); + 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 + [NSGraphicsContext setCurrentContext:nil]; + [view setNeedsDisplay:YES]; +#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 + [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 } @@ -1513,9 +1635,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) { @@ -1657,6 +1782,8 @@ ns_destroy_window (struct frame *f) { NSTRACE ("ns_destroy_window"); + check_window_system (f); + /* If this frame has a parent window, detach it as not doing so can cause a crash in GNUStep. */ if (FRAME_PARENT_FRAME (f) != NULL) @@ -1667,7 +1794,7 @@ ns_destroy_window (struct frame *f) [parent removeChildWindow: child]; } - check_window_system (f); + [[FRAME_NS_VIEW (f) window] close]; ns_free_frame_resources (f); ns_window_num--; } @@ -1680,61 +1807,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; - /* 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); +#ifdef NS_IMPL_GNUSTEP + /* Don't overlap the menu. + + 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 (); } @@ -1801,9 +1931,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 (); } @@ -1852,7 +1989,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 (); } } @@ -1901,8 +2037,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 @@ -1910,10 +2054,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 @@ -2014,29 +2186,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 */ } @@ -2155,9 +2319,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); @@ -2200,48 +2361,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; @@ -2302,8 +2446,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 @@ -2323,8 +2469,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 @@ -2430,7 +2578,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 @@ -2439,17 +2588,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); @@ -2478,7 +2634,7 @@ ns_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, id view; NSPoint view_position; Lisp_Object frame, tail; - struct frame *f; + struct frame *f = NULL; struct ns_display_info *dpyinfo; NSTRACE ("ns_mouse_position"); @@ -2770,16 +2926,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 (); } @@ -2800,46 +2956,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) @@ -2892,8 +3017,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 (); @@ -2901,6 +3030,46 @@ 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 = + !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, &frame_rect, 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 @@ -2928,12 +3097,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 (); } } @@ -2947,20 +3136,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]; } @@ -2996,10 +3177,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; } } @@ -3080,66 +3263,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); } @@ -3224,60 +3405,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)) { - 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_lookup_indexed_color (NS_FACE_FOREGROUND (face), f) set]; + hollow_color = FRAME_CURSOR_COLOR (f); + } + else + [FRAME_CURSOR_COLOR (f) set]; - /* 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_focus (f, &r, 1); - ns_reset_clipping (f); - } - else if (! redisplaying_p) + 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); } @@ -3295,14 +3468,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); } @@ -3329,42 +3500,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) { @@ -3589,8 +3760,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 @@ -3601,28 +3772,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) /* -------------------------------------------------------------------------- @@ -3672,27 +3843,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); } @@ -3708,7 +3879,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) @@ -3721,15 +3892,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)); @@ -3746,14 +3931,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); } } @@ -3769,7 +3955,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 @@ -3820,7 +4006,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; @@ -3833,7 +4019,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; @@ -3888,20 +4074,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]; } @@ -3946,7 +4151,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, @@ -3960,7 +4165,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); } } @@ -3969,89 +4174,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; } } @@ -4067,7 +4248,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; @@ -4093,7 +4274,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; @@ -4109,7 +4290,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) @@ -4201,11 +4382,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 { @@ -4220,12 +4399,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; } @@ -4234,11 +4411,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: @@ -4248,68 +4427,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: @@ -4320,11 +4497,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; @@ -5001,9 +5176,6 @@ ns_judge_scroll_bars (struct frame *f) if ([view judge]) removed = YES; } - - if (removed) - [eview updateFrameSize: NO]; } /* ========================================================================== @@ -5168,7 +5340,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, @@ -5368,7 +5540,8 @@ 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; unsigned long c; @@ -5396,7 +5569,7 @@ ns_term_init (Lisp_Object display_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 @@ -5775,7 +5948,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); @@ -6139,8 +6312,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)]]; } @@ -6157,8 +6329,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); @@ -6190,6 +6362,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 + CGContextRelease (drawingBuffer); +#endif + [toolbar release]; if (fs_state == FULLSCREEN_BOTH) [nonfs_window release]; @@ -6229,7 +6412,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); } } @@ -6305,7 +6488,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)) { @@ -6348,6 +6531,14 @@ not_in_argv (NSString *arg) code = 0xFF08; /* backspace */ else code = fnKeysym; + + /* Function keys (such as the F-keys, arrow keys, etc.) set + modifiers as though the fn key has been pressed when it + hasn't. Also some combinations of fn and a function key + return a different key than was pressed (e.g. fn-<left> + gives <home>). We need to unset the fn key flag in these + cases. */ + flags &= ~NS_FUNCTION_KEY_MASK; } /* The ⌘ and ⌥ modifiers can be either shift-like (for alternate @@ -6369,17 +6560,6 @@ not_in_argv (NSString *arg) Lisp_Object kind = fnKeysym ? QCfunction : QCordinary; emacs_event->modifiers = EV_MODIFIERS2 (flags, kind); - /* Function keys (such as the F-keys, arrow keys, etc.) set - modifiers as though the fn key has been pressed when it - hasn't. Also some combinations of fn and a function key - return a different key than was pressed (e.g. fn-<left> gives - <home>). We need to unset the fn modifier in these cases. - FIXME: Can we avoid setting it in the first place? */ - if (fnKeysym && (flags & NS_FUNCTION_KEY_MASK)) - emacs_event->modifiers - ^= parse_solitary_modifier (mod_of_kind (ns_function_modifier, - QCfunction)); - if (NS_KEYLOG) fprintf (stderr, "keyDown: code =%x\tfnKey =%x\tflags = %x\tmods = %x\n", code, fnKeysym, flags, emacs_event->modifiers); @@ -6540,7 +6720,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; @@ -6606,13 +6786,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); @@ -6719,8 +6904,6 @@ not_in_argv (NSString *arg) NSTRACE ("[EmacsView mouseDown:]"); - [self deleteWorkingText]; - if (!emacs_event) return; @@ -6930,6 +7113,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:]"); @@ -6972,7 +7156,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); @@ -7028,105 +7213,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)); @@ -7192,6 +7284,7 @@ not_in_argv (NSString *arg) size_title = xmalloc (strlen (old_title) + 40); esprintf (size_title, "%s — (%d x %d)", old_title, cols, rows); [window setTitle: [NSString stringWithUTF8String: size_title]]; + [window display]; xfree (size_title); } } @@ -7262,11 +7355,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); } @@ -7287,6 +7375,55 @@ 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]; + int oldw = (CGFloat)CGBitmapContextGetWidth (drawingBuffer) / scale; + int oldh = (CGFloat)CGBitmapContextGetHeight (drawingBuffer) / 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; + } + } +#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); + +#ifdef NS_DRAW_TO_BUFFER + [self createDrawingBuffer]; +#endif + SET_FRAME_GARBAGED (emacsframe); + cancel_mouse_face (emacsframe); +} + + - (void)windowDidBecomeKey: (NSNotification *)notification /* cf. x_detect_focus_change(), x_focus_changed(), x_new_focus_frame() */ { @@ -7345,7 +7482,6 @@ not_in_argv (NSString *arg) if (emacs_event && is_focus_frame) { - [self deleteWorkingText]; emacs_event->kind = FOCUS_OUT_EVENT; EV_TRAILER ((id)nil); } @@ -7411,7 +7547,7 @@ not_in_argv (NSString *arg) { NSRect r, wr; Lisp_Object tem; - NSWindow *win; + EmacsWindow *win; NSColor *col; NSString *name; @@ -7431,6 +7567,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; @@ -7460,7 +7597,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]; @@ -7489,16 +7629,8 @@ not_in_argv (NSString *arg) 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)]) @@ -7508,7 +7640,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) { @@ -7558,14 +7690,22 @@ not_in_argv (NSString *arg) [NSApp registerServicesMenuSendTypes: ns_send_types returnTypes: [NSArray array]]; +#ifdef NS_DRAW_TO_BUFFER + [self createDrawingBuffer]; +#endif + + /* 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 @@ -7587,15 +7727,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); + // } } } @@ -7795,6 +7935,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 */ @@ -7807,6 +7948,7 @@ not_in_argv (NSString *arg) { NSTRACE ("[EmacsView windowDidEnterFullScreen:]"); [self windowDidEnterFullScreen]; + in_fullscreen_transition = NO; } - (void)windowDidEnterFullScreen /* provided for direct calls */ @@ -7845,6 +7987,7 @@ not_in_argv (NSString *arg) - (void)windowWillExitFullScreen:(NSNotification *)notification { NSTRACE ("[EmacsView windowWillExitFullScreen:]"); + in_fullscreen_transition = YES; [self windowWillExitFullScreen]; } @@ -7864,6 +8007,7 @@ not_in_argv (NSString *arg) { NSTRACE ("[EmacsView windowDidExitFullScreen:]"); [self windowDidExitFullScreen]; + in_fullscreen_transition = NO; } - (void)windowDidExitFullScreen /* provided for direct calls */ @@ -7883,7 +8027,6 @@ not_in_argv (NSString *arg) { [toolbar setVisible:YES]; update_frame_tool_bar (emacsframe); - [self updateFrameSize:YES]; [[self window] display]; } else @@ -7893,6 +8036,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; @@ -7931,9 +8090,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 @@ -7959,8 +8131,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; } @@ -8061,11 +8239,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]; } } @@ -8209,13 +8387,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); @@ -8239,55 +8412,165 @@ not_in_argv (NSString *arg) } -- (void)viewWillDraw +#ifdef NS_DRAW_TO_BUFFER +- (void)createDrawingBuffer + /* Create and store a new CGGraphicsContext for Emacs to draw into. + + We can't do this in GNUstep as there's no equivalent, so under + GNUstep we retain the old method of drawing direct to the + EmacsView. */ { - /* If the frame has been garbaged there's no point in redrawing - anything. */ - if (FRAME_GARBAGED_P (emacsframe)) - [self setNeedsDisplay:NO]; + NSTRACE ("EmacsView createDrawingBuffer]"); + + if (! [self wantsUpdateLayer]) + return; + + NSGraphicsContext *screen; + CGColorSpaceRef colorSpace = [[[self window] colorSpace] CGColorSpace]; + CGFloat scale = [[self window] backingScaleFactor]; + NSRect frame = [self frame]; + + if (drawingBuffer != nil) + CGContextRelease (drawingBuffer); + + drawingBuffer = CGBitmapContextCreate (nil, NSWidth (frame) * scale, NSHeight (frame) * scale, + 8, 0, colorSpace, + kCGImageAlphaPremultipliedFirst | kCGBitmapByteOrder32Host); + + /* This fixes the scale to match the backing scale factor, and flips the image. */ + CGContextTranslateCTM(drawingBuffer, 0, NSHeight (frame) * scale); + CGContextScaleCTM(drawingBuffer, scale, -scale); } -- (void)drawRect: (NSRect)rect + +- (void)focusOnDrawingBuffer { - const NSRect *rectList; - NSInteger numRects; + NSTRACE ("EmacsView focusOnDrawingBuffer]"); - NSTRACE ("[EmacsView drawRect:" NSTRACE_FMT_RECT "]", - NSTRACE_ARG_RECT(rect)); + NSGraphicsContext *buf = + [NSGraphicsContext + graphicsContextWithCGContext:drawingBuffer flipped:YES]; - if (!emacsframe || !emacsframe->output_data.ns) + [NSGraphicsContext setCurrentContext:buf]; +} + + +- (void)windowDidChangeBackingProperties:(NSNotification *)notification + /* Update the drawing buffer when the backing properties change. */ +{ + NSTRACE ("EmacsView windowDidChangeBackingProperties:]"); + + if (! [self wantsUpdateLayer]) return; - block_input (); + NSRect frame = [self frame]; + [self createDrawingBuffer]; + 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 + CGImageRef copy; + NSRect frame = [self frame]; + NSAffineTransform *setOrigin = [NSAffineTransform transform]; + + [[NSGraphicsContext currentContext] saveGraphicsState]; + + /* Set the clipping before messing with the buffer's + orientation. */ + NSRectClip (dstRect); + + /* Unflip the buffer as the copied image will be unflipped, and + offset the top left so when we draw back into the buffer the + correct part of the image is drawn. */ + CGContextScaleCTM(drawingBuffer, 1, -1); + CGContextTranslateCTM(drawingBuffer, + NSMinX (dstRect) - NSMinX (srcRect), + -NSHeight (frame) - (NSMinY (dstRect) - NSMinY (srcRect))); - /* Get only the precise dirty rectangles to avoid redrawing - potentially large areas of the frame that haven't changed. + /* Take a copy of the buffer and then draw it back to the buffer, + limited by the clipping rectangle. */ + copy = CGBitmapContextCreateImage (drawingBuffer); + CGContextDrawImage (drawingBuffer, frame, copy); - 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++) + CGImageRelease (copy); + + [[NSGraphicsContext currentContext] restoreGraphicsState]; + [self setNeedsDisplayInRect:dstRect]; + +#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 - emacsframe->async_visible = 1; - emacsframe->async_iconified = 0; - */ + /* Running on macOS 10.14 or above. */ + return YES; +} + + +- (void)updateLayer +{ + NSTRACE ("[EmacsView updateLayer]"); + + CGImageRef contentsImage = CGBitmapContextCreateImage(drawingBuffer); + [[self layer] setContents:(id)contentsImage]; + CGImageRelease(contentsImage); +} +#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); + + ns_clear_frame_area (emacsframe, x, y, width, height); + block_input (); + expose_frame (emacsframe, x, y, width, height); + unblock_input (); } @@ -8361,7 +8644,7 @@ not_in_argv (NSString *arg) fenum = [files objectEnumerator]; while ( (file = [fenum nextObject]) ) - strings = Fcons (build_string ([file UTF8String]), strings); + strings = Fcons ([file lispString], strings); } else if ([type isEqualToString: NSPasteboardTypeURL]) { @@ -8370,7 +8653,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]) @@ -8382,7 +8665,7 @@ not_in_argv (NSString *arg) type_sym = Qnil; - strings = list1 (build_string ([data UTF8String])); + strings = list1 ([data lispString]); } else { @@ -8488,13 +8771,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; @@ -8561,9 +8837,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]; } } @@ -8748,6 +9022,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 { diff --git a/src/nsxwidget.h b/src/nsxwidget.h new file mode 100644 index 00000000000..dcdb26cb34c --- /dev/null +++ b/src/nsxwidget.h @@ -0,0 +1,80 @@ +/* Header for NS Cocoa part of xwidget and webkit widget. + +Copyright (C) 2019-2020 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..dbd4cb29a62 --- /dev/null +++ b/src/nsxwidget.m @@ -0,0 +1,601 @@ +/* NS Cocoa part implementation of xwidget and webkit widget. + +Copyright (C) 2019-2020 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. */ + +static Lisp_Object build_string_with_nsstr (NSString *nsstr); + +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 build_string_with_nsstr (xwWebView.URL.absoluteString); +} + +Lisp_Object +nsxwidget_webkit_title (struct xwidget *xw) +{ + XwWebView *xwWebView = (XwWebView *) xw->xwWidget; + return build_string_with_nsstr (xwWebView.title); +} + +/* @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. */ +} + +/* Build lisp string */ +static Lisp_Object +build_string_with_nsstr (NSString *nsstr) +{ + const char *utfstr = [nsstr UTF8String]; + NSUInteger bytes = [nsstr lengthOfBytesUsingEncoding:NSUTF8StringEncoding]; + return make_string (utfstr, bytes); +} + +/* 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 build_string_with_nsstr ((NSString *) value); + 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 (build_string_with_nsstr (prop_key), + 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 3ee11460405..0096a4d45a3 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 @@ -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_EE36B4292E # 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 }; @@ -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 6a99b511f2f..c793fb40580 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 425b0dc4ee3..008bf5e6391 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; } @@ -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 @@ -1578,27 +1590,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 +1815,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 +1848,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 +1926,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 +1971,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 +1988,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 +2018,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 +2070,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 +2083,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 +2093,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 +2158,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 +2210,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 +2289,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 91d426103d8..bf64ead24e5 100644 --- a/src/process.c +++ b/src/process.c @@ -1205,6 +1205,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 +1227,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); @@ -1392,14 +1406,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 +1651,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 +1669,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 @@ -1804,10 +1820,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; @@ -2452,10 +2465,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. */ @@ -3181,21 +3191,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 +3212,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 +3247,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 +3288,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); } @@ -3667,10 +3668,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) { @@ -5416,14 +5414,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 @@ -5497,6 +5497,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 @@ -5566,7 +5570,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), @@ -5584,59 +5617,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 } @@ -7079,10 +7074,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; @@ -8200,6 +8192,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. */ @@ -8214,13 +8217,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 @@ -8277,19 +8296,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; } @@ -8459,6 +8465,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 7884efc5494..a783a31cb86 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 22d49f25b6c..00000000000 --- a/src/ptr-bounds.h +++ /dev/null @@ -1,79 +0,0 @@ -/* Pointer bounds checking for GNU Emacs - -Copyright 2017-2020 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 5e23fc94e4f..971a5f63749 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; } } } @@ -3868,6 +3872,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 +3931,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 +3980,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 +4130,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 +4179,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 +4242,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 +4270,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 @@ -4377,12 +4381,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 +4399,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 +4432,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 818bb4af246..e7f90949464 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; @@ -3276,7 +3271,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 +3285,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 +3303,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); diff --git a/src/syntax.c b/src/syntax.c index e8b32f5a445..df07809aaaf 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 addaf4dc28a..29c88f5308e 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,14 @@ 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 +#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 +120,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 +130,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 +194,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 +211,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 +267,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,8 +310,8 @@ 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) { @@ -1770,24 +1763,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,143 +1954,6 @@ init_signals (void) main_thread_id = pthread_self (); #endif -#if !HAVE_DECL_SYS_SIGLIST && !defined _sys_siglist - if (! initialized) - { - 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. */ @@ -2282,9 +2120,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; @@ -2311,23 +2147,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) { @@ -2456,7 +2283,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. @@ -2464,17 +2311,23 @@ 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); +} + /* Open FILE as a stream for Emacs use, with mode MODE. Act like emacs_open with respect to threads, signals, and quits. */ @@ -2733,21 +2586,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 @@ -2771,15 +2609,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"; @@ -3058,7 +2894,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. */ @@ -3074,37 +2911,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 @@ -3143,7 +2986,7 @@ make_lisp_timeval (struct timeval t) #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) { @@ -3491,7 +3334,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; @@ -3878,8 +3721,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); @@ -4129,14 +3985,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 0d600d6895e..ebd75526495 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 005388fd5a4..73c764a9401 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 00ca4a1c58d..b59a3d1c690 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 370f6fcd453..fee3b555751 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 */ @@ -1931,6 +1931,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 +1975,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 +2011,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; @@ -2402,7 +2416,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,22 +2430,6 @@ 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) -{ - /* 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; -} - /* Return the current time, as a Time value. Wrap around on overflow. */ static Time current_Time (void) @@ -2483,7 +2481,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 +2534,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 +2776,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 +4111,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 +4156,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 @@ -4530,6 +4525,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 cc6f2d11acd..1ace4c93103 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 c96b81913b0..c967e7d04f4 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 d18b750c3a2..44ab14225fd 100644 --- a/src/termhooks.h +++ b/src/termhooks.h @@ -220,10 +220,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,7 +366,7 @@ enum { #ifdef HAVE_GPM #include <gpm.h> -extern int handle_one_term_event (struct tty_display_info *, Gpm_Event *, struct input_event *); +extern int handle_one_term_event (struct tty_display_info *, Gpm_Event *); #ifndef HAVE_WINDOW_SYSTEM extern void term_mouse_moveto (int, int); #endif diff --git a/src/textprop.c b/src/textprop.c index ee048336ac0..0876badc873 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 c7fe0614269..7ab1e6de1fc 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/timefns.c b/src/timefns.c index 553daf6e6a9..4a28f707a3b 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 59cbe3c18b9..8cf68bb92e1 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 5a68162e25c..75933526db1 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 6fed5ba8d3d..5ebae324c20 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) @@ -9764,7 +9884,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 +9976,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 +9985,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 +10258,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 b8655ec788c..1afb8ad0873 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 *); @@ -221,6 +222,9 @@ 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/w32fns.c b/src/w32fns.c index fd13a958651..a840f0e1227 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. */ @@ -1700,10 +1558,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)) { @@ -3307,6 +3163,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 +3301,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 +3640,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 +3701,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 @@ -7132,7 +7004,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 +7088,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). */ @@ -8091,7 +7963,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 +8082,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 +8135,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 +8145,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 +8230,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 +9081,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 +9091,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 (); @@ -9866,7 +9738,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 +10098,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 /*********************************************************************** @@ -10761,6 +10678,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 +10968,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 5cc64287291..dfec1f08617 100644 --- a/src/w32gui.h +++ b/src/w32gui.h @@ -41,6 +41,12 @@ 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); + #define FACE_DEFAULT (~0) extern HINSTANCE hinst; diff --git a/src/w32heap.c b/src/w32heap.c index 3a6c7804675..a72bed62caf 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..70b2eb29b87 --- /dev/null +++ b/src/w32image.c @@ -0,0 +1,477 @@ +/* Implementation of MS-Windows native image API via the GDI+ library. + +Copyright (C) 2020 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 e076043f7b7..da2db78a940 100644 --- a/src/w32menu.c +++ b/src/w32menu.c @@ -1485,7 +1485,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 62d7377130f..0cf82013065 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, @@ -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 9a4b43bc69a..e754e1f1ed2 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 76cf6bd6964..23cb380040b 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. */ @@ -1982,7 +2008,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 +2060,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 +2080,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 +2193,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; @@ -5452,15 +5478,15 @@ w32_read_socket (struct terminal *terminal, /* 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); } } @@ -6851,7 +6877,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 +7165,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. */ @@ -7657,6 +7689,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 f8a8a727e8a..694493c6c82 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 ff17cd88f38..6cd3122b43b 100644 --- a/src/window.c +++ b/src/window.c @@ -1895,10 +1895,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 +2108,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 +2643,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); @@ -4328,11 +4317,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 +5464,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 @@ -6835,19 +6824,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 +7159,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 +7196,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 +7478,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 +7509,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 * @@ -7976,19 +7975,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 +8003,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 +8035,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,7 +8059,7 @@ 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; } @@ -8423,7 +8411,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 +8419,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); diff --git a/src/window.h b/src/window.h index aa8d2c8d1d2..167d1be7abb 100644 --- a/src/window.h +++ b/src/window.h @@ -1184,7 +1184,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 *); diff --git a/src/xdisp.c b/src/xdisp.c index e65505b1b16..76ef420a364 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); @@ -1101,6 +1171,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 +1490,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 +1502,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 +1589,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. @@ -1969,16 +2065,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 +2095,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 +2139,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 +2166,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 +2219,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 +2232,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 +3376,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 +3746,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 +3977,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; @@ -4402,8 +4494,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 +4636,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 +5773,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 +6637,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 +6732,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 +7564,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 +7639,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 +7652,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 +7782,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 +7858,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 +7873,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 +7885,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 +7924,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 +8335,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 +8559,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 +8597,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 +8655,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 +8770,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 +8780,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 +8808,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 +8954,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 +9277,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 a character that allows + wrapping after it. 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 +9305,10 @@ move_it_in_display_line_to (struct it *it, } /* Otherwise, we can wrap here. */ SAVE_IT (wrap_it, *it, wrap_data); - may_wrap = false; + next_may_wrap = false; } + /* Update may_wrap for the next iteration. */ + may_wrap = next_may_wrap; } } @@ -9322,10 +9436,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 +9451,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 +9530,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 +9840,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 @@ -9963,7 +10080,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 +10255,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); } @@ -10490,22 +10621,21 @@ 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_char_advance (&start, &bpos); if (!(c == ' ' || c == '\t' || c == '\n' || c == '\r')) break; } 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 +10649,20 @@ 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; } 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); @@ -10757,32 +10884,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 +11052,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 +11155,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 @@ -11249,8 +11370,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 +11642,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 +11659,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 +11702,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 +11720,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)); } @@ -11700,7 +11818,20 @@ resize_mini_window (struct window *w, bool exact_p) height = (max_height / unit) * unit; 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; } else SET_TEXT_POS (start, BEGV, BEGV_BYTE); @@ -11740,8 +11871,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 +11881,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); @@ -11828,7 +11957,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 +11967,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 +12021,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 +12409,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 +12431,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 +12587,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 +12603,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 +12673,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 +12718,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 +12732,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); @@ -12721,23 +12859,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 +12993,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 +13671,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 +13846,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 +13928,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 +14628,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 +15227,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 +15270,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 +15473,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 +15742,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 +18829,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 +18844,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 +19391,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 +20535,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 @@ -21264,7 +21456,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 +21826,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 +21850,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 +22013,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 +22348,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 +22608,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 +22810,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 +22828,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 +23504,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 +23525,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 +23651,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 +23690,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 +24259,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 +24655,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 +24884,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 +25295,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 +25368,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; @@ -25517,6 +25732,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 +26183,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 +26213,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 +26358,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 +26436,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; @@ -27317,7 +27542,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 +27924,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 +27959,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 +29162,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 +29290,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 +29402,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 +29636,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 +29652,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 +29692,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; @@ -29929,6 +30176,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 +30316,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 +30431,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 +30841,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 +30870,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 +31132,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 +31139,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 +31237,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 +31277,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; } } @@ -34321,7 +34557,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 +34572,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); @@ -34530,7 +34773,8 @@ 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 +34879,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 +34937,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 @@ -35032,12 +35292,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); @@ -35235,6 +35495,12 @@ 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; } @@ -35245,6 +35511,8 @@ init_xdisp (void) { CHARPOS (this_line_start_pos) = 0; + echo_area_window = minibuf_window; + if (!noninteractive) { struct window *m = XWINDOW (minibuf_window); @@ -35254,8 +35522,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 66d6c340302..73a536b19c6 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)) @@ -4366,15 +4489,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 +4507,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) { @@ -4941,7 +5066,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 +5217,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 +5281,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. */ @@ -5608,7 +5741,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 +5962,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 +5970,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 +5991,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 +6007,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)) { @@ -6103,6 +6252,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); @@ -7011,4 +7162,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 6f7c590ecee..46e4bd73a6b 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 (); @@ -1807,10 +1804,7 @@ x_change_tool_bar_height (struct frame *f, int height) 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)) { @@ -3382,10 +3376,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 +3389,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 +3880,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 */ @@ -5563,12 +5557,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 +5890,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 +6197,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 +6370,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 +6535,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); diff --git a/src/xfont.c b/src/xfont.c index f6131dcec5a..32f63c3f7ce 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 f8d0bac7fac..be70107b756 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 a38591f3296..512bf3ad85f 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 9201a283b47..dba7e88f486 100644 --- a/src/xmenu.c +++ b/src/xmenu.c @@ -763,7 +763,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. diff --git a/src/xrdb.c b/src/xrdb.c index d3ac1175521..3d7f715c88f 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 48d6215a7bb..383aebf96c8 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 a567ab163af..0d2452de929 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1750,7 +1750,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 +1795,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 +1845,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 +1889,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 +2000,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 +2376,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 +2387,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 +2742,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 +2767,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 +2775,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 +2786,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 +2838,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 +2852,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 +2868,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 +2895,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 +2916,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 +2928,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 +2954,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 +2963,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 +3006,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 +3070,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 +3189,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 +3257,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 +3276,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 +3378,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); @@ -4786,6 +4774,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), @@ -8701,7 +8699,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 +8949,9 @@ 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)) { block_input (); if (FRAME_X_DOUBLE_BUFFERED_P (f)) @@ -8965,10 +8964,10 @@ handle_one_xevent (struct x_display_info *dpyinfo, configureEvent.xconfigure.height); #endif f = 0; - } + } #endif - if (f) - { + if (f && FRAME_VISIBLE_P(f)) + { #ifdef USE_GTK /* For GTK+ don't call x_net_wm_state for the scroll bar window. (Bug#24963, Bug#25887) */ @@ -9058,7 +9057,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, xic_set_statusarea (f); #endif - } + } goto OTHER; case ButtonRelease: @@ -9923,6 +9922,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. @@ -12922,19 +12928,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); diff --git a/src/xterm.h b/src/xterm.h index bc10043c54c..0f8ba5e82b4 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 fb906d181ac..e078a28a35b 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); @@ -94,10 +106,11 @@ Returns the newly constructed xwidget, or nil if construction fails. */) 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 +128,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 +182,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 +220,7 @@ xwidget_hidden (struct xwidget_view *xv) return xv->hidden; } +#ifdef USE_GTK static void xwidget_show_view (struct xwidget_view *xv) { @@ -227,13 +254,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 +275,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 +311,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 +360,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 +378,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 +542,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 +552,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 +566,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 +624,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 +640,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 +652,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 +715,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 +733,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 +756,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 +827,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 +870,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 +904,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 +921,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 +935,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 +946,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 +963,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 +973,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 +999,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 +1082,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 +1200,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 +1374,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 +1403,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 +1436,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 +1450,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 99fa8bbd612..40ad8ae8334 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) {} |