[COMMIT] Preserve extent information in the command builder code.

APPROVE COMMIT NOTE: This patch has been committed # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net&gt; # Date 1405341762 -3600 # Mon Jul 14 13:42:42 2014 +0100 # Node ID b79e1e02bf012f32241a818847a2e9eedd5e3e96 # Parent 236e4afc565dcd32516d0946525c2c63397573c3 Preserve extent information in the command builder code. src/ChangeLog addition: 2014-07-14 Aidan Kehoe <kehoea(a)parhasard.net&gt; * event-stream.c: * event-stream.c (mark_command_builder): * event-stream.c (finalize_command_builder): Removed. * event-stream.c (allocate_command_builder): * event-stream.c (free_command_builder): Removed. Use free_normal_lisp_object() instead. * event-stream.c (echo_key_event): * event-stream.c (regenerate_echo_keys_from_this_command_keys): Detach all extents here. * event-stream.c (maybe_echo_keys): * event-stream.c (reset_key_echo): * event-stream.c (execute_help_form): * event-stream.c (Fnext_event): * event-stream.c (command_builder_find_leaf_no_jit_binding): * event-stream.c (command_builder_find_leaf): * event-stream.c (lookup_command_event): * events.h (struct command_builder): Move the command builder's echo_buf to being a Lisp string rather than a malloced Ibyte array. This allows passing through extent information, which was previously dropped. It also simplifies the allocation and release code for the command builder. Rename echo_buf_index to echo_buf_fill_pointer, better reflecting its function. Don't rely on zero-termination (something not particularly compatible with Lisp-level code) when showing a substring of echo_buf that differs from that designated by echo_buf_fill_pointer, keep a separate counter instead and use that. * minibuf.c: * minibuf.c (echo_area_append): Use the new START and END keyword arguments to #'append-message, rather than consing a new string for basically every #'next-event prompt displayed. test/ChangeLog addition: 2014-07-14 Aidan Kehoe <kehoea(a)parhasard.net&gt; * automated/extent-tests.el: Check that extent information is passed through to the echo area correctly with #'next-event's PROMPT argument. lisp/ChangeLog addition: 2014-07-14 Aidan Kehoe <kehoea(a)parhasard.net&gt; * simple.el (raw-append-message): Use #'write-sequence in this, take its START and END keyword arguments, so our callers don't have to cons as much. * simple.el (append-message): Pass through START and END here. diff -r 236e4afc565d -r b79e1e02bf01 lisp/ChangeLog --- a/lisp/ChangeLog Wed Jul 02 17:45:49 2014 +0100 +++ b/lisp/ChangeLog Mon Jul 14 13:42:42 2014 +0100 ＠＠ -1,3 +1,11 ＠＠ +2014-07-14 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * simple.el (raw-append-message): + Use #'write-sequence in this, take its START and END keyword + arguments, so our callers don't have to cons as much. + * simple.el (append-message): + Pass through START and END here. + 2014-07-02 Aidan Kehoe <kehoea(a)parhasard.net&gt; * byte-optimize.el (side-effect-free-fns): diff -r 236e4afc565d -r b79e1e02bf01 lisp/simple.el --- a/lisp/simple.el Wed Jul 02 17:45:49 2014 +0100 +++ b/lisp/simple.el Mon Jul 14 13:42:42 2014 +0100 ＠＠ -4412,14 +4412,21 ＠＠ (car (car log)) (cdr (car log)))) (setq log (cdr log))))) -(defun append-message (label message &optional frame stdout-p) +(defun* append-message (label message &optional frame stdout-p + &key (start 0) end) "Add MESSAGE to the message-stack, or append it to the existing text. + LABEL is the class of the message. If it is the same as that of the top of the message stack, MESSAGE is appended to the existing message, otherwise it is pushed on the stack. + FRAME determines the minibuffer window to send the message to. + STDOUT-P is ignored, except for output to stream devices. For streams, -STDOUT-P non-nil directs output to stdout, otherwise to stderr." +STDOUT-P non-nil directs output to stdout, otherwise to stderr. + +START and END, if supplied, designate a substring of MESSAGE to add. See +`write-sequence'." (or frame (setq frame (selected-frame))) ;; If outputting to the terminal, make sure output from anyone else clears ;; the left side first, but don't do it ourselves, otherwise we won't be ＠＠ -4430,17 +4437,18 ＠＠ (if (eq label (car top)) (setcdr top (concat (cdr top) message)) (push (cons label message) message-stack))) - (raw-append-message message frame stdout-p) + (raw-append-message message frame stdout-p :start start :end end) (if (eq 'stream (frame-type frame)) (set-device-clear-left-side (frame-device frame) t))) ;; Really append the message to the echo area. No fiddling with ;; message-stack. -(defun raw-append-message (message &optional frame stdout-p) +(defun* raw-append-message (message &optional frame stdout-p + &key (start 0) end) (unless (equal message "") (let ((inhibit-read-only t)) (with-current-buffer " *Echo Area*" - (insert-string message) + (write-sequence message (current-buffer) :start start :end end) ;; #### This needs to be conditional; cf discussion by Stefan Monnier ;; et al on emacs-devel in mid-to-late April 2007. One problem is ;; there is no known good way to guess whether the user wants to have ＠＠ -4489,7 +4497,8 ＠＠ ;; we ever create another non-redisplayable device type (e.g. ;; processes? printers?). (if (eq 'stream (frame-type frame)) - (send-string-to-terminal message stdout-p (frame-device frame)) + (send-string-to-terminal (subseq message start end) stdout-p + (frame-device frame)) (funcall redisplay-echo-area-function)))))) (defun display-message (label message &optional frame stdout-p) diff -r 236e4afc565d -r b79e1e02bf01 src/ChangeLog --- a/src/ChangeLog Wed Jul 02 17:45:49 2014 +0100 +++ b/src/ChangeLog Mon Jul 14 13:42:42 2014 +0100 ＠＠ -1,3 +1,39 ＠＠ +2014-07-14 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * event-stream.c: + * event-stream.c (mark_command_builder): + * event-stream.c (finalize_command_builder): Removed. + * event-stream.c (allocate_command_builder): + * event-stream.c (free_command_builder): Removed. Use + free_normal_lisp_object() instead. + * event-stream.c (echo_key_event): + * event-stream.c (regenerate_echo_keys_from_this_command_keys): + Detach all extents here. + * event-stream.c (maybe_echo_keys): + * event-stream.c (reset_key_echo): + * event-stream.c (execute_help_form): + * event-stream.c (Fnext_event): + * event-stream.c (command_builder_find_leaf_no_jit_binding): + * event-stream.c (command_builder_find_leaf): + * event-stream.c (lookup_command_event): + * events.h (struct command_builder): + Move the command builder's echo_buf to being a Lisp string rather + than a malloced Ibyte array. This allows passing through extent + information, which was previously dropped. It also simplifies the + allocation and release code for the command builder. + Rename echo_buf_index to echo_buf_fill_pointer, better reflecting + its function. + Don't rely on zero-termination (something not particularly + compatible with Lisp-level code) when showing a substring of + echo_buf that differs from that designated by + echo_buf_fill_pointer, keep a separate counter instead and use + that. + * minibuf.c: + * minibuf.c (echo_area_append): + Use the new START and END keyword arguments to #'append-message, + rather than consing a new string for basically every #'next-event + prompt displayed. + 2014-07-02 Aidan Kehoe <kehoea(a)parhasard.net&gt; * keymap.c (Fkeymapp): diff -r 236e4afc565d -r b79e1e02bf01 src/event-stream.c --- a/src/event-stream.c Wed Jul 02 17:45:49 2014 +0100 +++ b/src/event-stream.c Mon Jul 14 13:42:42 2014 +0100 ＠＠ -81,6 +81,7 ＠＠ #include "device-impl.h" #include "elhash.h" #include "events.h" +#include "extents.h" #include "frame-impl.h" #include "insdel.h" /* for buffer_reset_changes */ #include "keymap.h" ＠＠ -336,6 +337,7 ＠＠ { XD_LISP_OBJECT, offsetof (struct command_builder, last_non_munged_event) }, { XD_LISP_OBJECT, offsetof (struct command_builder, console) }, { XD_LISP_OBJECT_ARRAY, offsetof (struct command_builder, first_mungeable_event), 2 }, + { XD_LISP_OBJECT, offsetof (struct command_builder, echo_buf) }, { XD_END } }; ＠＠ -348,24 +350,13 ＠＠ mark_object (builder->last_non_munged_event); mark_object (builder->first_mungeable_event[0]); mark_object (builder->first_mungeable_event[1]); + mark_object (builder->echo_buf); return builder->console; } -static void -finalize_command_builder (Lisp_Object obj) -{ - struct command_builder *b = XCOMMAND_BUILDER (obj); - if (b->echo_buf) - { - xfree (b->echo_buf); - b->echo_buf = 0; - } -} - DEFINE_NODUMP_LISP_OBJECT ("command-builder", command_builder, mark_command_builder, - internal_object_printer, - finalize_command_builder, 0, 0, + internal_object_printer, 0, 0, 0, command_builder_description, struct command_builder); ＠＠ -389,17 +380,13 ＠＠ reset_command_builder_event_chain (builder); if (with_echo_buf) { - /* #### This badly needs to be turned into a Dynarr */ - builder->echo_buf_length = 300; /* #### Kludge */ - builder->echo_buf = xnew_array (Ibyte, builder->echo_buf_length); - builder->echo_buf[0] = 0; + builder->echo_buf = make_uninit_string (300 * MAX_ICHAR_LEN); } else { - builder->echo_buf_length = 0; - builder->echo_buf = NULL; + builder->echo_buf = Qnil; } - builder->echo_buf_index = -1; + builder->echo_buf_fill_pointer = builder->echo_buf_end = -1; builder->self_insert_countdown = 0; return builder_obj; ＠＠ -446,17 +433,6 ＠＠ } static void -free_command_builder (struct command_builder *builder) -{ - if (builder->echo_buf) - { - xfree (builder->echo_buf); - builder->echo_buf = NULL; - } - free_normal_lisp_object (wrap_command_builder (builder)); -} - -static void command_builder_append_event (struct command_builder *builder, Lisp_Object event) { ＠＠ -660,35 +636,37 ＠＠ { /* This function can GC */ DECLARE_EISTRING_MALLOC (buf); - Bytecount buf_index = command_builder->echo_buf_index; - Ibyte *e; + Bytecount buf_fill_pointer = command_builder->echo_buf_fill_pointer; Bytecount len; - if (buf_index < 0) + if (buf_fill_pointer < 0) { - buf_index = 0; /* We're echoing now */ + buf_fill_pointer = 0; clear_echo_area (selected_frame (), Qnil, 0); } format_event_object (buf, event, 1); len = eilen (buf); - if (len + buf_index + 4 > command_builder->echo_buf_length) + if (NILP (command_builder->echo_buf) || + (len + buf_fill_pointer + 4 > XSTRING_LENGTH (command_builder->echo_buf))) { eifree (buf); return; } - e = command_builder->echo_buf + buf_index; - memcpy (e, eidata (buf), len); - e += len; + + eicat_ascii (buf, " - "); + + memcpy (XSTRING_DATA (command_builder->echo_buf) + buf_fill_pointer, + eidata (buf), eilen (buf)); + init_string_ascii_begin (command_builder->echo_buf); + bump_string_modiff (command_builder->echo_buf); + sledgehammer_check_ascii_begin (command_builder->echo_buf); + + command_builder->echo_buf_end = buf_fill_pointer + eilen (buf); + /* *Not* including the trailing " - ". */ + command_builder->echo_buf_fill_pointer = buf_fill_pointer + len + 1; eifree (buf); - - e[0] = ' '; - e[1] = '-'; - e[2] = ' '; - e[3] = 0; - - command_builder->echo_buf_index = buf_index + len + 1; } static void ＠＠ -697,7 +675,11 ＠＠ { Lisp_Object event; - builder->echo_buf_index = 0; + builder->echo_buf_fill_pointer = builder->echo_buf_end = 0; + if (STRINGP (builder->echo_buf)) + { + detach_all_extents (builder->echo_buf); + } EVENT_CHAIN_LOOP (event, Vthis_command_keys) echo_key_event (builder, event); ＠＠ -734,11 +716,8 ＠＠ goto done; } - echo_area_message (f, command_builder->echo_buf, Qnil, 0, - /* not echo_buf_index. That doesn't include - the terminating " - ". */ - strlen ((char *) command_builder->echo_buf), - Qcommand); + echo_area_message (f, NULL, command_builder->echo_buf, 0, + command_builder->echo_buf_end, Qcommand); } done: ＠＠ -754,7 +733,10 ＠＠ struct frame *f = selected_frame (); if (command_builder) - command_builder->echo_buf_index = -1; + { + command_builder->echo_buf_fill_pointer = + command_builder->echo_buf_end = -1; + } if (remove_echo_area_echo) clear_echo_area (f, Qcommand, 0); ＠＠ -814,11 +796,11 ＠＠ /* This function can GC */ Lisp_Object help = Qnil; int speccount = specpdl_depth (); - Bytecount buf_index = command_builder->echo_buf_index; - Lisp_Object echo = ((buf_index <= 0) - ? Qnil -: make_string (command_builder->echo_buf, - buf_index)); + Bytecount buf_fill_pointer = command_builder->echo_buf_fill_pointer; + Bytecount buf_end = command_builder->echo_buf_end; + Lisp_Object echo = ((buf_fill_pointer <= 0) ? Qnil +: Fcopy_sequence (command_builder->echo_buf)); + struct gcpro gcpro1, gcpro2; GCPRO2 (echo, help); ＠＠ -856,10 +838,13 ＠＠ Fnext_command_event (event, Qnil); } - command_builder->echo_buf_index = buf_index; - if (buf_index > 0) - memcpy (command_builder->echo_buf, - XSTRING_DATA (echo), buf_index + 1); /* terminating 0 */ + command_builder->echo_buf_fill_pointer = buf_fill_pointer; + command_builder->echo_buf_end = buf_end; + + if (buf_fill_pointer > 0) + { + command_builder->echo_buf = echo; + } UNGCPRO; } ＠＠ -2182,19 +2167,28 ＠＠ if (!NILP (prompt)) { Bytecount len; + Lisp_Object args[] = { Qnil, prompt }; CHECK_STRING (prompt); len = XSTRING_LENGTH (prompt); - if (command_builder->echo_buf_length < len) - len = command_builder->echo_buf_length - 1; - memcpy (command_builder->echo_buf, XSTRING_DATA (prompt), len); - command_builder->echo_buf[len] = 0; - command_builder->echo_buf_index = len; - echo_area_message (XFRAME (CONSOLE_SELECTED_FRAME (con)), - command_builder->echo_buf, - Qnil, 0, - command_builder->echo_buf_index, - Qcommand); + + detach_all_extents (command_builder->echo_buf); + if (XSTRING_LENGTH (command_builder->echo_buf) < len) + { + command_builder->echo_buf + = make_uninit_string (len + 200 * MAX_ICHAR_LEN); + } + + args[0] = command_builder->echo_buf; + Freplace (countof (args), args); + copy_string_extents (command_builder->echo_buf, prompt, 0, 0, + XSTRING_LENGTH (prompt)); + command_builder->echo_buf_fill_pointer + = command_builder->echo_buf_end = len; + + echo_area_message (XFRAME (CONSOLE_SELECTED_FRAME (con)), NULL, + command_builder->echo_buf, 0, + command_builder->echo_buf_end, Qcommand); } start_over_and_avoid_hosage: ＠＠ -3392,7 +3386,7 ＠＠ copy_command_builder (neub, builder); *did_munge = 1; } - free_command_builder (neub); + free_normal_lisp_object (wrap_command_builder (neub)); UNGCPRO; if (!NILP (result)) return result; ＠＠ -3604,7 +3598,7 ＠＠ (newb, allow_misc_user_events_p, did_munge); } - free_command_builder (newb); + free_normal_lisp_object (wrap_command_builder (newb)); UNGCPRO; if (!NILP (result)) ＠＠ -4074,14 +4068,27 ＠＠ if (STRINGP (prompt)) { /* Append keymap prompt to key echo buffer */ - int buf_index = command_builder->echo_buf_index; + int buf_fill_pointer = command_builder->echo_buf_fill_pointer; Bytecount len = XSTRING_LENGTH (prompt); - if (len + buf_index + 1 <= command_builder->echo_buf_length) + if (len + buf_fill_pointer + 1 + <= XSTRING_LENGTH (command_builder->echo_buf)) { - Ibyte *echo = command_builder->echo_buf + buf_index; - memcpy (echo, XSTRING_DATA (prompt), len); - echo[len] = 0; + memcpy (XSTRING_DATA (command_builder->echo_buf) + + buf_fill_pointer, + XSTRING_DATA (prompt), + len); + copy_string_extents (command_builder->echo_buf, prompt, + buf_fill_pointer, 0, len); + + init_string_ascii_begin (command_builder->echo_buf); + bump_string_modiff (command_builder->echo_buf); + sledgehammer_check_ascii_begin (command_builder->echo_buf); + + /* Show the keymap prompt, but don't adjust the fill + pointer to reflect it. */ + command_builder->echo_buf_end + = command_builder->echo_buf_fill_pointer + len; } maybe_echo_keys (command_builder, 1); } ＠＠ -4104,12 +4111,13 ＠＠ else if (!NILP (leaf)) { if (EQ (Qcommand, echo_area_status (f)) - && command_builder->echo_buf_index > 0) + && command_builder->echo_buf_fill_pointer > 0) { /* If we had been echoing keys, echo the last one (without the trailing dash) and redisplay before executing the command. */ - command_builder->echo_buf[command_builder->echo_buf_index] = 0; + command_builder->echo_buf_end = + command_builder->echo_buf_fill_pointer; maybe_echo_keys (command_builder, 1); Fsit_for (Qzero, Qt); } diff -r 236e4afc565d -r b79e1e02bf01 src/events.h --- a/src/events.h Wed Jul 02 17:45:49 2014 +0100 +++ b/src/events.h Mon Jul 14 13:42:42 2014 +0100 ＠＠ -1148,11 +1148,13 ＠＠ translation loop). If this is nil, then the next-read event is the first that can begin a function key sequence. */ Lisp_Object first_mungeable_event[2]; - Ibyte *echo_buf; - - Bytecount echo_buf_length; /* size of echo_buf */ - Bytecount echo_buf_index; /* index into echo_buf + Lisp_Object echo_buf; + Bytecount echo_buf_fill_pointer; /* Fill pointer for echo_buf. * -1 before doing echoing for new cmd */ + Bytecount echo_buf_end; /* End of the text to be shown in + echo_buf. Can be after the fill + pointer, but usually identical to + it */ /* Self-insert-command is magic in that it doesn't always push an undo- boundary: up to 20 consecutive self-inserts can happen before an undo- boundary is pushed. This variable is that counter. diff -r 236e4afc565d -r b79e1e02bf01 src/minibuf.c --- a/src/minibuf.c Wed Jul 02 17:45:49 2014 +0100 +++ b/src/minibuf.c Mon Jul 14 13:42:42 2014 +0100 ＠＠ -34,6 +34,7 ＠＠ #include "frame-impl.h" #include "insdel.h" #include "redisplay.h" +#include "text.h" #include "window-impl.h" #include "elhash.h" ＠＠ -842,10 +843,6 ＠＠ Lisp_Object label) { /* This function can call lisp */ - Lisp_Object obj; - struct gcpro gcpro1; - Lisp_Object frame; - /* There is an inlining bug in egcs-20000131 c++ that can be worked around as follows: */ #if defined (__GNUC__) && defined (__cplusplus) ＠＠ -864,21 +861,27 ＠＠ if (length == 0) return; - if (!NILP (Ffboundp (Qappend_message))) + if (!UNBOUNDP (XSYMBOL_FUNCTION (Qappend_message))) { - if (STRINGP (reloc) && offset == 0 && length == XSTRING_LENGTH (reloc)) - obj = reloc; - else - { - if (STRINGP (reloc)) - nonreloc = XSTRING_DATA (reloc); - obj = make_string (nonreloc + offset, length); - } + Lisp_Object obj + = STRINGP (reloc) ? reloc : make_string (nonreloc + offset, length); + Lisp_Object args[] = { Qappend_message, label, obj, wrap_frame (f), + EQ (label, Qprint) ? Qt : Qnil, Q_start, Qzero, + Q_end, Qnil }; + struct gcpro gcpro1; - frame = wrap_frame (f); - GCPRO1 (obj); - call4 (Qappend_message, label, obj, frame, - EQ (label, Qprint) ? Qt : Qnil); + if (STRINGP (reloc) + && (offset != 0 || length != XSTRING_LENGTH (reloc))) + { + assert (EQ (args[5], Q_start)); + args[6] = make_fixnum (string_index_byte_to_char (reloc, offset)); + assert (EQ (args[7], Q_end)); + args[8] + = make_fixnum (string_index_byte_to_char (reloc, offset + length)); + } + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + Ffuncall (countof (args), args); UNGCPRO; } else diff -r 236e4afc565d -r b79e1e02bf01 tests/ChangeLog --- a/tests/ChangeLog Wed Jul 02 17:45:49 2014 +0100 +++ b/tests/ChangeLog Mon Jul 14 13:42:42 2014 +0100 ＠＠ -1,3 +1,9 ＠＠ +2014-07-14 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * automated/extent-tests.el: + Check that extent information is passed through to the echo area + correctly with #'next-event's PROMPT argument. + 2014-04-19 Mats Lidell <matsl(a)xemacs.org&gt; * automated/keymap-tests.el: Use diff -r 236e4afc565d -r b79e1e02bf01 tests/automated/extent-tests.el --- a/tests/automated/extent-tests.el Wed Jul 02 17:45:49 2014 +0100 +++ b/tests/automated/extent-tests.el Mon Jul 14 13:42:42 2014 +0100 ＠＠ -367,3 +367,31 ＠＠ (put e 'start-open t) (et-insert-at "foo" 4) (Assert (equal (et-range e) '(4 4))))) + +;;----------------------------------------------------- +;; Extents and the minibuffer. +;;----------------------------------------------------- + +(let* ((string (copy-sequence "Der Hoelle Rache kocht in meinem Herzen")) + (e (make-extent (search "Rache" string) (search "kocht" string) + string)) + (ee (make-extent (search "meinem" string) (search "Herzen" string) + string)) + (property-name '#:secret-token) + event list) + (setf (extent-property e 'duplicable) t + (extent-property e property-name) t + (extent-property ee 'duplicable) nil) ;; Actually the default. + (block enough + (enqueue-eval-event #'(lambda (ignore) (return-from enough)) nil) + ;; Silence prompt on TTY. Maybe we shouldn't be doing this. + (flet ((send-string-to-terminal (&rest ignore))) + (while (setq event (next-event event string)) + (dispatch-event event)))) + (setq list (extent-list (get-buffer " *Echo Area*"))) + (Assert list "checking extent info was preserved in #'next-event") + (Assert (eql 1 (length list)) "checking only one extent was preserved") + (Assert (eql t (get (car list) property-name)) + "checking it was our duplicable extent that was preserved")) + + -- ‘Liston operated so fast that he once accidentally amputated an assistant’s fingers along with a patient’s leg, […] The patient and the assistant both died of sepsis, and a spectator reportedly died of shock, resulting in the only known procedure with a 300% mortality.’ (Atul Gawande, NEJM, 2012) _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches