Shift selection using interactive spec

[Chong Yidong]

Here is a prototype for implementing shift-selection using a new
interactive spec code, `^'.  It uses transient-mark-mode's `only'
setting as suggested by Miles and Johan.

I haven't changed all the movement commands, just enough of them to
play around with the shift selection.  (left, right, up, down, etc).

Currently, M-F doesn't DTRT, but this appears to be due to an existing
bug (feature?): if there is no mapping for M-F, Emacs 22 translates it
to M-f, while Emacs 23 translates it to f.  I haven't tracked down
where this change was made.

A few observations:

Firstly, if we adopt this approach, we have to work around the fact
that read_key_sequence automatically attempts translates unbound key
sequences by trying to shift them (e.g., changing S-right to right).
Here, I create a new global variable
this_command_keys_shift_translated, which is set to 1 by
read_key_sequence when it does this translation.  This tells
Fcall_interactively that the activating key sequence is indeed
shifted, regardless of what this_command_keys says.

The present code probably doesn't handle shifting/shifting properly
when Fread_key_sequence is called from Lisp, but that is easily
remedied.

Secondly, there are two C level functions, direct_output_forward_char
and direct_output_forward_char, which are called instead of
forward_char and backward_char if certain conditions are met.  This is
a redisplay optimization.  To get this to work, we must avoid using
these functions when appropriate.  In the present code, I don't call
them when this_command_keys_shift_translated is non-zero, but this may
need more analysis.

Thirdly, I'm not too happy about the variable separation in this code.
Here, callint.c pulls in this_command_keys_shift_translated and
this_single_command_key_start from keyboard.c, Qonly from frame.h,
Qidentity from casefiddle.c, and it needs to call intern ("shift") on
each invokation to get the symbol for `shift'.  If we end up going
with this approach, maybe someone could suggest a way to clean up
these variables.

Comments are welcome.


*** trunk/src/callint.c.~1.161.~        2008-02-21 11:10:47.000000000 -0500
--- trunk/src/callint.c 2008-03-13 18:48:05.000000000 -0400
***************
*** 121,128 ****
  If the string begins with `@', then Emacs searches the key sequence
   which invoked the command for its first mouse click (or any other
   event which specifies a window), and selects that window before
!  reading any arguments.  You may use both `@' and `*'; they are
!  processed in the order that they appear.
  usage: (interactive ARGS)  */)
       (args)
       Lisp_Object args;
--- 121,132 ----
  If the string begins with `@', then Emacs searches the key sequence
   which invoked the command for its first mouse click (or any other
   event which specifies a window), and selects that window before
!  reading any arguments.
! If the string begins with `^', and the key sequence which invoked the
!  command contains the shift modifier, then Emacs activates Transient
!  Mark Mode temporarily for this command.
! You may use `@', `*', and `^' together; they are processed in the
!  order that they appear.
  usage: (interactive ARGS)  */)
       (args)
       Lisp_Object args;
***************
*** 244,249 ****
--- 248,258 ----
      }
  }
  
