commit e54e44c94e390c9f472d62fef5d1360a962e7269 (HEAD, refs/remotes/origin/master) Author: Po Lu Date: Thu May 19 06:46:21 2022 +0000 Fix specifying terminal names to some functions on Haiku * src/haikufns.c (haiku_display_info_for_name): Implement correctly. diff --git a/src/haikufns.c b/src/haikufns.c index 314152008b..427ca7762d 100644 --- a/src/haikufns.c +++ b/src/haikufns.c @@ -358,12 +358,12 @@ haiku_display_info_for_name (Lisp_Object name) { CHECK_STRING (name); - if (!NILP (Fstring_equal (name, build_string ("be")))) + if (!strcmp (SSDATA (name), "be")) { - if (!x_display_list) + if (x_display_list) return x_display_list; - error ("Haiku windowing not initialized"); + return haiku_term_init (); } error ("Haiku displays can only be named \"be\""); commit b1ed3e49d6a67b233f4b9937c4b99c002fb30dbb Author: Po Lu Date: Thu May 19 13:50:39 2022 +0800 Satisfy Valgrind when iconifying frames * src/xterm.c (x_iconify_frame): Set the rest of data in the WM_CHANGE_STATE message to 0 instead of leaving it uninitialized. diff --git a/src/xterm.c b/src/xterm.c index b12aa4b843..142c2f81ce 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -23045,6 +23045,10 @@ x_iconify_frame (struct frame *f) msg.xclient.message_type = FRAME_DISPLAY_INFO (f)->Xatom_wm_change_state; msg.xclient.format = 32; msg.xclient.data.l[0] = IconicState; + msg.xclient.data.l[1] = 0; + msg.xclient.data.l[2] = 0; + msg.xclient.data.l[3] = 0; + msg.xclient.data.l[4] = 0; if (! XSendEvent (FRAME_X_DISPLAY (f), FRAME_DISPLAY_INFO (f)->root_window, commit 4dfaefcffc987400a317b5ccf0c9bf00f7c84134 Author: Po Lu Date: Thu May 19 03:43:39 2022 +0000 Fix race conditions processing frame fullscreen state on Haiku * doc/lispref/frames.texi (Size Parameters): Remove note saying Haiku doesn't support `fullwidth' and `fullboth'. * src/haiku_support.cc (subset_windows, class EmacsWindow) (Unparent, ParentTo): Stop calling old fullscreen functions. (ClearFullscreen, FullscreenRectForMode, SetFullscreen): New functions. Completely rewrite old zoom and fullscreen handling code. (Zoom): Send a ZOOM_EVENT and don't actually zoom. (BWindow_zoom, EmacsWindow_make_fullscreen, EmacsWindow_unzoom): Delete functions. (be_set_window_fullscreen_mode): New function. * src/haiku_support.h (struct haiku_zoom_event): Remove `zoomed_p' parameter. (enum haiku_fullscreen_mode): New enum. Update prototypes. * src/haikufns.c (Fx_display_pixel_height): Return height instead of width. * src/haikuterm.c (haiku_make_fullscreen_consistent) (haiku_read_socket, haiku_fullscreen): Adjust to always set zoom and fullscreen in the main thread instead of the UI threads. * src/haikuterm.h (struct haiku_output): Remove flag `zoomed_p' and add field `fullscreen_mode'. diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index 5853c45b79..5ea060871f 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -1734,16 +1734,14 @@ fit will be clipped by the window manager. @item fullscreen This parameter specifies whether to maximize the frame's width, height or both. Its value can be @code{fullwidth}, @code{fullheight}, -@code{fullboth}, or @code{maximized}.@footnote{On Haiku, setting -@code{fullscreen} to @code{fullwidth} or @code{fullheight} has no -effect.} A @dfn{fullwidth} frame is as +@code{fullboth}, or @code{maximized}. A @dfn{fullwidth} frame is as wide as possible, a @dfn{fullheight} frame is as tall as possible, and a @dfn{fullboth} frame is both as wide and as tall as possible. A -@dfn{maximized} frame is like a ``fullboth'' frame, except that it usually -keeps its title bar and the buttons for resizing -and closing the frame. Also, maximized frames typically avoid hiding -any task bar or panels displayed on the desktop. A ``fullboth'' frame, -on the other hand, usually omits the title bar and occupies the entire +@dfn{maximized} frame is like a ``fullboth'' frame, except that it +usually keeps its title bar and the buttons for resizing and closing +the frame. Also, maximized frames typically avoid hiding any task bar +or panels displayed on the desktop. A ``fullboth'' frame, on the +other hand, usually omits the title bar and occupies the entire available screen space. Full-height and full-width frames are more similar to maximized diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 0c126dab3d..0b3ab4cf4a 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -17,6 +17,7 @@ You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see . */ #include +#include #include #include @@ -518,33 +519,42 @@ class EmacsWindow : public BWindow struct child_frame *next; int xoff, yoff; EmacsWindow *window; - } *subset_windows = NULL; + } *subset_windows; - EmacsWindow *parent = NULL; + EmacsWindow *parent; BRect pre_fullscreen_rect; BRect pre_zoom_rect; - int x_before_zoom = INT_MIN; - int y_before_zoom = INT_MIN; - bool fullscreen_p = false; - bool zoomed_p = false; - bool shown_flag = false; - volatile int was_shown_p = 0; - bool menu_bar_active_p = false; - bool override_redirect_p = false; + int x_before_zoom; + int y_before_zoom; + bool shown_flag; + volatile bool was_shown_p; + bool menu_bar_active_p; + bool override_redirect_p; window_look pre_override_redirect_look; window_feel pre_override_redirect_feel; uint32 pre_override_redirect_workspaces; int window_id; - bool *menus_begun = NULL; + bool *menus_begun; enum haiku_z_group z_group; - bool tooltip_p = false; + bool tooltip_p; + enum haiku_fullscreen_mode fullscreen_mode; EmacsWindow () : BWindow (BRect (0, 0, 0, 0), "", B_TITLED_WINDOW_LOOK, - B_NORMAL_WINDOW_FEEL, B_NO_SERVER_SIDE_WINDOW_MODIFIERS) + B_NORMAL_WINDOW_FEEL, B_NO_SERVER_SIDE_WINDOW_MODIFIERS), + subset_windows (NULL), + parent (NULL), + x_before_zoom (INT_MIN), + y_before_zoom (INT_MIN), + shown_flag (false), + was_shown_p (false), + menu_bar_active_p (false), + override_redirect_p (false), + window_id (current_window_id), + menus_begun (NULL), + z_group (Z_GROUP_NONE), + tooltip_p (false), + fullscreen_mode (FULLSCREEN_MODE_NONE) { - window_id = current_window_id++; - z_group = Z_GROUP_NONE; - /* This pulse rate is used by scroll bars for repeating a button action while a button is held down. */ SetPulseRate (30000); @@ -711,12 +721,6 @@ class EmacsWindow : public BWindow RecomputeFeel (); UpwardsUnSubsetChildren (parent); this->RemoveFromSubset (this); - - if (fullscreen_p) - { - fullscreen_p = 0; - MakeFullscreen (1); - } child_frame_lock.Unlock (); } @@ -766,11 +770,6 @@ class EmacsWindow : public BWindow this->AddToSubset (this); if (!IsHidden () && this->parent) UpwardsSubsetChildren (parent); - if (fullscreen_p) - { - fullscreen_p = 0; - MakeFullscreen (1); - } window->LinkChild (this); child_frame_lock.Unlock (); @@ -1161,41 +1160,103 @@ class EmacsWindow : public BWindow } void - Zoom (BPoint o, float w, float h) + ClearFullscreen (void) { - struct haiku_zoom_event rq; - BRect rect; - rq.window = this; + switch (fullscreen_mode) + { + case FULLSCREEN_MODE_MAXIMIZED: + BWindow::Zoom (pre_zoom_rect.LeftTop (), + BE_RECT_WIDTH (pre_zoom_rect) - 1, + BE_RECT_HEIGHT (pre_zoom_rect) - 1); + break; - if (fullscreen_p) - MakeFullscreen (0); + case FULLSCREEN_MODE_BOTH: + case FULLSCREEN_MODE_HEIGHT: + case FULLSCREEN_MODE_WIDTH: + MoveTo (pre_fullscreen_rect.LeftTop ()); + ResizeTo (BE_RECT_WIDTH (pre_fullscreen_rect) - 1, + BE_RECT_HEIGHT (pre_fullscreen_rect) - 1); - if (!zoomed_p) - { - pre_zoom_rect = Frame (); - zoomed_p = true; - rect = CalculateZoomRect (); - } - else - { - zoomed_p = false; - rect = pre_zoom_rect; + SetFlags (Flags () & ~(B_NOT_MOVABLE + | B_NOT_ZOOMABLE + | B_NOT_RESIZABLE)); + break; + + case FULLSCREEN_MODE_NONE: + break; } - rq.zoomed = zoomed_p; - haiku_write (ZOOM_EVENT, &rq); + fullscreen_mode = FULLSCREEN_MODE_NONE; + } - BWindow::Zoom (rect.LeftTop (), BE_RECT_WIDTH (rect) - 1, - BE_RECT_HEIGHT (rect) - 1); + BRect + FullscreenRectForMode (enum haiku_fullscreen_mode mode) + { + BScreen screen (this); + BRect frame; + + if (!screen.IsValid ()) + return BRect (0, 0, 0, 0); + + frame = screen.Frame (); + + if (mode == FULLSCREEN_MODE_HEIGHT) + frame.right -= BE_RECT_WIDTH (frame) / 2; + else if (mode == FULLSCREEN_MODE_WIDTH) + frame.bottom -= BE_RECT_HEIGHT (frame) / 2; + + return frame; } void - UnZoom (void) + SetFullscreen (enum haiku_fullscreen_mode mode) { - if (!zoomed_p) + BRect zoom_rect; + + if (fullscreen_mode == mode) return; - BWindow::Zoom (); + ClearFullscreen (); + + switch (mode) + { + case FULLSCREEN_MODE_MAXIMIZED: + pre_zoom_rect = Frame (); + zoom_rect = CalculateZoomRect (); + BWindow::Zoom (zoom_rect.LeftTop (), + BE_RECT_WIDTH (zoom_rect) - 1, + BE_RECT_HEIGHT (zoom_rect) - 1); + break; + + case FULLSCREEN_MODE_BOTH: + SetFlags (Flags () | B_NOT_MOVABLE); + FALLTHROUGH; + + case FULLSCREEN_MODE_HEIGHT: + case FULLSCREEN_MODE_WIDTH: + SetFlags (Flags () | B_NOT_ZOOMABLE | B_NOT_RESIZABLE); + pre_fullscreen_rect = Frame (); + zoom_rect = FullscreenRectForMode (mode); + ResizeTo (BE_RECT_WIDTH (zoom_rect) - 1, + BE_RECT_HEIGHT (zoom_rect) - 1); + MoveTo (zoom_rect.left, zoom_rect.top); + + break; + + case FULLSCREEN_MODE_NONE: + break; + } + + fullscreen_mode = mode; + } + + void + Zoom (BPoint o, float w, float h) + { + struct haiku_zoom_event rq; + + rq.window = this; + haiku_write (ZOOM_EVENT, &rq); } void @@ -1218,51 +1279,6 @@ class EmacsWindow : public BWindow child_frame_lock.Lock (); gui_abort ("Trying to calculate offsets for a child frame that doesn't exist"); } - - void - MakeFullscreen (int make_fullscreen_p) - { - BScreen screen (this); - uint32 flags; - BRect screen_frame; - - if (!screen.IsValid ()) - gui_abort ("Trying to make a window fullscreen without a screen"); - - screen_frame = screen.Frame (); - UnZoom (); - - if (make_fullscreen_p == fullscreen_p) - return; - - fullscreen_p = make_fullscreen_p; - flags = Flags (); - - if (fullscreen_p) - { - if (zoomed_p) - UnZoom (); - - flags |= B_NOT_MOVABLE | B_NOT_ZOOMABLE; - pre_fullscreen_rect = Frame (); - - MoveTo (0, 0); - ResizeTo (BE_RECT_WIDTH (screen_frame) - 1, - BE_RECT_HEIGHT (screen_frame) - 1); - } - else - { - flags &= ~(B_NOT_MOVABLE | B_NOT_ZOOMABLE); - - /* Use MoveTo directly since pre_fullscreen_rect isn't - adjusted for decorator sizes. */ - MoveTo (pre_fullscreen_rect.left, - pre_fullscreen_rect.top); - ResizeTo (BE_RECT_WIDTH (pre_fullscreen_rect) - 1, - BE_RECT_HEIGHT (pre_fullscreen_rect) - 1); - } - SetFlags (flags); - } }; class EmacsMenuBar : public BMenuBar @@ -4486,30 +4502,6 @@ be_popup_file_dialog (int open_p, const char *default_dir, int must_match_p, return file_name; } -/* Zoom WINDOW. */ -void -BWindow_zoom (void *window) -{ - BWindow *w = (BWindow *) window; - w->Zoom (); -} - -/* Make WINDOW fullscreen if FULLSCREEN_P. */ -void -EmacsWindow_make_fullscreen (void *window, int fullscreen_p) -{ - EmacsWindow *w = (EmacsWindow *) window; - w->MakeFullscreen (fullscreen_p); -} - -/* Unzoom (maximize) WINDOW. */ -void -EmacsWindow_unzoom (void *window) -{ - EmacsWindow *w = (EmacsWindow *) window; - w->UnZoom (); -} - /* Move the pointer into MBAR and start tracking. Return whether the menu bar was opened correctly. */ bool @@ -5180,3 +5172,15 @@ be_unlock_window (void *window) wnd->UnlockLooper (); } + +void +be_set_window_fullscreen_mode (void *window, enum haiku_fullscreen_mode mode) +{ + EmacsWindow *w = (EmacsWindow *) window; + + if (!w->LockLooper ()) + gui_abort ("Failed to lock window to set fullscreen mode"); + + w->SetFullscreen (mode); + w->UnlockLooper (); +} diff --git a/src/haiku_support.h b/src/haiku_support.h index 14dd36e275..0bfd027c0d 100644 --- a/src/haiku_support.h +++ b/src/haiku_support.h @@ -249,7 +249,6 @@ struct haiku_menu_bar_help_event struct haiku_zoom_event { void *window; - bool zoomed; }; enum haiku_font_specification @@ -316,6 +315,15 @@ enum haiku_font_weight HAIKU_MEDIUM = 2000, }; +enum haiku_fullscreen_mode + { + FULLSCREEN_MODE_NONE, + FULLSCREEN_MODE_WIDTH, + FULLSCREEN_MODE_HEIGHT, + FULLSCREEN_MODE_BOTH, + FULLSCREEN_MODE_MAXIMIZED, + }; + struct haiku_font_pattern { /* Bitmask indicating which fields are set. */ @@ -495,7 +503,6 @@ extern void BWindow_center_on_screen (void *); extern void BWindow_change_decoration (void *, int); extern void BWindow_set_tooltip_decoration (void *); extern void BWindow_set_avoid_focus (void *, int); -extern void BWindow_zoom (void *); extern void BWindow_set_size_alignment (void *, int, int); extern void BWindow_sync (void *); extern void BWindow_send_behind (void *, void *); @@ -623,8 +630,6 @@ extern void BAlert_delete (void *); extern void EmacsWindow_parent_to (void *, void *); extern void EmacsWindow_unparent (void *); extern void EmacsWindow_move_weak_child (void *, void *, int, int); -extern void EmacsWindow_make_fullscreen (void *, int); -extern void EmacsWindow_unzoom (void *); extern void be_get_version_string (char *, int); extern int be_get_display_planes (void); @@ -690,6 +695,7 @@ extern status_t be_roster_launch (const char *, const char *, char **, extern void be_get_window_decorator_dimensions (void *, int *, int *, int *, int *); extern void be_get_window_decorator_frame (void *, int *, int *, int *, int *); extern void be_send_move_frame_event (void *); +extern void be_set_window_fullscreen_mode (void *, enum haiku_fullscreen_mode); extern void be_lock_window (void *); extern void be_unlock_window (void *); diff --git a/src/haikufns.c b/src/haikufns.c index 76a8569970..314152008b 100644 --- a/src/haikufns.c +++ b/src/haikufns.c @@ -2281,7 +2281,7 @@ DEFUN ("x-display-pixel-height", Fx_display_pixel_height, Sx_display_pixel_heigh check_haiku_display_info (terminal); be_get_screen_dimensions (&width, &height); - return make_fixnum (width); + return make_fixnum (height); } DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height, 0, 1, 0, diff --git a/src/haikuterm.c b/src/haikuterm.c index 2db1e352ff..731afd9d39 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -3018,11 +3018,20 @@ static struct redisplay_interface haiku_redisplay_interface = static void haiku_make_fullscreen_consistent (struct frame *f) { - Lisp_Object lval = get_frame_param (f, Qfullscreen); - - if (!EQ (lval, Qmaximized) && FRAME_OUTPUT_DATA (f)->zoomed_p) + Lisp_Object lval; + struct haiku_output *output; + + output = FRAME_OUTPUT_DATA (f); + + if (output->fullscreen_mode == FULLSCREEN_MODE_BOTH) + lval = Qfullboth; + else if (output->fullscreen_mode == FULLSCREEN_MODE_WIDTH) + lval = Qfullwidth; + else if (output->fullscreen_mode == FULLSCREEN_MODE_HEIGHT) + lval = Qfullheight; + else if (output->fullscreen_mode == FULLSCREEN_MODE_MAXIMIZED) lval = Qmaximized; - else if (EQ (lval, Qmaximized) && !FRAME_OUTPUT_DATA (f)->zoomed_p) + else lval = Qnil; store_frame_param (f, Qfullscreen, lval); @@ -3857,14 +3866,20 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) case ZOOM_EVENT: { struct haiku_zoom_event *b = buf; - struct frame *f = haiku_window_to_frame (b->window); + struct haiku_output *output; if (!f) continue; - FRAME_OUTPUT_DATA (f)->zoomed_p = b->zoomed; - haiku_make_fullscreen_consistent (f); + output = FRAME_OUTPUT_DATA (f); + + if (output->fullscreen_mode == FULLSCREEN_MAXIMIZED) + f->want_fullscreen = FULLSCREEN_NONE; + else + f->want_fullscreen = FULLSCREEN_MAXIMIZED; + + FRAME_TERMINAL (f)->fullscreen_hook (f); break; } case DRAG_AND_DROP_EVENT: @@ -4096,6 +4111,8 @@ haiku_toggle_invisible_pointer (struct frame *f, bool invisible_p) static void haiku_fullscreen (struct frame *f) { + enum haiku_fullscreen_mode mode; + /* When FRAME_OUTPUT_DATA (f)->configury_done is false, the frame is being created, and its regular width and height have not yet been set. This function will be called again by haiku_create_frame, @@ -4104,18 +4121,22 @@ haiku_fullscreen (struct frame *f) return; if (f->want_fullscreen == FULLSCREEN_MAXIMIZED) - BWindow_zoom (FRAME_HAIKU_WINDOW (f)); + mode = FULLSCREEN_MODE_MAXIMIZED; else if (f->want_fullscreen == FULLSCREEN_BOTH) - EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 1); + mode = FULLSCREEN_MODE_BOTH; + else if (f->want_fullscreen == FULLSCREEN_WIDTH) + mode = FULLSCREEN_MODE_WIDTH; + else if (f->want_fullscreen == FULLSCREEN_HEIGHT) + mode = FULLSCREEN_MODE_HEIGHT; else - { - EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 0); - EmacsWindow_unzoom (FRAME_HAIKU_WINDOW (f)); - } + mode = FULLSCREEN_MODE_NONE; f->want_fullscreen = FULLSCREEN_NONE; + be_set_window_fullscreen_mode (FRAME_HAIKU_WINDOW (f), mode); + FRAME_OUTPUT_DATA (f)->fullscreen_mode = mode; haiku_update_size_hints (f); + haiku_make_fullscreen_consistent (f); } static struct terminal * diff --git a/src/haikuterm.h b/src/haikuterm.h index 068be82687..41b1a85b00 100644 --- a/src/haikuterm.h +++ b/src/haikuterm.h @@ -160,13 +160,16 @@ struct haiku_output int fontset; int baseline_offset; - bool_bf zoomed_p : 1; + /* Whether or not the hourglass cursor is currently being + displayed. */ bool_bf hourglass_p : 1; + + /* Whether or not the menu bar is open. */ bool_bf menu_bar_open_p : 1; /* Whether or not there is data in a back buffer that hasn't been displayed yet. */ - bool dirty_p; + bool_bf dirty_p : 1; struct font *font; @@ -201,6 +204,10 @@ struct haiku_output and top_pos in that the decorator and parent frames are not taken into account. */ int frame_x, frame_y; + + /* The current fullscreen mode of this frame. This should be `enum + haiku_fullscreen_mode', but that isn't available here. */ + int fullscreen_mode; }; struct x_output commit bc604417f87f9fce865e70b3bc88b6bf2a8fd415 Author: Po Lu Date: Thu May 19 09:30:33 2022 +0800 Respond to changes to the size of the root window * src/xterm.c (x_display_pixel_height, x_display_pixel_width): Move here instead. (handle_one_xevent): Handle ConfigureNotify for the root window. (x_term_init): Select for structure events on the root window. * src/xterm.h (struct x_display_info): New fields `screen_width' and `screen_height'. (x_display_pixel_height, x_display_pixel_width): Make prototypes. diff --git a/src/xterm.c b/src/xterm.c index b5fbb474ec..b12aa4b843 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -14506,6 +14506,24 @@ x_dnd_update_state (struct x_display_info *dpyinfo, Time timestamp) } } +int +x_display_pixel_height (struct x_display_info *dpyinfo) +{ + if (dpyinfo->screen_height) + return dpyinfo->screen_height; + + return HeightOfScreen (dpyinfo->screen); +} + +int +x_display_pixel_width (struct x_display_info *dpyinfo) +{ + if (dpyinfo->screen_width) + return dpyinfo->screen_width; + + return WidthOfScreen (dpyinfo->screen); +} + /* Handles the XEvent EVENT on display DPYINFO. *FINISH is X_EVENT_GOTO_OUT if caller should stop reading events. @@ -16514,6 +16532,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, So if this ConfigureNotify is immediately followed by another for the same window, use the info from the latest update, and consider the events all handled. */ + /* Opaque resize may be trickier; ConfigureNotify events are mixed with Expose events for multiple windows. */ configureEvent = *event; @@ -16535,6 +16554,15 @@ handle_one_xevent (struct x_display_info *dpyinfo, configureEvent = next_event; } + /* If we get a ConfigureNotify for the root window, this means + the dimensions of the screen it's on changed. */ + + if (configureEvent.xconfigure.window == dpyinfo->root_window) + { + dpyinfo->screen_width = configureEvent.xconfigure.width; + dpyinfo->screen_height = configureEvent.xconfigure.height; + } + if (x_dnd_in_progress && x_dnd_use_toplevels && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) { @@ -23870,6 +23898,11 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) } #endif + /* Select for structure events on the root window, since this allows + us to record changes to the size of the screen. */ + + XSelectInput (dpy, DefaultRootWindow (dpy), StructureNotifyMask); + /* We have definitely succeeded. Record the new connection. */ dpyinfo = xzalloc (sizeof *dpyinfo); diff --git a/src/xterm.h b/src/xterm.h index 3437037e67..a05bc404f6 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -690,6 +690,12 @@ struct x_display_info int n_protected_windows; int protected_windows_max; #endif + + /* The current dimensions of the screen. This is updated when a + ConfigureNotify is received for the root window, and is zero if + that didn't happen. */ + int screen_width; + int screen_height; }; #ifdef HAVE_X_I18N @@ -1439,17 +1445,8 @@ extern void x_dnd_do_unsupported_drop (struct x_display_info *, Lisp_Object, int, Time); extern void x_set_dnd_targets (Atom *, int); -INLINE int -x_display_pixel_height (struct x_display_info *dpyinfo) -{ - return HeightOfScreen (dpyinfo->screen); -} - -INLINE int -x_display_pixel_width (struct x_display_info *dpyinfo) -{ - return WidthOfScreen (dpyinfo->screen); -} +extern int x_display_pixel_height (struct x_display_info *); +extern int x_display_pixel_width (struct x_display_info *); INLINE unsigned long x_make_truecolor_pixel (struct x_display_info *dpyinfo, int r, int g, int b) commit 9178428b02500005aeaaa4ea40353589a029a63e Author: Stefan Kangas Date: Thu May 19 01:41:44 2022 +0200 Delete entry on SPC completes file names from FAQ * doc/misc/efaq.texi (SPC no longer completes file names): Delete node: this is about a change that took place over 15 years ago and is not likely to be a FAQ these days. diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi index 08f7ebf6f2..081205e155 100644 --- a/doc/misc/efaq.texi +++ b/doc/misc/efaq.texi @@ -3713,7 +3713,6 @@ information is available from * Compose Character:: * Binding combinations of modifiers and function keys:: * Meta key does not work in xterm:: -* SPC no longer completes file names:: @end menu @node Binding keys to commands @@ -4183,22 +4182,6 @@ You might have to replace @samp{Meta} with @samp{Alt}. @end itemize -@node SPC no longer completes file names -@section Why doesn't @key{SPC} complete file names anymore? -@cindex @kbd{SPC} file name completion - -Starting with Emacs 22.1, @kbd{SPC} no longer completes file names in -the minibuffer, so that file names with embedded spaces could be typed -without the need to quote the spaces. - -You can get the old behavior by binding @kbd{SPC} to -@code{minibuffer-complete-word} in the minibuffer, as follows: - -@lisp -(define-key minibuffer-local-filename-completion-map (kbd "SPC") - 'minibuffer-complete-word) -@end lisp - @c ------------------------------------------------------------ @node Alternate character sets @chapter Alternate character sets commit fb4aa2a5eff29a63ded6470e6493a75a180356b0 Author: Stefan Kangas Date: Thu May 19 01:27:31 2022 +0200 Don't refer to obsolete Ultrix support in FAQ * doc/misc/efaq.texi (Meta key does not work in xterm): Delete reference to Ultrix; that platform support was removed in Emacs 23.1. diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi index 7d92183505..08f7ebf6f2 100644 --- a/doc/misc/efaq.texi +++ b/doc/misc/efaq.texi @@ -4158,10 +4158,6 @@ If there is an @code{rlogin} connection between @code{xterm} and Emacs, the @samp{-8} argument may need to be given to rlogin to make it pass all 8 bits of every character. -@item -If Emacs is running on Ultrix, it is reported that evaluating -@code{(set-input-mode t nil)} helps. - @item If all else fails, you can make @code{xterm} generate @kbd{@key{ESC} W} when you type @kbd{M-W}, which is the same conversion Emacs would make if it commit ec7567f02cc1a1a86ab56abbd6347c86ee41e13a Author: Paul Eggert Date: Wed May 18 12:39:30 2022 -0700 Avoid formatting twice in flymake * lisp/progmodes/flymake.el (flymake-error): Don't format a message twice, as that can translate quotes we don't want translated. diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index fbbfacfcfe..0b7958e52f 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -303,7 +303,7 @@ generated it." (defun flymake-error (text &rest args) "Format TEXT with ARGS and signal an error for Flymake." (let ((msg (apply #'format-message text args))) - (flymake-log :error msg) + (flymake-log :error "%s" msg) (error (concat "[Flymake] " msg)))) (cl-defstruct (flymake--diag commit e55b4074af27ff0840a90baea6fc9aecd28fbbc8 Author: Augusto Stoffel Date: Sun May 15 22:48:50 2022 +0200 Fix last change in minibuffer-lazy-highlight-setup * lisp/isearch.el (minibuffer-lazy-highlight-setup): Apply advices buffer-locally. diff --git a/lisp/isearch.el b/lisp/isearch.el index 3e1dab4d15..31fbdf01bf 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -4410,14 +4410,17 @@ LAX-WHITESPACE: The value of `isearch-lax-whitespace' and (let ((unwind (make-symbol "minibuffer-lazy-highlight--unwind")) (after-change (make-symbol "minibuffer-lazy-highlight--after-change")) (display-count (make-symbol "minibuffer-lazy-highlight--display-count")) + (buffer (current-buffer)) overlay) (fset unwind (lambda () - (remove-function isearch-filter-predicate filter) + (when filter + (with-current-buffer buffer + (remove-function (local 'isearch-filter-predicate) filter))) (remove-hook 'lazy-count-update-hook display-count) (when overlay (delete-overlay overlay)) - (remove-hook 'after-change-functions after-change) - (remove-hook 'minibuffer-exit-hook unwind) + (remove-hook 'after-change-functions after-change t) + (remove-hook 'minibuffer-exit-hook unwind t) (let ((lazy-highlight-cleanup cleanup)) (lazy-highlight-cleanup)))) (fset after-change @@ -4447,8 +4450,8 @@ LAX-WHITESPACE: The value of `isearch-lax-whitespace' and (setq overlay (make-overlay (point-min) (point-min) (current-buffer) t)) (add-hook 'lazy-count-update-hook display-count)) (when filter - (make-local-variable 'isearch-filter-predicate) - (add-function :after-while isearch-filter-predicate filter)) + (with-current-buffer buffer + (add-function :after-while (local 'isearch-filter-predicate) filter))) (funcall after-change nil nil nil))))) commit b1620a44ff201966c9900a116a640597093e6030 Author: Eli Zaretskii Date: Wed May 18 16:53:49 2022 +0300 ; * lisp/progmodes/flymake.el (flymake-mode): Fix a typo. diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 46a4fdfa37..fbbfacfcfe 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -1104,7 +1104,7 @@ diagnostics annotated in the buffer. By default, `flymake-mode' doesn't override the \\[next-error] command, but if you're using Flymake a lot (and don't use the regular compilation -mechanisms that often), if can be useful to put something like +mechanisms that often), it can be useful to put something like the following in your init file: (setq next-error-function \\='flymake-goto-next-error) commit a67d8e0d70d5563044f9981795de9ee2876b6463 Author: Lars Ingebrigtsen Date: Wed May 18 15:33:11 2022 +0200 Add a new display-buffer-full-frame display action * doc/lispref/windows.texi (Buffer Display Action Functions): Document it. * lisp/window.el (display-buffer-full-frame): New display action (bug#34169). (display-buffer--action-function-custom-type): Add. (display-buffer): Mention it. diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index 4ff71a3575..0bb873f3a9 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -2845,6 +2845,11 @@ the function specified in @code{pop-up-frame-function} the newly created frame's parameters. @end defun +@defun display-buffer-full-frame buffer alist +This function displays the buffer on the current frame, deleting all +other windows so that it takes up the full frame. +@end defun + @defun display-buffer-in-child-frame buffer alist This function tries to display @var{buffer} in a child frame (@pxref{Child Frames}) of the selected frame, either reusing an diff --git a/etc/NEWS b/etc/NEWS index 7089e3a271..8aa53e62e0 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -605,6 +605,11 @@ specifiers can now use ':type webp'. ** Windows ++++ +*** New display action 'display-buffer-full-frame'. +This action removes other windows on the frame when displaying a +buffer. + +++ *** 'display-buffer' now can set up the body size of the chosen window. For example, a 'display-buffer-alist' entry of diff --git a/lisp/window.el b/lisp/window.el index 8b8940197e..4ad2defdf9 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -7435,6 +7435,7 @@ The actual non-nil value of this variable will be copied to the (const display-buffer-pop-up-window) (const display-buffer-same-window) (const display-buffer-pop-up-frame) + (const display-buffer-full-frame) (const display-buffer-in-child-frame) (const display-buffer-below-selected) (const display-buffer-at-bottom) @@ -7581,6 +7582,7 @@ to an expression containing one of these \"action\" functions: `display-buffer-use-least-recent-window' -- Try to avoid re-using windows that have recently been switched to. `display-buffer-pop-up-window' -- Pop up a new window. + `display-buffer-full-frame' -- Delete other windows and use the full frame. `display-buffer-below-selected' -- Use or pop up a window below the selected one. `display-buffer-at-bottom' -- Use or pop up a window at the @@ -7814,6 +7816,23 @@ indirectly called by the latter." (window-dedicated-p)) (window--display-buffer buffer (selected-window) 'reuse alist))) +(defun display-buffer-full-frame (buffer alist) + "Display BUFFER in the current frame, taking the entire frame. +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. + +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." + (when-let ((window (or (display-buffer-reuse-window buffer alist) + (display-buffer-same-window buffer alist) + (display-buffer-pop-up-window buffer alist) + (display-buffer-use-some-window buffer alist)))) + (delete-other-windows window) + window)) + (defun display-buffer--maybe-same-window (buffer alist) "Conditionally display BUFFER in the selected window. ALIST is an association list of action symbols and values. See commit 960008aa982e0481c77ef6a8b871e9c4b3014491 Author: Lars Ingebrigtsen Date: Wed May 18 14:13:16 2022 +0200 Mention next-error-function in flymake-mode doc string * lisp/progmodes/flymake.el (flymake-mode): Note that you can set next-error-function (bug#32322). diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index b5f4fff3c3..46a4fdfa37 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -1102,6 +1102,13 @@ The commands `flymake-goto-next-error' and `flymake-goto-prev-error' can be used to navigate among Flymake diagnostics annotated in the buffer. +By default, `flymake-mode' doesn't override the \\[next-error] command, but +if you're using Flymake a lot (and don't use the regular compilation +mechanisms that often), if can be useful to put something like +the following in your init file: + + (setq next-error-function \\='flymake-goto-next-error) + The visual appearance of each type of diagnostic can be changed by setting properties `flymake-overlay-control', `flymake-bitmap' and `flymake-severity' on the symbols of diagnostic types (like commit d5540d7dbcee2a35dc928670ac210c5ffb909a75 Author: Po Lu Date: Wed May 18 12:36:50 2022 +0000 Implement gamma-correction on Haiku * src/dispextern.h: Add `gamma_correct' prototype on Haiku as well. * src/haikufns.c (gamma_correct): New function. * src/haikuterm.c (haiku_defined_color): Gamma-correct colors if their pixels are being allocated. diff --git a/src/dispextern.h b/src/dispextern.h index a7f478acdf..910f630a50 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -3615,6 +3615,9 @@ void gamma_correct (struct frame *, XColor *); #ifdef HAVE_NTGUI void gamma_correct (struct frame *, COLORREF *); #endif +#ifdef HAVE_HAIKU +void gamma_correct (struct frame *, Emacs_Color *); +#endif #ifdef HAVE_WINDOW_SYSTEM diff --git a/src/haikufns.c b/src/haikufns.c index 8b6296e6ae..76a8569970 100644 --- a/src/haikufns.c +++ b/src/haikufns.c @@ -268,6 +268,22 @@ haiku_set_tab_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) haiku_change_tab_bar_height (f, nlines * FRAME_LINE_HEIGHT (f)); } +void +gamma_correct (struct frame *f, Emacs_Color *color) +{ + if (f->gamma) + { + color->red = (pow (color->red / 65535.0, f->gamma) + * 65535.0 + 0.5); + color->green = (pow (color->green / 65535.0, f->gamma) + * 65535.0 + 0.5); + color->blue = (pow (color->blue / 65535.0, f->gamma) + * 65535.0 + 0.5); + color->pixel = RGB_TO_ULONG (color->red / 256, + color->green / 256, + color->blue / 256); + } +} int haiku_get_color (const char *name, Emacs_Color *color) diff --git a/src/haikuterm.c b/src/haikuterm.c index af20d1c11c..2db1e352ff 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -575,7 +575,14 @@ static bool haiku_defined_color (struct frame *f, const char *name, Emacs_Color *color, bool alloc, bool make_index) { - return !haiku_get_color (name, color); + int rc; + + rc = !haiku_get_color (name, color); + + if (rc && f->gamma && alloc) + gamma_correct (f, color); + + return rc; } /* Adapted from xterm `x_draw_box_rect'. */ commit 3faba1dff6fa340033071e92309a1b112d58a7fa Author: Lars Ingebrigtsen Date: Wed May 18 13:20:26 2022 +0200 Improve previous apropos-documentation-check-elc-file change * lisp/apropos.el (apropos-documentation-check-elc-file): Add comment to explain what's going on and expand to lisp-directory (bug#55492). diff --git a/lisp/apropos.el b/lisp/apropos.el index 428aeb1541..0b84f9fa63 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -1055,8 +1055,11 @@ non-nil." (setq sepa (goto-char sepb))))) (defun apropos-documentation-check-elc-file (file) + ;; .elc files have the location of the file specified as #$, but for + ;; built-in files, that's a relative name (while for the rest, it's + ;; absolute). So expand the name in the former case. (unless (file-name-absolute-p file) - (setq file (locate-library file))) + (setq file (expand-file-name file lisp-directory))) (if (or (member file apropos-files-scanned) (not (file-exists-p file))) nil commit 7969e41654b2b5c628c290deb938699a95e85fec Author: Alan Mackenzie Date: Wed May 18 09:18:15 2022 +0000 Fix M-x compile-defun when an interactive form is (list ...) This is for when lexical-binding is nil. The problem fixed was M-x compile-defun leaving symbols with position in the compiled function's arglist and interactive form. This fixes bug #55323. Also ensure the doc string is correctly stripped when lexical-binding is t. * lisp/emacs-lisp/bytecomp.el (byte-compile-lambda): For a (list ...) interactive form when lexical-binding is nil, strip the positions from the symbols in the form. Also strip the position from the symbols in the arglist. (byte-compile-make-closure): (Twice) strip symbols from positions in the doc string expression. Add comments. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 1fef9b00d8..e72b96af4a 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3114,7 +3114,8 @@ lambda-expression." ;; which may include "calls" to ;; internal-make-closure (Bug#29988). lexical-binding) - (setq int `(,(car int) ,newform))))) + (setq int `(,(car int) ,newform)) + (setq int (byte-run-strip-symbol-positions int))))) ; for compile-defun. ((cdr int) ; Invalid (interactive . something). (byte-compile-warn-x int "malformed interactive spec: %s" int)))) @@ -3129,7 +3130,7 @@ lambda-expression." (byte-compile-make-lambda-lexenv arglistvars)) reserved-csts)) - (bare-arglist arglist)) + (bare-arglist (byte-run-strip-symbol-positions arglist))) ; for compile-defun. ;; Build the actual byte-coded function. (cl-assert (eq 'byte-code (car-safe compiled))) (let ((out @@ -3951,7 +3952,9 @@ discarding." (byte-defop-compiler-1 internal-get-closed-var byte-compile-get-closed-var) (defun byte-compile-make-closure (form) - "Byte-compile the special `internal-make-closure' form." + "Byte-compile the special `internal-make-closure' form. + +This function is never called when `lexical-binding' is nil." (if byte-compile--for-effect (setq byte-compile--for-effect nil) (let* ((vars (nth 1 form)) (env (nth 2 form)) @@ -3973,24 +3976,33 @@ discarding." (number-sequence 4 (1- (length fun))))) (proto-fun (apply #'make-byte-code - (aref fun 0) (aref fun 1) + (aref fun 0) ; The arglist is always the 15-bit + ; form, never the list of symbols. + (aref fun 1) ; The byte-code. ;; Prepend dummy cells to the constant vector, ;; to get the indices right when disassembling. (vconcat dummy-vars (aref fun 2)) - (aref fun 3) + (aref fun 3) ; Stack depth of function (if docstring-exp - (cons (eval docstring-exp t) (cdr opt-args)) + (cons + (eval (byte-run-strip-symbol-positions + docstring-exp) + t) + (cdr opt-args)) ; The interactive spec will + ; have been stripped in + ; `byte-compile-lambda'. opt-args)))) `(make-closure ,proto-fun ,@env)) ;; Nontrivial doc string expression: create a bytecode object ;; from small pieces at run time. `(make-byte-code - ',(aref fun 0) ',(aref fun 1) - (vconcat (vector . ,env) ',(aref fun 2)) + ',(aref fun 0) ; 15-bit form of arglist descriptor. + ',(aref fun 1) ; The byte-code. + (vconcat (vector . ,env) ',(aref fun 2)) ; constant vector. ,@(let ((rest (nthcdr 3 (mapcar (lambda (x) `',x) fun)))) (if docstring-exp `(,(car rest) - ,docstring-exp + ,(byte-run-strip-symbol-positions docstring-exp) ,@(cddr rest)) rest)))) )))) commit e1c972b2479cbd9780224620b52731a2447fa612 Author: Martin Rudalics Date: Wed May 18 11:09:58 2022 +0200 Clean up and simplify 'quit-restore-window' code * lisp/window.el (window--quit-restore-select-window): New internal name for 'quit-restore-select-window'. (quit-restore-window): Use 'window--quit-restore-select-window' instead of 'quit-restore-select-window'. Simplify code. diff --git a/lisp/window.el b/lisp/window.el index e378652e28..8b8940197e 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -5142,7 +5142,7 @@ all window-local buffer lists." :version "27.1" :group 'windows) -(defun quit-restore-select-window (window) +(defun window--quit-restore-select-window (window) "Select WINDOW after having quit another one. Do not select an inactive minibuffer window." (when (and (window-live-p window) @@ -5188,6 +5188,7 @@ nil means to not handle the buffer in a particular way. This (setq window (window-normalize-window window t)) (let* ((buffer (window-buffer window)) (quit-restore (window-parameter window 'quit-restore)) + (quit-restore-2 (nth 2 quit-restore)) (prev-buffer (catch 'prev-buffer (dolist (buf (window-prev-buffers window)) (unless (eq (car buf) buffer) @@ -5199,13 +5200,13 @@ nil means to not handle the buffer in a particular way. This ((and dedicated (not (eq dedicated 'side)) (window--delete window 'dedicated (eq bury-or-kill 'kill))) ;; If the previously selected window is still alive, select it. - (quit-restore-select-window (nth 2 quit-restore))) + (window--quit-restore-select-window quit-restore-2)) ((and (not prev-buffer) (eq (nth 1 quit-restore) 'tab) (eq (nth 3 quit-restore) buffer)) (tab-bar-close-tab) ;; If the previously selected window is still alive, select it. - (quit-restore-select-window (nth 2 quit-restore))) + (window--quit-restore-select-window quit-restore-2)) ((and (not prev-buffer) (or (eq (nth 1 quit-restore) 'frame) (and (eq (nth 1 quit-restore) 'window) @@ -5217,7 +5218,7 @@ nil means to not handle the buffer in a particular way. This ;; Delete WINDOW if possible. (window--delete window nil (eq bury-or-kill 'kill))) ;; If the previously selected window is still alive, select it. - (quit-restore-select-window (nth 2 quit-restore))) + (window--quit-restore-select-window quit-restore-2)) ((and (listp (setq quad (nth 1 quit-restore))) (buffer-live-p (car quad)) (eq (nth 3 quit-restore) buffer)) @@ -5262,7 +5263,7 @@ nil means to not handle the buffer in a particular way. This (set-window-parameter window 'quit-restore nil) ;; Select old window. ;; If the previously selected window is still alive, select it. - (quit-restore-select-window (nth 2 quit-restore))) + (window--quit-restore-select-window quit-restore-2)) (t ;; Show some other buffer in WINDOW and reset the quit-restore ;; parameter. @@ -5276,7 +5277,7 @@ nil means to not handle the buffer in a particular way. This (set-window-dedicated-p window 'side)) (window--delete window nil (eq bury-or-kill 'kill)) ;; If the previously selected window is still alive, select it. - (quit-restore-select-window (nth 2 quit-restore))))) + (window--quit-restore-select-window quit-restore-2)))) ;; Deal with the buffer. (cond commit 97400c4c2446f00ee0783249b9c4f1fbfaf65fb2 Author: Mattias Engdegård Date: Fri May 13 13:36:13 2022 +0200 Make printing mostly non-recursive (bug#55481) Introduce explicit stacks for traversing common data types during printing: conses, vectors, records, byte-code, hash-tables and char-tables, all previously traversed using recursion in C. This greatly reduces the risk of crashing Emacs from C stack overflow when printing deeply nested data. * src/print.c (Fprinc, print, PRINT_CIRCLE_CANDIDATE_P): Special-case Fprinc with a plain string argument to eliminate the need for keeping track of print_depth during the preprocessing phase. This also improves performance. (struct print_pp_entry, struct print_pp_stack, ppstack) (grow_pp_stack, pp_stack_push_value, pp_stack_push_values) (pp_stack_empty_p, pp_stack_pop): New stack for preprocessing. (print_preprocess): Make mostly nonrecursive, except for string properties. (enum print_entry_type, struct print_stack_entry) (struct print_stack, prstack, grow_print_stack) (print_stack_push, print_stack_push_vector): New stack for printing. (print_vectorlike, print_object): Make mostly nonrecursive, except for string properties and some less heavily used types. * test/src/print-tests.el (print-deeply-nested): New test. diff --git a/src/print.c b/src/print.c index 55f4c2345a..da4869e8fb 100644 --- a/src/print.c +++ b/src/print.c @@ -834,7 +834,13 @@ is used instead. */) if (NILP (printcharfun)) printcharfun = Vstandard_output; PRINTPREPARE; - print (object, printcharfun, 0); + if (STRINGP (object) + && !string_intervals (object) + && NILP (Vprint_continuous_numbering)) + /* fast path for plain strings */ + print_string (object, printcharfun); + else + print (object, printcharfun, 0); PRINTFINISH; return object; } @@ -1249,7 +1255,6 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { /* Construct Vprint_number_table. This increments print_number_index for the objects added. */ - print_depth = 0; print_preprocess (obj); if (HASH_TABLE_P (Vprint_number_table)) @@ -1273,10 +1278,7 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) } #define PRINT_CIRCLE_CANDIDATE_P(obj) \ - ((STRINGP (obj) \ - && (string_intervals (obj) \ - || print_depth > 1 \ - || !NILP (Vprint_continuous_numbering))) \ + (STRINGP (obj) \ || CONSP (obj) \ || (VECTORLIKEP (obj) \ && (VECTORP (obj) || COMPILEDP (obj) \ @@ -1287,6 +1289,78 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) && SYMBOLP (obj) \ && !SYMBOL_INTERNED_P (obj))) +/* The print preprocess stack, used to traverse data structures. */ + +struct print_pp_entry { + ptrdiff_t n; /* number of values, or 0 if a single value */ + union { + Lisp_Object value; /* when n = 0 */ + Lisp_Object *values; /* when n > 0 */ + } u; +}; + +struct print_pp_stack { + struct print_pp_entry *stack; /* base of stack */ + ptrdiff_t size; /* allocated size in entries */ + ptrdiff_t sp; /* current number of entries */ +}; + +static struct print_pp_stack ppstack = {NULL, 0, 0}; + +NO_INLINE static void +grow_pp_stack (void) +{ + struct print_pp_stack *ps = &ppstack; + eassert (ps->sp == ps->size); + ps->stack = xpalloc (ps->stack, &ps->size, 1, -1, sizeof *ps->stack); + eassert (ps->sp < ps->size); +} + +static inline void +pp_stack_push_value (Lisp_Object value) +{ + if (ppstack.sp >= ppstack.size) + grow_pp_stack (); + ppstack.stack[ppstack.sp++] = (struct print_pp_entry){.n = 0, + .u.value = value}; +} + +static inline void +pp_stack_push_values (Lisp_Object *values, ptrdiff_t n) +{ + eassume (n >= 0); + if (n == 0) + return; + if (ppstack.sp >= ppstack.size) + grow_pp_stack (); + ppstack.stack[ppstack.sp++] = (struct print_pp_entry){.n = n, + .u.values = values}; +} + +static inline bool +pp_stack_empty_p (void) +{ + return ppstack.sp <= 0; +} + +static inline Lisp_Object +pp_stack_pop (void) +{ + eassume (!pp_stack_empty_p ()); + struct print_pp_entry *e = &ppstack.stack[ppstack.sp - 1]; + if (e->n == 0) /* single value */ + { + --ppstack.sp; + return e->u.value; + } + /* Array of values: pop them left to right, which seems to be slightly + faster than right to left. */ + e->n--; + if (e->n == 0) + --ppstack.sp; /* last value consumed */ + return (++e->u.values)[-1]; +} + /* Construct Vprint_number_table for the print-circle feature according to the structure of OBJ. OBJ itself and all its elements will be added to Vprint_number_table recursively if it is a list, @@ -1298,86 +1372,81 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) static void print_preprocess (Lisp_Object obj) { - int i; - ptrdiff_t size; - int loop_count = 0; - Lisp_Object halftail; - eassert (!NILP (Vprint_circle)); + ptrdiff_t base_sp = ppstack.sp; - print_depth++; - halftail = obj; - - loop: - if (PRINT_CIRCLE_CANDIDATE_P (obj)) + for (;;) { - if (!HASH_TABLE_P (Vprint_number_table)) - Vprint_number_table = CALLN (Fmake_hash_table, QCtest, Qeq); - - Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil); - if (!NILP (num) - /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym, - always print the gensym with a number. This is a special for - the lisp function byte-compile-output-docform. */ - || (!NILP (Vprint_continuous_numbering) - && SYMBOLP (obj) - && !SYMBOL_INTERNED_P (obj))) - { /* OBJ appears more than once. Let's remember that. */ - if (!FIXNUMP (num)) - { - print_number_index++; - /* Negative number indicates it hasn't been printed yet. */ - Fputhash (obj, make_fixnum (- print_number_index), - Vprint_number_table); + if (PRINT_CIRCLE_CANDIDATE_P (obj)) + { + if (!HASH_TABLE_P (Vprint_number_table)) + Vprint_number_table = CALLN (Fmake_hash_table, QCtest, Qeq); + + Lisp_Object num = Fgethash (obj, Vprint_number_table, Qnil); + if (!NILP (num) + /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym, + always print the gensym with a number. This is a special for + the lisp function byte-compile-output-docform. */ + || (!NILP (Vprint_continuous_numbering) + && SYMBOLP (obj) + && !SYMBOL_INTERNED_P (obj))) + { /* OBJ appears more than once. Let's remember that. */ + if (!FIXNUMP (num)) + { + print_number_index++; + /* Negative number indicates it hasn't been printed yet. */ + Fputhash (obj, make_fixnum (- print_number_index), + Vprint_number_table); + } } - print_depth--; - return; - } - else - /* OBJ is not yet recorded. Let's add to the table. */ - Fputhash (obj, Qt, Vprint_number_table); + else + { + /* OBJ is not yet recorded. Let's add to the table. */ + Fputhash (obj, Qt, Vprint_number_table); - switch (XTYPE (obj)) - { - case Lisp_String: - /* A string may have text properties, which can be circular. */ - traverse_intervals_noorder (string_intervals (obj), - print_preprocess_string, NULL); - break; + switch (XTYPE (obj)) + { + case Lisp_String: + /* A string may have text properties, + which can be circular. */ + traverse_intervals_noorder (string_intervals (obj), + print_preprocess_string, NULL); + break; - case Lisp_Cons: - /* Use HALFTAIL and LOOP_COUNT to detect circular lists, - just as in print_object. */ - if (loop_count && EQ (obj, halftail)) - break; - print_preprocess (XCAR (obj)); - obj = XCDR (obj); - loop_count++; - if (!(loop_count & 1)) - halftail = XCDR (halftail); - goto loop; - - case Lisp_Vectorlike: - size = ASIZE (obj); - if (size & PSEUDOVECTOR_FLAG) - size &= PSEUDOVECTOR_SIZE_MASK; - for (i = (SUB_CHAR_TABLE_P (obj) - ? SUB_CHAR_TABLE_OFFSET : 0); i < size; i++) - print_preprocess (AREF (obj, i)); - if (HASH_TABLE_P (obj)) - { /* For hash tables, the key_and_value slot is past - `size' because it needs to be marked specially in case - the table is weak. */ - struct Lisp_Hash_Table *h = XHASH_TABLE (obj); - print_preprocess (h->key_and_value); - } - break; + case Lisp_Cons: + if (!NILP (XCDR (obj))) + pp_stack_push_value (XCDR (obj)); + obj = XCAR (obj); + continue; - default: - break; + case Lisp_Vectorlike: + { + struct Lisp_Vector *vec = XVECTOR (obj); + ptrdiff_t size = ASIZE (obj); + if (size & PSEUDOVECTOR_FLAG) + size &= PSEUDOVECTOR_SIZE_MASK; + ptrdiff_t start = (SUB_CHAR_TABLE_P (obj) + ? SUB_CHAR_TABLE_OFFSET : 0); + pp_stack_push_values (vec->contents + start, size - start); + if (HASH_TABLE_P (obj)) + { + struct Lisp_Hash_Table *h = XHASH_TABLE (obj); + obj = h->key_and_value; + continue; + } + break; + } + + default: + break; + } + } } + + if (ppstack.sp <= base_sp) + break; + obj = pp_stack_pop (); } - print_depth--; } DEFUN ("print--preprocess", Fprint_preprocess, Sprint_preprocess, 1, 1, 0, @@ -1569,162 +1638,6 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, } return true; - case PVEC_HASH_TABLE: - { - struct Lisp_Hash_Table *h = XHASH_TABLE (obj); - /* Implement a readable output, e.g.: - #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */ - /* Always print the size. */ - int len = sprintf (buf, "#s(hash-table size %"pD"d", - HASH_TABLE_SIZE (h)); - strout (buf, len, len, printcharfun); - - if (!NILP (h->test.name)) - { - print_c_string (" test ", printcharfun); - print_object (h->test.name, printcharfun, escapeflag); - } - - if (!NILP (h->weak)) - { - print_c_string (" weakness ", printcharfun); - print_object (h->weak, printcharfun, escapeflag); - } - - print_c_string (" rehash-size ", printcharfun); - print_object (Fhash_table_rehash_size (obj), - printcharfun, escapeflag); - - print_c_string (" rehash-threshold ", printcharfun); - print_object (Fhash_table_rehash_threshold (obj), - printcharfun, escapeflag); - - if (h->purecopy) - { - print_c_string (" purecopy ", printcharfun); - print_object (h->purecopy ? Qt : Qnil, printcharfun, escapeflag); - } - - print_c_string (" data ", printcharfun); - - /* Print the data here as a plist. */ - ptrdiff_t real_size = HASH_TABLE_SIZE (h); - ptrdiff_t size = h->count; - - /* Don't print more elements than the specified maximum. */ - if (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size) - size = XFIXNAT (Vprint_length); - - printchar ('(', printcharfun); - ptrdiff_t j = 0; - for (ptrdiff_t i = 0; i < real_size; i++) - { - Lisp_Object key = HASH_KEY (h, i); - if (!EQ (key, Qunbound)) - { - if (j++) printchar (' ', printcharfun); - print_object (key, printcharfun, escapeflag); - printchar (' ', printcharfun); - print_object (HASH_VALUE (h, i), printcharfun, escapeflag); - if (j == size) - break; - } - } - - if (j < h->count) - { - if (j) - printchar (' ', printcharfun); - print_c_string ("...", printcharfun); - } - - print_c_string ("))", printcharfun); - } - return true; - - case PVEC_RECORD: - { - ptrdiff_t size = PVSIZE (obj); - - /* Don't print more elements than the specified maximum. */ - ptrdiff_t n - = (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size - ? XFIXNAT (Vprint_length) : size); - - print_c_string ("#s(", printcharfun); - for (ptrdiff_t i = 0; i < n; i ++) - { - if (i) printchar (' ', printcharfun); - print_object (AREF (obj, i), printcharfun, escapeflag); - } - if (n < size) - print_c_string (" ...", printcharfun); - printchar (')', printcharfun); - } - return true; - - case PVEC_SUB_CHAR_TABLE: - case PVEC_COMPILED: - case PVEC_CHAR_TABLE: - case PVEC_NORMAL_VECTOR: - { - ptrdiff_t size = ASIZE (obj); - if (COMPILEDP (obj)) - { - printchar ('#', printcharfun); - size &= PSEUDOVECTOR_SIZE_MASK; - } - if (CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj)) - { - /* Print a char-table as if it were a vector, - lumping the parent and default slots in with the - character slots. But add #^ as a prefix. */ - - /* Make each lowest sub_char_table start a new line. - Otherwise we'll make a line extremely long, which - results in slow redisplay. */ - if (SUB_CHAR_TABLE_P (obj) - && XSUB_CHAR_TABLE (obj)->depth == 3) - printchar ('\n', printcharfun); - print_c_string ("#^", printcharfun); - if (SUB_CHAR_TABLE_P (obj)) - printchar ('^', printcharfun); - size &= PSEUDOVECTOR_SIZE_MASK; - } - if (size & PSEUDOVECTOR_FLAG) - return false; - - printchar ('[', printcharfun); - - int idx = SUB_CHAR_TABLE_P (obj) ? SUB_CHAR_TABLE_OFFSET : 0; - Lisp_Object tem; - ptrdiff_t real_size = size; - - /* For a sub char-table, print heading non-Lisp data first. */ - if (SUB_CHAR_TABLE_P (obj)) - { - int i = sprintf (buf, "%d %d", XSUB_CHAR_TABLE (obj)->depth, - XSUB_CHAR_TABLE (obj)->min_char); - strout (buf, i, i, printcharfun); - } - - /* Don't print more elements than the specified maximum. */ - if (FIXNATP (Vprint_length) - && XFIXNAT (Vprint_length) < size) - size = XFIXNAT (Vprint_length); - - for (int i = idx; i < size; i++) - { - if (i) printchar (' ', printcharfun); - tem = AREF (obj, i); - print_object (tem, printcharfun, escapeflag); - } - if (size < real_size) - print_c_string (" ...", printcharfun); - printchar (']', printcharfun); - } - return true; - default: break; } @@ -2103,32 +2016,118 @@ named_escape (int i) return 0; } +enum print_entry_type { + PE_list, /* print rest of list */ + PE_rbrac, /* print ")" */ + PE_vector, /* print rest of vector */ + PE_hash, /* print rest of hash data */ +}; + +struct print_stack_entry { + enum print_entry_type type; + union { + struct { + Lisp_Object last; /* cons whose car was just printed */ + ptrdiff_t idx; /* index of next element */ + intmax_t maxlen; /* max length (from Vprint_length) */ + /* state for Brent cycle detection */ + Lisp_Object tortoise; /* slow pointer */ + ptrdiff_t n; /* tortoise step countdown */ + ptrdiff_t m; /* tortoise step period */ + } list; + struct { + Lisp_Object obj; /* object to print after " . " */ + } dotted_cdr; + struct { + Lisp_Object obj; /* vector object */ + ptrdiff_t size; /* length of vector */ + ptrdiff_t idx; /* index of next element */ + const char *end; /* string to print at end */ + bool truncated; /* whether to print "..." before end */ + } vector; + struct { + Lisp_Object obj; /* hash-table object */ + ptrdiff_t nobjs; /* number of keys and values to print */ + ptrdiff_t idx; /* index of key-value pair */ + ptrdiff_t printed; /* number of keys and values printed */ + bool truncated; /* whether to print "..." before end */ + } hash; + } u; +}; + +struct print_stack { + struct print_stack_entry *stack; /* base of stack */ + ptrdiff_t size; /* allocated size in entries */ + ptrdiff_t sp; /* current number of entries */ +}; + +static struct print_stack prstack = {NULL, 0, 0}; + +NO_INLINE static void +grow_print_stack (void) +{ + struct print_stack *ps = &prstack; + eassert (ps->sp == ps->size); + ps->stack = xpalloc (ps->stack, &ps->size, 1, -1, sizeof *ps->stack); + eassert (ps->sp < ps->size); +} + +static inline void +print_stack_push (struct print_stack_entry e) +{ + if (prstack.sp >= prstack.size) + grow_print_stack (); + prstack.stack[prstack.sp++] = e; +} + +static void +print_stack_push_vector (const char *lbrac, const char *rbrac, + Lisp_Object obj, ptrdiff_t start, ptrdiff_t size, + Lisp_Object printcharfun) +{ + print_c_string (lbrac, printcharfun); + + ptrdiff_t print_size = ((FIXNATP (Vprint_length) + && XFIXNAT (Vprint_length) < size) + ? XFIXNAT (Vprint_length) : size); + print_stack_push ((struct print_stack_entry){ + .type = PE_vector, + .u.vector.obj = obj, + .u.vector.size = print_size, + .u.vector.idx = start, + .u.vector.end = rbrac, + .u.vector.truncated = (print_size < size), + }); +} + static void print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { + ptrdiff_t base_depth = print_depth; + ptrdiff_t base_sp = prstack.sp; char buf[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT), max (sizeof " . #" + INT_STRLEN_BOUND (intmax_t), max ((sizeof " with data 0x" + (sizeof (uintmax_t) * CHAR_BIT + 4 - 1) / 4), 40)))]; current_thread->stack_top = buf; + + print_obj: maybe_quit (); /* Detect circularities and truncate them. */ if (NILP (Vprint_circle)) { /* Simple but incomplete way. */ - int i; - if (print_depth >= PRINT_CIRCLE) error ("Apparently circular structure being printed"); - for (i = 0; i < print_depth; i++) + for (int i = 0; i < print_depth; i++) if (BASE_EQ (obj, being_printed[i])) { int len = sprintf (buf, "#%d", i); strout (buf, len, len, printcharfun); - return; + goto next_obj; } being_printed[print_depth] = obj; } @@ -2152,7 +2151,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) /* Just print #n# if OBJ has already been printed. */ int len = sprintf (buf, "#%"pI"d#", n); strout (buf, len, len, printcharfun); - return; + goto next_obj; } } } @@ -2226,7 +2225,8 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) for (i = 0, i_byte = 0; i_byte < size_byte;) { /* Here, we must convert each multi-byte form to the - corresponding character code before handing it to printchar. */ + corresponding character code before handing it to + printchar. */ int c = fetch_string_char_advance (obj, &i, &i_byte); maybe_quit (); @@ -2246,7 +2246,8 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) else if (multibyte && ! ASCII_CHAR_P (c) && print_escape_multibyte) { - /* When requested, print multibyte chars using hex escapes. */ + /* When requested, print multibyte chars using + hex escapes. */ char outbuf[sizeof "\\x" + INT_STRLEN_BOUND (c)]; int len = sprintf (outbuf, "\\x%04x", c + 0u); strout (outbuf, len, len, printcharfun); @@ -2357,14 +2358,22 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) && EQ (XCAR (obj), Qquote)) { printchar ('\'', printcharfun); - print_object (XCAR (XCDR (obj)), printcharfun, escapeflag); + obj = XCAR (XCDR (obj)); + --print_depth; /* tail recursion */ + goto print_obj; } else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj))) && EQ (XCAR (obj), Qfunction)) { print_c_string ("#'", printcharfun); - print_object (XCAR (XCDR (obj)), printcharfun, escapeflag); + obj = XCAR (XCDR (obj)); + --print_depth; /* tail recursion */ + goto print_obj; } + /* FIXME: Do we really need the new_backquote_output gating of + special syntax for comma and comma-at? There is basically no + benefit from it at all, and it would be nice to get rid of + the recursion here without additional complexity. */ else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj))) && EQ (XCAR (obj), Qbackquote)) { @@ -2374,9 +2383,9 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) new_backquote_output--; } else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj))) - && new_backquote_output && (EQ (XCAR (obj), Qcomma) - || EQ (XCAR (obj), Qcomma_at))) + || EQ (XCAR (obj), Qcomma_at)) + && new_backquote_output) { print_object (XCAR (obj), printcharfun, false); new_backquote_output--; @@ -2386,70 +2395,135 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) else { printchar ('(', printcharfun); - /* Negative values of print-length are invalid in CL. Treat them like nil, as CMUCL does. */ intmax_t print_length = (FIXNATP (Vprint_length) ? XFIXNAT (Vprint_length) : INTMAX_MAX); - Lisp_Object objtail = Qnil; - intmax_t i = 0; - FOR_EACH_TAIL_SAFE (obj) + if (print_length == 0) + print_c_string ("...)", printcharfun); + else { - if (i != 0) - { - printchar (' ', printcharfun); - - if (!NILP (Vprint_circle)) - { - /* With the print-circle feature. */ - Lisp_Object num = Fgethash (obj, Vprint_number_table, - Qnil); - if (FIXNUMP (num)) - { - print_c_string (". ", printcharfun); - print_object (obj, printcharfun, escapeflag); - goto end_of_list; - } - } - } - - if (print_length <= i) - { - print_c_string ("...", printcharfun); - goto end_of_list; - } - - i++; - print_object (XCAR (obj), printcharfun, escapeflag); - objtail = XCDR (obj); + print_stack_push ((struct print_stack_entry){ + .type = PE_list, + .u.list.last = obj, + .u.list.maxlen = print_length, + .u.list.idx = 1, + .u.list.tortoise = obj, + .u.list.n = 2, + .u.list.m = 2, + }); + /* print the car */ + obj = XCAR (obj); + goto print_obj; } + } + break; - /* OBJTAIL non-nil here means it's the end of a dotted list - or FOR_EACH_TAIL_SAFE detected a circular list. */ - if (!NILP (objtail)) - { - print_c_string (" . ", printcharfun); + case Lisp_Vectorlike: + /* First do all the vectorlike types that have a readable syntax. */ + switch (PSEUDOVECTOR_TYPE (XVECTOR (obj))) + { + case PVEC_NORMAL_VECTOR: + { + print_stack_push_vector ("[", "]", obj, 0, ASIZE (obj), + printcharfun); + goto next_obj; + } + case PVEC_RECORD: + { + print_stack_push_vector ("#s(", ")", obj, 0, PVSIZE (obj), + printcharfun); + goto next_obj; + } + case PVEC_COMPILED: + { + print_stack_push_vector ("#[", "]", obj, 0, PVSIZE (obj), + printcharfun); + goto next_obj; + } + case PVEC_CHAR_TABLE: + { + print_stack_push_vector ("#^[", "]", obj, 0, PVSIZE (obj), + printcharfun); + goto next_obj; + } + case PVEC_SUB_CHAR_TABLE: + { + /* Make each lowest sub_char_table start a new line. + Otherwise we'll make a line extremely long, which + results in slow redisplay. */ + if (XSUB_CHAR_TABLE (obj)->depth == 3) + printchar ('\n', printcharfun); + print_c_string ("#^^[", printcharfun); + int n = sprintf (buf, "%d %d", + XSUB_CHAR_TABLE (obj)->depth, + XSUB_CHAR_TABLE (obj)->min_char); + strout (buf, n, n, printcharfun); + print_stack_push_vector ("", "]", obj, + SUB_CHAR_TABLE_OFFSET, PVSIZE (obj), + printcharfun); + goto next_obj; + } + case PVEC_HASH_TABLE: + { + struct Lisp_Hash_Table *h = XHASH_TABLE (obj); + /* Implement a readable output, e.g.: + #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */ + /* Always print the size. */ + int len = sprintf (buf, "#s(hash-table size %"pD"d", + HASH_TABLE_SIZE (h)); + strout (buf, len, len, printcharfun); - if (CONSP (objtail) && NILP (Vprint_circle)) - { - int len = sprintf (buf, "#%"PRIdMAX, i >> 1); - strout (buf, len, len, printcharfun); - goto end_of_list; - } + if (!NILP (h->test.name)) + { + print_c_string (" test ", printcharfun); + print_object (h->test.name, printcharfun, escapeflag); + } - print_object (objtail, printcharfun, escapeflag); - } + if (!NILP (h->weak)) + { + print_c_string (" weakness ", printcharfun); + print_object (h->weak, printcharfun, escapeflag); + } - end_of_list: - printchar (')', printcharfun); + print_c_string (" rehash-size ", printcharfun); + print_object (Fhash_table_rehash_size (obj), + printcharfun, escapeflag); + + print_c_string (" rehash-threshold ", printcharfun); + print_object (Fhash_table_rehash_threshold (obj), + printcharfun, escapeflag); + + if (h->purecopy) + print_c_string (" purecopy t", printcharfun); + + print_c_string (" data (", printcharfun); + + ptrdiff_t size = h->count; + /* Don't print more elements than the specified maximum. */ + if (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size) + size = XFIXNAT (Vprint_length); + + print_stack_push ((struct print_stack_entry){ + .type = PE_hash, + .u.hash.obj = obj, + .u.hash.nobjs = size * 2, + .u.hash.idx = 0, + .u.hash.printed = 0, + .u.hash.truncated = (size < h->count), + }); + goto next_obj; + } + + default: + break; } - break; - case Lisp_Vectorlike: if (print_vectorlike (obj, printcharfun, escapeflag, buf)) break; FALLTHROUGH; + default: { int len; @@ -2464,10 +2538,160 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) print_c_string ((" Save your buffers immediately" " and please report this bug>"), printcharfun); + break; } } - print_depth--; + + next_obj: + if (prstack.sp > base_sp) + { + /* Handle a continuation on the print stack. */ + struct print_stack_entry *e = &prstack.stack[prstack.sp - 1]; + switch (e->type) + { + case PE_list: + { + /* after "(" ELEM (* " " ELEM) */ + Lisp_Object next = XCDR (e->u.list.last); + if (NILP (next)) + { + /* end of list: print ")" */ + printchar (')', printcharfun); + --prstack.sp; + --print_depth; + goto next_obj; + } + else if (CONSP (next)) + { + if (!NILP (Vprint_circle)) + { + /* With the print-circle feature. */ + Lisp_Object num = Fgethash (next, Vprint_number_table, + Qnil); + if (FIXNUMP (num)) + { + print_c_string (" . ", printcharfun); + obj = next; + e->type = PE_rbrac; + goto print_obj; + } + } + + /* list continues: print " " ELEM ... */ + + printchar (' ', printcharfun); + + /* FIXME: We wouldn't need to keep track of idx if we + count down maxlen instead, and maintain a separate + tortoise index if required. */ + if (e->u.list.idx >= e->u.list.maxlen) + { + print_c_string ("...)", printcharfun); + --prstack.sp; + --print_depth; + goto next_obj; + } + + e->u.list.last = next; + e->u.list.idx++; + e->u.list.n--; + if (e->u.list.n == 0) + { + /* Double tortoise update period and teleport it. */ + e->u.list.m <<= 1; + e->u.list.n = e->u.list.m; + e->u.list.tortoise = next; + } + else if (BASE_EQ (next, e->u.list.tortoise)) + { + /* FIXME: This #N tail index is bug-compatible with + previous implementations but actually nonsense; + see bug#55395. */ + int len = sprintf (buf, ". #%" PRIdMAX ")", + (e->u.list.idx >> 1) - 1); + strout (buf, len, len, printcharfun); + --prstack.sp; + --print_depth; + goto next_obj; + } + obj = XCAR (next); + } + else + { + /* non-nil ending: print " . " ELEM ")" */ + print_c_string (" . ", printcharfun); + obj = next; + e->type = PE_rbrac; + } + break; + } + + case PE_rbrac: + printchar (')', printcharfun); + --prstack.sp; + --print_depth; + goto next_obj; + + case PE_vector: + if (e->u.vector.idx >= e->u.vector.size) + { + if (e->u.vector.truncated) + { + if (e->u.vector.idx > 0) + printchar (' ', printcharfun); + print_c_string ("...", printcharfun); + } + print_c_string (e->u.vector.end, printcharfun); + --prstack.sp; + --print_depth; + goto next_obj; + } + if (e->u.vector.idx > 0) + printchar (' ', printcharfun); + obj = AREF (e->u.vector.obj, e->u.vector.idx); + e->u.vector.idx++; + break; + + case PE_hash: + if (e->u.hash.printed >= e->u.hash.nobjs) + { + if (e->u.hash.truncated) + { + if (e->u.hash.printed) + printchar (' ', printcharfun); + print_c_string ("...", printcharfun); + } + print_c_string ("))", printcharfun); + --prstack.sp; + --print_depth; + goto next_obj; + } + + if (e->u.hash.printed) + printchar (' ', printcharfun); + + struct Lisp_Hash_Table *h = XHASH_TABLE (e->u.hash.obj); + if ((e->u.hash.printed & 1) == 0) + { + Lisp_Object key; + ptrdiff_t idx = e->u.hash.idx; + while (BASE_EQ ((key = HASH_KEY (h, idx)), Qunbound)) + idx++; + e->u.hash.idx = idx; + obj = key; + } + else + { + obj = HASH_VALUE (h, e->u.hash.idx); + e->u.hash.idx++; + } + e->u.hash.printed++; + break; + } + goto print_obj; + } + eassert (print_depth == base_depth); } diff --git a/test/src/print-tests.el b/test/src/print-tests.el index b9b282e580..1b28fd19ee 100644 --- a/test/src/print-tests.el +++ b/test/src/print-tests.el @@ -468,5 +468,21 @@ otherwise, use a different charset." (should-error (prin1-to-string 'foo nil '((a . b) b))) (should-error (prin1-to-string 'foo nil '((length . 10) . b)))) +(ert-deftest print-deeply-nested () + ;; Check that we can print a deeply nested data structure correctly. + (let ((print-circle t)) + (let ((levels 10000) + (x 'a) + (prefix nil) + (suffix nil)) + (dotimes (_ levels) + (setq x (list (vector (record 'r x)))) + (push "([#s(r " prefix) + (push ")])" suffix)) + (let ((expected (concat (apply #'concat prefix) + "a" + (apply #'concat suffix)))) + (should (equal (prin1-to-string x) expected)))))) + (provide 'print-tests) ;;; print-tests.el ends here commit 24f7719cb66e8fa45f3746f22f938dceff94a576 Author: Michael Albinus Date: Wed May 18 10:05:32 2022 +0200 ; Fix thinko in etc/NEWS diff --git a/etc/NEWS b/etc/NEWS index a27470dbc4..7089e3a271 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -37,7 +37,7 @@ can be enabled by configuring Emacs with the option '--with-be-app', which will require the Haiku Application Kit development headers and a C++ compiler to be present on your system. If Emacs is not built with the option '--with-be-app', the resulting Emacs will only run in -'text-mode' terminals. +text-mode terminals. +++ ** Cairo drawing support has been enabled for Haiku builds.