------------------------------------------------------------ revno: 117924 committer: Paul Eggert branch nick: trunk timestamp: Mon 2014-09-22 22:42:47 -0700 message: Fix SAFE_ALLOCA to not exhaust the stack when in a loop. Problem reported by Dmietry Antipov in thread leading to: http://lists.gnu.org/archive/html/emacs-devel/2014-09/msg00713.html This patch fixes only SAFE_ALLOCA, SAFE_NALLOCA, and SAFE_ALLOCA_LISP; the experimental local_* macros enabled by USE_LOCAL_ALLOCATORS remain unfixed. * callproc.c (call_process): Save and restore sa_avail. * lisp.h (USE_SAFE_ALLOCA): Define sa_avail. (AVAIL_ALLOCA): New macro. (SAFE_ALLOCA, SAFE_NALLOCA, SAFE_ALLOCA_LISP): Use it, and check against sa_avail rather than MAX_ALLOCA. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2014-09-22 19:20:45 +0000 +++ src/ChangeLog 2014-09-23 05:42:47 +0000 @@ -1,3 +1,17 @@ +2014-09-23 Paul Eggert + + Fix SAFE_ALLOCA to not exhaust the stack when in a loop. + Problem reported by Dmietry Antipov in thread leading to: + http://lists.gnu.org/archive/html/emacs-devel/2014-09/msg00713.html + This patch fixes only SAFE_ALLOCA, SAFE_NALLOCA, and SAFE_ALLOCA_LISP; + the experimental local_* macros enabled by USE_LOCAL_ALLOCATORS + remain unfixed. + * callproc.c (call_process): Save and restore sa_avail. + * lisp.h (USE_SAFE_ALLOCA): Define sa_avail. + (AVAIL_ALLOCA): New macro. + (SAFE_ALLOCA, SAFE_NALLOCA, SAFE_ALLOCA_LISP): + Use it, and check against sa_avail rather than MAX_ALLOCA. + 2014-09-22 Dmitry Antipov On OSX, do not free font-specific data more than once (Bug#18501). === modified file 'src/callproc.c' --- src/callproc.c 2014-09-14 08:23:48 +0000 +++ src/callproc.c 2014-09-23 05:42:47 +0000 @@ -632,6 +632,7 @@ int volatile fd_error_volatile = fd_error; int volatile filefd_volatile = filefd; ptrdiff_t volatile count_volatile = count; + ptrdiff_t volatile sa_avail_volatile = sa_avail; ptrdiff_t volatile sa_count_volatile = sa_count; char **volatile new_argv_volatile = new_argv; int volatile callproc_fd_volatile[CALLPROC_FDS]; @@ -648,6 +649,7 @@ fd_error = fd_error_volatile; filefd = filefd_volatile; count = count_volatile; + sa_avail = sa_avail_volatile; sa_count = sa_count_volatile; new_argv = new_argv_volatile; === modified file 'src/lisp.h' --- src/lisp.h 2014-09-22 19:20:45 +0000 +++ src/lisp.h 2014-09-23 05:42:47 +0000 @@ -4496,12 +4496,15 @@ extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1)); #define USE_SAFE_ALLOCA \ + ptrdiff_t sa_avail = MAX_ALLOCA; \ ptrdiff_t sa_count = SPECPDL_INDEX (); bool sa_must_free = false +#define AVAIL_ALLOCA(size) (sa_avail -= (size), alloca (size)) + /* SAFE_ALLOCA allocates a simple buffer. */ -#define SAFE_ALLOCA(size) ((size) <= MAX_ALLOCA \ - ? alloca (size) \ +#define SAFE_ALLOCA(size) ((size) <= sa_avail \ + ? AVAIL_ALLOCA (size) \ : (sa_must_free = true, record_xmalloc (size))) /* SAFE_NALLOCA sets BUF to a newly allocated array of MULTIPLIER * @@ -4510,8 +4513,8 @@ #define SAFE_NALLOCA(buf, multiplier, nitems) \ do { \ - if ((nitems) <= MAX_ALLOCA / sizeof *(buf) / (multiplier)) \ - (buf) = alloca (sizeof *(buf) * (multiplier) * (nitems)); \ + if ((nitems) <= sa_avail / sizeof *(buf) / (multiplier)) \ + (buf) = AVAIL_ALLOCA (sizeof *(buf) * (multiplier) * (nitems)); \ else \ { \ (buf) = xnmalloc (nitems, sizeof *(buf) * (multiplier)); \ @@ -4543,8 +4546,8 @@ #define SAFE_ALLOCA_LISP(buf, nelt) \ do { \ - if ((nelt) <= MAX_ALLOCA / word_size) \ - (buf) = alloca ((nelt) * word_size); \ + if ((nelt) <= sa_avail / word_size) \ + (buf) = AVAIL_ALLOCA ((nelt) * word_size); \ else if ((nelt) <= min (PTRDIFF_MAX, SIZE_MAX) / word_size) \ { \ Lisp_Object arg_; \ ------------------------------------------------------------ revno: 117923 [merge] committer: Stefan Monnier branch nick: trunk timestamp: Mon 2014-09-22 15:20:45 -0400 message: Merge from emacs-24 diff: === modified file 'ChangeLog' --- ChangeLog 2014-09-15 00:20:21 +0000 +++ ChangeLog 2014-09-22 19:20:45 +0000 @@ -1,3 +1,8 @@ +2014-09-22 Jan Djärv + + * configure.ac: Increase headerpad_extra to 1000, update the comment + about load commands (Bug#18505). + 2014-09-15 Eli Zaretskii * configure.ac (HAVE_SOUND): Check for mmsystem.h header that @@ -1539,8 +1544,8 @@ 2013-07-29 Michael Albinus - * INSTALL (DETAILED BUILDING AND INSTALLATION): Add - --without-file-notification to --without-all. + * INSTALL (DETAILED BUILDING AND INSTALLATION): + Add --without-file-notification to --without-all. 2013-07-29 Xue Fuqiao @@ -1813,8 +1818,8 @@ CONFIG_SITE for the MSYS build on MS-Windows. (Makefile): Use $(CFG). - * .bzrignore: Ignore *.res, *.tmp, and *.map. Remove - src/emacs.res. + * .bzrignore: Ignore *.res, *.tmp, and *.map. + Remove src/emacs.res. 2013-05-16 Paul Eggert @@ -13428,7 +13433,7 @@ detail: -with-x... and --srcdir. (options, boolean_opts): Delete; we don't have enough options to make this worthwhile. - (prefix, bindir, lisppath, datadir, libdir, lockdir): Deleted, + (prefix, bindir, lisppath, datadir, libdir, lockdir): Delete, along with the code which supported them; these should be set as arguments to the top-level make. (config_h_opts): Since this no longer doubles as a list of option === modified file 'configure.ac' --- configure.ac 2014-09-15 00:20:21 +0000 +++ configure.ac 2014-09-22 19:20:45 +0000 @@ -4936,17 +4936,19 @@ darwin) ## The -headerpad option tells ld (see man page) to leave room at the ## end of the header for adding load commands. Needed for dumping. - ## 0x690 is the total size of 30 segment load commands (at 56 - ## each); under Cocoa 31 commands are required. + ## 0x1000 is enough for roughly 52 load commands on the x86_64 + ## architecture (where they are 78 bytes each). The actual number of + ## load commands added is not consistent but normally ranges from + ## about 14 to about 34. Setting it high gets us plenty of slop and + ## only costs about 1.5K of wasted binary space. + headerpad_extra=1000 if test "$HAVE_NS" = "yes"; then libs_nsgui="-framework AppKit" if test "$NS_IMPL_COCOA" = "yes"; then libs_nsgui="$libs_nsgui -framework IOKit" fi - headerpad_extra=6C8 else libs_nsgui= - headerpad_extra=690 fi LD_SWITCH_SYSTEM_TEMACS="-fno-pie -prebind $libs_nsgui -Xlinker -headerpad -Xlinker $headerpad_extra" === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2014-09-22 19:19:29 +0000 +++ lisp/ChangeLog 2014-09-22 19:20:45 +0000 @@ -1,3 +1,9 @@ +2014-09-22 Kan-Ru Chen + + * window.el (fit-window-to-buffer): When counting buffer width, + count the whole visible buffer. Correctly convert the body-height + to pixel size for window-text-pixel-size (Bug#18498). + 2014-09-22 Sam Steingold * progmodes/sql.el (sql-product-alist): Improve the Vertica entry. @@ -191,8 +197,8 @@ (pcase--expand): Use it. (pcase-exhaustive): New macro. (Bug#16567) - * emacs-lisp/lisp-mode.el (lisp-el-font-lock-keywords-2): Add - pcase-exhaustive. + * emacs-lisp/lisp-mode.el (lisp-el-font-lock-keywords-2): + Add pcase-exhaustive. 2014-09-13 Eli Zaretskii @@ -349,8 +355,8 @@ 2014-09-05 Martin Rudalics - * scroll-bar.el (horizontal-scroll-bars-available-p): New - function. + * scroll-bar.el (horizontal-scroll-bars-available-p): + New function. (horizontal-scroll-bar-mode): Rewrite using horizontal-scroll-bars-available-p. * menu-bar.el (menu-bar-showhide-scroll-bar-menu): Rewrite using === modified file 'lisp/cedet/ChangeLog' --- lisp/cedet/ChangeLog 2014-06-19 22:07:09 +0000 +++ lisp/cedet/ChangeLog 2014-09-22 19:20:45 +0000 @@ -1,3 +1,9 @@ +2014-09-22 David Engster + + * ede/emacs.el (ede-emacs-version): Do not call 'egrep' to + determine Emacs version (it was dead code anyway). Make sure that + configure.ac or configure.in exist. (Bug#18476) + 2014-06-19 Stefan Monnier * semantic/ia.el (semantic-ia-complete-symbol-menu): Use posn-at-point === modified file 'lisp/cedet/ede/emacs.el' --- lisp/cedet/ede/emacs.el 2014-04-02 15:14:50 +0000 +++ lisp/cedet/ede/emacs.el 2014-09-22 19:20:45 +0000 @@ -80,12 +80,6 @@ (with-current-buffer buff (erase-buffer) (setq default-directory (file-name-as-directory dir)) - (or (file-exists-p configure_ac) - (setq configure_ac "configure.in")) - ;(call-process "egrep" nil buff nil "-n" "-e" "^version=" "Makefile") - (call-process "egrep" nil buff nil "-n" "-e" "AC_INIT" configure_ac) - (goto-char (point-min)) - ;(re-search-forward "version=\\([0-9.]+\\)") (cond ;; Maybe XEmacs? ((file-exists-p "version.sh") @@ -113,7 +107,8 @@ ;; Insert other Emacs here... ;; Vaguely recent version of GNU Emacs? - (t + ((or (file-exists-p configure_ac) + (file-exists-p (setq configure_ac "configure.in"))) (insert-file-contents configure_ac) (goto-char (point-min)) (re-search-forward "AC_INIT(\\(?:GNU \\)?[eE]macs,\\s-*\\([0-9.]+\\)\\s-*[,)]") === modified file 'lisp/url/ChangeLog' --- lisp/url/ChangeLog 2014-08-07 11:49:36 +0000 +++ lisp/url/ChangeLog 2014-09-22 19:20:45 +0000 @@ -1,3 +1,9 @@ +2014-09-22 Dmitry Gutov + + * url.el (url-retrieve-internal): Clarify the docstring. + + * url-http.el (url-http): Same. (Bug#18116) + 2014-08-07 Reuben Thomas * url-handlers.el: Remove a comment about VMS, which we no longer === modified file 'lisp/url/url-http.el' --- lisp/url/url-http.el 2014-06-26 06:55:15 +0000 +++ lisp/url/url-http.el 2014-09-22 19:20:45 +0000 @@ -1171,8 +1171,8 @@ "Retrieve URL via HTTP asynchronously. URL must be a parsed URL. See `url-generic-parse-url' for details. -When retrieval is completed, execute the function CALLBACK, using -the arguments listed in CBARGS. The first element in CBARGS +When retrieval is completed, execute the function CALLBACK, passing it +an updated value of CBARGS as arguments. The first element in CBARGS should be a plist describing what has happened so far during the request, as described in the docstring of `url-retrieve' (if in doubt, specify nil). === modified file 'lisp/url/url.el' --- lisp/url/url.el 2014-03-29 00:55:44 +0000 +++ lisp/url/url.el 2014-09-22 19:20:45 +0000 @@ -170,8 +170,8 @@ (defun url-retrieve-internal (url callback cbargs &optional silent inhibit-cookies) "Internal function; external interface is `url-retrieve'. -CBARGS is the list of arguments that the callback function will -receive; its first element should be a plist specifying what has +The callback function will receive an updated value of CBARGS as +arguments; its first element should be a plist specifying what has happened so far during the request, as described in the docstring of `url-retrieve' (if in doubt, specify nil). === modified file 'lisp/window.el' --- lisp/window.el 2014-09-15 00:20:21 +0000 +++ lisp/window.el 2014-09-22 19:20:45 +0000 @@ -7377,10 +7377,10 @@ max-width)) (+ total-width (window-max-delta nil t nil nil nil nil pixelwise)))) - ;; When fitting vertically, assume that WINDOW's start - ;; position remains unaltered. WINDOW can't get wider - ;; than its frame's pixel width, its height remains - ;; unaltered. + ;; When fitting horizontally, assume that WINDOW's + ;; start position remains unaltered. WINDOW can't get + ;; wider than its frame's pixel width, its height + ;; remains unaltered. (width (+ (car (window-text-pixel-size nil (window-start) (point-max) (frame-pixel-width) @@ -7389,7 +7389,7 @@ ;; overshoots when the first line below ;; the bottom is wider than the window. (* body-height - (if pixelwise char-height 1)))) + (if pixelwise 1 char-height)))) (window-right-divider-width)))) (unless pixelwise (setq width (/ (+ width char-width -1) char-width))) === modified file 'src/ChangeLog' --- src/ChangeLog 2014-09-22 14:37:22 +0000 +++ src/ChangeLog 2014-09-22 19:20:45 +0000 @@ -1,3 +1,75 @@ +2014-09-22 Dmitry Antipov + + On OSX, do not free font-specific data more than once (Bug#18501). + * macfont.m (macfont_close): Release and free font-specific data + only if it wasn't previously freed. + +2014-09-22 David Caldwell (tiny change) + + * unexmacosx.c (dump_it): Improve error message. + +2014-09-22 Juri Linkov + + * image.c (imagemagick_load_image): Add delay to imagemagick metadata. + (Bug#10747, bug#18334) + +2014-09-22 Eli Zaretskii + + * frame.c (Fmouse_position, Fset_mouse_position): Clarify the + units in which the position is measured. (Bug#18493) + + * xdisp.c (redisplay_internal): Force redisplay of all windows + that show a buffer whose narrowing has changed. (Bug#18490) + +2014-09-22 Eli Zaretskii + + * xterm.c (x_draw_hollow_cursor, x_draw_bar_cursor): + * w32term.c (x_draw_hollow_cursor, x_draw_bar_cursor): In R2L + lines, draw the hollow-box and hbar cursors on the right side of + cursor-glyph. Thanks to martin rudalics for + testing on X. + + * xterm.c (x_draw_stretch_glyph_string): + * w32term.c (x_draw_stretch_glyph_string): Fix a thinko that + caused the block cursor to disappear on a TAB in R2L lines in + every window except the leftmost one. Reported by Martin Rudalics + . + +2014-09-22 Dmitry Antipov + + Always use matched specpdl entry to record call arguments (Bug#18473). + * lisp.h (record_in_backtrace): Adjust prototype. + * eval.c (record_in_backtrace): Return current specpdl level. + (set_backtrace_args, set_backtrace_nargs): Merge. Adjust all users. + (eval_sub, Ffuncall): Record call arguments in matched specpdl + entry and use that entry in call to backtrace_debug_on_exit. + (apply_lambda): Likewise. Get current specpdl level as 3rd arg. + (do_debug_on_call): Get current specpdl level as 2nd arg. + + Prefer ptrdiff_t to int and avoid integer overflows. + * fileio.c (make_temp_name): + * font.c (font_parse_family_registry): Avoid integer + overflow on string size calculation. + * data.c (Faset): Likewise for byte index. + +2014-09-22 Eli Zaretskii + + Fix display of R2L lines in partial-width windows. + * xdisp.c (init_iterator): Don't use it->bidi_p before it is + assigned the correct value. + (extend_face_to_end_of_line): Account for truncation and + continuation glyphs in R2L rows when one of the fringes is not + displayed. + (display_line): Don't assign negative X offset to a row if we are + going to produce a truncation glyph for it. When handling + truncated R2L rows, consider the width of the left fringe instead + of the right one. + (produce_special_glyphs): Fix bogus assignments. + +2014-09-22 Eli Zaretskii + + * w32.c (fcntl): Support O_NONBLOCK fcntl on the write side of pipes. + 2014-09-22 Eli Zaretskii * fileio.c (Fexpand_file_name) [DOS_NT]: Make sure newdirlim is @@ -103,17 +175,17 @@ file names properly displayed. (do_play_sound) [WINDOWSNT]: Use Unicode APIs to play sound files when w32-unicode-filenames is non-nil, but not on Windows 9X, - where these APIs are not available even in UNICOWS.DLL. Improve - the format of error messages and include the file name in them + where these APIs are not available even in UNICOWS.DLL. + Improve the format of error messages and include the file name in them where appropriate. (Fplay_sound_internal) [WINDOWSNT]: Make the MS-Windows branch call play-sound-functions, per documentation. - * w32.c (w32_get_long_filename, w32_get_short_filename): Constify - the input file name arguments. + * w32.c (w32_get_long_filename, w32_get_short_filename): + Constify the input file name arguments. - * w32.h (w32_get_long_filename, w32_get_short_filename): Update - prototypes. + * w32.h (w32_get_long_filename, w32_get_short_filename): + Update prototypes. 2014-09-15 Dmitry Antipov @@ -220,8 +292,8 @@ * lread.c (readevalloop_eager_expand_eval): Add GCPRO and fix bootstrap broken if GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE. - Remove redundant GCPROs around Ffuncall and Fapply calls. This - is safe because Ffuncall protects all of its arguments by itself. + Remove redundant GCPROs around Ffuncall and Fapply calls. + This is safe because Ffuncall protects all of its arguments by itself. * charset.c (map_charset_for_dump): Remove redundant GCPRO. * eval.c (Fapply, apply1, call0, call1, call2, call3, call4, call5) (call6, call7): Likewise. Use compound literals where applicable. @@ -511,8 +583,8 @@ 2014-09-03 Martin Rudalics * buffer.c (scroll-bar-height): Fix typo in doc-string. - * frame.c (Vdefault_frame_horizontal_scroll_bars): Remove - variable. + * frame.c (Vdefault_frame_horizontal_scroll_bars): + Remove variable. * nsfns.m (Fx_create_frame): * w32fns.c (Fx_create_frame): * xfns.c (Fx_create_frame): Default horizontal scroll bars to @@ -750,8 +822,8 @@ 2014-08-28 Martin Rudalics - * w32term.c (w32_horizontal_scroll_bar_handle_click): In - `event->y' return entire range (the size of the scroll bar minus + * w32term.c (w32_horizontal_scroll_bar_handle_click): + In `event->y' return entire range (the size of the scroll bar minus that of the thumb). * xterm.c (xm_scroll_callback, xaw_jump_callback): In `whole' return entire range (the scaled size of the scroll bar minus @@ -771,8 +843,8 @@ * xdisp.c (display_line): Don't assume that the call to reseat_at_next_visible_line_start ends up at a character - immediately following the newline on the previous line. Avoids - setting the ends_at_zv_p flag on screen lines that are not at or + immediately following the newline on the previous line. + Avoids setting the ends_at_zv_p flag on screen lines that are not at or beyond ZV, which causes infloop in redisplay. For the details, see http://lists.gnu.org/archive/html/emacs-devel/2014-08/msg00368.html. @@ -796,8 +868,8 @@ (newlocale, wcscoll_l): Define substitutes for platforms that lack them, so as to simplify the mainline code. (str_collate): Simplify the code by assuming the above definitions. - Use wcscoll_l, not uselocale, as uselocale is too fragile. For - example, the old version left the Emacs in the wrong locale if + Use wcscoll_l, not uselocale, as uselocale is too fragile. + For example, the old version left the Emacs in the wrong locale if wcscoll reported an error. Use 'int', not ptrdiff_t, for the int result. Report an error if newlocale fails. @@ -1016,8 +1088,8 @@ * term.c (OUTPUT, tty_set_terminal_modes) (tty_set_terminal_window, tty_set_scroll_region) (tty_clear_to_end, tty_write_glyphs, tty_write_glyphs_with_face) - (tty_ins_del_lines, tty_menu_display, tty_menu_activate): Use - FRAME_TOTAL_LINES instead of FRAME_LINES. + (tty_ins_del_lines, tty_menu_display, tty_menu_activate): + Use FRAME_TOTAL_LINES instead of FRAME_LINES. (Fresume_tty): Use FRAME_TOTAL_LINES instead of FRAME_LINES. Call change_frame_size with frame's menu bar lines subtracted from height. @@ -1068,14 +1140,14 @@ 2014-08-04 Martin Rudalics - * frame.h (FRAME_HAS_HORIZONTAL_SCROLL_BARS): Condition - correctly according to toolkit used. + * frame.h (FRAME_HAS_HORIZONTAL_SCROLL_BARS): + Condition correctly according to toolkit used. * frame.c (make_initial_frame, make_terminal_frame) (x_set_horizontal_scroll_bars, x_set_scroll_bar_height) (Vdefault_frame_horizontal_scroll_bars): Correctly condition assignments according to presence of toolkit scrollbars. - * window.h (WINDOW_HAS_HORIZONTAL_SCROLL_BAR): Condition - correctly according to toolkit used. + * window.h (WINDOW_HAS_HORIZONTAL_SCROLL_BAR): + Condition correctly according to toolkit used. * window.c (set_window_scroll_bars): Set horizontal scroll bar only if toolkit supports it. * w32term.c (w32_redeem_scroll_bar): Always redeem scroll bar if @@ -1331,15 +1403,15 @@ (x_set_scroll_bar_height): Add external declarations. * frame.c: (frame_inhibit_resize, frame_windows_min_size) (adjust_frame_size): New functions. - (make_frame): Initial horizontal_scroll_bars field. Use - SET_FRAME_LINES. Don't allow horizontal scroll bar in + (make_frame): Initial horizontal_scroll_bars field. + Use SET_FRAME_LINES. Don't allow horizontal scroll bar in minibuffer window. (make_initial_frame, make_terminal_frame): No horizontal scroll bar in initial and terminal frames. Use adjust_frame_size. (Fframe_total_cols): Fix doc-string. (Fframe_total_lines, Fscroll_bar_height): New Lisp functions. - (Fset_frame_height, Fset_frame_width, Fset_frame_size): Rewrite - using adjust_frame_size. + (Fset_frame_height, Fset_frame_width, Fset_frame_size): + Rewrite using adjust_frame_size. (Qscroll_bar_height, Qhorizontal_scroll_bars) (Qframe_windows_min_size): New symbols. (x_set_frame_parameters): Remove call of check_frame_size. @@ -1350,8 +1422,8 @@ (x_set_internal_border_width, x_set_vertical_scroll_bars) (x_set_scroll_bar_width, x_set_right_divider_width) (x_set_bottom_divider_width): Rewrite using adjust_frame_size. - (x_set_horizontal_scroll_bars, x_set_scroll_bar_height): New - functions. + (x_set_horizontal_scroll_bars, x_set_scroll_bar_height): + New functions. (x_figure_window_size): Rewrite to make frame display the expected number of lines. (Vdefault_frame_scroll_bars): Rewrite doc-string. @@ -1398,8 +1470,8 @@ compute_fringe_widths. * term.c (Fresume_tty): When changing the size of a tty frame do not pass height of menu bar. - (clear_tty_hooks, set_tty_hooks): Clear - horizontal_scroll_bar_hook. + (clear_tty_hooks, set_tty_hooks): + Clear horizontal_scroll_bar_hook. (init_tty): Frame has no horizontal scroll bars. * termhooks.h (enum scroll_bar_part): Add scroll_bar_move_ratio, scroll_bar_before_handle, scroll_bar_horizontal_handle, @@ -1408,25 +1480,25 @@ scroll_bar_to_rightmost entries. (enum event_kind): Add HORIZONTAL_SCROLL_BAR_CLICK_EVENT (struct terminal): Add set_horizontal_scroll_bar_hook. - * w32console.c (initialize_w32_display): Clear - horizontal_scroll_bar_hook. + * w32console.c (initialize_w32_display): + Clear horizontal_scroll_bar_hook. * w32fns.c (x_set_mouse_color): Use FRAME_W32_DISPLAY instead of FRAME_X_DISPLAY. (x_clear_under_internal_border, x_set_internal_border_width): New functions. - (x_set_menu_bar_lines): Rewrite using frame_inhibit_resize. Set - windows_or_buffers_changed when adding the menu bar. + (x_set_menu_bar_lines): Rewrite using frame_inhibit_resize. + Set windows_or_buffers_changed when adding the menu bar. (x_set_tool_bar_lines): Rewrite using adjust_frame_size. (x_change_tool_bar_height, x_set_scroll_bar_default_height) (w32_createhscrollbar): New functions. (w32_createscrollbar): Rename to w32_createvscrollbar. (w32_createwindow): Init WND_HSCROLLBAR_INDEX. (w32_name_of_message): Replace WM_EMACS_CREATESCROLLBAR by - WM_EMACS_CREATEVSCROLLBAR and WM_EMACS_CREATEHSCROLLBAR. Add - WM_EMACS_SHOWCURSOR. + WM_EMACS_CREATEVSCROLLBAR and WM_EMACS_CREATEHSCROLLBAR. + Add WM_EMACS_SHOWCURSOR. (w32_wnd_proc): Handle WM_HSCROLL case. In WM_WINDOWPOSCHANGING - case do not artificially impose WM size hints. Handle - WM_EMACS_SHOWCURSOR case. Replace WM_EMACS_CREATESCROLLBAR case + case do not artificially impose WM size hints. + Handle WM_EMACS_SHOWCURSOR case. Replace WM_EMACS_CREATESCROLLBAR case by WM_EMACS_CREATEVSCROLLBAR and WM_EMACS_CREATEHSCROLLBAR cases. (my_create_tip_window): Replace WND_SCROLLBAR_INDEX by @@ -1445,8 +1517,8 @@ pass height of menu bar to change_frame_size. * w32menu.c (set_frame_menubar): Rewrite using frame_inhibit_resize. - * w32term.h (struct w32_display_info): Add - horizontal_scroll_bar_cursor and cursor_display_counter. + * w32term.h (struct w32_display_info): + Add horizontal_scroll_bar_cursor and cursor_display_counter. (struct scroll_bar): Add horizontal. (HORIZONTAL_SCROLL_BAR_INSIDE_HEIGHT) (HORIZONTAL_SCROLL_BAR_LEFT_RANGE) @@ -1456,8 +1528,8 @@ (HORIZONTAL_SCROLL_BAR_TOP_BORDER) (HORIZONTAL_SCROLL_BAR_BOTTOM_BORDER) (HORIZONTAL_SCROLL_BAR_MIN_HANDLE): New macros. - (WM_EMACS_CREATEVSCROLLBAR, WM_EMACS_CREATEHSCROLLBAR): Define - instead of WM_EMACS_CREATESCROLLBAR. + (WM_EMACS_CREATEVSCROLLBAR, WM_EMACS_CREATEHSCROLLBAR): + Define instead of WM_EMACS_CREATESCROLLBAR. (WND_VSCROLLBAR_INDEX, WND_HSCROLLBAR_INDEX): Define instead of WND_SCROLLBAR_INDEX. * w32term.c (horizontal_scroll_bar_min_handle) @@ -1476,18 +1548,18 @@ scrollbar cases. (my_create_scrollbar): Replace with two new functions my_create_vscrollbar and my_create_hscrollbar. - (x_scroll_bar_create): New argument "horizontal". Update - callers accordingly. + (x_scroll_bar_create): New argument "horizontal". + Update callers accordingly. (x_scroll_bar_remove, w32_condemn_scroll_bars) (w32_redeem_scroll_bar, x_scroll_bar_clear): Handle horizontal scroll bar case. (w32_read_socket): Handle WM_HSCROLL cae. - (x_new_font): Don't recompute fringe widths. Use - frame_inhibit_resize. Calculate new menu bar height iff we + (x_new_font): Don't recompute fringe widths. + Use frame_inhibit_resize. Calculate new menu bar height iff we build without toolkit. Always clear under internal border. (x_set_window_size): Don't check frame size or recompute - fringes. Reset fullscreen status before applying sizes. Always - resize as requested by pixelwise argument. Don't call + fringes. Reset fullscreen status before applying sizes. + Always resize as requested by pixelwise argument. Don't call do_pending_window_change. (x_wm_set_size_hint): Add call for FRAME_SCROLL_BAR_AREA_HEIGHT. (w32_initialize_display_info): Initialize dpyinfo's @@ -1513,8 +1585,8 @@ (WINDOW_TOPMOST_P, WINDOW_HAS_HORIZONTAL_SCROLL_BAR) (WINDOW_CONFIG_SCROLL_BAR_HEIGHT) (WINDOW_CONFIG_SCROLL_BAR_LINES) - (WINDOW_SCROLL_BAR_LINES, WINDOW_SCROLL_BAR_AREA_HEIGHT): New - macros. + (WINDOW_SCROLL_BAR_LINES, WINDOW_SCROLL_BAR_AREA_HEIGHT): + New macros. (WINDOW_LEFT_FRINGE_COLS, WINDOW_RIGHT_FRINGE_COLS) (WINDOW_FRINGE_COLS, WINDOW_FRINGE_EXTENDED_P): Remove macros. (WINDOW_VERTICAL_SCROLL_BAR_TYPE) @@ -1527,11 +1599,11 @@ (Fwindow_old_point, sanitize_window_sizes): New functions. (Qwindow_sanitize_window_sizes): New symbol. (window_body_height): Count in horizontal scroll bar. - (set_window_hscroll, Fscroll_left, Fscroll_right): Set - suspend_auto_hscroll slot. + (set_window_hscroll, Fscroll_left, Fscroll_right): + Set suspend_auto_hscroll slot. (Fwindow_inside_edges): Count fringes pixelwise. - (coordinates_in_window, Fcoordinates_in_window_p): Consider - horizontal scroll bar. + (coordinates_in_window, Fcoordinates_in_window_p): + Consider horizontal scroll bar. (check_frame_size, adjust_window_margins): Remove functions and corresponding calls. (set_window_buffer): Initialize old_pointm and horizontal scroll @@ -1547,8 +1619,8 @@ (Fsplit_window_internal): Inherit horizontal scroll bar type and height. (Fdelete_window_internal): Unchain old_pointm marker. - (window_scroll_pixel_based, Fscroll_other_window): Adjust - old_pointm. + (window_scroll_pixel_based, Fscroll_other_window): + Adjust old_pointm. (Fwindow_text_width, Fwindow_text_height): New argument "pixelwise". (struct saved_window): New fields, old_pointm, hscroll_whole, @@ -1603,10 +1675,10 @@ (x_frame_parm_handlers): Add x_set_scroll_bar_height, x_set_horizontal_scroll_bars, x_set_left_fringe, x_set_right_fringe. - * xmenu.c (update_frame_menubar, free_frame_menubar): Use - adjust_frame_size. - * xterm.h (struct x_display_info): Add - horizontal_scroll_bar_cursor and Xatom_Horizontal_Scrollbar + * xmenu.c (update_frame_menubar, free_frame_menubar): + Use adjust_frame_size. + * xterm.h (struct x_display_info): + Add horizontal_scroll_bar_cursor and Xatom_Horizontal_Scrollbar slots. (struct scroll_bar): Add horizontal slot. (HORIZONTAL_SCROLL_BAR_INSIDE_HEIGHT) @@ -1629,15 +1701,15 @@ (x_set_toolkit_horizontal_scroll_bar_thumb) (XTset_horizontal_scroll_bar, x_net_wm_state) (x_horizontal_scroll_bar_report_motion): New functions. - (xg_scroll_callback, x_scroll_bar_handle_click): Handle - horizontal scroll bars. + (xg_scroll_callback, x_scroll_bar_handle_click): + Handle horizontal scroll bars. (SCROLL_BAR_HORIZONTAL_NAME): Define. (XTset_vertical_scroll_bar): Attempt to clear areas not covered by scroll bar. - (XTcondemn_scroll_bars, XTredeem_scroll_bar): Rewrite. Handle - horizontal scroll bars. - (handle_one_xevent): Handle horizontal scroll bar events. Call - x_net_wm_state. + (XTcondemn_scroll_bars, XTredeem_scroll_bar): Rewrite. + Handle horizontal scroll bars. + (handle_one_xevent): Handle horizontal scroll bar events. + Call x_net_wm_state. (x_set_window_size_1, x_wm_set_size_hint): Don't call check_frame_size. (x_set_window_size): Don't call check_frame_size and @@ -1687,8 +1759,8 @@ 2014-07-25 Eli Zaretskii - * w32term.h (current_popup_menu, menubar_in_use): Move - declarations from w32term.c. + * w32term.h (current_popup_menu, menubar_in_use): + Move declarations from w32term.c. 2014-07-25 Martin Rudalics @@ -1742,8 +1814,8 @@ * xterm.c (handle_one_xevent): * gtkutil.c (xg_event_is_for_menubar): * xfns.c (x_window) [USE_X_TOOLKIT]: - * xmenu.c (set_frame_menubar, free_frame_menubar): Prefer - to use FRAME_MENUBAR_HEIGHT. + * xmenu.c (set_frame_menubar, free_frame_menubar): + Prefer to use FRAME_MENUBAR_HEIGHT. 2014-07-21 Dmitry Antipov @@ -1764,12 +1836,12 @@ 2014-07-21 Eli Zaretskii - * w32select.c (setup_windows_coding_system): Apply - CODING_ANNOTATION_MASK to the common_flags member of struct + * w32select.c (setup_windows_coding_system): + Apply CODING_ANNOTATION_MASK to the common_flags member of struct coding_system. Reported by martin rudalics . - * w16select.c (Fw16_get_clipboard_data): Apply - CODING_ANNOTATION_MASK to the common_flags member of struct + * w16select.c (Fw16_get_clipboard_data): + Apply CODING_ANNOTATION_MASK to the common_flags member of struct coding_system. * xdisp.c (init_iterator): Initialize it->stop_charpos to the @@ -1777,8 +1849,8 @@ (handle_invisible_prop): Record in it->stop_charpos the position where the invisible text ends. (Bug#18035) (hscroll_window_tree): Don't try hscrolling windows whose cursor - row has zero buffer position as their start position. Reported by - martin rudalics . + row has zero buffer position as their start position. + Reported by martin rudalics . * xdisp.c (move_it_vertically_backward, move_it_by_lines): Prevent infinite looping in redisplay when display lines don't have enough @@ -2218,8 +2290,8 @@ are in sync with what the window wants. (Bug#17892) - * xdisp.c (display_line, display_mode_line): Call - prepare_desired_row with additional arguments, as appropriate. + * xdisp.c (display_line, display_mode_line): + Call prepare_desired_row with additional arguments, as appropriate. * dispextern.h (prepare_desired_row): Adjust prototype. @@ -2308,7 +2380,7 @@ 2014-06-28 K. Handa - * coding.c (MAX_CHARBUF_SIZE): Renamed from CHARBUF_SIZE. + * coding.c (MAX_CHARBUF_SIZE): Rename from CHARBUF_SIZE. (MIN_CHARBUF_SIZE): New macro. (ALLOC_CONVERSION_WORK_AREA): New arg SIZE. Callers changed. === modified file 'src/dispextern.h' --- src/dispextern.h 2014-08-03 12:34:44 +0000 +++ src/dispextern.h 2014-09-22 19:20:45 +0000 @@ -2523,7 +2523,9 @@ /* First and last visible x-position in the display area. If window is hscrolled by n columns, first_visible_x == n * FRAME_COLUMN_WIDTH - (f), and last_visible_x == pixel width of W + first_visible_x. */ + (f), and last_visible_x == pixel width of W + first_visible_x. + When truncation or continuation glyphs are produced due to lack of + fringes, last_visible_x excludes the space required for these glyphs. */ int first_visible_x, last_visible_x; /* Last visible y-position + 1 in the display area without a mode === modified file 'src/eval.c' --- src/eval.c 2014-09-11 13:21:19 +0000 +++ src/eval.c 2014-09-22 19:20:45 +0000 @@ -104,7 +104,7 @@ union specbinding *backtrace_top (void) EXTERNALLY_VISIBLE; static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *); -static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args); +static Lisp_Object apply_lambda (Lisp_Object, Lisp_Object, ptrdiff_t); static Lisp_Object specpdl_symbol (union specbinding *pdl) @@ -172,17 +172,11 @@ /* Functions to modify slots of backtrace records. */ static void -set_backtrace_args (union specbinding *pdl, Lisp_Object *args) +set_backtrace_args (union specbinding *pdl, Lisp_Object *args, ptrdiff_t nargs) { eassert (pdl->kind == SPECPDL_BACKTRACE); pdl->bt.args = args; -} - -static void -set_backtrace_nargs (union specbinding *pdl, ptrdiff_t n) -{ - eassert (pdl->kind == SPECPDL_BACKTRACE); - pdl->bt.nargs = n; + pdl->bt.nargs = nargs; } static void @@ -334,10 +328,10 @@ } static void -do_debug_on_call (Lisp_Object code) +do_debug_on_call (Lisp_Object code, ptrdiff_t count) { debug_on_next_call = 0; - set_backtrace_debug_on_exit (specpdl_ptr - 1, true); + set_backtrace_debug_on_exit (specpdl + count, true); call_debugger (list1 (code)); } @@ -2035,9 +2029,11 @@ } } -void +ptrdiff_t record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs) { + ptrdiff_t count = SPECPDL_INDEX (); + eassert (nargs >= UNEVALLED); specpdl_ptr->bt.kind = SPECPDL_BACKTRACE; specpdl_ptr->bt.debug_on_exit = false; @@ -2045,6 +2041,8 @@ specpdl_ptr->bt.args = args; specpdl_ptr->bt.nargs = nargs; grow_specpdl (); + + return count; } /* Eval a sub-expression of the current expression (i.e. in the same @@ -2055,6 +2053,7 @@ Lisp_Object fun, val, original_fun, original_args; Lisp_Object funcar; struct gcpro gcpro1, gcpro2, gcpro3; + ptrdiff_t count; if (SYMBOLP (form)) { @@ -2092,10 +2091,10 @@ original_args = XCDR (form); /* This also protects them from gc. */ - record_in_backtrace (original_fun, &original_args, UNEVALLED); + count = record_in_backtrace (original_fun, &original_args, UNEVALLED); if (debug_on_next_call) - do_debug_on_call (Qt); + do_debug_on_call (Qt, count); /* At this point, only original_fun and original_args have values that will be used below. */ @@ -2147,8 +2146,7 @@ gcpro3.nvars = argnum; } - set_backtrace_args (specpdl_ptr - 1, vals); - set_backtrace_nargs (specpdl_ptr - 1, XINT (numargs)); + set_backtrace_args (specpdl + count, vals, XINT (numargs)); val = (XSUBR (fun)->function.aMANY) (XINT (numargs), vals); UNGCPRO; @@ -2169,8 +2167,7 @@ UNGCPRO; - set_backtrace_args (specpdl_ptr - 1, argvals); - set_backtrace_nargs (specpdl_ptr - 1, XINT (numargs)); + set_backtrace_args (specpdl + count, argvals, XINT (numargs)); switch (i) { @@ -2223,7 +2220,7 @@ } } else if (COMPILEDP (fun)) - val = apply_lambda (fun, original_args); + val = apply_lambda (fun, original_args, count); else { if (NILP (fun)) @@ -2240,7 +2237,7 @@ } if (EQ (funcar, Qmacro)) { - ptrdiff_t count = SPECPDL_INDEX (); + ptrdiff_t count1 = SPECPDL_INDEX (); Lisp_Object exp; /* Bind lexical-binding during expansion of the macro, so the macro can know reliably if the code it outputs will be @@ -2248,19 +2245,19 @@ specbind (Qlexical_binding, NILP (Vinternal_interpreter_environment) ? Qnil : Qt); exp = apply1 (Fcdr (fun), original_args); - unbind_to (count, Qnil); + unbind_to (count1, Qnil); val = eval_sub (exp); } else if (EQ (funcar, Qlambda) || EQ (funcar, Qclosure)) - val = apply_lambda (fun, original_args); + val = apply_lambda (fun, original_args, count); else xsignal1 (Qinvalid_function, original_fun); } check_cons_list (); lisp_eval_depth--; - if (backtrace_debug_on_exit (specpdl_ptr - 1)) + if (backtrace_debug_on_exit (specpdl + count)) val = call_debugger (list2 (Qexit, val)); specpdl_ptr--; @@ -2657,7 +2654,7 @@ Lisp_Object lisp_numargs; Lisp_Object val; register Lisp_Object *internal_args; - ptrdiff_t i; + ptrdiff_t i, count; QUIT; @@ -2670,13 +2667,13 @@ } /* This also GCPROs them. */ - record_in_backtrace (args[0], &args[1], nargs - 1); + count = record_in_backtrace (args[0], &args[1], nargs - 1); /* Call GC after setting up the backtrace, so the latter GCPROs the args. */ maybe_gc (); if (debug_on_next_call) - do_debug_on_call (Qlambda); + do_debug_on_call (Qlambda, count); check_cons_list (); @@ -2796,14 +2793,14 @@ } check_cons_list (); lisp_eval_depth--; - if (backtrace_debug_on_exit (specpdl_ptr - 1)) + if (backtrace_debug_on_exit (specpdl + count)) val = call_debugger (list2 (Qexit, val)); specpdl_ptr--; return val; } static Lisp_Object -apply_lambda (Lisp_Object fun, Lisp_Object args) +apply_lambda (Lisp_Object fun, Lisp_Object args, ptrdiff_t count) { Lisp_Object args_left; ptrdiff_t i; @@ -2830,15 +2827,14 @@ UNGCPRO; - set_backtrace_args (specpdl_ptr - 1, arg_vector); - set_backtrace_nargs (specpdl_ptr - 1, i); + set_backtrace_args (specpdl + count, arg_vector, i); tem = funcall_lambda (fun, numargs, arg_vector); /* Do the debug-on-exit now, while arg_vector still exists. */ - if (backtrace_debug_on_exit (specpdl_ptr - 1)) + if (backtrace_debug_on_exit (specpdl + count)) { /* Don't do it again when we return to eval. */ - set_backtrace_debug_on_exit (specpdl_ptr - 1, false); + set_backtrace_debug_on_exit (specpdl + count, false); tem = call_debugger (list2 (Qexit, tem)); } SAFE_FREE (); === modified file 'src/frame.c' --- src/frame.c 2014-09-18 11:34:24 +0000 +++ src/frame.c 2014-09-22 19:20:45 +0000 @@ -1806,9 +1806,9 @@ DEFUN ("mouse-position", Fmouse_position, Smouse_position, 0, 0, 0, doc: /* Return a list (FRAME X . Y) giving the current mouse frame and position. -The position is given in character cells, where (0, 0) is the -upper-left corner of the frame, X is the horizontal offset, and Y is -the vertical offset. +The position is given in canonical character cells, where (0, 0) is the +upper-left corner of the frame, X is the horizontal offset, and Y is the +vertical offset, measured in units of the frame's default character size. If Emacs is running on a mouseless terminal or hasn't been programmed to read the mouse position, it returns the selected frame for FRAME and nil for X and Y. @@ -1927,9 +1927,10 @@ so the coordinates of the top left character in the frame may be nonzero due to left-hand scroll bars or the menu bar. -The position is given in character cells, where (0, 0) is the -upper-left corner of the frame, X is the horizontal offset, and Y is -the vertical offset. +The position is given in canonical character cells, where (0, 0) is +the upper-left corner of the frame, X is the horizontal offset, and +Y is the vertical offset, measured in units of the frame's default +character size. This function is a no-op for an X frame that is not visible. If you have just created a frame, you must wait for it to become visible === modified file 'src/image.c' --- src/image.c 2014-09-07 07:04:01 +0000 +++ src/image.c 2014-09-22 19:20:45 +0000 @@ -8231,6 +8231,12 @@ return 0; } + if (MagickGetImageDelay (image_wand) > 0) + img->lisp_data = + Fcons (Qdelay, + Fcons (make_float (MagickGetImageDelay (image_wand) / 100.0), + img->lisp_data)); + if (MagickGetNumberImages (image_wand) > 1) img->lisp_data = Fcons (Qcount, === modified file 'src/lisp.h' --- src/lisp.h 2014-09-22 06:06:19 +0000 +++ src/lisp.h 2014-09-22 19:20:45 +0000 @@ -3976,8 +3976,7 @@ extern void init_eval (void); extern void syms_of_eval (void); extern void unwind_body (Lisp_Object); -extern void record_in_backtrace (Lisp_Object function, - Lisp_Object *args, ptrdiff_t nargs); +extern ptrdiff_t record_in_backtrace (Lisp_Object, Lisp_Object *, ptrdiff_t); extern void mark_specpdl (void); extern void get_backtrace (Lisp_Object array); Lisp_Object backtrace_top_function (void); === modified file 'src/macfont.m' --- src/macfont.m 2014-08-25 07:00:42 +0000 +++ src/macfont.m 2014-09-22 19:20:45 +0000 @@ -2598,20 +2598,25 @@ macfont_close (struct font *font) { struct macfont_info *macfont_info = (struct macfont_info *) font; - int i; - - block_input (); - CFRelease (macfont_info->macfont); - CGFontRelease (macfont_info->cgfont); - if (macfont_info->screen_font) - CFRelease (macfont_info->screen_font); - macfont_release_cache (macfont_info->cache); - for (i = 0; i < macfont_info->metrics_nrows; i++) - if (macfont_info->metrics[i]) - xfree (macfont_info->metrics[i]); - if (macfont_info->metrics) - xfree (macfont_info->metrics); - unblock_input (); + + if (macfont_info->cache) + { + int i; + + block_input (); + CFRelease (macfont_info->macfont); + CGFontRelease (macfont_info->cgfont); + if (macfont_info->screen_font) + CFRelease (macfont_info->screen_font); + macfont_release_cache (macfont_info->cache); + for (i = 0; i < macfont_info->metrics_nrows; i++) + if (macfont_info->metrics[i]) + xfree (macfont_info->metrics[i]); + if (macfont_info->metrics) + xfree (macfont_info->metrics); + macfont_info->cache = NULL; + unblock_input (); + } } static int === modified file 'src/unexmacosx.c' --- src/unexmacosx.c 2014-09-17 19:58:31 +0000 +++ src/unexmacosx.c 2014-09-22 19:20:45 +0000 @@ -1322,7 +1322,9 @@ } if (curr_header_offset > text_seg_lowest_offset) - unexec_error ("not enough room for load commands for new __DATA segments"); + unexec_error ("not enough room for load commands for new __DATA segments" + " (increase headerpad_extra in configure.in to at least %lX)", + num_unexec_regions * sizeof (struct segment_command)); printf ("%ld unused bytes follow Mach-O header\n", text_seg_lowest_offset - curr_header_offset); === modified file 'src/w32term.c' --- src/w32term.c 2014-08-28 06:46:58 +0000 +++ src/w32term.c 2014-09-22 19:20:45 +0000 @@ -2228,7 +2228,7 @@ { /* In R2L rows, draw the cursor on the right edge of the stretch glyph. */ - int right_x = window_box_right_offset (s->w, TEXT_AREA); + int right_x = window_box_right (s->w, TEXT_AREA); if (x + background_width > right_x) background_width -= x - right_x; @@ -5472,6 +5472,12 @@ /* Compute frame-relative coordinates for phys cursor. */ get_phys_cursor_geometry (w, row, cursor_glyph, &left, &top, &h); rect.left = left; + /* When on R2L character, show cursor at the right edge of the + glyph, unless the cursor box is as wide as the glyph or wider + (the latter happens when x-stretch-cursor is non-nil). */ + if ((cursor_glyph->resolved_level & 1) != 0 + && cursor_glyph->pixel_width > w->phys_cursor_width) + rect.left += cursor_glyph->pixel_width - w->phys_cursor_width; rect.top = top; rect.bottom = rect.top + h; rect.right = rect.left + w->phys_cursor_width; @@ -5553,7 +5559,7 @@ WINDOW_TO_FRAME_PIXEL_Y (w, w->phys_cursor.y), width, row->height); } - else + else /* HBAR_CURSOR */ { int dummy_x, dummy_y, dummy_h; @@ -5564,6 +5570,9 @@ get_phys_cursor_geometry (w, row, cursor_glyph, &dummy_x, &dummy_y, &dummy_h); + if ((cursor_glyph->resolved_level & 1) != 0 + && cursor_glyph->pixel_width > w->phys_cursor_width) + x += cursor_glyph->pixel_width - w->phys_cursor_width; w32_fill_area (f, hdc, cursor_color, x, WINDOW_TO_FRAME_PIXEL_Y (w, w->phys_cursor.y + row->height - width), === modified file 'src/xdisp.c' --- src/xdisp.c 2014-09-21 22:49:24 +0000 +++ src/xdisp.c 2014-09-22 19:20:45 +0000 @@ -2995,12 +2995,8 @@ /* If we truncate lines, leave room for the truncation glyph(s) at the right margin. Otherwise, leave room for the continuation - glyph(s). Done only if the window has no fringes. Since we - don't know at this point whether there will be any R2L lines in - the window, we reserve space for truncation/continuation glyphs - even if only one of the fringes is absent. */ - if (WINDOW_RIGHT_FRINGE_WIDTH (it->w) == 0 - || (it->bidi_p && WINDOW_LEFT_FRINGE_WIDTH (it->w) == 0)) + glyph(s). Done only if the window has no right fringe. */ + if (WINDOW_RIGHT_FRINGE_WIDTH (it->w) == 0) { if (it->line_wrap == TRUNCATE) it->last_visible_x -= it->truncation_pixel_width; @@ -3065,6 +3061,19 @@ iterator. */ if (it->bidi_p) { + /* Since we don't know at this point whether there will be + any R2L lines in the window, we reserve space for + truncation/continuation glyphs even if only the left + fringe is absent. */ + if (base_face_id == DEFAULT_FACE_ID + && WINDOW_LEFT_FRINGE_WIDTH (it->w) == 0 + && WINDOW_RIGHT_FRINGE_WIDTH (it->w) != 0) + { + if (it->line_wrap == TRUNCATE) + it->last_visible_x -= it->truncation_pixel_width; + else + it->last_visible_x -= it->continuation_pixel_width; + } /* Note the paragraph direction that this buffer wants to use. */ if (EQ (BVAR (current_buffer, bidi_paragraph_direction), @@ -13564,6 +13573,12 @@ if (mode_line_update_needed (w)) w->update_mode_line = 1; + + /* If reconsider_clip_changes above decided that the narrowing + in the current buffer changed, make sure all other windows + showing that buffer will be redisplayed. */ + if (current_buffer->clip_changed) + bset_update_mode_line (current_buffer); } /* Normally the message* functions will have already displayed and @@ -19386,7 +19401,18 @@ for (row_width = 0, g = row_start; g < row_end; g++) row_width += g->pixel_width; - stretch_width = window_box_width (it->w, TEXT_AREA) - row_width; + + /* FIXME: There are various minor display glitches in R2L + rows when only one of the fringes is missing. The + strange condition below produces the least bad effect. */ + if ((WINDOW_LEFT_FRINGE_WIDTH (it->w) == 0) + == (WINDOW_RIGHT_FRINGE_WIDTH (it->w) == 0) + || WINDOW_RIGHT_FRINGE_WIDTH (it->w) != 0) + stretch_width = window_box_width (it->w, TEXT_AREA); + else + stretch_width = it->last_visible_x - it->first_visible_x; + stretch_width -= row_width; + if (stretch_width > 0) { stretch_ascent = @@ -20527,9 +20553,17 @@ /* When the last glyph of an R2L row only fits partially on the line, we need to set row->x to a negative offset, so that the leftmost glyph is - the one that is partially visible. */ - if (row->reversed_p && new_x > it->last_visible_x) - row->x = it->last_visible_x - new_x; + the one that is partially visible. But if we are + going to produce the truncation glyph, this will + be taken care of in produce_special_glyphs. */ + if (row->reversed_p + && new_x > it->last_visible_x + && !(it->line_wrap == TRUNCATE + && WINDOW_LEFT_FRINGE_WIDTH (it->w) == 0)) + { + eassert (FRAME_WINDOW_P (it->f)); + row->x = it->last_visible_x - new_x; + } } else { @@ -20603,7 +20637,10 @@ that they are cropped at the right edge of the window, so an image glyph will always end exactly at last_visible_x, even if there's no right fringe. */ - && (WINDOW_RIGHT_FRINGE_WIDTH (it->w) || it->what == IT_IMAGE)) + && ((row->reversed_p + ? WINDOW_LEFT_FRINGE_WIDTH (it->w) + : WINDOW_RIGHT_FRINGE_WIDTH (it->w)) + || it->what == IT_IMAGE)) ? (it->current_x >= it->last_visible_x) : (it->current_x > it->last_visible_x))) { @@ -25780,14 +25817,13 @@ temp_it.dp = NULL; temp_it.what = IT_CHARACTER; - temp_it.len = 1; temp_it.c = temp_it.char_to_display = GLYPH_CHAR (glyph); temp_it.face_id = GLYPH_FACE (glyph); temp_it.len = CHAR_BYTES (temp_it.c); PRODUCE_GLYPHS (&temp_it); it->pixel_width = temp_it.pixel_width; - it->nglyphs = temp_it.pixel_width; + it->nglyphs = temp_it.nglyphs; } #ifdef HAVE_WINDOW_SYSTEM === modified file 'src/xterm.c' --- src/xterm.c 2014-09-16 08:20:08 +0000 +++ src/xterm.c 2014-09-22 19:20:45 +0000 @@ -2474,7 +2474,7 @@ { /* In R2L rows, draw the cursor on the right edge of the stretch glyph. */ - int right_x = window_box_right_offset (s->w, TEXT_AREA); + int right_x = window_box_right (s->w, TEXT_AREA); if (x + background_width > right_x) background_width -= x - right_x; @@ -7977,6 +7977,15 @@ GCForeground, &xgcv); gc = dpyinfo->scratch_cursor_gc; + /* When on R2L character, show cursor at the right edge of the + glyph, unless the cursor box is as wide as the glyph or wider + (the latter happens when x-stretch-cursor is non-nil). */ + if ((cursor_glyph->resolved_level & 1) != 0 + && cursor_glyph->pixel_width > w->phys_cursor_width) + { + x += cursor_glyph->pixel_width - w->phys_cursor_width; + wd -= 1; + } /* Set clipping, draw the rectangle, and reset clipping again. */ x_clip_to_row (w, row, TEXT_AREA, gc); XDrawRectangle (dpy, FRAME_X_WINDOW (f), gc, x, y, wd, h - 1); @@ -8062,9 +8071,10 @@ WINDOW_TO_FRAME_PIXEL_Y (w, w->phys_cursor.y), width, row->height); } - else + else /* HBAR_CURSOR */ { int dummy_x, dummy_y, dummy_h; + int x = WINDOW_TEXT_TO_FRAME_PIXEL_X (w, w->phys_cursor.x); if (width < 0) width = row->height; @@ -8074,8 +8084,10 @@ get_phys_cursor_geometry (w, row, cursor_glyph, &dummy_x, &dummy_y, &dummy_h); - XFillRectangle (dpy, window, gc, - WINDOW_TEXT_TO_FRAME_PIXEL_X (w, w->phys_cursor.x), + if ((cursor_glyph->resolved_level & 1) != 0 + && cursor_glyph->pixel_width > w->phys_cursor_width) + x += cursor_glyph->pixel_width - w->phys_cursor_width; + XFillRectangle (dpy, window, gc, x, WINDOW_TO_FRAME_PIXEL_Y (w, w->phys_cursor.y + row->height - width), w->phys_cursor_width, width); ------------------------------------------------------------ revno: 117922 committer: Sam Steingold branch nick: trunk timestamp: Mon 2014-09-22 15:19:29 -0400 message: oops diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2014-09-22 19:17:40 +0000 +++ lisp/ChangeLog 2014-09-22 19:19:29 +0000 @@ -1,6 +1,7 @@ 2014-09-22 Sam Steingold * progmodes/sql.el (sql-product-alist): Improve the Vertica entry. + (sql-execute): Use `special-mode'. 2014-09-22 Stefan Monnier ------------------------------------------------------------ revno: 117921 committer: Sam Steingold branch nick: trunk timestamp: Mon 2014-09-22 15:18:29 -0400 message: (sql-execute): Use `special-mode'. * sql.el (sql-execute): Use `special-mode'. diff: === modified file 'lisp/progmodes/sql.el' --- lisp/progmodes/sql.el 2014-09-22 19:17:40 +0000 +++ lisp/progmodes/sql.el 2014-09-22 19:18:29 +0000 @@ -3624,7 +3624,11 @@ (get-lru-window)))) (with-current-buffer outbuf (set-buffer-modified-p nil) - (read-only-mode +1)) + (setq-local revert-buffer-function + (lambda (_ignore-auto _noconfirm) + (sql-execute sqlbuf (buffer-name outbuf) + command enhanced arg))) + (special-mode)) (pop-to-buffer outbuf) (when one-win (shrink-window-if-larger-than-buffer))))) ------------------------------------------------------------ revno: 117920 committer: Sam Steingold branch nick: trunk timestamp: Mon 2014-09-22 15:17:40 -0400 message: (sql-product-alist): Improve the Vertica entry. * lisp/progmodes/sql.el (sql-product-alist): Improve the Vertica entry. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2014-09-22 18:22:02 +0000 +++ lisp/ChangeLog 2014-09-22 19:17:40 +0000 @@ -1,3 +1,7 @@ +2014-09-22 Sam Steingold + + * progmodes/sql.el (sql-product-alist): Improve the Vertica entry. + 2014-09-22 Stefan Monnier Add pcase-defmacro, as well as `quote' and `app' patterns. === modified file 'lisp/progmodes/sql.el' --- lisp/progmodes/sql.el 2014-09-14 01:28:27 +0000 +++ lisp/progmodes/sql.el 2014-09-22 19:17:40 +0000 @@ -511,9 +511,8 @@ :sqli-program sql-vertica-program :sqli-options sql-vertica-options :sqli-login sql-vertica-login-params - :sqli-comint-func 'sql-comint-vertica - :list-all ("select table_name from v_catalog.tables" . - "select * from v_catalog.tables") + :sqli-comint-func sql-comint-vertica + :list-all ("\\d" . "\\dS") :list-table "\\d %s" :prompt-regexp "^\\w*=[#>] " :prompt-length 5 ------------------------------------------------------------ revno: 117919 [merge] committer: Stefan Monnier branch nick: trunk timestamp: Mon 2014-09-22 14:22:02 -0400 message: Add pcase-defmacro, as well as `quote' and `app' patterns. * loadup.el: Increase max-lisp-eval-depth when macroexpanding macroexp. * emacs-lisp/pcase.el: Allow (F . ARGS) in `app' patterns. (pcase--funcall, pcase--eval): New functions. (pcase--u1): Use them for guard, pred, let, and app. (\`): Use the new feature to generate better code for vector patterns. * emacs-lisp/pcase.el: Use pcase-defmacro to handle backquote. (pcase--upat): Remove. (pcase--macroexpand): Don't hardcode handling of `. (pcase--split-consp, pcase--split-vector): Remove. (pcase--split-equal): Disregard ` since it's expanded away. (pcase--split-member): Optimize for quote rather than for `. (pcase--split-pred): Optimize for quote rather than for `. (pcase--u1): Remove handling of ` (and of `or' and `and'). Quote non-selfquoting values when passing them to `eq'. Drop `app's let-binding if the variable is not used. (pcase--q1): Remove. (`): Define as a pattern macro. * emacs-lisp/pcase.el (pcase--match): New smart-constructor function. (pcase--expand pcase--q1, pcase--app-subst-match): Use it. (pcase--macroexpand): Handle self-quoting patterns here, expand them to quote patterns. (pcase--split-match): Don't hoist or/and here any more. (pcase--split-equal): Optimize quote patterns as well as ` patterns. (pcase--flip): New helper macro. (pcase--u1): Optimize the memq case directly. Don't handle neither self-quoting nor and/or patterns any more. * emacs-lisp/pcase.el (pcase-defmacro): New macro. (pcase--macroexpand): New function. (pcase--expand): Use it. * emacs-lisp/pcase.el (pcase--app-subst-match, pcase--app-subst-rest): New optimization functions. (pcase--u1): Add support for `quote' and `app'. (pcase): Document them in the docstring. diff: === modified file 'etc/NEWS' --- etc/NEWS 2014-09-15 00:20:21 +0000 +++ etc/NEWS 2014-09-22 15:04:12 +0000 @@ -102,6 +102,10 @@ * Changes in Specialized Modes and Packages in Emacs 24.5 +** pcase +*** New UPatterns `quote' and `app'. +*** New UPatterns can be defined with `pcase-defmacro'. + ** Lisp mode *** Strings after `:documentation' are highlighted as docstrings. === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2014-09-22 14:10:53 +0000 +++ lisp/ChangeLog 2014-09-22 18:22:02 +0000 @@ -1,5 +1,42 @@ 2014-09-22 Stefan Monnier + Add pcase-defmacro, as well as `quote' and `app' patterns. + * loadup.el: Increase max-lisp-eval-depth when macroexpanding macroexp. + * emacs-lisp/pcase.el: Allow (F . ARGS) in `app' patterns. + (pcase--funcall, pcase--eval): New functions. + (pcase--u1): Use them for guard, pred, let, and app. + (\`): Use the new feature to generate better code for vector patterns. + * emacs-lisp/pcase.el: Use pcase-defmacro to handle backquote. + (pcase--upat): Remove. + (pcase--macroexpand): Don't hardcode handling of `. + (pcase--split-consp, pcase--split-vector): Remove. + (pcase--split-equal): Disregard ` since it's expanded away. + (pcase--split-member): Optimize for quote rather than for `. + (pcase--split-pred): Optimize for quote rather than for `. + (pcase--u1): Remove handling of ` (and of `or' and `and'). + Quote non-selfquoting values when passing them to `eq'. + Drop `app's let-binding if the variable is not used. + (pcase--q1): Remove. + (`): Define as a pattern macro. + * emacs-lisp/pcase.el (pcase--match): New smart-constructor function. + (pcase--expand pcase--q1, pcase--app-subst-match): Use it. + (pcase--macroexpand): Handle self-quoting patterns here, expand them to + quote patterns. + (pcase--split-match): Don't hoist or/and here any more. + (pcase--split-equal): Optimize quote patterns as well as ` patterns. + (pcase--flip): New helper macro. + (pcase--u1): Optimize the memq case directly. + Don't handle neither self-quoting nor and/or patterns any more. + * emacs-lisp/pcase.el (pcase-defmacro): New macro. + (pcase--macroexpand): New function. + (pcase--expand): Use it. + * emacs-lisp/pcase.el (pcase--app-subst-match, pcase--app-subst-rest): + New optimization functions. + (pcase--u1): Add support for `quote' and `app'. + (pcase): Document them in the docstring. + +2014-09-22 Stefan Monnier + Use lexical-bindin in Ibuffer. * ibuffer.el (ibuffer-do-toggle-read-only): `arg' is unused. (ibuffer-compile-format): Simplify. === modified file 'lisp/emacs-lisp/pcase.el' --- lisp/emacs-lisp/pcase.el 2014-09-13 16:30:21 +0000 +++ lisp/emacs-lisp/pcase.el 2014-09-22 18:05:22 +0000 @@ -102,10 +102,12 @@ SYMBOL matches anything and binds it to SYMBOL. (or UPAT...) matches if any of the patterns matches. (and UPAT...) matches if all the patterns match. + 'VAL matches if the object is `equal' to VAL `QPAT matches if the QPattern QPAT matches. - (pred PRED) matches if PRED applied to the object returns non-nil. + (pred FUN) matches if FUN applied to the object returns non-nil. (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. (let UPAT EXP) matches if EXP matches UPAT. + (app FUN UPAT) matches if FUN applied to the object matches UPAT. If a SYMBOL is used twice in the same pattern (i.e. the pattern is \"non-linear\"), then the second occurrence is turned into an `eq'uality test. @@ -117,12 +119,14 @@ STRING matches if the object is `equal' to STRING. ATOM matches if the object is `eq' to ATOM. -PRED can take the form - FUNCTION in which case it gets called with one argument. - (FUN ARG1 .. ARGN) in which case it gets called with an N+1'th argument +FUN can take the form + SYMBOL or (lambda ARGS BODY) in which case it's called with one argument. + (F ARG1 .. ARGn) in which case F gets called with an n+1'th argument which is the value being matched. -A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION). -PRED patterns can refer to variables bound earlier in the pattern. +So a FUN of the form SYMBOL is equivalent to one of the form (FUN). +FUN can refer to variables bound earlier in the pattern. +FUN is assumed to be pure, i.e. it can be dropped if its result is not used, +and two identical calls can be merged into one. E.g. you can match pairs where the cdr is larger than the car with a pattern like `(,a . ,(pred (< a))) or, with more checks: `(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))" @@ -157,6 +161,7 @@ (let* ((x (make-symbol "x")) (pcase--dontwarn-upats (cons x pcase--dontwarn-upats))) (pcase--expand + ;; FIXME: Could we add the FILE:LINE data in the error message? exp (append cases `((,x (error "No clause matching `%S'" ,x))))))) (defun pcase--let* (bindings body) @@ -277,7 +282,7 @@ (main (pcase--u (mapcar (lambda (case) - `((match ,val . ,(car case)) + `(,(pcase--match val (pcase--macroexpand (car case))) ,(lambda (vars) (unless (memq case used-cases) ;; Keep track of the cases that are used. @@ -296,6 +301,45 @@ (message "Redundant pcase pattern: %S" (car case)))) (macroexp-let* defs main)))) +(defun pcase--macroexpand (pat) + "Expands all macro-patterns in PAT." + (let ((head (car-safe pat))) + (cond + ((null head) + (if (pcase--self-quoting-p pat) `',pat pat)) + ((memq head '(pred guard quote)) pat) + ((memq head '(or and)) `(,head ,@(mapcar #'pcase--macroexpand (cdr pat)))) + ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat))) + ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat)))) + (t + (let* ((expander (get head 'pcase-macroexpander)) + (npat (if expander (apply expander (cdr pat))))) + (if (null npat) + (error (if expander + "Unexpandable %s pattern: %S" + "Unknown %s pattern: %S") + head pat) + (pcase--macroexpand npat))))))) + +;;;###autoload +(defmacro pcase-defmacro (name args &rest body) + "Define a pcase UPattern macro." + (declare (indent 2) (debug (def-name sexp def-body)) (doc-string 3)) + `(put ',name 'pcase-macroexpander + (lambda ,args ,@body))) + +(defun pcase--match (val upat) + "Build a MATCH structure, hoisting all `or's and `and's outside." + (cond + ;; Hoist or/and patterns into or/and matches. + ((memq (car-safe upat) '(or and)) + `(,(car upat) + ,@(mapcar (lambda (upat) + (pcase--match val upat)) + (cdr upat)))) + (t + `(match ,val . ,upat)))) + (defun pcase-codegen (code vars) ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy @@ -319,11 +363,6 @@ ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen? (t (macroexp-if test then else)))) -(defun pcase--upat (qpattern) - (cond - ((eq (car-safe qpattern) '\,) (cadr qpattern)) - (t (list '\` qpattern)))) - ;; Note about MATCH: ;; When we have patterns like `(PAT1 . PAT2), after performing the `consp' ;; check, we want to turn all the similar patterns into ones of the form @@ -399,17 +438,8 @@ ((eq (car match) 'match) (if (not (eq sym (cadr match))) (cons match match) - (let ((pat (cddr match))) - (cond - ;; Hoist `or' and `and' patterns to `or' and `and' matches. - ((memq (car-safe pat) '(or and)) - (pcase--split-match sym splitter - (cons (car pat) - (mapcar (lambda (alt) - `(match ,sym . ,alt)) - (cdr pat))))) - (t (let ((res (funcall splitter (cddr match)))) - (cons (or (car res) match) (or (cdr res) match)))))))) + (let ((res (funcall splitter (cddr match)))) + (cons (or (car res) match) (or (cdr res) match))))) ((memq (car match) '(or and)) (let ((then-alts '()) (else-alts '()) @@ -446,45 +476,13 @@ (push (cons (cdr split) code&vars) else-rest)))) (cons (nreverse then-rest) (nreverse else-rest)))) -(defun pcase--split-consp (syma symd pat) - (cond - ;; A QPattern for a cons, can only go the `then' side. - ((and (eq (car-safe pat) '\`) (consp (cadr pat))) - (let ((qpat (cadr pat))) - (cons `(and (match ,syma . ,(pcase--upat (car qpat))) - (match ,symd . ,(pcase--upat (cdr qpat)))) - :pcase--fail))) - ;; A QPattern but not for a cons, can only go to the `else' side. - ((eq (car-safe pat) '\`) '(:pcase--fail . nil)) - ((and (eq (car-safe pat) 'pred) - (pcase--mutually-exclusive-p #'consp (cadr pat))) - '(:pcase--fail . nil)))) - -(defun pcase--split-vector (syms pat) - (cond - ;; A QPattern for a vector of same length. - ((and (eq (car-safe pat) '\`) - (vectorp (cadr pat)) - (= (length syms) (length (cadr pat)))) - (let ((qpat (cadr pat))) - (cons `(and ,@(mapcar (lambda (s) - `(match ,(car s) . - ,(pcase--upat (aref qpat (cdr s))))) - syms)) - :pcase--fail))) - ;; Other QPatterns go to the `else' side. - ((eq (car-safe pat) '\`) '(:pcase--fail . nil)) - ((and (eq (car-safe pat) 'pred) - (pcase--mutually-exclusive-p #'vectorp (cadr pat))) - '(:pcase--fail . nil)))) - (defun pcase--split-equal (elem pat) (cond ;; The same match will give the same result. - ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem)) + ((and (eq (car-safe pat) 'quote) (equal (cadr pat) elem)) '(:pcase--succeed . :pcase--fail)) ;; A different match will fail if this one succeeds. - ((and (eq (car-safe pat) '\`) + ((and (eq (car-safe pat) 'quote) ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) ;; (consp (cadr pat))) ) @@ -498,6 +496,7 @@ '(:pcase--fail . nil)))))) (defun pcase--split-member (elems pat) + ;; FIXME: The new pred-based member code doesn't do these optimizations! ;; Based on pcase--split-equal. (cond ;; The same match (or a match of membership in a superset) will @@ -505,10 +504,10 @@ ;; (??? ;; '(:pcase--succeed . nil)) ;; A match for one of the elements may succeed or fail. - ((and (eq (car-safe pat) '\`) (member (cadr pat) elems)) + ((and (eq (car-safe pat) 'quote) (member (cadr pat) elems)) nil) ;; A different match will fail if this one succeeds. - ((and (eq (car-safe pat) '\`) + ((and (eq (car-safe pat) 'quote) ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) ;; (consp (cadr pat))) ) @@ -539,7 +538,7 @@ ((and (eq 'pred (car upat)) (let ((otherpred (cond ((eq 'pred (car-safe pat)) (cadr pat)) - ((not (eq '\` (car-safe pat))) nil) + ((not (eq 'quote (car-safe pat))) nil) ((consp (cadr pat)) #'consp) ((vectorp (cadr pat)) #'vectorp) ((byte-code-function-p (cadr pat)) @@ -547,7 +546,7 @@ (pcase--mutually-exclusive-p (cadr upat) otherpred))) '(:pcase--fail . nil)) ((and (eq 'pred (car upat)) - (eq '\` (car-safe pat)) + (eq 'quote (car-safe pat)) (symbolp (cadr upat)) (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat))) (get (cadr upat) 'side-effect-free) @@ -569,10 +568,70 @@ (defun pcase--self-quoting-p (upat) (or (keywordp upat) (numberp upat) (stringp upat))) +(defun pcase--app-subst-match (match sym fun nsym) + (cond + ((eq (car match) 'match) + (if (and (eq sym (cadr match)) + (eq 'app (car-safe (cddr match))) + (equal fun (nth 1 (cddr match)))) + (pcase--match nsym (nth 2 (cddr match))) + match)) + ((memq (car match) '(or and)) + `(,(car match) + ,@(mapcar (lambda (match) + (pcase--app-subst-match match sym fun nsym)) + (cdr match)))) + (t (error "Uknown MATCH %s" match)))) + +(defun pcase--app-subst-rest (rest sym fun nsym) + (mapcar (lambda (branch) + `(,(pcase--app-subst-match (car branch) sym fun nsym) + ,@(cdr branch))) + rest)) + (defsubst pcase--mark-used (sym) ;; Exceptionally, `sym' may be a constant expression rather than a symbol. (if (symbolp sym) (put sym 'pcase-used t))) +(defmacro pcase--flip (fun arg1 arg2) + "Helper function, used internally to avoid (funcall (lambda ...) ...)." + (declare (debug (sexp body))) + `(,fun ,arg2 ,arg1)) + +(defun pcase--funcall (fun arg vars) + "Build a function call to FUN with arg ARG." + (if (symbolp fun) + `(,fun ,arg) + (let* (;; `vs' is an upper bound on the vars we need. + (vs (pcase--fgrep (mapcar #'car vars) fun)) + (env (mapcar (lambda (var) + (list var (cdr (assq var vars)))) + vs)) + (call (progn + (when (memq arg vs) + ;; `arg' is shadowed by `env'. + (let ((newsym (make-symbol "x"))) + (push (list newsym arg) env) + (setq arg newsym))) + (if (functionp fun) + `(funcall #',fun ,arg) + `(,@fun ,arg))))) + (if (null vs) + call + ;; Let's not replace `vars' in `fun' since it's + ;; too difficult to do it right, instead just + ;; let-bind `vars' around `fun'. + `(let* ,env ,call))))) + +(defun pcase--eval (exp vars) + "Build an expression that will evaluate EXP." + (let* ((found (assq exp vars))) + (if found (cdr found) + (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) + (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) + vs))) + (if env (macroexp-let* env exp) exp))))) + ;; It's very tempting to use `pcase' below, tho obviously, it'd create ;; bootstrapping problems. (defun pcase--u1 (matches code vars rest) @@ -594,22 +653,26 @@ ((eq 'or (caar matches)) (let* ((alts (cdar matches)) (var (if (eq (caar alts) 'match) (cadr (car alts)))) - (simples '()) (others '())) + (simples '()) (others '()) (memq-ok t)) (when var (dolist (alt alts) (if (and (eq (car alt) 'match) (eq var (cadr alt)) (let ((upat (cddr alt))) - (and (eq (car-safe upat) '\`) - (or (integerp (cadr upat)) (symbolp (cadr upat)) - (stringp (cadr upat)))))) - (push (cddr alt) simples) + (eq (car-safe upat) 'quote))) + (let ((val (cadr (cddr alt)))) + (unless (or (integerp val) (symbolp val)) + (setq memq-ok nil)) + (push (cadr (cddr alt)) simples)) (push alt others)))) (cond ((null alts) (error "Please avoid it") (pcase--u rest)) + ;; Yes, we can use `memq' (or `member')! ((> (length simples) 1) - ;; De-hoist the `or' MATCH into an `or' pattern that will be - ;; turned into a `memq' below. - (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches)) + (pcase--u1 (cons `(match ,var + . (pred (pcase--flip + ,(if memq-ok #'memq #'member) + ',simples))) + (cdr matches)) code vars (if (null others) rest (cons (cons @@ -643,35 +706,11 @@ sym (lambda (pat) (pcase--split-pred vars upat pat)) rest)) (then-rest (car splitrest)) (else-rest (cdr splitrest))) - (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat))) - `(,(cadr upat) ,sym) - (let* ((exp (cadr upat)) - ;; `vs' is an upper bound on the vars we need. - (vs (pcase--fgrep (mapcar #'car vars) exp)) - (env (mapcar (lambda (var) - (list var (cdr (assq var vars)))) - vs)) - (call (if (eq 'guard (car upat)) - exp - (when (memq sym vs) - ;; `sym' is shadowed by `env'. - (let ((newsym (make-symbol "x"))) - (push (list newsym sym) env) - (setq sym newsym))) - (if (functionp exp) - `(funcall #',exp ,sym) - `(,@exp ,sym))))) - (if (null vs) - call - ;; Let's not replace `vars' in `exp' since it's - ;; too difficult to do it right, instead just - ;; let-bind `vars' around `exp'. - `(let* ,env ,call)))) + (pcase--if (if (eq (car upat) 'pred) + (pcase--funcall (cadr upat) sym vars) + (pcase--eval (cadr upat) vars)) (pcase--u1 matches code vars then-rest) (pcase--u else-rest)))) - ((pcase--self-quoting-p upat) - (pcase--mark-used sym) - (pcase--q1 sym upat matches code vars rest)) ((symbolp upat) (pcase--mark-used sym) (if (not (assq upat vars)) @@ -686,57 +725,41 @@ ;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest) (macroexp-let2 macroexp-copyable-p sym - (let* ((exp (nth 2 upat)) - (found (assq exp vars))) - (if found (cdr found) - (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) - (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) - vs))) - (if env (macroexp-let* env exp) exp)))) - (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches) + (pcase--eval (nth 2 upat) vars) + (pcase--u1 (cons (pcase--match sym (nth 1 upat)) matches) code vars rest))) - ((eq (car-safe upat) '\`) - (pcase--mark-used sym) - (pcase--q1 sym (cadr upat) matches code vars rest)) - ((eq (car-safe upat) 'or) - (let ((all (> (length (cdr upat)) 1)) - (memq-fine t)) - (when all - (dolist (alt (cdr upat)) - (unless (if (pcase--self-quoting-p alt) - (progn - (unless (or (symbolp alt) (integerp alt)) - (setq memq-fine nil)) - t) - (and (eq (car-safe alt) '\`) - (or (symbolp (cadr alt)) (integerp (cadr alt)) - (setq memq-fine nil) - (stringp (cadr alt))))) - (setq all nil)))) - (if all - ;; Use memq for (or `a `b `c `d) rather than a big tree. - (let* ((elems (mapcar (lambda (x) (if (consp x) (cadr x) x)) - (cdr upat))) - (splitrest - (pcase--split-rest - sym (lambda (pat) (pcase--split-member elems pat)) rest)) - (then-rest (car splitrest)) - (else-rest (cdr splitrest))) - (pcase--mark-used sym) - (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems) - (pcase--u1 matches code vars then-rest) - (pcase--u else-rest))) - (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars - (append (mapcar (lambda (upat) - `((and (match ,sym . ,upat) ,@matches) - ,code ,@vars)) - (cddr upat)) - rest))))) - ((eq (car-safe upat) 'and) - (pcase--u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat)) - (cdr upat)) - matches) - code vars rest)) + ((eq (car-safe upat) 'app) + ;; A upat of the form (app FUN UPAT) + (pcase--mark-used sym) + (let* ((fun (nth 1 upat)) + (nsym (make-symbol "x")) + (body + ;; We don't change `matches' to reuse the newly computed value, + ;; because we assume there shouldn't be such redundancy in there. + (pcase--u1 (cons (pcase--match nsym (nth 2 upat)) matches) + code vars + (pcase--app-subst-rest rest sym fun nsym)))) + (if (not (get nsym 'pcase-used)) + body + (macroexp-let* + `((,nsym ,(pcase--funcall fun sym vars))) + body)))) + ((eq (car-safe upat) 'quote) + (pcase--mark-used sym) + (let* ((val (cadr upat)) + (splitrest (pcase--split-rest + sym (lambda (pat) (pcase--split-equal val pat)) rest)) + (then-rest (car splitrest)) + (else-rest (cdr splitrest))) + (pcase--if (cond + ((null val) `(null ,sym)) + ((or (integerp val) (symbolp val)) + (if (pcase--self-quoting-p val) + `(eq ,sym ,val) + `(eq ,sym ',val))) + (t `(equal ,sym ',val))) + (pcase--u1 matches code vars then-rest) + (pcase--u else-rest)))) ((eq (car-safe upat) 'not) ;; FIXME: The implementation below is naive and results in ;; inefficient code. @@ -758,79 +781,25 @@ (pcase--u rest)) vars (list `((and . ,matches) ,code . ,vars)))) - (t (error "Unknown upattern `%s'" upat))))) - (t (error "Incorrect MATCH %s" (car matches))))) + (t (error "Unknown internal pattern `%S'" upat))))) + (t (error "Incorrect MATCH %S" (car matches))))) -(defun pcase--q1 (sym qpat matches code vars rest) - "Return code that runs CODE if SYM matches QPAT and if MATCHES match. -Otherwise, it defers to REST which is a list of branches of the form -\(OTHER_MATCH OTHER-CODE . OTHER-VARS)." +(pcase-defmacro \` (qpat) (cond - ((eq (car-safe qpat) '\,) (error "Can't use `,UPATTERN")) - ((floatp qpat) (error "Floating point patterns not supported")) + ((eq (car-safe qpat) '\,) (cadr qpat)) ((vectorp qpat) - (let* ((len (length qpat)) - (syms (mapcar (lambda (i) (cons (make-symbol (format "xaref%s" i)) i)) - (number-sequence 0 (1- len)))) - (splitrest (pcase--split-rest - sym - (lambda (pat) (pcase--split-vector syms pat)) - rest)) - (then-rest (car splitrest)) - (else-rest (cdr splitrest)) - (then-body (pcase--u1 - `(,@(mapcar (lambda (s) - `(match ,(car s) . - ,(pcase--upat (aref qpat (cdr s))))) - syms) - ,@matches) - code vars then-rest))) - (pcase--if - `(and (vectorp ,sym) (= (length ,sym) ,len)) - (macroexp-let* (delq nil (mapcar (lambda (s) - (and (get (car s) 'pcase-used) - `(,(car s) (aref ,sym ,(cdr s))))) - syms)) - then-body) - (pcase--u else-rest)))) + `(and (pred vectorp) + (app length ,(length qpat)) + ,@(let ((upats nil)) + (dotimes (i (length qpat)) + (push `(app (pcase--flip aref ,i) ,(list '\` (aref qpat i))) + upats)) + (nreverse upats)))) ((consp qpat) - (let* ((syma (make-symbol "xcar")) - (symd (make-symbol "xcdr")) - (splitrest (pcase--split-rest - sym - (lambda (pat) (pcase--split-consp syma symd pat)) - rest)) - (then-rest (car splitrest)) - (else-rest (cdr splitrest)) - (then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat))) - (match ,symd . ,(pcase--upat (cdr qpat))) - ,@matches) - code vars then-rest))) - (pcase--if - `(consp ,sym) - ;; We want to be careful to only add bindings that are used. - ;; The byte-compiler could do that for us, but it would have to pay - ;; attention to the `consp' test in order to figure out that car/cdr - ;; can't signal errors and our byte-compiler is not that clever. - ;; FIXME: Some of those let bindings occur too early (they are used in - ;; `then-body', but only within some sub-branch). - (macroexp-let* - `(,@(if (get syma 'pcase-used) `((,syma (car ,sym)))) - ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym))))) - then-body) - (pcase--u else-rest)))) - ((or (integerp qpat) (symbolp qpat) (stringp qpat)) - (let* ((splitrest (pcase--split-rest - sym (lambda (pat) (pcase--split-equal qpat pat)) rest)) - (then-rest (car splitrest)) - (else-rest (cdr splitrest))) - (pcase--if (cond - ((stringp qpat) `(equal ,sym ,qpat)) - ((null qpat) `(null ,sym)) - (t `(eq ,sym ',qpat))) - (pcase--u1 matches code vars then-rest) - (pcase--u else-rest)))) - (t (error "Unknown QPattern %s" qpat)))) + `(and (pred consp) + (app car ,(list '\` (car qpat))) + (app cdr ,(list '\` (cdr qpat))))) + ((or (stringp qpat) (integerp qpat) (symbolp qpat)) `',qpat))) (provide 'pcase) === modified file 'lisp/loadup.el' --- lisp/loadup.el 2014-06-01 02:36:40 +0000 +++ lisp/loadup.el 2014-09-22 18:17:27 +0000 @@ -119,7 +119,8 @@ (let ((macroexp--pending-eager-loads '(skip))) (load "emacs-lisp/pcase")) ;; Re-load macroexp so as to eagerly macro-expand its uses of pcase. - (load "emacs-lisp/macroexp")) + (let ((max-lisp-eval-depth (* 2 max-lisp-eval-depth))) + (load "emacs-lisp/macroexp"))) (load "cus-face") (load "faces") ; after here, `defface' may be used. === added file 'test/automated/pcase-tests.el' --- test/automated/pcase-tests.el 1970-01-01 00:00:00 +0000 +++ test/automated/pcase-tests.el 2014-09-22 18:05:22 +0000 @@ -0,0 +1,68 @@ +;;; pcase-tests.el --- Test suite for pcase macro. + +;; Copyright (C) 2012-2014 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 . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(ert-deftest pcase-tests-base () + "Test pcase code." + (should (equal (pcase '(1 . 2) ((app car '2) 6) ((app car '1) 5)) 5))) + +(pcase-defmacro pcase-tests-plus (pat n) + `(app (lambda (v) (- v ,n)) ,pat)) + +(ert-deftest pcase-tests-macro () + (should (equal (pcase 5 ((pcase-tests-plus x 3) x)) 2))) + +(defun pcase-tests-grep (fname exp) + (when (consp exp) + (or (eq fname (car exp)) + (cl-some (lambda (exp) (pcase-tests-grep fname exp)) (cdr exp))))) + +(ert-deftest pcase-tests-tests () + (should (pcase-tests-grep 'memq '(or (+ 2 3) (memq x y)))) + (should-not (pcase-tests-grep 'memq '(or (+ 2 3) (- x y))))) + +(ert-deftest pcase-tests-member () + (should (pcase-tests-grep + 'memq (macroexpand-all '(pcase x ((or 1 2 3) body))))) + (should (pcase-tests-grep + 'member (macroexpand-all '(pcase x ((or '"a" '2 '3) body))))) + (should-not (pcase-tests-grep + 'memq (macroexpand-all '(pcase x ((or "a" 2 3) body))))) + (let ((exp (macroexpand-all + '(pcase x + ("a" body1) + (2 body2) + ((or "a" 2 3) body))))) + (should-not (pcase-tests-grep 'memq exp)) + (should-not (pcase-tests-grep 'member exp)))) + +(ert-deftest pcase-tests-vectors () + (should (equal (pcase [1 2] (`[,x] 1) (`[,x ,y] (+ x y))) 3))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; pcase-tests.el ends here. ------------------------------------------------------------ revno: 117918 fixes bug: http://debbugs.gnu.org/18516 committer: Eli Zaretskii branch nick: trunk timestamp: Mon 2014-09-22 17:37:22 +0300 message: Fix bug #18516 with SIGSEGV in expand-file-name. src/fileio.c (Fexpand_file_name) [DOS_NT]: Make sure newdirlim is always set to a valid value. Make sure the size passed to alloca is always positive. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2014-09-22 06:06:19 +0000 +++ src/ChangeLog 2014-09-22 14:37:22 +0000 @@ -1,3 +1,9 @@ +2014-09-22 Eli Zaretskii + + * fileio.c (Fexpand_file_name) [DOS_NT]: Make sure newdirlim is + always set to a valid value. Make sure the size passed to alloca + is always positive. (Bug#18516) + 2014-09-22 Dmitry Antipov Avoid extra call to oblookup when interning symbols. === modified file 'src/fileio.c' --- src/fileio.c 2014-09-16 08:20:08 +0000 +++ src/fileio.c 2014-09-22 14:37:22 +0000 @@ -1237,6 +1237,8 @@ newdirlim = adir + SBYTES (tem); memcpy (adir, SSDATA (tem), SBYTES (tem) + 1); } + else + newdirlim = adir + strlen (adir); } if (!adir) { @@ -1383,6 +1385,7 @@ /* Now concatenate the directory and name to new space in the stack frame. */ tlen = length + file_name_as_directory_slop + (nmlim - nm) + 1; + eassert (tlen > file_name_as_directory_slop + 1); #ifdef DOS_NT /* Reserve space for drive specifier and escape prefix, since either or both may need to be inserted. (The Microsoft x86 compiler ------------------------------------------------------------ revno: 117917 committer: Stefan Monnier branch nick: trunk timestamp: Mon 2014-09-22 10:10:53 -0400 message: Use lexical-bindin in Ibuffer. * lisp/ibuffer.el (ibuffer-do-toggle-read-only): `arg' is unused. (ibuffer-compile-format): Simplify. (ibuffer-clear-summary-columns): Simplify. * lisp/ibuf-ext.el (ibuffer-generate-filter-groups): Don't use the third elem of dotimes when we don't refer to the iteration var from it. (ibuffer-toggle-sorting-mode): Avoid add-to-list. * lisp/ibuf-macs.el (define-ibuffer-column, define-ibuffer-op): Silence byte-compiler. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2014-09-22 13:52:06 +0000 +++ lisp/ChangeLog 2014-09-22 14:10:53 +0000 @@ -1,5 +1,17 @@ 2014-09-22 Stefan Monnier + Use lexical-bindin in Ibuffer. + * ibuffer.el (ibuffer-do-toggle-read-only): `arg' is unused. + (ibuffer-compile-format): Simplify. + (ibuffer-clear-summary-columns): Simplify. + * ibuf-ext.el (ibuffer-generate-filter-groups): Don't use the third + elem of dotimes when we don't refer to the iteration var from it. + (ibuffer-toggle-sorting-mode): Avoid add-to-list. + * ibuf-macs.el (define-ibuffer-column, define-ibuffer-op): + Silence byte-compiler. + +2014-09-22 Stefan Monnier + * font-lock.el (font-lock-compile-keyword): Don't confuse a lambda expression for a list. === modified file 'lisp/ibuf-ext.el' --- lisp/ibuf-ext.el 2014-01-01 07:43:34 +0000 +++ lisp/ibuf-ext.el 2014-09-22 14:10:53 +0000 @@ -1,4 +1,4 @@ -;;; ibuf-ext.el --- extensions for ibuffer +;;; ibuf-ext.el --- extensions for ibuffer -*- lexical-binding:t -*- ;; Copyright (C) 2000-2014 Free Software Foundation, Inc. @@ -523,9 +523,9 @@ ibuffer-filter-groups (append ibuffer-filter-groups (list (cons "Default" nil)))))) -;; (dolist (hidden ibuffer-hidden-filter-groups) -;; (setq filter-group-alist (ibuffer-delete-alist -;; hidden filter-group-alist))) + ;; (dolist (hidden ibuffer-hidden-filter-groups) + ;; (setq filter-group-alist (ibuffer-delete-alist + ;; hidden filter-group-alist))) (let ((vec (make-vector (length filter-group-alist) nil)) (i 0)) (dolist (filtergroup filter-group-alist) @@ -540,12 +540,13 @@ (cl-incf i) (setq bmarklist lamers)))) (let (ret) - (dotimes (j i ret) + (dotimes (j i) (let ((bufs (aref vec j))) (unless (and noempty (null bufs)) (push (cons (car (nth j filter-group-alist)) bufs) - ret)))))))) + ret)))) + ret)))) ;;;###autoload (defun ibuffer-filters-to-filter-group (name) @@ -1100,9 +1101,9 @@ Major Mode - the name of the major mode of the buffer Size - the size of the buffer" (interactive) - (let ((modes (mapcar 'car ibuffer-sorting-functions-alist))) - (add-to-list 'modes 'recency) - (setq modes (sort modes 'string-lessp)) + (let ((modes (mapcar #'car ibuffer-sorting-functions-alist))) + (cl-pushnew 'recency modes) + (setq modes (sort modes #'string-lessp)) (let ((next (or (car-safe (cdr-safe (memq ibuffer-sorting-mode modes))) (car modes)))) (setq ibuffer-sorting-mode next) === modified file 'lisp/ibuf-macs.el' --- lisp/ibuf-macs.el 2014-01-01 07:43:34 +0000 +++ lisp/ibuf-macs.el 2014-09-22 14:10:53 +0000 @@ -1,4 +1,4 @@ -;;; ibuf-macs.el --- macros for ibuffer +;;; ibuf-macs.el --- macros for ibuffer -*- lexical-binding:t -*- ;; Copyright (C) 2000-2014 Free Software Foundation, Inc. @@ -111,6 +111,7 @@ ,(if inline `(push '(,sym ,bod) ibuffer-inline-columns) `(defun ,sym (buffer mark) + (ignore mark) ;Silence byte-compiler if mark is unused. ,bod)) (put (quote ,sym) 'ibuffer-column-name ,(if (stringp name) @@ -204,7 +205,8 @@ (declare (indent 2) (doc-string 3)) `(progn (defun ,(intern (concat (if (string-match "^ibuffer-do" (symbol-name op)) - "" "ibuffer-do-") (symbol-name op))) + "" "ibuffer-do-") + (symbol-name op))) ,args ,(if (stringp documentation) documentation @@ -247,6 +249,9 @@ (_ 'ibuffer-map-marked-lines)) #'(lambda (buf mark) + ;; Silence warning for code that doesn't + ;; use `mark'. + (ignore mark) ,(if (eq modifier-p :maybe) `(let ((ibuffer-tmp-previous-buffer-modification (buffer-modified-p buf))) === modified file 'lisp/ibuffer.el' --- lisp/ibuffer.el 2014-08-31 20:44:36 +0000 +++ lisp/ibuffer.el 2014-09-22 14:10:53 +0000 @@ -1,4 +1,4 @@ -;;; ibuffer.el --- operate on buffers like dired +;;; ibuffer.el --- operate on buffers like dired -*- lexical-binding:t -*- ;; Copyright (C) 2000-2014 Free Software Foundation, Inc. @@ -907,7 +907,7 @@ (when (zerop columns) (setq columns 1)) (while list - (dotimes (i (1- columns)) + (dotimes (_ (1- columns)) (insert (concat (car list) (make-string (- max (length (car list))) ?\s))) (setq list (cdr list))) @@ -1275,7 +1275,7 @@ :modifier-p t) (set-buffer-modified-p (not (buffer-modified-p)))) -(define-ibuffer-op ibuffer-do-toggle-read-only (&optional arg) +(define-ibuffer-op ibuffer-do-toggle-read-only (&optional _arg);FIXME:arg unused! "Toggle read only status in marked buffers. With optional ARG, make read-only only if ARG is not negative." (:opstring "toggled read only status in" @@ -1520,7 +1520,7 @@ ;; We use these variables to keep track of which variables ;; inside the generated function we need to bind, since ;; binding variables in Emacs takes time. - str-used tmp1-used tmp2-used global-strlen-used) + (vars-used ())) (dolist (form format) (push ;; Generate a form based on a particular format entry, like @@ -1546,8 +1546,8 @@ ;; This is a complex case; they want it limited to a ;; minimum size. (setq min-used t) - (setq str-used t strlen-used t global-strlen-used t - tmp1-used t tmp2-used t) + (setq strlen-used t) + (setq vars-used '(str strlen tmp1 tmp2)) ;; Generate code to limit the string to a minimum size. (setq minform `(progn (setq str @@ -1559,7 +1559,8 @@ strlen) align))))) (when (or (not (integerp max)) (> max 0)) - (setq str-used t max-used t) + (setq max-used t) + (cl-pushnew 'str vars-used) ;; Generate code to limit the string to a maximum size. (setq maxform `(progn (setq str @@ -1587,8 +1588,9 @@ ;; don't even understand it, and I wrote it five ;; minutes ago. (insertgenfn - (ibuffer-aif (get sym 'ibuffer-column-summarizer) + (if (get sym 'ibuffer-column-summarizer) ;; I really, really wish Emacs Lisp had closures. + ;; FIXME: Elisp does have them now. (lambda (arg sym) `(insert (let ((ret ,arg)) @@ -1596,7 +1598,7 @@ (cons ret (get ',sym 'ibuffer-column-summary))) ret))) - (lambda (arg sym) + (lambda (arg _sym) `(insert ,arg)))) (mincompform `(< strlen ,(if (integerp min) min @@ -1624,10 +1626,9 @@ `(when ,maxcompform ,maxform))) outforms) - (push (append - `(setq str ,callform) - (when strlen-used - `(strlen (length str)))) + (push `(setq str ,callform + ,@(when strlen-used + `(strlen (length str)))) outforms) (setq outforms (append outforms @@ -1640,25 +1641,17 @@ `(let ,letbindings ,@outforms))))) result)) - (setq result - ;; We don't want to unconditionally load the byte-compiler. - (funcall (if (or ibuffer-always-compile-formats - (featurep 'bytecomp)) - #'byte-compile - #'identity) - ;; Here, we actually create a lambda form which - ;; inserts all the generated forms for each entry - ;; in the format string. - (nconc (list 'lambda '(buffer mark)) - `((let ,(append (when str-used - '(str)) - (when global-strlen-used - '(strlen)) - (when tmp1-used - '(tmp1)) - (when tmp2-used - '(tmp2))) - ,@(nreverse result)))))))) + ;; We don't want to unconditionally load the byte-compiler. + (funcall (if (or ibuffer-always-compile-formats + (featurep 'bytecomp)) + #'byte-compile + #'identity) + ;; Here, we actually create a lambda form which + ;; inserts all the generated forms for each entry + ;; in the format string. + `(lambda (buffer mark) + (let ,vars-used + ,@(nreverse result)))))) (defun ibuffer-recompile-formats () "Recompile `ibuffer-formats'." @@ -1676,8 +1669,8 @@ (defun ibuffer-clear-summary-columns (format) (dolist (form format) - (ibuffer-awhen (and (consp form) - (get (car form) 'ibuffer-column-summarizer)) + (when (and (consp form) + (get (car form) 'ibuffer-column-summarizer)) (put (car form) 'ibuffer-column-summary nil)))) (defun ibuffer-check-formats () ------------------------------------------------------------ revno: 117916 committer: Stefan Monnier branch nick: trunk timestamp: Mon 2014-09-22 09:52:06 -0400 message: * lisp/font-lock.el (font-lock-compile-keyword): Don't confuse a lambda expression for a list. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2014-09-22 13:47:47 +0000 +++ lisp/ChangeLog 2014-09-22 13:52:06 +0000 @@ -1,5 +1,8 @@ 2014-09-22 Stefan Monnier + * font-lock.el (font-lock-compile-keyword): Don't confuse a lambda + expression for a list. + * emacs-lisp/bytecomp.el (byte-compile-lambda): Don't add fundoc usage for functions with no arguments. === modified file 'lisp/font-lock.el' --- lisp/font-lock.el 2014-05-29 03:45:29 +0000 +++ lisp/font-lock.el 2014-09-22 13:52:06 +0000 @@ -1759,7 +1759,7 @@ keywords (setq keywords (cons t (cons keywords - (mapcar 'font-lock-compile-keyword keywords)))) + (mapcar #'font-lock-compile-keyword keywords)))) (if (and (not syntactic-keywords) (let ((beg-function (or font-lock-beginning-of-syntax-function @@ -1783,7 +1783,7 @@ keywords)) (defun font-lock-compile-keyword (keyword) - (cond ((nlistp keyword) ; MATCHER + (cond ((or (functionp keyword) (nlistp keyword)) ; MATCHER (list keyword '(0 font-lock-keyword-face))) ((eq (car keyword) 'eval) ; (eval . FORM) (font-lock-compile-keyword (eval (cdr keyword)))) ------------------------------------------------------------ revno: 117915 committer: Stefan Monnier branch nick: trunk timestamp: Mon 2014-09-22 09:47:47 -0400 message: * lisp/emacs-lisp/bytecomp.el (byte-compile-lambda): Don't add fundoc usage for functions with no arguments. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2014-09-22 13:42:57 +0000 +++ lisp/ChangeLog 2014-09-22 13:47:47 +0000 @@ -1,5 +1,8 @@ 2014-09-22 Stefan Monnier + * emacs-lisp/bytecomp.el (byte-compile-lambda): Don't add fundoc usage + for functions with no arguments. + * mpc.el (mpc-data-directory): Use locate-user-emacs-file. (mpc-volume-refresh): Make sure the corresponding header-line is updated. === modified file 'lisp/emacs-lisp/bytecomp.el' --- lisp/emacs-lisp/bytecomp.el 2014-04-22 06:51:30 +0000 +++ lisp/emacs-lisp/bytecomp.el 2014-09-22 13:47:47 +0000 @@ -2521,7 +2521,8 @@ "Return an expression which will evaluate to a function value FUN. FUN should be either a `lambda' value or a `closure' value." (pcase-let* (((or (and `(lambda ,args . ,body) (let env nil)) - `(closure ,env ,args . ,body)) fun) + `(closure ,env ,args . ,body)) + fun) (renv ())) ;; Turn the function's closed vars (if any) into local let bindings. (dolist (binding env) @@ -2723,7 +2724,9 @@ ;; byte-string, constants-vector, stack depth (cdr compiled) ;; optionally, the doc string. - (cond (lexical-binding + (cond ((and lexical-binding arglist) + ;; byte-compile-make-args-desc lost the args's names, + ;; so preserve them in the docstring. (list (help-add-fundoc-usage doc arglist))) ((or doc int) (list doc))) ------------------------------------------------------------ revno: 117914 committer: Stefan Monnier branch nick: trunk timestamp: Mon 2014-09-22 09:42:57 -0400 message: * lisp/mpc.el (mpc-data-directory): Use locate-user-emacs-file. (mpc-volume-refresh): Make sure the corresponding header-line is updated. (mpc-songs-jump-to, mpc-play): Use user-error. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2014-09-21 22:09:40 +0000 +++ lisp/ChangeLog 2014-09-22 13:42:57 +0000 @@ -1,3 +1,8 @@ +2014-09-22 Stefan Monnier + + * mpc.el (mpc-data-directory): Use locate-user-emacs-file. + (mpc-volume-refresh): Make sure the corresponding header-line is updated. + 2014-09-17 Tom Willemse (tiny change) * simple.el (clone-indirect-buffer): Mention the return value === modified file 'lisp/mpc.el' --- lisp/mpc.el 2014-08-12 16:16:00 +0000 +++ lisp/mpc.el 2014-09-22 13:42:57 +0000 @@ -1,4 +1,4 @@ -;;; mpc.el --- A client for the Music Player Daemon -*- coding: utf-8; lexical-binding: t -*- +;;; mpc.el --- A client for the Music Player Daemon -*- lexical-binding: t -*- ;; Copyright (C) 2006-2014 Free Software Foundation, Inc. @@ -891,9 +891,7 @@ :type '(choice (const nil) directory)) (defcustom mpc-data-directory - (if (and (not (file-directory-p "~/.mpc")) - (file-directory-p "~/.emacs.d")) - "~/.emacs.d/mpc" "~/.mpc") + (locate-user-emacs-file "mpc" ".mpc") "Directory where MPC.el stores auxiliary data." :type 'directory) @@ -1807,7 +1805,9 @@ ;; Maintain the volume. (setq mpc-volume (mpc-volume-widget - (string-to-number (cdr (assq 'volume mpc-status)))))) + (string-to-number (cdr (assq 'volume mpc-status))))) + (let ((status-buf (mpc-proc-buffer (mpc-proc) 'status))) + (when status-buf (with-current-buffer status-buf (force-mode-line-update))))) (defvar mpc-volume-step 5) @@ -2036,7 +2036,7 @@ (match-string 1))))) (cond ((null re) (posn-set-point posn)) - ((null sn) (error "This song is not in the playlist")) + ((null sn) (user-error "This song is not in the playlist")) ((null (with-current-buffer plbuf (re-search-forward re nil t))) ;; song-file only appears once in the playlist: no ambiguity, ;; we're good to go! @@ -2346,7 +2346,7 @@ (if (mpc-playlist-add) (if (member (cdr (assq 'state (mpc-cmd-status))) '("stop")) (mpc-cmd-play)) - (error "Don't know what to play")))) + (user-error "Don't know what to play")))) (defun mpc-next () "Jump to the next song in the queue." @@ -2610,7 +2610,8 @@ (mpc-cmd-move (let ((poss '())) (dotimes (i (length songs)) (push (+ i (length pl)) poss)) - (nreverse poss)) dest-pos mpc-songs-playlist) + (nreverse poss)) + dest-pos mpc-songs-playlist) (message "Added %d songs" (length songs))))) (mpc-songs-refresh)) (t ------------------------------------------------------------ revno: 117913 committer: Dmitry Antipov branch nick: trunk timestamp: Mon 2014-09-22 10:06:19 +0400 message: Avoid extra call to oblookup when interning symbols. * lisp.h (intern_driver): Add prototype. * lread.c (intern_driver): New function. (intern1, intern_c_string_1, Fintern): * font.c (font_intern_prop): * w32font.c (intern_font_name): Use it. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2014-09-21 22:49:24 +0000 +++ src/ChangeLog 2014-09-22 06:06:19 +0000 @@ -1,3 +1,12 @@ +2014-09-22 Dmitry Antipov + + Avoid extra call to oblookup when interning symbols. + * lisp.h (intern_driver): Add prototype. + * lread.c (intern_driver): New function. + (intern1, intern_c_string_1, Fintern): + * font.c (font_intern_prop): + * w32font.c (intern_font_name): Use it. + 2014-09-21 Paul Eggert Minor improvements to new stack-allocated Lisp objects. === modified file 'src/font.c' --- src/font.c 2014-09-15 14:53:23 +0000 +++ src/font.c 2014-09-22 06:06:19 +0000 @@ -277,10 +277,8 @@ Lisp_Object font_intern_prop (const char *str, ptrdiff_t len, bool force_symbol) { - ptrdiff_t i; - Lisp_Object tem; - Lisp_Object obarray; - ptrdiff_t nbytes, nchars; + ptrdiff_t i, nbytes, nchars; + Lisp_Object tem, name, obarray; if (len == 1 && *str == '*') return Qnil; @@ -311,12 +309,11 @@ parse_str_as_multibyte ((unsigned char *) str, len, &nchars, &nbytes); tem = oblookup (obarray, str, (len == nchars || len != nbytes) ? len : nchars, len); - if (SYMBOLP (tem)) return tem; - tem = make_specified_string (str, nchars, len, - len != nchars && len == nbytes); - return Fintern (tem, obarray); + name = make_specified_string (str, nchars, len, + len != nchars && len == nbytes); + return intern_driver (name, obarray, XINT (tem)); } /* Return a pixel size of font-spec SPEC on frame F. */ === modified file 'src/lisp.h' --- src/lisp.h 2014-09-21 22:49:24 +0000 +++ src/lisp.h 2014-09-22 06:06:19 +0000 @@ -3877,6 +3877,7 @@ extern Lisp_Object check_obarray (Lisp_Object); extern Lisp_Object intern_1 (const char *, ptrdiff_t); extern Lisp_Object intern_c_string_1 (const char *, ptrdiff_t); +extern Lisp_Object intern_driver (Lisp_Object, Lisp_Object, ptrdiff_t); extern Lisp_Object oblookup (Lisp_Object, const char *, ptrdiff_t, ptrdiff_t); INLINE void LOADHIST_ATTACH (Lisp_Object x) === modified file 'src/lread.c' --- src/lread.c 2014-09-16 08:20:08 +0000 +++ src/lread.c 2014-09-22 06:06:19 +0000 @@ -3807,6 +3807,30 @@ return obarray; } +/* Intern a symbol with name STRING in OBARRAY using bucket INDEX. */ + +Lisp_Object +intern_driver (Lisp_Object string, Lisp_Object obarray, ptrdiff_t index) +{ + Lisp_Object *ptr, sym = Fmake_symbol (string); + + XSYMBOL (sym)->interned = (EQ (obarray, initial_obarray) + ? SYMBOL_INTERNED_IN_INITIAL_OBARRAY + : SYMBOL_INTERNED); + + if ((SREF (string, 0) == ':') && EQ (obarray, initial_obarray)) + { + XSYMBOL (sym)->constant = 1; + XSYMBOL (sym)->redirect = SYMBOL_PLAINVAL; + SET_SYMBOL_VAL (XSYMBOL (sym), sym); + } + + ptr = aref_addr (obarray, index); + set_symbol_next (sym, SYMBOLP (*ptr) ? XSYMBOL (*ptr) : NULL); + *ptr = sym; + return sym; +} + /* Intern the C string STR: return a symbol with that name, interned in the current obarray. */ @@ -3816,7 +3840,8 @@ Lisp_Object obarray = check_obarray (Vobarray); Lisp_Object tem = oblookup (obarray, str, len, len); - return SYMBOLP (tem) ? tem : Fintern (make_string (str, len), obarray); + return SYMBOLP (tem) ? tem : intern_driver (make_string (str, len), + obarray, XINT (tem)); } Lisp_Object @@ -3825,16 +3850,14 @@ Lisp_Object obarray = check_obarray (Vobarray); Lisp_Object tem = oblookup (obarray, str, len, len); - if (SYMBOLP (tem)) - return tem; - - if (NILP (Vpurify_flag)) - /* Creating a non-pure string from a string literal not - implemented yet. We could just use make_string here and live - with the extra copy. */ - emacs_abort (); - - return Fintern (make_pure_c_string (str, len), obarray); + if (!SYMBOLP (tem)) + { + /* Creating a non-pure string from a string literal not implemented yet. + We could just use make_string here and live with the extra copy. */ + eassert (!NILP (Vpurify_flag)); + tem = intern_driver (make_pure_c_string (str, len), obarray, XINT (tem)); + } + return tem; } DEFUN ("intern", Fintern, Sintern, 1, 2, 0, @@ -3844,43 +3867,16 @@ it defaults to the value of `obarray'. */) (Lisp_Object string, Lisp_Object obarray) { - register Lisp_Object tem, sym, *ptr; - - if (NILP (obarray)) obarray = Vobarray; - obarray = check_obarray (obarray); - + Lisp_Object tem; + + obarray = check_obarray (NILP (obarray) ? Vobarray : obarray); CHECK_STRING (string); - tem = oblookup (obarray, SSDATA (string), - SCHARS (string), - SBYTES (string)); - if (!INTEGERP (tem)) - return tem; - - if (!NILP (Vpurify_flag)) - string = Fpurecopy (string); - sym = Fmake_symbol (string); - - if (EQ (obarray, initial_obarray)) - XSYMBOL (sym)->interned = SYMBOL_INTERNED_IN_INITIAL_OBARRAY; - else - XSYMBOL (sym)->interned = SYMBOL_INTERNED; - - if ((SREF (string, 0) == ':') - && EQ (obarray, initial_obarray)) - { - XSYMBOL (sym)->constant = 1; - XSYMBOL (sym)->redirect = SYMBOL_PLAINVAL; - SET_SYMBOL_VAL (XSYMBOL (sym), sym); - } - - ptr = aref_addr (obarray, XINT (tem)); - if (SYMBOLP (*ptr)) - set_symbol_next (sym, XSYMBOL (*ptr)); - else - set_symbol_next (sym, NULL); - *ptr = sym; - return sym; + tem = oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string)); + if (!SYMBOLP (tem)) + tem = intern_driver (NILP (Vpurify_flag) ? string + : Fpurecopy (string), obarray, XINT (tem)); + return tem; } DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0, === modified file 'src/w32font.c' --- src/w32font.c 2014-09-16 11:43:49 +0000 +++ src/w32font.c 2014-09-22 06:06:19 +0000 @@ -291,7 +291,7 @@ Lisp_Object obarray = check_obarray (Vobarray); Lisp_Object tem = oblookup (obarray, SDATA (str), len, len); /* This code is similar to intern function from lread.c. */ - return SYMBOLP (tem) ? tem : Fintern (str, obarray); + return SYMBOLP (tem) ? tem : intern_driver (str, obarray, XINT (tem)); } /* w32 implementation of get_cache for font backend. ------------------------------------------------------------ Use --include-merged or -n0 to see merged revisions.