+ extern int this_command_keys_shift_translated;
+ extern int this_single_command_key_start;
+ extern Lisp_Object Qonly;
+ extern Lisp_Object Qidentity;
+ 
  DEFUN ("call-interactively", Fcall_interactively, Scall_interactively, 1, 3, 
0,
         doc: /* Call FUNCTION, reading args according to its interactive 
calling specs.
  Return the value FUNCTION returns.
***************
*** 423,428 ****
--- 432,469 ----
        /* Ignore this for semi-compatibility with Lucid.  */
        else if (*string == '-')
        string++;
+       else if (*string == '^')
+       {
+         Lisp_Object *key = XVECTOR (this_command_keys)->contents
+           + this_single_command_key_start;
+         Lisp_Object *key_max = XVECTOR (this_command_keys)->contents
+           + this_command_key_count;
+         Lisp_Object shift = intern ("shift");
+         int shifted = this_command_keys_shift_translated;
+ 
+         if (!shifted)
+           for (; key < key_max; ++key)
+             {
+               if (SYMBOLP (*key))
+                 shifted = !NILP (Fmemq (shift,
+                                         Fget (*key, Qevent_symbol_elements)));
+               if (!shifted)
+                 break;
+             }
+ 
+         if (shifted)
+           {
+             Lisp_Object push_mark_call[4] = { intern ("push-mark"),
+                                               Qnil, Qnil, Qt };
+             if (!EQ (Vtransient_mark_mode, Qidentity))
+               Ffuncall (4, push_mark_call);
+             if (EQ (Vtransient_mark_mode, Qidentity)
+                 || NILP (Vtransient_mark_mode))
+               Vtransient_mark_mode = Qonly;
+           }
+ 
+         string++;
+       }
        else if (*string == '@')
        {
          Lisp_Object event, tem;
*** trunk/src/keyboard.c.~1.947.~       2008-02-25 11:04:08.000000000 -0500
--- trunk/src/keyboard.c        2008-03-13 18:49:38.000000000 -0400
***************
*** 132,137 ****
--- 132,142 ----
  Lisp_Object raw_keybuf;
  int raw_keybuf_count;
  
+ /* This is non-zero if the present key sequence was obtained by
+    unshifting a key sequence (i.e. changing an upper-case letter to
+    lower-case or a shifted function key to an unshifted one).  */
+ int this_command_keys_shift_translated;
+ 
  #define GROW_RAW_KEYBUF                                                       
\
   if (raw_keybuf_count == XVECTOR (raw_keybuf)->size)                  \
     raw_keybuf = larger_vector (raw_keybuf, raw_keybuf_count * 2, Qnil)  \
***************
*** 1648,1653 ****
--- 1653,1659 ----
        Vthis_command = Qnil;
        real_this_command = Qnil;
        Vthis_original_command = Qnil;
+       this_command_keys_shift_translated = 0;
  
        /* Read next key sequence; i gets its length.  */
        i = read_key_sequence (keybuf, sizeof keybuf / sizeof keybuf[0],
***************
*** 1761,1767 ****
  
              /* Recognize some common commands in common situations and
                 do them directly.  */
!             if (EQ (Vthis_command, Qforward_char) && PT < ZV)
                {
                    struct Lisp_Char_Table *dp
                    = window_display_table (XWINDOW (selected_window));
--- 1767,1774 ----
  
              /* Recognize some common commands in common situations and
                 do them directly.  */
!             if (EQ (Vthis_command, Qforward_char) && PT < ZV
!                 && !this_command_keys_shift_translated)
                {
                    struct Lisp_Char_Table *dp
                    = window_display_table (XWINDOW (selected_window));
***************
*** 1801,1807 ****
                    direct_output_forward_char (1);
                  goto directly_done;
                }
!             else if (EQ (Vthis_command, Qbackward_char) && PT > BEGV)
                {
                    struct Lisp_Char_Table *dp
                    = window_display_table (XWINDOW (selected_window));
--- 1808,1815 ----
                    direct_output_forward_char (1);
                  goto directly_done;
                }
!             else if (EQ (Vthis_command, Qbackward_char) && PT > BEGV
!                      && !this_command_keys_shift_translated)
                {
                    struct Lisp_Char_Table *dp
                    = window_display_table (XWINDOW (selected_window));
***************
*** 9194,9199 ****
--- 9202,9212 ----
    /* Likewise, for key_translation_map and input-decode-map.  */
    volatile keyremap keytran, indec;
  
+   /* If we are trying to map a key by unshifting it (i.e. changing an
+      upper-case letter to lower-case or a shifted function key to an
+      unshifted one), then we set this to != 0.  */
+   volatile int shift_translated = 0;
+ 
    /* If we receive a `switch-frame' or `select-window' event in the middle of
       a key sequence, we put it off for later.
       While we're reading, we keep the event here.  */
***************
*** 10113,10118 ****
--- 10126,10133 ----
          keybuf[t - 1] = new_key;
          mock_input = max (t, mock_input);
  
+         shift_translated = 1;
+ 
          goto replay_sequence;
        }
        /* If KEY is not defined in any of the keymaps,
***************
*** 10154,10159 ****
--- 10169,10176 ----
              fkey.start = fkey.end = 0;
              keytran.start = keytran.end = 0;
  
+             shift_translated = 1;
+ 
              goto replay_sequence;
            }
        }
***************
*** 10191,10196 ****
--- 10208,10215 ----
      }
  
  
+   if (shift_translated && read_key_sequence_cmd)
+     this_command_keys_shift_translated = 1;
  
    UNGCPRO;
    return t;
*** trunk/src/cmds.c.~1.102.~   2008-02-01 13:47:24.000000000 -0500
--- trunk/src/cmds.c    2008-03-13 13:36:57.000000000 -0400
***************
*** 56,62 ****
    return make_number (PT + XINT (n));
  }
  
! DEFUN ("forward-char", Fforward_char, Sforward_char, 0, 1, "p",
         doc: /* Move point right N characters (left if N is negative).
  On reaching end of buffer, stop and signal error.  */)
       (n)
--- 56,62 ----
    return make_number (PT + XINT (n));
  }
  
! DEFUN ("forward-char", Fforward_char, Sforward_char, 0, 1, "^p",
         doc: /* Move point right N characters (left if N is negative).
  On reaching end of buffer, stop and signal error.  */)
       (n)
***************
*** 92,98 ****
    return Qnil;
  }
  
! DEFUN ("backward-char", Fbackward_char, Sbackward_char, 0, 1, "p",
         doc: /* Move point left N characters (right if N is negative).
  On attempt to pass beginning or end of buffer, stop and signal error.  */)
       (n)
--- 92,98 ----
    return Qnil;
  }
  
! DEFUN ("backward-char", Fbackward_char, Sbackward_char, 0, 1, "^p",
         doc: /* Move point left N characters (right if N is negative).
  On attempt to pass beginning or end of buffer, stop and signal error.  */)
       (n)
*** trunk/lisp/simple.el.~1.905.~       2008-03-10 21:57:09.000000000 -0400
--- trunk/lisp/simple.el        2008-03-13 13:39:17.000000000 -0400
***************
*** 3651,3657 ****
  If you are thinking of using this in a Lisp program, consider
  using `forward-line' instead.  It is usually easier to use
  and more reliable (no dependence on goal column, etc.)."
!   (interactive "p\np")
    (or arg (setq arg 1))
    (if (and next-line-add-newlines (= arg 1))
        (if (save-excursion (end-of-line) (eobp))
--- 3651,3657 ----
  If you are thinking of using this in a Lisp program, consider
  using `forward-line' instead.  It is usually easier to use
  and more reliable (no dependence on goal column, etc.)."
!   (interactive "^p\np")
    (or arg (setq arg 1))
    (if (and next-line-add-newlines (= arg 1))
        (if (save-excursion (end-of-line) (eobp))
***************
*** 3684,3690 ****
  If you are thinking of using this in a Lisp program, consider using
  `forward-line' with a negative argument instead.  It is usually easier
  to use and more reliable (no dependence on goal column, etc.)."
!   (interactive "p\np")
    (or arg (setq arg 1))
    (if (interactive-p)
        (condition-case nil
--- 3684,3690 ----
  If you are thinking of using this in a Lisp program, consider using
  `forward-line' with a negative argument instead.  It is usually easier
  to use and more reliable (no dependence on goal column, etc.)."
!   (interactive "^p\np")
    (or arg (setq arg 1))
    (if (interactive-p)
        (condition-case nil
***************
*** 4307,4313 ****
  (defun backward-word (&optional arg)
    "Move backward until encountering the beginning of a word.
  With argument, do this that many times."
!   (interactive "p")
    (forward-word (- (or arg 1))))
  
  (defun mark-word (&optional arg allow-extend)
--- 4307,4313 ----
  (defun backward-word (&optional arg)
    "Move backward until encountering the beginning of a word.
  With argument, do this that many times."
!   (interactive "^p")
    (forward-word (- (or arg 1))))
  
  (defun mark-word (&optional arg allow-extend)